diff --git a/agora-test/Model/MultiSig.hs b/agora-test/Model/MultiSig.hs index bafb9b4..3ff1b04 100644 --- a/agora-test/Model/MultiSig.hs +++ b/agora-test/Model/MultiSig.hs @@ -1,9 +1,28 @@ -module Model.MultiSig () where +module Model.MultiSig (plutarchTests, genTests) where -import Agora.MultiSig (MultiSig (..)) -import Apropos (Apropos (Apropos), Formula (ExactlyOne), (:+)) -import Apropos.Script (HasScriptRunner (expect, script)) -import Plutus.V1.Ledger.Api (PubKeyHash, Script) +import Agora.MultiSig (MultiSig (..), validatedByMultisig) +import Apropos (Apropos (Apropos), Formula (ExactlyOne, Var, Yes), HasLogicalModel (..), HasParameterisedGenerator, LogicalModel (logic), parameterisedGenerator, runGeneratorTestsWhere, (:+)) +import Apropos.Gen (Gen, choice, int, linear, list) +import Apropos.LogicalModel (Enumerable) +import Apropos.LogicalModel.Enumerable (Enumerable (enumerated)) +import Apropos.Script (HasScriptRunner (expect, runScriptTestsWhere, script)) +import Data.List (intersect) +import Plutarch (compile) +import Plutus.V1.Ledger.Api ( + Script, + ScriptContext (scriptContextPurpose), + ScriptPurpose (Spending), + TxInfo (txInfoDCert, txInfoData, txInfoFee, txInfoId, txInfoInputs, txInfoMint, txInfoOutputs, txInfoValidRange, txInfoWdrl), + TxOutRef (TxOutRef), + scriptContextTxInfo, + txInfoSignatories, + ) +import Plutus.V1.Ledger.Contexts (ScriptContext (ScriptContext), TxInfo (TxInfo)) +import Plutus.V1.Ledger.Crypto (PubKeyHash) +import Plutus.V1.Ledger.Interval qualified as Interval +import Plutus.V1.Ledger.Value qualified as Value +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (fromGroup) {- @@ -33,27 +52,94 @@ data MultiSigModel = MultiSigModel { ms :: MultiSig , ctx :: ScriptContext } + deriving stock (Eq, Show) data MultiSigProp = MeetsMinSigs | DoesNotMeetMinSigs + deriving stock (Eq, Show, Ord) -instance LogicalModel MultiSigModel where +instance Enumerable MultiSigProp where + enumerated = [MeetsMinSigs, DoesNotMeetMinSigs] + +instance LogicalModel MultiSigProp where logic = ExactlyOne [Var MeetsMinSigs, Var DoesNotMeetMinSigs] instance HasLogicalModel MultiSigProp MultiSigModel where satisfiesProperty :: MultiSigProp -> MultiSigModel -> Bool satisfiesProperty p m = let minSigs = m.ms.minSigs - signatories = m.ctx.txInfo.txInfoSignatories + signatories = txInfoSignatories $ scriptContextTxInfo $ m.ctx matchingSigs = intersect m.ms.keys signatories in case p of - MeetsMinSigs -> length matchingSigs >= minSigs - DoesNotMeetMinSigs -> length matchingSigs < minSigs + MeetsMinSigs -> length matchingSigs >= fromInteger minSigs + DoesNotMeetMinSigs -> length matchingSigs < fromInteger minSigs -instance HasScriptRunner MultiSigProp MultiSig where +contextWithSignatures :: [PubKeyHash] -> ScriptContext +contextWithSignatures sigs = + ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = [] + , txInfoOutputs = [] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = sigs + , txInfoData = [] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + } + , scriptContextPurpose = Spending (TxOutRef "" 0) + } + +genPK :: Gen PubKeyHash +genPK = + choice + [ pure "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" + , pure "0b12051dd2da4b3629cebb92e2be111e0e99c63c04727ed55b74a296" + , pure "87f5f31e4d7437463cd901c4c9edb7a51903ac858661503e9d72f492" + , pure "f74ccaee8244264b3c73fce3b66bd2337de3db70efff4261d6ff145b" + ] + +instance HasParameterisedGenerator MultiSigProp MultiSigModel where + parameterisedGenerator s = do + expectedSignatures <- list (linear 1 4) genPK + minSigs <- toInteger <$> int (linear 1 (length expectedSignatures)) + let msig = MultiSig expectedSignatures minSigs + + actualSignaturesLength <- + if MeetsMinSigs `elem` s + then int (linear (fromInteger minSigs) (length expectedSignatures)) + else pure 0 + let actualSignatures = take actualSignaturesLength expectedSignatures + + let ctx = contextWithSignatures actualSignatures + pure (MultiSigModel msig ctx) + +instance HasScriptRunner MultiSigProp MultiSigModel where expect :: (MultiSigModel :+ MultiSigProp) -> Formula MultiSigProp - expect = undefined + expect Apropos = Var MeetsMinSigs - script :: (MultiSigModel :+ MultiSigProp) -> MultiSig -> Script - script Apropos msm = compile $ validatedByMultisig msm . ms + script :: (MultiSigModel :+ MultiSigProp) -> MultiSigModel -> Script + script Apropos msm = + compile $ + pif + (validatedByMultisig msm.ms # pconstant msm.ctx.scriptContextTxInfo) + (pcon PUnit) + perror + +genTests :: TestTree +genTests = + testGroup "genTests" $ + fromGroup + <$> [ runGeneratorTestsWhere (Apropos :: MultiSigModel :+ MultiSigProp) "Generator" Yes + ] + +plutarchTests :: TestTree +plutarchTests = + testGroup "plutarchTests" $ + fromGroup + <$> [ runScriptTestsWhere (Apropos :: MultiSigModel :+ MultiSigProp) "ScriptValid" Yes + ] diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 37def06..fada856 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -8,6 +8,7 @@ import Test.Tasty (defaultMain, testGroup) -------------------------------------------------------------------------------- +import Model.MultiSig qualified import Spec.Int import Spec.Stake qualified as Stake @@ -25,5 +26,10 @@ main = "Int" [ intPlutarchTests ] + , testGroup + "MultiSig" + [ Model.MultiSig.plutarchTests + , Model.MultiSig.genTests + ] ] ] diff --git a/agora.cabal b/agora.cabal index 6ffd3b3..be8ab96 100644 --- a/agora.cabal +++ b/agora.cabal @@ -151,6 +151,7 @@ test-suite agora-test Spec.Int Spec.Sample.Stake Spec.Stake + Model.MultiSig Spec.Util build-depends: agora diff --git a/agora/Agora/MultiSig.hs b/agora/Agora/MultiSig.hs index 2014c02..1e8a548 100644 --- a/agora/Agora/MultiSig.hs +++ b/agora/Agora/MultiSig.hs @@ -47,7 +47,7 @@ data MultiSig = MultiSig -- ^ List of PubKeyHashes that must be present in the list of signatories. , minSigs :: Integer } - deriving stock (GHC.Generic) + deriving stock (GHC.Generic, Eq, Show) deriving anyclass (Generic) PlutusTx.makeLift ''MultiSig