Improving testing framework and adding the capability to predicate on…

… resulting log (#450)

* tests pass with new mockchain return type

* more log levels

* logging removal of unusable balancing utxos

* improving logging in balancing

* new log version with dedicated constructors

* changing item

* integrating comments, adding comments and more readable bullets

* fixing the bug where collateral inputs were not resolved

* CHANGELOG.md

* integrating review comments

* typo

* removing useless instances

* wip

* reverting balancingspec

* starting to consume scripts in balancing spec, to be continued

* reworking empty collaterals

* 2 first test groups passé

* all tests fixed

* doc

* updating doc

* logging of unused collateral option

* post-rebase small fixes

* bye bye Ledger.TxOut

* update capi

* Proper script hash computation for all plutus versions

* helpers and qol changes

* MockChainSt has its own module now

* Support for hashed datums in reference inputs

* withdrawal support

* fixing balancing bug

* small post-rebase changes

* showbsspec finally gone

* Recreating an index to pass to the new fee estimate function

* post merge fix

* no tests built for dependencies, relying on cne directly

* CHANGELOG.md

* relying on the fork for translation functions

* credential and staking credential of a wallet

* moving time from either the lower or upper bound of current slot

* depending on cne

* post merge mini fix

* reworking withdrawals for proper maps

* hpack

* homogenizing tests + make them depend on log

* one more refactoring

* refactoring testing in progress

* finishing to rework testing

* flipping ==>

* restructuring and commenting testing module

* spreading around all the changes, removing fancy non-working type class

* better name

* post review changes

* CHANGELOG.md

* integrating review comments

---------

Co-authored-by: mmontin <mathieu.montin@tweag.io>

CHANGELOG.md

@@ -22,6 +22,7 @@
   constrained yet.
 - PrettyCooked option `pcOptPrintLog`, which is a boolean, to turn on or off the log
   display in the pretty printer. The default value is `True`.
+- Capability to test the result of a mockchain run based on the log entries.
 
 ### Removed
 
@@ -52,6 +53,7 @@
   * it now displays when the user specifies useless collateral utxos.
   * it is not visible from outside of `cooked-validators`
 - Dependency to cardano-api bumped to 8.46.
+- The whole testing API has been revamped
 
 ### Fixed
 

src/Cooked/MockChain/UtxoState.hs

@@ -14,7 +14,7 @@ import Data.Function (on)
 import Data.List qualified as List
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
-import Plutus.Script.Utils.Value qualified as Script
+import PlutusLedgerApi.V1.Value qualified as Api
 import PlutusLedgerApi.V3 qualified as Api
 
 -- | A description of who owns what in a blockchain. Owners are addresses and
@@ -51,7 +51,7 @@ data UtxoPayload = UtxoPayload
 instance Eq UtxoPayloadSet where
   (UtxoPayloadSet xs) == (UtxoPayloadSet ys) = xs' == ys'
     where
-      k (UtxoPayload ref val dat rs) = (ref, Script.flattenValue val, dat, rs)
+      k (UtxoPayload ref val dat rs) = (ref, Api.flattenValue val, dat, rs)
       xs' = List.sortBy (compare `on` k) xs
       ys' = List.sortBy (compare `on` k) ys
 

tests/Cooked/Attack/DatumHijackingSpec.hs

@@ -227,30 +227,25 @@ tests =
                   @=? fst <$> skelOut x2 (1 ==)
             ],
       testCase "careful validator" $
-        testFails
-          def
-          (isCekEvaluationFailure def)
-          ( somewhere
-              ( datumHijackingAttack @DHContract
-                  ( \(ConcreteOutput v _ d _ _) ->
-                      Script.validatorHash v == Script.validatorHash carefulValidator
-                        && d == TxSkelOutInlineDatum SecondLock
-                  )
-                  (const True)
-              )
-              (datumHijackingTrace carefulValidator)
-          ),
+        testFailsInPhase2 $
+          somewhere
+            ( datumHijackingAttack @DHContract
+                ( \(ConcreteOutput v _ d _ _) ->
+                    Script.validatorHash v == Script.validatorHash carefulValidator
+                      && d == TxSkelOutInlineDatum SecondLock
+                )
+                (const True)
+            )
+            (datumHijackingTrace carefulValidator),
       testCase "careless validator" $
