diff --git a/coop-plutus/test/Coop/Plutus/Test.hs b/coop-plutus/test/Coop/Plutus/Test.hs index a64f2b8..981341a 100644 --- a/coop-plutus/test/Coop/Plutus/Test.hs +++ b/coop-plutus/test/Coop/Plutus/Test.hs @@ -1,27 +1,28 @@ module Coop.Plutus.Test (spec) where -import Plutarch.Prelude (ClosedTerm, PBool (PTrue), PEq ((#==)), pconstant, pconstantData, (#)) -import Test.Hspec (Expectation, Spec, describe, runIO, shouldBe) +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) 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.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), 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) -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) @@ -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,13 @@ _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 :: ClosedTerm a -> Expectation +psucceeds = passert pshouldBe :: ClosedTerm a -> ClosedTerm b -> Expectation pshouldBe x y = do @@ -314,10 +302,24 @@ pshouldBe x y = do -} 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