POC for polysemy

IntersectMBO · May 25, 2024 · 5ad1e8c · 5ad1e8c
1 parent 8ebae88
commit 5ad1e8c
Show file tree

Hide file tree

Showing 10 changed files with 386 additions and 169 deletions.
diff --git a/cabal.project b/cabal.project
@@ -13,7 +13,7 @@ repository cardano-haskell-packages
 -- See CONTRIBUTING for information about these, including some Nix commands
 -- you need to run if you change them
 index-state:
-  , hackage.haskell.org 2024-05-02T11:03:23Z
+  , hackage.haskell.org 2024-05-25T09:09:57Z
   , cardano-haskell-packages 2024-05-14T04:43:46Z
 
 packages:
@@ -41,3 +41,14 @@ write-ghc-environment-files: always
 -- IMPORTANT
 -- Do NOT add more source-repository-package stanzas here unless they are strictly
 -- temporary! Please read the section in CONTRIBUTING about updating dependencies.
+
+-- Add upper bound to io-classes-mtl:
+
+constraints:
+  io-classes-mtl < 0.1.2.0
+
+source-repository-package
+    type: git
+    location: https://github.com/newhoggy/polysemy-conc
+    tag: 7d45ccd462c973f15156070ba24084ff15758f15
+    subdir: packages/conc
diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal
@@ -140,6 +140,7 @@ library
                         Cardano.CLI.Options
                         Cardano.CLI.OS.Posix
                         Cardano.CLI.Parser
+                        Cardano.CLI.Polysemy
                         Cardano.CLI.Pretty
                         Cardano.CLI.Read
                         Cardano.CLI.Render
@@ -217,6 +218,7 @@ library
                       , directory
                       , filepath
                       , formatting
+                      , hw-polysemy:core ^>= 0.2.5.0
                       , io-classes
                       , iproute
                       , mtl
@@ -230,6 +232,8 @@ library
                       , ouroboros-network-api
                       , ouroboros-network-protocols ^>=0.8
                       , parsec
+                      , polysemy
+                      , polysemy-plugin
                       , prettyprinter
                       , prettyprinter-ansi-terminal
                       , random
@@ -242,6 +246,7 @@ library
                       , unliftio-core
                       , utf8-string
                       , yaml
+  ghc-options:          -fplugin=Polysemy.Plugin
 
 executable cardano-cli
   import:               project-config
@@ -258,18 +263,27 @@ library cardano-cli-test-lib
   import:               project-config
   visibility:           public
   hs-source-dirs:       test/cardano-cli-test-lib
-  exposed-modules:      Test.Cardano.CLI.Aeson
+  exposed-modules:      Test.Cardano.Api.Polysemy
+                        Test.Cardano.CLI.Aeson
+                        Test.Cardano.CLI.Polysemy
                         Test.Cardano.CLI.Util
+  ghc-options:          -fplugin=Polysemy.Plugin
   build-depends:        aeson
                       , aeson-pretty
                       , bytestring
                       , cardano-api
+                      , cardano-api:internal
                       , cardano-cli
                       , directory
                       , exceptions
                       , filepath
                       , hedgehog
                       , hedgehog-extras ^>= 0.6.1.0
+                      , hw-polysemy:core ^>= 0.2.5.0
+                      , hw-polysemy:hedgehog ^>= 0.2.5.0
+                      , mtl
+                      , polysemy
+                      , polysemy-plugin
                       , lifted-base
                       , monad-control
                       , process
@@ -293,17 +307,23 @@ test-suite cardano-cli-test
                       , cardano-ledger-alonzo
                       , cardano-slotting
                       , containers
+                      , exceptions
                       , filepath
                       , hedgehog
                       , hedgehog-extras ^>= 0.6.1.0
-                      , exceptions
+                      , hw-polysemy:core ^>= 0.2.5.0
+                      , hw-polysemy:hedgehog ^>= 0.2.5.0
+                      , polysemy
+                      , polysemy-plugin
                       , regex-tdfa
                       , tasty
                       , tasty-hedgehog
                       , text
                       , time
                       , transformers
 
+  ghc-options:          -fplugin=Polysemy.Plugin
+
   build-tool-depends:   tasty-discover:tasty-discover
 
   other-modules:        Test.Cli.AddCostModels
@@ -354,6 +374,10 @@ test-suite cardano-cli-golden
                       , filepath
                       , hedgehog ^>= 1.4
                       , hedgehog-extras ^>= 0.6.1.0
+                      , hw-polysemy:core ^>= 0.2.5.0
+                      , hw-polysemy:hedgehog ^>= 0.2.5.0
+                      , polysemy
+                      , polysemy-plugin
                       , regex-compat
                       , regex-tdfa
                       , tasty
@@ -365,6 +389,8 @@ test-suite cardano-cli-golden
   build-tool-depends:   cardano-cli:cardano-cli
                       , tasty-discover:tasty-discover
 
+  ghc-options:          -fplugin=Polysemy.Plugin
+
   other-modules:        Test.Golden.Babbage.Transaction.CalculateMinFee
                         Test.Golden.Byron.SigningKeys
                         Test.Golden.Byron.Tx