-        testSucceeds
-          def
-          ( somewhere
-              ( datumHijackingAttack @DHContract
-                  ( \(ConcreteOutput v _ d _ _) ->
-                      Script.validatorHash v == Script.validatorHash carelessValidator
-                        && d == TxSkelOutInlineDatum SecondLock
-                  )
-                  (const True)
-              )
-              (datumHijackingTrace carelessValidator)
-          )
+        testSucceeds $
+          somewhere
+            ( datumHijackingAttack @DHContract
+                ( \(ConcreteOutput v _ d _ _) ->
+                    Script.validatorHash v == Script.validatorHash carelessValidator
+                      && d == TxSkelOutInlineDatum SecondLock
+                )
+                (const True)
+            )
+            (datumHijackingTrace carelessValidator)
     ]

tests/Cooked/Attack/DupTokenSpec.hs

@@ -114,17 +114,14 @@ tests =
       testCase "careful minting policy" $
         let tName = Script.tokenName "MockToken"
             pol = carefulPolicy tName 1
-         in testFails
-              def
-              (isCekEvaluationFailure def)
-              ( somewhere
-                  (dupTokenAttack (\_ n -> n + 1) (wallet 6))
-                  (dupTokenTrace pol tName 1 (wallet 1))
-              ),
+         in testFailsInPhase2 $
+              somewhere
+                (dupTokenAttack (\_ n -> n + 1) (wallet 6))
+                (dupTokenTrace pol tName 1 (wallet 1)),
       testCase "careless minting policy" $
         let tName = Script.tokenName "MockToken"
             pol = carelessPolicy
-         in testSucceeds def $
+         in testSucceeds $
               somewhere
                 (dupTokenAttack (\_ n -> n + 1) (wallet 6))
                 (dupTokenTrace pol tName 1 (wallet 1)),

tests/Cooked/BalancingSpec.hs

@@ -179,61 +179,71 @@ reachingMagic = do
               }
         }
 
-type ResProp prop = TestBalancingOutcome -> prop
+type ResProp = TestBalancingOutcome -> Assertion
 
