145 lines
4.7 KiB
Haskell
145 lines
4.7 KiB
Haskell
module Model.MultiSig (plutarchTests, genTests) where
|
|
|
|
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)
|
|
|
|
{-
|
|
|
|
1. Create proposition sum type.
|
|
2. Create logical model defining relationships between propositions.
|
|
3. Associating propositions with the "concrete" type i.e. MultiSig.
|
|
4. Create Generators.
|
|
5. Run tests (with magic).
|
|
|
|
-}
|
|
|
|
{-
|
|
|
|
1. Create a
|
|
|
|
Define a prop, as if it is the way a script can pass.
|
|
1. keys signed exceeds `minSigs`
|
|
2. `minSigs` is lte zero.
|
|
|
|
Props not passing:
|
|
1. No signatures present.
|
|
2. Signatures present is less than `minSigs`.
|
|
|
|
-}
|
|
|
|
data MultiSigModel = MultiSigModel
|
|
{ ms :: MultiSig
|
|
, ctx :: ScriptContext
|
|
}
|
|
deriving stock (Eq, Show)
|
|
|
|
data MultiSigProp
|
|
= MeetsMinSigs
|
|
| DoesNotMeetMinSigs
|
|
deriving stock (Eq, Show, Ord)
|
|
|
|
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 = txInfoSignatories $ scriptContextTxInfo $ m.ctx
|
|
matchingSigs = intersect m.ms.keys signatories
|
|
in case p of
|
|
MeetsMinSigs -> length matchingSigs >= fromInteger minSigs
|
|
DoesNotMeetMinSigs -> length matchingSigs < fromInteger minSigs
|
|
|
|
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 Apropos = Var MeetsMinSigs
|
|
|
|
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
|
|
]
|