diff --git a/cardano-cli/src/Cardano/CLI/Polysemy.hs b/cardano-cli/src/Cardano/CLI/Polysemy.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Cardano.CLI.Polysemy
+  ( ByronKeyFailure(..),
+    ByronKeyFormat(..),
+    SigningKeyFile,
+    File(..),
+    FileDirection(..),
+    readByronSigningKey
+  ) where
+
+import           Cardano.Api.Byron (SomeByronSigningKey (..))
+
+import           Cardano.CLI.Byron.Key (ByronKeyFailure (..))
+import qualified Cardano.CLI.Byron.Key as Cli
+import           Cardano.CLI.Types.Common
+
+import           Control.Monad.Except (runExceptT)
+
+import           HaskellWorks.Polysemy
+import           HaskellWorks.Polysemy.Prelude
+import           Polysemy ()
+
+readByronSigningKey :: ()
+  => Member (Error ByronKeyFailure) r
+  => Member (Embed IO) r
+  => ByronKeyFormat
+  -> SigningKeyFile In
+  -> Sem r SomeByronSigningKey
+readByronSigningKey bKeyFormat fp =
+  (embed $ runExceptT $ Cli.readByronSigningKey bKeyFormat fp)
+    & onLeftM throw
diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/SigningKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/SigningKeys.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Test.Golden.Byron.SigningKeys
   ( hprop_deserialise_legacy_signing_Key
@@ -11,106 +12,102 @@ module Test.Golden.Byron.SigningKeys
   , hprop_print_nonLegacy_signing_key_address
   ) where
 
-import           Cardano.Api.Byron
-
-import           Cardano.CLI.Byron.Key (readByronSigningKey)
 import           Cardano.CLI.Byron.Legacy (decodeLegacyDelegateKey)
-import           Cardano.CLI.Types.Common
+import           Cardano.CLI.Polysemy
 import qualified Cardano.Crypto.Signing as Crypto
 
-import           Codec.CBOR.Read (deserialiseFromBytes)
-import           Control.Monad (void)
-import qualified Data.ByteString.Lazy as LB
+import           Codec.CBOR.Read (DeserialiseFailure, deserialiseFromBytes)
 
-import           Test.Cardano.CLI.Util
+import           Test.Cardano.Api.Polysemy
+import           Test.Cardano.CLI.Polysemy
 
-import           Hedgehog (Property, property, success)
-import qualified Hedgehog as H
-import qualified Hedgehog.Extras.Test.Base as H
-import           Hedgehog.Internal.Property (failWith)
+import           HaskellWorks.Polysemy
+import qualified HaskellWorks.Polysemy.Data.ByteString.Lazy as LBS
+import           HaskellWorks.Polysemy.Hedgehog
+import           HaskellWorks.Prelude
 
 hprop_deserialise_legacy_signing_Key :: Property
-hprop_deserialise_legacy_signing_Key = propertyOnce $ do
-  legSkeyBs <- H.evalIO $ LB.readFile "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
-  case deserialiseFromBytes decodeLegacyDelegateKey legSkeyBs of
-    Left deSerFail -> failWith Nothing $ show deSerFail
-    Right _ -> success
+hprop_deserialise_legacy_signing_Key = propertyOnce $ localWorkspace $ do
+  legSkeyBs <- LBS.readFile "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
+    & trapFail @IOException
+
+  fromEither (deserialiseFromBytes decodeLegacyDelegateKey legSkeyBs)
+    & trapFail @DeserialiseFailure
+    & void
 
 hprop_deserialise_nonLegacy_signing_Key :: Property
-hprop_deserialise_nonLegacy_signing_Key = propertyOnce $ do
-  skeyBs <- H.evalIO $ LB.readFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey"
-  case deserialiseFromBytes Crypto.fromCBORXPrv skeyBs of
-    Left deSerFail -> failWith Nothing $ show deSerFail
-    Right _ -> success
+hprop_deserialise_nonLegacy_signing_Key = propertyOnce $ localWorkspace $ do
+  skeyBs <- LBS.readFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey"
+    & trapFail @IOException
+
+  fromEither (deserialiseFromBytes Crypto.fromCBORXPrv skeyBs)
+    & trapFail @DeserialiseFailure
+    & void
 
 hprop_print_legacy_signing_key_address :: Property
-hprop_print_legacy_signing_key_address = propertyOnce $ do
-  let legKeyFp = "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
+hprop_print_legacy_signing_key_address = propertyOnce $ localWorkspace $ do
+  legKeyFp <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
 
-  void $ execCardanoCLI
-   [ "signing-key-address", "--byron-legacy-formats"
-   , "--testnet-magic", "42"
-   , "--secret", legKeyFp
-   ]
+  execCardanoCli_
+    [ "signing-key-address", "--byron-legacy-formats"
+    , "--testnet-magic", "42"
+    , "--secret", legKeyFp
+    ]
 
