Replaced Apropos Property testing with PQ and PCB for MultiSig

agora-specs/Property/MultiSig.hs

@@ -0,0 +1,113 @@
+{- |
+Module     : Property.MultiSig
+Maintainer : seungheon.ooh@gmail.com
+Description: Property tests for 'MultiSig' functions
+
+Property model and tests for 'MultiSig' functions
+-}
+module Property.MultiSig (props) where
+
+import Agora.MultiSig (
+  MultiSig (MultiSig),
+  PMultiSig,
+  pvalidatedByMultisig,
+ )
+import Agora.Utils (tclet)
+import Data.Maybe (fromJust)
+import Data.Tagged (Tagged (Tagged))
+import Data.Universe (Finite (..), Universe (..))
+import Plutarch.Api.V1 (PScriptContext)
+import Plutarch.Context.Config (defaultConfig)
+import Plutarch.Context.Spending (
+  ValidatorUTXO (ValidatorUTXO),
+  inputSelfExtra,
+  signedWith,
+  spendingContext,
+ )
+import Plutus.V1.Ledger.Api (
+  ScriptContext (scriptContextTxInfo),
+  TxInfo (txInfoSignatories),
+ )
+import Spec.Generator (genAnyValue, genPubKeyHash)
+import Test.Tasty (TestTree)
+import Test.Tasty.Plutarch.Property (classifiedProperty)
+import Test.Tasty.QuickCheck (
+  Gen,
+  Property,
+  chooseInt,
+  listOf,
+  testProperty,
+  vectorOf,
+ )
+
+-- | apropos model for testing multisigs.
+type MultiSigModel = (MultiSig, ScriptContext)
+
+-- | Propositions that may hold true of a `MultiSigModel`.
+data MultiSigProp
+  = -- | Sufficient number of signatories in the script context.
+    MeetsMinSigs
+  | -- | Insufficient number of signatories in the script context.
+    DoesNotMeetMinSigs
+  deriving stock (Eq, Show, Ord)
+
+instance Universe MultiSigProp where
+  universe = [MeetsMinSigs, DoesNotMeetMinSigs]
+
+instance Finite MultiSigProp where
+  universeF = universe
+  cardinality = Tagged 2
+
+-- | Generate model with given proposition.
+genMultiSigProp :: MultiSigProp -> Gen MultiSigModel
+genMultiSigProp prop = do
+  size <- chooseInt (4, 20)
+  pkhs <- vectorOf size genPubKeyHash
+  vutxo <- pure . ValidatorUTXO () <$> genAnyValue
+  minSig <- chooseInt (1, length pkhs)
+  othersigners <- take 20 <$> listOf genPubKeyHash
+
+  let ms = MultiSig pkhs (toInteger minSig)
+
+  n <- case prop of
+    MeetsMinSigs -> chooseInt (minSig, length pkhs)
+    DoesNotMeetMinSigs -> chooseInt (0, minSig - 1)
+
+  let builder = foldr (<>) (inputSelfExtra mempty ()) (signedWith <$> take n pkhs <> othersigners)
+      ctx = fromJust $ spendingContext defaultConfig builder vutxo
+  pure (ms, ctx)
+
+-- | Classify model into propositions.
+classifyMultiSigProp :: MultiSigModel -> MultiSigProp
+classifyMultiSigProp (MultiSig keys (fromIntegral -> minsig), ctx)
+  | minsig <= length signer = MeetsMinSigs
+  | otherwise = DoesNotMeetMinSigs
+  where
+    signer = filter (`elem` keys) $ txInfoSignatories . scriptContextTxInfo $ ctx
+
+-- | Shrinker. Not used.
+shrinkMultiSigProp :: MultiSigModel -> [MultiSigModel]
+shrinkMultiSigProp = const []
+
+expected :: Term s (PBuiltinPair PMultiSig PScriptContext :--> PMaybe PBool)
+expected = plam $ \x -> unTermCont $ do
+  ms <- tclet $ pfstBuiltin # x
+  sc <- tclet $ psndBuiltin # x
+  multsig <- tcont $ pletFields @'["keys", "minSigs"] ms
+  let signers = pfromData $ pfield @"signatories" #$ pfromData (pfield @"txInfo" # sc)
+      validSigners = plength #$ pfilter # plam (\x -> pelem # x # multsig.keys) # signers
+  pure $ pcon $ PJust $ pfromData multsig.minSigs #<= validSigners
+
+actual :: Term s (PBuiltinPair PMultiSig PScriptContext :--> PBool)
+actual = plam $ \x -> unTermCont $ do
+  ms <- tclet $ pfstBuiltin # x
+  sc <- tclet $ psndBuiltin # x
+  pure $ pvalidatedByMultisig # ms # (pfield @"txInfo" # sc)
+
+prop :: Property
+prop = classifiedProperty genMultiSigProp shrinkMultiSigProp expected classifyMultiSigProp actual
+
+props :: [TestTree]
+props =
+  [ testProperty "MultiSig property" prop
+  ]