-hasFee :: (IsProp prop) => Integer -> ResProp prop
+hasFee :: Integer -> ResProp
 hasFee fee (_, _, fee', _, _) = testBool $ fee == fee'
 
-additionalOutsNb :: (IsProp prop) => Int -> ResProp prop
+additionalOutsNb :: Int -> ResProp
 additionalOutsNb ao (txSkel1, txSkel2, _, _, _) = testBool $ length (txSkelOuts txSkel2) - length (txSkelOuts txSkel1) == ao
 
-insNb :: (IsProp prop) => Int -> ResProp prop
+insNb :: Int -> ResProp
 insNb is (_, TxSkel {..}, _, _, _) = testBool $ length txSkelIns == is
 
-colInsNb :: (IsProp prop) => Int -> ResProp prop
+colInsNb :: Int -> ResProp
 colInsNb cis (_, _, _, Nothing, _) = testBool $ cis == 0
 colInsNb cis (_, _, _, Just (refs, _), _) = testBool $ cis == length refs
 
-retOutsNb :: (IsProp prop) => Int -> ResProp prop
+retOutsNb :: Int -> ResProp
 retOutsNb ros (_, _, _, _, refs) = testBool $ ros == length refs
 
-testBalancingSucceedsWith :: String -> [ResProp Assertion] -> StagedMockChain TestBalancingOutcome -> TestTree
-testBalancingSucceedsWith msg props smc = testCase msg $ testSucceedsFrom' def (\res _ -> testConjoin $ ($ res) <$> props) initialDistributionBalancing smc
+testBalancingSucceedsWith :: String -> [ResProp] -> StagedMockChain TestBalancingOutcome -> TestTree
+testBalancingSucceedsWith msg props run =
+  testCase msg $
+    testToProp $
+      mustSucceedTest run
+        `withInitDist` initialDistributionBalancing
+        `withValuePred` \res -> testConjoin (($ res) <$> props)
 
-failsAtBalancingWith :: (IsProp prop) => Api.Value -> Wallet -> MockChainError -> prop
+failsAtBalancingWith :: Api.Value -> Wallet -> MockChainError -> Assertion
 failsAtBalancingWith val' wal' (MCEUnbalanceable wal val _) = testBool $ val' == val && wal' == wal
 failsAtBalancingWith _ _ _ = testBool False
 
-failsAtBalancing :: (IsProp prop) => MockChainError -> prop
+failsAtBalancing :: MockChainError -> Assertion
 failsAtBalancing MCEUnbalanceable {} = testBool True
 failsAtBalancing _ = testBool False
 
-failsWithTooLittleFee :: (IsProp prop) => MockChainError -> prop
+failsWithTooLittleFee :: MockChainError -> Assertion
 failsWithTooLittleFee (MCEValidationError Ledger.Phase1 (Ledger.CardanoLedgerValidationError text)) = testBool $ isInfixOf "FeeTooSmallUTxO" text
 failsWithTooLittleFee _ = testBool False
 
-failsWithValueNotConserved :: (IsProp prop) => MockChainError -> prop
+failsWithValueNotConserved :: MockChainError -> Assertion
 failsWithValueNotConserved (MCEValidationError Ledger.Phase1 (Ledger.CardanoLedgerValidationError text)) = testBool $ isInfixOf "ValueNotConserved" text
 failsWithValueNotConserved _ = testBool False
 
-failsWithEmptyTxIns :: (IsProp prop) => MockChainError -> prop
+failsWithEmptyTxIns :: MockChainError -> Assertion
 failsWithEmptyTxIns (MCEGenerationError (TxBodyError _ Cardano.TxBodyEmptyTxIns)) = testBool True
 failsWithEmptyTxIns _ = testBool False
 
-failsAtCollateralsWith :: (IsProp prop) => Integer -> MockChainError -> prop
+failsAtCollateralsWith :: Integer -> MockChainError -> Assertion
 failsAtCollateralsWith fee' (MCENoSuitableCollateral fee percentage val) = testBool $ fee == fee' && val == Script.lovelace (1 + (fee * percentage) `div` 100)
 failsAtCollateralsWith _ _ = testBool False
 
-failsAtCollaterals :: (IsProp prop) => MockChainError -> prop
+failsAtCollaterals :: MockChainError -> Assertion
 failsAtCollaterals MCENoSuitableCollateral {} = testBool True
 failsAtCollaterals _ = testBool False
 
-failsLackOfCollateralWallet :: (IsProp prop) => MockChainError -> prop
+failsLackOfCollateralWallet :: MockChainError -> Assertion
 failsLackOfCollateralWallet (FailWith msg) = testBool $ "Can't select collateral utxos from a balancing wallet because it does not exist." == msg
 failsLackOfCollateralWallet _ = testBool False
 
 testBalancingFailsWith :: (Show a) => String -> (MockChainError -> Assertion) -> StagedMockChain a -> TestTree
-testBalancingFailsWith msg p smc = testCase msg $ testFailsFrom def p initialDistributionBalancing smc
+testBalancingFailsWith msg p smc =
+  testCase msg $
+    testToProp $
+      mustFailTest smc
+        `withInitDist` initialDistributionBalancing
+        `withErrorPred` p
 
 tests :: TestTree
 tests =
@@ -345,7 +355,8 @@ tests =
           testGroup
             "Manual balancing with auto fee"
             [ testCase "Auto fee with manual balancing yields maximum fee" $
-                testSucceedsFrom def initialDistributionBalancing noBalanceMaxFee
+                testToProp $
+                  mustSucceedTest noBalanceMaxFee `withInitDist` initialDistributionBalancing
             ],
           testGroup
             "Auto balancing with auto fee"
@@ -383,71 +394,67 @@ tests =
                     id
                 ),
               testCase "Auto fee are minimal: less fee will lead to strictly smaller fee than Cardano's estimate" $
-                testSucceedsFrom'
-                  def
-                  ( \(feeBalanced, feeBalanced', feeBalancedManual, feeBalancedManual') _ ->
-                      testBool $
-                        feeBalanced' <= feeBalanced && feeBalancedManual' > feeBalancedManual
-                  )
-                  initialDistributionBalancing
-                  balanceReduceFee,
+                testToProp $
+                  mustSucceedTest balanceReduceFee
+                    `withInitDist` initialDistributionBalancing
+                    `withValuePred` \(feeBalanced, feeBalanced', feeBalancedManual, feeBalancedManual') ->
+                      testBool $ feeBalanced' <= feeBalanced && feeBalancedManual' > feeBalancedManual,
               testCase "The auto-fee process can sometimes recover from a temporary balancing error..." $
-                testSucceedsFrom
-                  def
-                  initialDistributionBalancing
-                  ( simplePaymentToBob
-                      103_650_000
-                      0
-                      0
-                      0
-                      False
-                      id
-                  ),
+                testToProp $
+                  mustSucceedTest
+                    ( simplePaymentToBob
+                        103_650_000
+                        0
+                        0
+                        0
+                        False
+                        id
+                    )
+                    `withInitDist` initialDistributionBalancing,
               testCase "... but not always" $
