From 63e629b0f3e9db636b8eeafcf7efae499af2a6e4 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 18 Jun 2024 22:49:37 +1000 Subject: [PATCH] POC for polysemy --- cabal.project | 4 +- cardano-cli/cardano-cli.cabal | 30 +++- cardano-cli/src/Cardano/CLI/Polysemy.hs | 36 +++++ .../Test/Golden/Byron/SigningKeys.hs | 149 +++++++++--------- .../Test/Golden/Byron/Tx.hs | 68 ++++---- .../StakeAddress/DeregistrationCertificate.hs | 37 ++--- .../Test/Cardano/Api/Polysemy.hs | 61 +++++++ .../Test/Cardano/CLI/Polysemy.hs | 89 +++++++++++ .../Test/Cli/FilePermissions.hs | 50 +++--- .../Test/Cli/Shelley/Transaction/Build.hs | 22 +-- 10 files changed, 377 insertions(+), 169 deletions(-) create mode 100644 cardano-cli/src/Cardano/CLI/Polysemy.hs create mode 100644 cardano-cli/test/cardano-cli-test-lib/Test/Cardano/Api/Polysemy.hs create mode 100644 cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Polysemy.hs diff --git a/cabal.project b/cabal.project index 47ebdfe3a0..88e20671e5 100644 --- 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-06-12T10:10:17Z + , hackage.haskell.org 2024-06-18T11:54:44Z , cardano-haskell-packages 2024-06-12T10:10:17Z packages: @@ -45,3 +45,5 @@ 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: diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 8d38cbe257..857f434c72 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -147,6 +147,7 @@ library Cardano.CLI.Orphans Cardano.CLI.OS.Posix Cardano.CLI.Parser + Cardano.CLI.Polysemy Cardano.CLI.Pretty Cardano.CLI.Read Cardano.CLI.Render @@ -228,6 +229,7 @@ library , directory , filepath , formatting + , hw-polysemy:core ^>= 0.2.8.0 , io-classes , iproute , mtl @@ -241,6 +243,8 @@ library , ouroboros-network-api , ouroboros-network-protocols ^>=0.8 , parsec + , polysemy + , polysemy-plugin , prettyprinter , prettyprinter-ansi-terminal , random @@ -254,6 +258,7 @@ library , utf8-string , vector , yaml + ghc-options: -fplugin=Polysemy.Plugin executable cardano-cli import: project-config @@ -270,18 +275,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.8.0 + , hw-polysemy:hedgehog ^>= 0.2.8.0 + , mtl + , polysemy + , polysemy-plugin , lifted-base , monad-control , process @@ -305,10 +319,14 @@ 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.8.0 + , hw-polysemy:hedgehog ^>= 0.2.8.0 + , polysemy + , polysemy-plugin , regex-tdfa , tasty , tasty-hedgehog @@ -316,6 +334,8 @@ test-suite cardano-cli-test , time , transformers + ghc-options: -fplugin=Polysemy.Plugin + build-tool-depends: tasty-discover:tasty-discover other-modules: Test.Cli.AddCostModels @@ -366,6 +386,10 @@ test-suite cardano-cli-golden , filepath , hedgehog ^>= 1.4 , hedgehog-extras ^>= 0.6.1.0 + , hw-polysemy:core ^>= 0.2.8.0 + , hw-polysemy:hedgehog ^>= 0.2.8.0 + , polysemy + , polysemy-plugin , regex-compat , regex-tdfa , tasty @@ -377,6 +401,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 new file mode 100644 index 0000000000..f7d6975620 --- /dev/null +++ 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 index 9dcf4e7c8d..3a3fb82d2e 100644 --- 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 diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs index 6c9e44e378..23357eeb7c 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs @@ -1,30 +1,29 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{- HLINT ignore "Use camelCase" -} module Test.Golden.Byron.Tx where -import Cardano.Api +import Cardano.Api hiding (Error) import Cardano.Chain.UTxO (ATxAux) import Cardano.CLI.Byron.Tx -import Control.Monad (void) -import Data.ByteString (ByteString) - -import Test.Cardano.CLI.Util - -import Hedgehog (Property, (===)) -import qualified Hedgehog as H -import qualified Hedgehog.Extras.Test.Base as H -import Hedgehog.Internal.Property (failWith) +import Test.Cardano.CLI.Polysemy -{- HLINT ignore "Use camelCase" -} +import HaskellWorks.Polysemy +import HaskellWorks.Polysemy.Hedgehog +import HaskellWorks.Prelude hprop_byronTx_legacy :: Property -hprop_byronTx_legacy = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do - signingKey <- noteInputFile "test/cardano-cli-golden/files/input/byron/keys/legacy.skey" - expectedTx <- noteInputFile "test/cardano-cli-golden/files/input/byron/tx/legacy.tx" - createdTx <- noteTempFile tempDir "tx" - void $ execCardanoCLI +hprop_byronTx_legacy = propertyOnce $ localWorkspace $ do + signingKey <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/keys/legacy.skey" + expectedTx <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/tx/legacy.tx" + createdTx <- jotTempFile "tx" + + execCardanoCli_ [ "byron", "transaction", "issue-utxo-expenditure" , "--mainnet" , "--byron-legacy-formats" @@ -34,14 +33,15 @@ hprop_byronTx_legacy = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do , "--txout", "(\"2657WMsDfac6eFirdvKVPVMxNVYuACd1RGM2arH3g1y1yaQCr1yYpb2jr2b2aSiDZ\",999)" ] - compareByronTxs createdTx expectedTx + void $ compareByronTxs createdTx expectedTx hprop_byronTx :: Property -hprop_byronTx = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do - signingKey <- noteInputFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey" - expectedTx <- noteInputFile "test/cardano-cli-golden/files/input/byron/tx/normal.tx" - createdTx <- noteTempFile tempDir "tx" - void $ execCardanoCLI +hprop_byronTx = propertyOnce $ localWorkspace $ do + signingKey <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey" + expectedTx <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/tx/normal.tx" + createdTx <- jotTempFile "tx" + + execCardanoCli_ [ "byron", "transaction", "issue-utxo-expenditure" , "--mainnet" , "--byron-formats" @@ -53,16 +53,24 @@ hprop_byronTx = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do compareByronTxs createdTx expectedTx -getTxByteString :: FilePath -> H.PropertyT IO (ATxAux ByteString) +getTxByteString :: () + => Member (Embed IO) r + => Member (Error ByronTxError) r + => FilePath + -> Sem r (ATxAux ByteString) getTxByteString txFp = do - eATxAuxBS <- liftIO . runExceptT $ readByronTx $ File txFp - case eATxAuxBS of - Left err -> failWith Nothing . docToString $ renderByronTxError err - Right aTxAuxBS -> return aTxAuxBS + embed (runExceptT $ readByronTx $ File txFp) + & onLeftM throw -compareByronTxs :: FilePath -> FilePath -> H.PropertyT IO () +compareByronTxs :: () + => HasCallStack + => Member (Embed IO) r + => Member Hedgehog r + => FilePath + -> FilePath + -> Sem r () compareByronTxs createdTx expectedTx = do - createdATxAuxBS <- getTxByteString createdTx - expectedATxAuxBS <- getTxByteString expectedTx + createdATxAuxBS <- getTxByteString createdTx & trapFail @ByronTxError + expectedATxAuxBS <- getTxByteString expectedTx & trapFail @ByronTxError normalByronTxToGenTx expectedATxAuxBS === normalByronTxToGenTx createdATxAuxBS diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs index 8afa30d7de..393f9a4a0a 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs @@ -2,41 +2,38 @@ module Test.Golden.Shelley.StakeAddress.DeregistrationCertificate where -import Control.Monad (void) -import System.FilePath (()) +import Test.Cardano.CLI.Polysemy -import Test.Cardano.CLI.Util - -import Hedgehog (Property) -import qualified Hedgehog.Extras.Test.Base as H -import qualified Hedgehog.Extras.Test.Process as H -import qualified Hedgehog.Extras.Test.Golden as H +import HaskellWorks.Polysemy.Hedgehog +import HaskellWorks.Polysemy.Hedgehog.Golden +import Polysemy () {- HLINT ignore "Use camelCase" -} hprop_golden_shelley_stake_address_deregistration_certificate :: Property -hprop_golden_shelley_stake_address_deregistration_certificate = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - base <- H.getProjectBase +hprop_golden_shelley_stake_address_deregistration_certificate = propertyOnce $ localWorkspace $ do + verificationKeyFile <- jotPkgInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + deregistrationCertFile <- jotTempFile "deregistrationCertFile" + scriptDeregistrationCertFile <- jotTempFile "scripDeregistrationCertFile" + exampleScript <- jotRootInputFile "scripts/plutus/scripts/v1/custom-guess-42-datum-42.plutus" - verificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" - deregistrationCertFile <- noteTempFile tempDir "deregistrationCertFile" - scriptDeregistrationCertFile <- noteTempFile tempDir "scripDeregistrationCertFile" - exampleScript <- noteInputFile $ base "scripts/plutus/scripts/v1/custom-guess-42-datum-42.plutus" + jot_ exampleScript - void $ execCardanoCLI + execCardanoCli_ [ "babbage", "stake-address","deregistration-certificate" , "--staking-verification-key-file", verificationKeyFile , "--out-file", deregistrationCertFile ] - goldenFile1 <- H.note "test/cardano-cli-golden/files/golden/shelley/dereg-cert-1.json" - H.diffFileVsGoldenFile deregistrationCertFile goldenFile1 + goldenFile1 <- jotPkgGoldenFile "test/cardano-cli-golden/files/golden/shelley/dereg-cert-1.json" + diffFileVsGoldenFile deregistrationCertFile goldenFile1 - void $ execCardanoCLI + execCardanoCli_ [ "babbage", "stake-address","deregistration-certificate" , "--stake-script-file", exampleScript , "--out-file", scriptDeregistrationCertFile ] - goldenFile2 <- H.note "test/cardano-cli-golden/files/golden/shelley/dereg-cert-2.json" - H.diffFileVsGoldenFile scriptDeregistrationCertFile goldenFile2 + goldenFile2 <- jotPkgGoldenFile "test/cardano-cli-golden/files/golden/shelley/dereg-cert-2.json" + + diffFileVsGoldenFile scriptDeregistrationCertFile goldenFile2 diff --git a/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/Api/Polysemy.hs b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/Api/Polysemy.hs new file mode 100644 index 0000000000..9c1f4e236b --- /dev/null +++ b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/Api/Polysemy.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +module Test.Cardano.Api.Polysemy + ( File(..), + FileDirection(..), + VRFPrivateKeyFilePermissionError(..), + ByronKey, + ByronKeyLegacy, + + -- * Data family instances + AsType(..), + VerificationKey(..), + SigningKey(..), + Hash, + + -- * Legacy format + IsByronKey(..), + ByronKeyFormat(..), + + SomeByronSigningKey(..), + + SerialiseAsRawBytesError, + + checkVrfFilePermissions, + deserialiseFromRawBytes, + generateSigningKey, + serialiseToRawBytes, + ) where + +import Cardano.Api (AsType, File (..), FileDirection (..), Hash, Key, + SerialiseAsRawBytesError (..), SigningKey, VerificationKey (..), + deserialiseFromRawBytes, serialiseToRawBytes) +import qualified Cardano.Api as Api +import qualified Cardano.Api.IO as Api +import Cardano.Api.IO.Base (VRFPrivateKeyFilePermissionError (..)) +import Cardano.Api.Keys.Byron (ByronKey, ByronKeyFormat (..), ByronKeyLegacy, + IsByronKey (..), SomeByronSigningKey (..)) + +import Control.Monad.Except (runExceptT) + +import HaskellWorks.Polysemy +import HaskellWorks.Prelude +import Polysemy () + +generateSigningKey :: () + => Member (Embed IO) r + => Key keyrole + => AsType keyrole + -> Sem r (SigningKey keyrole) +generateSigningKey keytype = + embed (Api.generateSigningKey keytype) + +checkVrfFilePermissions :: () + => Member (Error VRFPrivateKeyFilePermissionError) r + => Member (Embed IO) r + => File () In + -> Sem r () +checkVrfFilePermissions vrfSignKey = + embed (runExceptT (Api.checkVrfFilePermissions vrfSignKey)) + & onLeftM throw diff --git a/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Polysemy.hs b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Polysemy.hs new file mode 100644 index 0000000000..1cfd4d8f68 --- /dev/null +++ b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Polysemy.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Cardano.CLI.Polysemy + ( cardanoCliPath, + execCardanoCli, + execCardanoCli_, + execDetailCardanoCli, + localWorkspace, + ) where + +import HaskellWorks.Polysemy +import HaskellWorks.Polysemy.Error.Types +import HaskellWorks.Polysemy.Hedgehog +import HaskellWorks.Polysemy.Hedgehog.Process +import HaskellWorks.Polysemy.Prelude +import HaskellWorks.Polysemy.System.Process +import Polysemy () + +cardanoCliPath :: FilePath +cardanoCliPath = "cardano-cli" + +-- | Execute cardano-cli via the command line. +-- +-- Waits for the process to finish and returns the stdout. +execCardanoCli :: () + => HasCallStack + => Member (Embed IO) r + => Member Hedgehog r + => Member Log r + => [String] + -- ^ Arguments to the CLI command + -> Sem r String + -- ^ Captured stdout +execCardanoCli args = withFrozenCallStack $ + execFlexOk "cardano-cli" "CARDANO_CLI" args + & trapFail @GenericError + & trapFail @IOException + +execCardanoCli_ :: () + => HasCallStack + => Member (Embed IO) r + => Member Hedgehog r + => Member Log r + => [String] + -- ^ Arguments to the CLI command + -> Sem r () +execCardanoCli_ args = withFrozenCallStack $ + void $ execCardanoCli args + +-- | Execute cardano-cli via the command line, expecting it to fail. +-- +-- Waits for the process to finish and returns the exit code, stdout and stderr. +execDetailCardanoCli :: () + => HasCallStack + => Member (Embed IO) r + => Member Hedgehog r + => Member Log r + => [String] + -- ^ Arguments to the CLI command + -> Sem r (ExitCode, String, String) + -- ^ Captured stdout +execDetailCardanoCli arguments = withFrozenCallStack $ + execDetailFlex defaultExecConfig "cardano-cli" "CARDANO_CLI" arguments + & trapFail @GenericError + & trapFail @IOException + +localWorkspace :: () + => Member Hedgehog r + => Member Log r + => Member (Embed IO) r + => Sem + ( Reader Workspace + : Reader ProjectRoot + : Reader PackagePath + : Resource + : r) + () + -> Sem r () +localWorkspace f = do + cabalProjectDir <- findCabalProjectDir "." + + f & moduleWorkspace "cardano-cli" + & runReader (ProjectRoot cabalProjectDir) + & runReader (PackagePath "cardano-cli") + & runResource diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/FilePermissions.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/FilePermissions.hs index 8dc5620628..2a70e412ad 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/FilePermissions.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/FilePermissions.hs @@ -1,40 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Test.Cli.FilePermissions ( hprop_createVRFSigningKeyFilePermissions ) where -import Cardano.Api -import Cardano.Api.IO (checkVrfFilePermissions) +import Test.Cardano.Api.Polysemy +import Test.Cardano.CLI.Polysemy -import Control.Monad (void) - -import Test.Cardano.CLI.Util (execCardanoCLI) - -import Hedgehog (Property, success) -import qualified Hedgehog.Extras.Test.Base as H -import Hedgehog.Internal.Property (failWith) +import HaskellWorks.Polysemy.Hedgehog +import HaskellWorks.Prelude -- | This property ensures that the VRF signing key file is created only with owner permissions hprop_createVRFSigningKeyFilePermissions :: Property -hprop_createVRFSigningKeyFilePermissions = - H.propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - -- Key filepaths - vrfVerKey <- H.noteTempFile tempDir "VRF-verification-key-file" - - vrfSignKey <- H.noteTempFile tempDir "VRF-signing-key-file" - - -- Create VRF key pair - void $ execCardanoCLI - [ "node", "key-gen-VRF" - , "--verification-key-file", vrfVerKey - , "--signing-key-file", vrfSignKey - ] - - result <- liftIO . runExceptT $ checkVrfFilePermissions (File vrfSignKey) - case result of - Left err -> - failWith Nothing - $ "key-gen-VRF cli command created a VRF signing key \ - \file with the wrong permissions: " <> show err - Right () -> success +hprop_createVRFSigningKeyFilePermissions = propertyOnce $ localWorkspace $ do + -- Key filepaths + vrfVerKey <- jotTempFile "VRF-verification-key-file" + vrfSignKey <- jotTempFile "VRF-signing-key-file" + + -- Create VRF key pair + execCardanoCli_ + [ "node", "key-gen-VRF" + , "--verification-key-file", vrfVerKey + , "--signing-key-file", vrfSignKey + ] + + checkVrfFilePermissions (File vrfSignKey) + -- key-gen-VRF cli command created a VRF signing key file with the wrong permissions + & trapFail @VRFPrivateKeyFilePermissionError diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs index f1a7e5af24..aad04b68cc 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs @@ -2,13 +2,12 @@ module Test.Cli.Shelley.Transaction.Build where import Data.List (isInfixOf) import System.Exit (ExitCode (..)) -import System.FilePath (()) -import Test.Cardano.CLI.Util +import Test.Cardano.CLI.Polysemy -import Hedgehog -import qualified Hedgehog as H -import qualified Hedgehog.Extras.Test.Base as H +import Polysemy () +import HaskellWorks.Polysemy.Hedgehog +import HaskellWorks.Prelude inputDir :: FilePath inputDir = "test/cardano-cli-test/files/input/shelley/transaction" @@ -17,10 +16,10 @@ inputDir = "test/cardano-cli-test/files/input/shelley/transaction" -- Execute me with: -- @cabal test cardano-cli-test --test-options '-p "/conway transaction build one voter many votes/"'@ hprop_conway_transaction_build_one_voter_many_votes :: Property -hprop_conway_transaction_build_one_voter_many_votes = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do - outFile <- H.noteTempFile tempDir "tx.traw" +hprop_conway_transaction_build_one_voter_many_votes = propertyOnce $ localWorkspace $ do + outFile <- jotTempFile "tx.traw" - (exitCode, _stdout, stderr) <- H.noteShowM $ execDetailCardanoCLI + (exitCode, _stdout, stderr) <- jotShowM $ execDetailCardanoCli [ "conway", "transaction", "build-raw" , "--tx-in", "6e8c947816e82627aeccb55300074f2894a2051332f62a1c8954e7b588a18be7#0" , "--tx-out", "addr_test1vpfwv0ezc5g8a4mkku8hhy3y3vp92t7s3ul8g778g5yegsgalc6gc+24910487859" @@ -31,5 +30,8 @@ hprop_conway_transaction_build_one_voter_many_votes = propertyOnce $ H.moduleWor , "--out-file", outFile ] - exitCode H.=== ExitFailure 1 - H.assertWith stderr ("This would cause ignoring some of the votes" `isInfixOf`) + exitCode === ExitFailure 1 + + unless ("This would cause ignoring some of the votes" `isInfixOf` stderr) $ do + jot_ stderr + failure