-  void $ execCardanoCLI
-   [ "signing-key-address", "--byron-legacy-formats"
-   , "--mainnet"
-   , "--secret", legKeyFp
-   ]
+  execCardanoCli_
+    [ "signing-key-address", "--byron-legacy-formats"
+    , "--mainnet"
+    , "--secret", legKeyFp
+    ]
 
 hprop_print_nonLegacy_signing_key_address :: Property
-hprop_print_nonLegacy_signing_key_address = propertyOnce $ do
-  let nonLegKeyFp = "test/cardano-cli-golden/files/input/byron/keys/byron.skey"
+hprop_print_nonLegacy_signing_key_address = propertyOnce $ localWorkspace $ do
+  nonLegKeyFp <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey"
 
-  void $ execCardanoCLI
-   [ "signing-key-address", "--byron-formats"
-   , "--testnet-magic", "42"
-   , "--secret", nonLegKeyFp
-   ]
+  execCardanoCli_
+    [ "signing-key-address", "--byron-formats"
+    , "--testnet-magic", "42"
+    , "--secret", nonLegKeyFp
+    ]
 
-  void $ execCardanoCLI
-   [ "signing-key-address", "--byron-formats"
-   , "--mainnet"
-   , "--secret", nonLegKeyFp
-   ]
+  execCardanoCli_
+    [ "signing-key-address", "--byron-formats"
+    , "--mainnet"
+    , "--secret", nonLegKeyFp
+    ]
 
 hprop_generate_and_read_nonlegacy_signingkeys :: Property
-hprop_generate_and_read_nonlegacy_signingkeys = property $ do
-  byronSkey <- H.evalIO $ generateSigningKey AsByronKey
-  case deserialiseFromRawBytes (AsSigningKey AsByronKey) (serialiseToRawBytes byronSkey) of
-    Left _ -> failWith Nothing "Failed to deserialise non-legacy Byron signing key. "
-    Right _ -> success
+hprop_generate_and_read_nonlegacy_signingkeys = propertyOnce $ localWorkspace $ do
+  byronSkey <- generateSigningKey AsByronKey
 
-hprop_migrate_legacy_to_nonlegacy_signingkeys :: Property
-hprop_migrate_legacy_to_nonlegacy_signingkeys =
-  propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do
-    let legKeyFp = "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
-    nonLegacyKeyFp <- noteTempFile tempDir "nonlegacy.skey"
+  fromEither (deserialiseFromRawBytes (AsSigningKey AsByronKey) (serialiseToRawBytes byronSkey))
+    -- Failed to deserialise non-legacy Byron signing key
+    & trapFail @SerialiseAsRawBytesError
+    & void
 
-    void $ execCardanoCLI
-     [ "migrate-delegate-key-from"
-     , "--from", legKeyFp
-     , "--to", nonLegacyKeyFp
-     ]
+hprop_migrate_legacy_to_nonlegacy_signingkeys :: Property
+hprop_migrate_legacy_to_nonlegacy_signingkeys = propertyOnce $ localWorkspace $ do
+  legKeyFp <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
+  nonLegacyKeyFp <- jotTempFile "nonlegacy.skey"
 
-    eSignKey <- H.evalIO . runExceptT . readByronSigningKey NonLegacyByronKeyFormat
-                  $ File nonLegacyKeyFp
+  execCardanoCli_
+    [ "migrate-delegate-key-from"
+    , "--from", legKeyFp
+    , "--to", nonLegacyKeyFp
+    ]
 
-    case eSignKey of
-      Left err -> failWith Nothing $ show err
-      Right _ -> success
+  readByronSigningKey NonLegacyByronKeyFormat (File nonLegacyKeyFp)
+    & trapFail @ByronKeyFailure
+    & void
 
 hprop_deserialise_NonLegacy_Signing_Key_API :: Property
-hprop_deserialise_NonLegacy_Signing_Key_API = propertyOnce $ do
-  eFailOrWit <- H.evalIO . runExceptT $ readByronSigningKey NonLegacyByronKeyFormat "test/cardano-cli-golden/files/input/byron/keys/byron.skey"
-  case eFailOrWit of
-    Left keyFailure -> failWith Nothing $ show keyFailure
-    Right _ -> success
+hprop_deserialise_NonLegacy_Signing_Key_API = propertyOnce $ localWorkspace $ do
+  readByronSigningKey NonLegacyByronKeyFormat "test/cardano-cli-golden/files/input/byron/keys/byron.skey"
+    & trapFail @ByronKeyFailure
+    & void
 
 hprop_deserialiseLegacy_Signing_Key_API :: Property
-hprop_deserialiseLegacy_Signing_Key_API = propertyOnce $ do
-  eFailOrWit <- H.evalIO . runExceptT $ readByronSigningKey LegacyByronKeyFormat "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
-  case eFailOrWit of
-    Left keyFailure -> failWith Nothing $ show keyFailure
-    Right _ -> success
+hprop_deserialiseLegacy_Signing_Key_API = propertyOnce $ localWorkspace $ do
+  readByronSigningKey LegacyByronKeyFormat "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
+    & trapFail @ByronKeyFailure
+    & void