-                testFailsFrom
-                  def
-                  failsAtBalancing
-                  initialDistributionBalancing
-                  ( simplePaymentToBob
-                      104_000_000
-                      0
-                      0
-                      0
-                      False
-                      id
-                  ),
+                testToProp $
+                  mustFailTest
+                    ( simplePaymentToBob
+                        104_000_000
+                        0
+                        0
+                        0
+                        False
+                        id
+                    )
+                    `withInitDist` initialDistributionBalancing
+                    `withErrorPred` failsAtBalancing,
               testCase "The auto-fee process can recover from a temporary collateral error..." $
-                testSucceedsFrom
-                  def
-                  initialDistributionBalancing
-                  ( testingBalancingTemplate
-                      (Script.ada 142)
-                      mempty
-                      emptySearch
-                      emptySearch
-                      (aliceNAdaUtxos 2)
-                      True
-                      id
-                  ),
+                testToProp $
+                  mustSucceedTest
+                    ( testingBalancingTemplate
+                        (Script.ada 142)
+                        mempty
+                        emptySearch
+                        emptySearch
+                        (aliceNAdaUtxos 2)
+                        True
+                        id
+                    )
+                    `withInitDist` initialDistributionBalancing,
               testCase "... but not always" $
-                testFailsFrom
-                  def
-                  failsAtCollaterals
-                  initialDistributionBalancing
-                  ( testingBalancingTemplate
-                      (Script.ada 142)
-                      mempty
-                      (utxosAtSearch alice)
-                      emptySearch
-                      (aliceNAdaUtxos 1)
-                      True
-                      id
-                  ),
+                testToProp $
+                  mustFailTest
+                    ( testingBalancingTemplate
+                        (Script.ada 142)
+                        mempty
+                        (utxosAtSearch alice)
+                        emptySearch
+                        (aliceNAdaUtxos 1)
+                        True
+                        id
+                    )
+                    `withInitDist` initialDistributionBalancing
+                    `withErrorPred` failsAtCollaterals,
               testCase "Reaching magical spot with the exact balance during auto fee computation" $
-                testSucceedsFrom
-                  def
-                  initialDistributionBalancing
-                  reachingMagic
+                testToProp $
+                  mustSucceedTest reachingMagic
+                    `withInitDist` initialDistributionBalancing
             ],
           testGroup
             "Auto balancing with manual fee"

tests/Cooked/BasicUsageSpec.hs

@@ -67,9 +67,9 @@ tests :: TestTree
 tests =
   testGroup
     "Basic usage"
-    [ testCase "Payment from alice to bob, with auto-balancing" $ testSucceedsFrom def def (pkToPk alice bob 10),
-      testCase "Circular payments of 10 Script.ada between alice bob and carrie" $ testSucceedsFrom def def multiplePksToPks,
-      testCase "Minting quick tokens" $ testSucceedsFrom def def mintingQuickValue,
-      testCase "Paying to the always true validator" $ testSucceedsFrom def def payToAlwaysTrueValidator,
-      testCase "Consuming the always true validator" $ testSucceedsFrom def def consumeAlwaysTrueValidator
+    [ testCase "Payment from alice to bob, with auto-balancing" $ testSucceeds $ pkToPk alice bob 10,
+      testCase "Circular payments of 10 Script.ada between alice bob and carrie" $ testSucceeds multiplePksToPks,
+      testCase "Minting quick tokens" $ testSucceeds mintingQuickValue,
+      testCase "Paying to the always true validator" $ testSucceeds payToAlwaysTrueValidator,
+      testCase "Consuming the always true validator" $ testSucceeds consumeAlwaysTrueValidator
     ]

tests/Cooked/InitialDistributionSpec.hs

@@ -2,7 +2,6 @@ module Cooked.InitialDistributionSpec where
 
 import Control.Monad
 import Cooked
-import Data.Default
 import Data.Map qualified as Map
 import Data.Maybe (catMaybes)
 import Plutus.Script.Utils.Value qualified as Script
@@ -52,7 +51,12 @@ tests =
   testGroup
     "Initial distributions"
     [ testCase "Reading datums placed in the initial distribution, inlined or hashed" $
-        testSucceedsFrom' def (\results _ -> testBool $ results == [10, 10]) initialDistributionWithDatum getValueFromInitialDatum,
+        testToProp $
+          mustSucceedTest getValueFromInitialDatum
+            `withInitDist` initialDistributionWithDatum
+            `withValuePred` (testBool . (== [10, 10])),
       testCase "Spending a script placed as a reference script in the initial distribution" $
-        testSucceedsFrom def initialDistributionWithReferenceScript spendReferenceAlwaysTrueValidator
+        testToProp $
+          mustSucceedTest spendReferenceAlwaysTrueValidator
+            `withInitDist` initialDistributionWithReferenceScript
     ]