From 2c57825cb255d7e15ef3ad597507fd94da4765bf Mon Sep 17 00:00:00 2001 From: Drazen Popovic Date: Sat, 26 Aug 2023 15:49:00 +0200 Subject: [PATCH 1/2] Misc improvements and fixes --- coop-plutus/test/Coop/Plutus/Test.hs | 69 ++++++++++--------- .../test/Coop/Plutus/Test/Generators.hs | 9 ++- 2 files changed, 45 insertions(+), 33 deletions(-) diff --git a/coop-plutus/test/Coop/Plutus/Test.hs b/coop-plutus/test/Coop/Plutus/Test.hs index a64f2b8..ef9c22d 100644 --- a/coop-plutus/test/Coop/Plutus/Test.hs +++ b/coop-plutus/test/Coop/Plutus/Test.hs @@ -1,13 +1,13 @@ module Coop.Plutus.Test (spec) where import Plutarch.Prelude (ClosedTerm, PBool (PTrue), PEq ((#==)), pconstant, pconstantData, (#)) -import Test.Hspec (Expectation, Spec, describe, runIO, shouldBe) +import Test.Hspec (Expectation, Spec, describe, expectationFailure, runIO, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (NonEmptyList (getNonEmpty), Positive (getPositive), choose, forAll, generate) import Codec.Serialise (deserialiseOrFail) import Coop.Plutus (certV, exampleConsumer, fsV, mkAuthMp, mkCertMp, mkFsMp, pmustSpendAtLeastAa) -import Coop.Plutus.Aux (hashTxInputs, pmustBurnOwnSingletonValue) +import Coop.Plutus.Aux (hashTxInputs, pmustBurnOwnSingletonValue, punit) import Coop.Plutus.Test.Generators (distribute, genAaInputs, genCertRdmrAc, genCorrectAuthMpBurningCtx, genCorrectAuthMpMintingCtx, genCorrectCertMpBurningCtx, genCorrectCertMpMintingCtx, genCorrectCertVSpendingCtx, genCorrectConsumerCtx, genCorrectFsMpBurningCtx, genCorrectFsMpMintingCtx, genCorrectFsVSpendingCtx, genCorrectMustBurnOwnSingletonValueCtx, genCorruptAuthMpBurningCtx, genCorruptAuthMpMintingCtx, genCorruptCertMpBurningCtx, genCorruptCertMpMintingCtx, genCorruptCertVSpendingCtx, genCorruptFsMpBurningCtx, genCorruptFsMpMintingCtx, genCorruptFsVSpendingCtx, genCorruptMustBurnOwnSingletonValueCtx, mkScriptContext) import Coop.Plutus.Types (PAuthMpParams, PCertMpParams, PFsMpParams) import Coop.Types (AuthMpParams (AuthMpParams), AuthMpRedeemer (AuthMpBurn, AuthMpMint), AuthParams (AuthParams), CertMpParams (CertMpParams), CertMpRedeemer (CertMpBurn, CertMpMint), FsMpParams (FsMpParams), FsMpRedeemer (FsMpBurn, FsMpMint)) @@ -16,15 +16,16 @@ import Data.Foldable (Foldable (fold)) import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text (Text, unpack) -import Plutarch (Config (Config, tracingMode), TracingMode (DetTracing), compile, pcon, printScript) +import Plutarch (Config (Config, tracingMode), TracingMode (DetTracing, DoTracing), compile, pcon, printScript) import Plutarch.Api.V1 (PCurrencySymbol) import Plutarch.Builtin (PIsData (pdataImpl)) import Plutarch.Evaluate (evalScript) -import Plutarch.Test (pfails, psucceeds) +import Plutarch.Test (pfails) import PlutusLedgerApi.V1.Address (scriptHashAddress) +import PlutusLedgerApi.V1.Scripts (applyArguments) import PlutusLedgerApi.V1.Value (AssetClass, TokenName (TokenName), assetClass, currencySymbol) import PlutusLedgerApi.V2 (Address, CurrencySymbol, Script, ScriptPurpose (Minting), ValidatorHash (ValidatorHash), dataToBuiltinData, toData) -import PlutusTx (Data) +import PlutusTx (Data, applyCode, liftCode) import PlutusTx.Builtins.Class (stringToBuiltinByteString) coopAc :: AssetClass @@ -209,45 +210,29 @@ spec = do describe "should-succeed" $ do prop "mint $FS" $ let fsMpParams = FsMpParams coopAc fsVAddr (AuthParams authCs certCs) + fsMp = applyArguments (comp mkFsMp) [toData fsMpParams] in forAll (genCorrectFsMpMintingCtx fsMpParams fsCs) $ \ctx -> - psucceeds - ( mkFsMp - # pconstantData @PFsMpParams fsMpParams - # pdataImpl (pconstant FsMpMint) - # pconstant ctx - ) + succeeds $ applyArguments fsMp [toData FsMpMint, toData ctx] prop "burn $FS" $ let fsMpParams = FsMpParams coopAc fsVAddr (AuthParams authCs certCs) + fsMp = applyArguments (comp mkFsMp) [toData fsMpParams] in forAll (genCorrectFsMpBurningCtx fsMpParams fsCs) $ \ctx -> - psucceeds - ( mkFsMp - # pconstantData @PFsMpParams fsMpParams - # pdataImpl (pconstant FsMpBurn) - # pconstant ctx - ) + succeeds $ applyArguments fsMp [toData FsMpBurn, toData ctx] describe "should-fail" $ do prop "mint $FS" $ let fsMpParams = FsMpParams coopAc fsVAddr (AuthParams authCs certCs) + fsMp = applyArguments (comp mkFsMp) [toData fsMpParams] in forAll (genCorruptFsMpMintingCtx fsMpParams fsCs) $ \ctx -> - pfails - ( mkFsMp - # pconstantData @PFsMpParams fsMpParams - # pdataImpl (pconstant FsMpMint) - # pconstant ctx - ) + fails $ applyArguments fsMp [toData FsMpMint, toData ctx] prop "burn $FS" $ let fsMpParams = FsMpParams coopAc fsVAddr (AuthParams authCs certCs) + fsMp = applyArguments (comp mkFsMp) [toData fsMpParams] in forAll (genCorruptFsMpBurningCtx fsMpParams fsCs) $ \ctx -> - pfails - ( mkFsMp - # pconstantData @PFsMpParams fsMpParams - # pdataImpl (pconstant FsMpBurn) - # pconstant ctx - ) + fails $ applyArguments fsMp [toData FsMpBurn, toData ctx] describe "@FsV" $ do describe "should-succeed" $ do prop "spend $FS" $ @@ -293,10 +278,12 @@ _ptraces' p traceMap traceMappedShouldBe = (Right _, _, traceLog) -> traceMap traceLog `shouldBe` traceMappedShouldBe comp :: ClosedTerm a -> Script -comp t = either (error . unpack) id $ compile (Config {tracingMode = DetTracing}) t +comp t = either (error . unpack) id $ compile (Config {tracingMode = DoTracing}) t passert :: ClosedTerm a -> Expectation -passert p = pshouldBe p (pcon PTrue) +passert p = pshouldBe p punit + +psucceeds = passert pshouldBe :: ClosedTerm a -> ClosedTerm b -> Expectation pshouldBe x y = do @@ -309,15 +296,33 @@ pshouldBe x y = do (Left e, _, trace) -> fail $ "Script evaluation failed: " <> show e <> " with trace: " <> show trace (Right x', _, _) -> pure x' +plutusUnit = comp punit + +pscriptSucceeds p = pscriptShouldBe p plutusUnit + {- | Like `pshouldBe` but on `Script` -} pscriptShouldBe :: Script -> Script -> Expectation pscriptShouldBe x y = - printScript x `shouldBe` printScript y + evalScript x `shouldBe` evalScript y readPlutusDataCbor :: FilePath -> IO Data readPlutusDataCbor fname = do cborBytes <- LB.readFile fname let errOrDecoded = deserialiseOrFail @Data cborBytes either (\err -> error $ "File " <> fname <> " can't be parsed into PlutusData CBOR: " <> show err) return errOrDecoded + +-- | Asserts the term evaluates successfully without failing +succeeds :: Script -> Expectation +succeeds s = + case evalScript s of + (Left _, _, t) -> expectationFailure $ "Term failed to evaluate, here's the trace:\n" <> show t + (Right _, _, _) -> pure () + +-- | Asserts the term evaluates without success +fails :: Script -> Expectation +fails s = do + case evalScript s of + (Left _, _, _) -> pure () + (Right _, _, t) -> expectationFailure $ "Term succeeded, here's the trace:\n" <> show t diff --git a/coop-plutus/test/Coop/Plutus/Test/Generators.hs b/coop-plutus/test/Coop/Plutus/Test/Generators.hs index fdef83a..0d7e6c2 100644 --- a/coop-plutus/test/Coop/Plutus/Test/Generators.hs +++ b/coop-plutus/test/Coop/Plutus/Test/Generators.hs @@ -21,6 +21,7 @@ import Coop.Types (AuthMpParams (amp'authAuthorityAc, amp'requiredAtLeastAaQ), A import PlutusLedgerApi.V1.Interval (interval) import PlutusLedgerApi.V2 qualified as Value import PlutusTx.Prelude (Group (inv)) +import Test.QuickCheck.Gen qualified as Q mkScriptContext :: ScriptPurpose -> [TxInInfo] -> [TxInInfo] -> Value -> [TxOut] -> [PubKeyHash] -> ScriptContext mkScriptContext purpose ins refs mints outs sigs = @@ -350,12 +351,13 @@ genCorrectFsMpMintingCtx fsMpParams fsCs = do certRefs <- for certIds (genCertInput certVAddr certCs certRdmrAc validity) authIns <- for certIds (genAuthInput authCs) (otherIns, otherMint, otherOuts) <- genOthers 5 + gcAfter <- genExtendedTime let authsBurned = mconcat [Value.singleton authCs (TokenName certId) (-1) | certId <- certIds] fsVOuts = [ TxOut fsVAddr (Value.singleton fsCs (TokenName . toBuiltin $ hashTxInputs [authIn]) 1) - (toOutputDatum $ FsDatum (toBuiltinData True) "deadbeef" (Finite 100) submitter) + (toOutputDatum $ FsDatum (toBuiltinData True) "deadbeef" gcAfter submitter) Nothing | authIn <- authIns ] @@ -544,6 +546,11 @@ genTokenName = TokenName <$> genBuiltinByteString "tn-" 32 genCurrencySymbol :: Gen CurrencySymbol genCurrencySymbol = CurrencySymbol <$> genBuiltinByteString "cs-" 28 +genExtendedTime :: Gen (Extended POSIXTime) +genExtendedTime = Q.oneof [return NegInf, return PosInf, genFinite] + where + genFinite = Finite . POSIXTime <$> chooseInteger (0, 100) + genAuthenticatonId :: Gen BuiltinByteString genAuthenticatonId = genBuiltinByteString "authid-" 28 From 13320e7ad927ff946c6d87e84da4fccaf3fa3300 Mon Sep 17 00:00:00 2001 From: Drazen Popovic Date: Wed, 18 Oct 2023 10:23:54 +0200 Subject: [PATCH 2/2] Fixes CI --- coop-plutus/test/Coop/Plutus/Test.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/coop-plutus/test/Coop/Plutus/Test.hs b/coop-plutus/test/Coop/Plutus/Test.hs index ef9c22d..981341a 100644 --- a/coop-plutus/test/Coop/Plutus/Test.hs +++ b/coop-plutus/test/Coop/Plutus/Test.hs @@ -1,6 +1,6 @@ module Coop.Plutus.Test (spec) where -import Plutarch.Prelude (ClosedTerm, PBool (PTrue), PEq ((#==)), pconstant, pconstantData, (#)) +import Plutarch.Prelude (ClosedTerm, PEq ((#==)), pconstant, pconstantData, (#)) import Test.Hspec (Expectation, Spec, describe, expectationFailure, runIO, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (NonEmptyList (getNonEmpty), Positive (getPositive), choose, forAll, generate) @@ -9,14 +9,14 @@ import Codec.Serialise (deserialiseOrFail) import Coop.Plutus (certV, exampleConsumer, fsV, mkAuthMp, mkCertMp, mkFsMp, pmustSpendAtLeastAa) import Coop.Plutus.Aux (hashTxInputs, pmustBurnOwnSingletonValue, punit) import Coop.Plutus.Test.Generators (distribute, genAaInputs, genCertRdmrAc, genCorrectAuthMpBurningCtx, genCorrectAuthMpMintingCtx, genCorrectCertMpBurningCtx, genCorrectCertMpMintingCtx, genCorrectCertVSpendingCtx, genCorrectConsumerCtx, genCorrectFsMpBurningCtx, genCorrectFsMpMintingCtx, genCorrectFsVSpendingCtx, genCorrectMustBurnOwnSingletonValueCtx, genCorruptAuthMpBurningCtx, genCorruptAuthMpMintingCtx, genCorruptCertMpBurningCtx, genCorruptCertMpMintingCtx, genCorruptCertVSpendingCtx, genCorruptFsMpBurningCtx, genCorruptFsMpMintingCtx, genCorruptFsVSpendingCtx, genCorruptMustBurnOwnSingletonValueCtx, mkScriptContext) -import Coop.Plutus.Types (PAuthMpParams, PCertMpParams, PFsMpParams) +import Coop.Plutus.Types (PAuthMpParams, PCertMpParams) import Coop.Types (AuthMpParams (AuthMpParams), AuthMpRedeemer (AuthMpBurn, AuthMpMint), AuthParams (AuthParams), CertMpParams (CertMpParams), CertMpRedeemer (CertMpBurn, CertMpMint), FsMpParams (FsMpParams), FsMpRedeemer (FsMpBurn, FsMpMint)) import Data.ByteString.Lazy qualified as LB import Data.Foldable (Foldable (fold)) import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text (Text, unpack) -import Plutarch (Config (Config, tracingMode), TracingMode (DetTracing, DoTracing), compile, pcon, printScript) +import Plutarch (Config (Config, tracingMode), TracingMode (DoTracing), compile) import Plutarch.Api.V1 (PCurrencySymbol) import Plutarch.Builtin (PIsData (pdataImpl)) import Plutarch.Evaluate (evalScript) @@ -25,7 +25,7 @@ import PlutusLedgerApi.V1.Address (scriptHashAddress) import PlutusLedgerApi.V1.Scripts (applyArguments) import PlutusLedgerApi.V1.Value (AssetClass, TokenName (TokenName), assetClass, currencySymbol) import PlutusLedgerApi.V2 (Address, CurrencySymbol, Script, ScriptPurpose (Minting), ValidatorHash (ValidatorHash), dataToBuiltinData, toData) -import PlutusTx (Data, applyCode, liftCode) +import PlutusTx (Data) import PlutusTx.Builtins.Class (stringToBuiltinByteString) coopAc :: AssetClass @@ -283,6 +283,7 @@ comp t = either (error . unpack) id $ compile (Config {tracingMode = DoTracing}) passert :: ClosedTerm a -> Expectation passert p = pshouldBe p punit +psucceeds :: ClosedTerm a -> Expectation psucceeds = passert pshouldBe :: ClosedTerm a -> ClosedTerm b -> Expectation @@ -296,10 +297,6 @@ pshouldBe x y = do (Left e, _, trace) -> fail $ "Script evaluation failed: " <> show e <> " with trace: " <> show trace (Right x', _, _) -> pure x' -plutusUnit = comp punit - -pscriptSucceeds p = pscriptShouldBe p plutusUnit - {- | Like `pshouldBe` but on `Script` -}