test: add property-based testing

Anastasia-Labs · Jan 5, 2024 · 1a6afcc · 1a6afcc
1 parent c208738
commit 1a6afcc
Show file tree

Hide file tree

Showing 15 changed files with 901 additions and 91 deletions.
diff --git a/.direnv/flake-profile b/.direnv/flake-profile
diff --git a/.direnv/flake-profile-1-link b/.direnv/flake-profile-1-link
diff --git a/.gitignore b/.gitignore
@@ -3,6 +3,7 @@ dist-newstyle
 tmp
 .pre-commit-config.yaml
 .direnv
+.direnv/**
 
 front-end/tmp
 

diff --git a/bridge-template.cabal b/bridge-template.cabal
@@ -161,13 +161,15 @@ executable bridge-template
   build-depends:  bridge-template
   hs-source-dirs: app
 
--- test-suite bridge-template-test
---   import:         lang, test-dependencies
---   type:           exitcode-stdio-1.0
---   main-is:        Spec.hs
---   hs-source-dirs: test
---   other-modules:
---     Spec.GuardianValidatorSpec
---     Spec.MintCBTCSpec
-
---   build-depends:  bridge-template
+test-suite bridge-template-test
+  import:         lang, test-dependencies
+  type:           exitcode-stdio-1.0
+  main-is:        Spec.hs
+  hs-source-dirs: test
+  other-modules:
+    Spec.GuardianValidatorSpec
+    Spec.MultiSigMintPolicySpec
+    Spec.MultiSigValidatorSpec
+    Spec.WrapMintPolicySpec
+
+  build-depends:  bridge-template
diff --git a/src/Collection/Utils.hs b/src/Collection/Utils.hs
@@ -44,7 +44,7 @@ paysToCredential = phoistAcyclic $
 ptryOwnInput :: (PIsListLike list PTxInInfo) => Term s (list PTxInInfo :--> PTxOutRef :--> PTxOut)
 ptryOwnInput = phoistAcyclic $
   plam $ \inputs ownRef ->
-    precList (\self x xs -> pletFields @'["outRef", "resolved"] x $ \txInFields -> pif (ownRef #== txInFields.outRef) txInFields.resolved (self # xs)) (const perror) # inputs
+    precList (\self x xs -> pletFields @'["outRef", "resolved"] x $ \txInFields -> pif (ownRef #== txInFields.outRef) txInFields.resolved (self # xs)) (const (ptraceError $ pshow ownRef)) # inputs
 
 -- Get the head of the list if the list contains exactly one element, otherwise error.
 pheadSingleton :: (PListLike list, PElemConstraint list a) => Term s (list a :--> a)

diff --git a/src/GuardianValidator.hs b/src/GuardianValidator.hs
@@ -1,27 +1,27 @@
 {-# LANGUAGE TemplateHaskell #-}
 
-module GuardianValidator (validator, PWitnessDatum (PWitnessDatum), PWitnessParametersD (..)) where
+module GuardianValidator (validator, PWitnessDatum (PWitnessDatum), PWitnessParametersD (..), WitnessDatum (..)) where
 
 import Collection.Utils (paysToCredential, pheadSingleton, ppositiveSymbolValueOf, ptryOwnInput, (#>))
 import Plutarch.Api.V1.Address (PCredential (PScriptCredential))
 import Plutarch.Api.V2 (PAddress, PCurrencySymbol, PScriptHash, PScriptPurpose (PSpending), PTxInInfo, PValidator)
-import Plutarch.DataRepr
-  ( DerivePConstantViaData (DerivePConstantViaData),
-    PDataFields,
-  )
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pletFieldsC, pmatchC)
-import Plutarch.Lift
-  ( PConstantDecl,
-    PUnsafeLiftDecl (PLifted),
-  )
+import Plutarch.DataRepr (
+  DerivePConstantViaData (DerivePConstantViaData),
+  PDataFields,
+ )
+import Plutarch.Lift (
+  PConstantDecl,
+  PUnsafeLiftDecl (PLifted),
+ )
 import Plutarch.Prelude
 import PlutusLedgerApi.V2 (Address, BuiltinByteString, CurrencySymbol, ScriptHash)
 import PlutusTx qualified
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pletFieldsC, pmatchC)
 
 data WitnessDatum = WitnessDatum
-  { btcSent :: Integer,
-    btcAddress :: BuiltinByteString,
-    adaAddr :: Address
+  { bridgeAmt :: Integer
+  , otherChainAddr :: BuiltinByteString
+  , cardanoPKH :: Address
   }
   deriving stock (Generic, Show)
 
@@ -32,9 +32,9 @@ newtype PWitnessDatum (s :: S)
       ( Term
           s
           ( PDataRecord
-              '[ "bridgeAmt" ':= PInteger,
-                 "otherChainAddr" ':= PByteString,
-                 "cardanoPKH" ':= PAddress
+              '[ "bridgeAmt" ':= PInteger
+               , "otherChainAddr" ':= PByteString
+               , "cardanoPKH" ':= PAddress
                ]
           )
       )
@@ -79,14 +79,14 @@ deriving via
     (PConstantDecl GuardianRedeemer)
 
 data WitnessParameters = WitnessParameters
-  { multisigVH :: ScriptHash,
-    multisigCert :: CurrencySymbol
+  { multisigVH :: ScriptHash
+  , multisigCert :: CurrencySymbol
   }
   deriving stock (Generic, Show)
 
 data PWitnessParameters (s :: S) = PWitnessParameters
-  { pmultisigVH :: Term s PScriptHash,
-    pmultisigCert :: Term s PCurrencySymbol
+  { pmultisigVH :: Term s PScriptHash
+  , pmultisigCert :: Term s PCurrencySymbol
   }
   deriving stock (Generic)
   deriving anyclass (PlutusType, PShow)
@@ -104,8 +104,8 @@ newtype PWitnessParametersD (s :: S)
       ( Term
           s
           ( PDataRecord
-              '[ "multisigVH" ':= PAsData PScriptHash,
-                 "multisigCert" ':= PAsData PCurrencySymbol
+              '[ "multisigVH" ':= PAsData PScriptHash
+               , "multisigCert" ':= PAsData PCurrencySymbol
                ]
           )
       )

diff --git a/src/MultiSigMintPolicy.hs b/src/MultiSigMintPolicy.hs
@@ -6,11 +6,11 @@ import Collection.Utils (paysToCredential, phasInput, pheadSingleton, pnegativeS
 import MultiSigValidator (PMultisigDatum)
 import Plutarch.Api.V2 (PMintingPolicy, POutputDatum (POutputDatum), PPubKeyHash, PScriptHash, PScriptPurpose (PMinting), PTxOutRef)
 import Plutarch.DataRepr (DerivePConstantViaData (DerivePConstantViaData))
-import "liqwid-plutarch-extra" Plutarch.Extra.ScriptContext (pfromPDatum)
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pletFieldsC, pmatchC)
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import Plutarch.Prelude
 import PlutusTx qualified
+import "liqwid-plutarch-extra" Plutarch.Extra.ScriptContext (pfromPDatum)
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pletFieldsC, pmatchC)
 
 data GuardianMintAction
   = MintGuardianCrt

diff --git a/src/MultiSigValidator.hs b/src/MultiSigValidator.hs
@@ -1,42 +1,84 @@
-module MultiSigValidator (validator, PMultisigDatum (PMultisigDatum)) where
+{-# LANGUAGE TemplateHaskell #-}
+
+module MultiSigValidator (
+  validator,
+  PMultisigDatum (PMultisigDatum),
+  MultisigDatum (..),
+  MultisigRedeemer (..),
+) where
 
 import Collection.Utils (paysToCredential, pheadSingleton, ptryOwnInput, pvalueContains, (#>), (#>=))
 import Plutarch.Api.V1.Address (PCredential (PScriptCredential))
-import Plutarch.Api.V2
-  ( POutputDatum (POutputDatum),
-    PPubKeyHash,
-    PScriptPurpose (PSpending),
-    PValidator,
-  )
-import Plutarch.DataRepr (PDataFields)
+import Plutarch.Api.V2 (
+  POutputDatum (POutputDatum),
+  PPubKeyHash,
+  PScriptPurpose (PSpending),
+  PValidator,
+ )
+import Plutarch.DataRepr (
+  DerivePConstantViaData (DerivePConstantViaData),
+  PDataFields,
+ )
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
+import Plutarch.Prelude
+import PlutusLedgerApi.V2 (PubKeyHash)
+import PlutusTx qualified
 import "liqwid-plutarch-extra" Plutarch.Extra.ScriptContext (pfromPDatum)
 import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pletFieldsC, pmatchC, ptryFromC)
-import Plutarch.Prelude
+
+data MultisigDatum = MultisigDatum
+  { keys :: [PubKeyHash]
+  , requiredCount :: Integer
+  }
+  deriving stock (Generic, Eq, Show)
+
+PlutusTx.makeIsDataIndexed ''MultisigDatum [('MultisigDatum, 0)]
+PlutusTx.makeLift ''MultisigDatum
 
 newtype PMultisigDatum (s :: S)
   = PMultisigDatum
       ( Term
           s
           ( PDataRecord
-              '[ "keys" ':= PBuiltinList (PAsData PPubKeyHash),
-                 "requiredCount" ':= PInteger
+              '[ "keys" ':= PBuiltinList (PAsData PPubKeyHash)
+               , "requiredCount" ':= PInteger
                ]
           )
       )
   deriving stock (Generic)
   deriving anyclass (PlutusType, PIsData, PDataFields, PEq)
-
+instance PUnsafeLiftDecl PMultisigDatum where type PLifted PMultisigDatum = MultisigDatum
+deriving via (DerivePConstantViaData MultisigDatum PMultisigDatum) instance PConstantDecl MultisigDatum
 instance PTryFrom PData PMultisigDatum
-
 instance DerivePlutusType PMultisigDatum where
   type DPTStrat _ = PlutusTypeData
 
+data MultisigRedeemer
+  = Update
+  | Sign
+  deriving stock (Show, Eq, Generic)
+
+PlutusTx.makeIsDataIndexed
+  ''MultisigRedeemer
+  [ ('Update, 0)
+  , ('Sign, 1)
+  ]
+PlutusTx.makeLift ''MultisigRedeemer
+
 data PMultisigRedeemer (s :: S)
   = PUpdate (Term s (PDataRecord '[]))
   | PSign (Term s (PDataRecord '[]))
   deriving stock (Generic)
   deriving anyclass (PlutusType, PIsData, PShow)
 
+deriving via
+  (DerivePConstantViaData MultisigRedeemer PMultisigRedeemer)
+  instance
+    PConstantDecl MultisigRedeemer
+
+instance PUnsafeLiftDecl PMultisigRedeemer where
+  type PLifted PMultisigRedeemer = MultisigRedeemer
+
 instance PTryFrom PData PMultisigRedeemer
 
 instance DerivePlutusType PMultisigRedeemer where
@@ -62,7 +104,7 @@ psignedByAMajority :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PInteger :
 psignedByAMajority = phoistAcyclic $ plam $ \allKeys requiredCount signers ->
   plength # (pfilter # plam (\sig -> pelem # sig # allKeys) # signers) #>= requiredCount
 
-validator :: ClosedTerm (PValidator)
+validator :: ClosedTerm PValidator
 validator = phoistAcyclic $ plam $ \dat' redeemer' ctx -> unTermCont $ do
   contextFields <- pletFieldsC @["txInfo", "purpose"] ctx
   PSpending ownRef' <- pmatchC contextFields.purpose
@@ -85,7 +127,7 @@ validator = phoistAcyclic $ plam $ \dat' redeemer' ctx -> unTermCont $ do
   pure $
     popaque $
       pif
-        ( ptraceIfFalse "MultiSigValidator f1" (psignedByAMajority # datF.keys # datF.requiredCount # txInfoFields.signatories)
+        ( ptraceIfFalse "MultiSigValidator f1 " (psignedByAMajority # datF.keys # datF.requiredCount # txInfoFields.signatories)
             #&& ptraceIfFalse "MultiSigValidator f2" (pvalueContains # ownOutputFields.value # ownInputFields.value)
             #&& pmatch
               redeemer

diff --git a/src/Utils.hs b/src/Utils.hs
@@ -1,47 +1,47 @@
-module Utils
-  ( evalT,
-    evalSerialize,
-    phasOneCurrecySymbolOneTokenName,
-    phasScriptHash,
-    writePlutusScript,
-    compileD,
-  )
+module Utils (
+  evalT,
+  evalSerialize,
+  phasOneCurrecySymbolOneTokenName,
+  phasScriptHash,
+  writePlutusScript,
+  compileD,
+)
 where
 
 import Cardano.Binary qualified as CBOR
 import Data.Aeson (KeyValue ((.=)), object)
 import Data.Aeson.Encode.Pretty (encodePretty)
-import Data.Bifunctor
-  ( first,
-  )
+import Data.Bifunctor (
+  first,
+ )
 import Data.ByteString.Base16 qualified as Base16
 import Data.ByteString.Lazy qualified as LBS
-import Data.Text
-  ( Text,
-    pack,
-  )
+import Data.Text (
+  Text,
+  pack,
+ )
 import Data.Text.Encoding qualified as Text
-import Plutarch
-  ( Config (Config),
-    TracingMode (DoTracing),
-    compile,
-  )
+import Plutarch (
+  Config (Config),
+  TracingMode (DoTracing),
+  compile,
+ )
 import Plutarch.Api.V1.Address (PCredential (PPubKeyCredential, PScriptCredential))
 import Plutarch.Api.V2 (AmountGuarantees, KeyGuarantees, PMap (PMap), PScriptHash, PTxInInfo, PValue (PValue))
-import Plutarch.Evaluate
-  ( evalScript,
-  )
-import "liqwid-plutarch-extra" Plutarch.Extra.List (pisSingleton)
-import "liqwid-plutarch-extra" Plutarch.Extra.Script
-  ( applyArguments,
-  )
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pmatchC)
+import Plutarch.Evaluate (
+  evalScript,
+ )
 import Plutarch.Prelude
 import Plutarch.Script (Script, serialiseScript)
-import PlutusLedgerApi.V2
-  ( Data,
-    ExBudget,
-  )
+import PlutusLedgerApi.V2 (
+  Data,
+  ExBudget,
+ )
+import "liqwid-plutarch-extra" Plutarch.Extra.List (pisSingleton)
+import "liqwid-plutarch-extra" Plutarch.Extra.Script (
+  applyArguments,
+ )
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pmatchC)
 
 evalSerialize :: ClosedTerm a -> Text
 evalSerialize x =
@@ -84,8 +84,9 @@ only checks length of CurrencySymbol, and not TokenName length
 mockCtx3 fails
 -}
 
--- | Returns 'PTrue' if the argument 'PValue' has one 'PCurrencySymbol'
---  and one 'PTokenName', if PValue is not /normalized/ ('PValue' ''Sorted' ''NonZero') it will return 'PFalse'
+{- | Returns 'PTrue' if the argument 'PValue' has one 'PCurrencySymbol'
+ and one 'PTokenName', if PValue is not /normalized/ ('PValue' ''Sorted' ''NonZero') it will return 'PFalse'
+-}
 phasOneCurrecySymbolOneTokenName ::
   forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
   Term s (PValue keys amounts :--> PBool)