feat(testing-interface): Initialize in TestingMonad (#13)

Author: sjoerdvisscher

src/testing-interface/lib/Convex/TestingInterface.hs

@@ -31,10 +31,6 @@ module Convex.TestingInterface (
   defaultOptions,
   modifyTransactionLimits,
 
-  -- * Actions
-  Actions (Actions),
-  InvalidActions (..),
-
   -- * Coverage helpers
   withCoverage,
   CoverageConfig (..),
@@ -63,7 +59,7 @@ import Control.Monad (foldM, forM, unless, when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Test.HUnit (Assertion)
 import Test.QuickCheck (Arbitrary (..), Gen, Property, counterexample, discard, elements, frequency, oneof, property)
-import Test.QuickCheck.Monadic (monadicIO, monitor, run)
+import Test.QuickCheck.Monadic (PropertyM, monadicIO, monitor, pick, run)
 import Test.Tasty (DependencyType (..), TestTree, sequentialTestGroup, testGroup, withResource)
 import Test.Tasty.ExpectedFailure (ignoreTestBecause)
 import Test.Tasty.HUnit (assertFailure, testCaseSteps)
@@ -76,7 +72,7 @@ import Control.Lens ((&), (.~), (^.))
 import Control.Monad.Trans (MonadTrans (..))
 import Convex.Class (MonadBlockchain, MonadMockchain, coverageData, getTxs)
 import Convex.CoinSelection (BalanceTxError, coverageFromBalanceTxError)
-import Convex.MockChain (MockChainState (..), MockchainT, initialStateFor, runMockchain0IOWith, runMockchainIO)
+import Convex.MockChain (MockChainState (..), MockchainT, initialStateFor, runMockchainIO, runMockchainT)
 import Convex.MockChain.Defaults qualified as Defaults
 import Convex.MonadLog (MonadLog)
 import Convex.NodeParams (NodeParams (..))
@@ -116,7 +112,7 @@ The type parameter @state@ represents the model's view of the world. It should
 track all relevant information needed to validate that the contract is behaving
 correctly.
 
-Minimal complete definition: 'Action', 'initialState', 'arbitraryAction', 'nextState', 'perform'
+Minimal complete definition: 'Action', 'initialize', 'arbitraryAction', 'nextState', 'perform'
 -}
 class (Show state, Eq state) => TestingInterface state where
   {- | Actions that can be performed on the contract.
@@ -125,7 +121,7 @@ class (Show state, Eq state) => TestingInterface state where
   data Action state
 
   -- | The initial state of the model, before any actions are performed.
-  initialState :: state
+  initialize :: (MonadIO m) => TestingMonadT m state
 
   {- | Generate a random action given the current state.
   The generated action should be appropriate for the current state.
@@ -205,8 +201,8 @@ class (Show state, Eq state) => TestingInterface state where
 Leaving handling of balancing errors to the testing interface is important because
 the errors can contain data for code coverage.
 -}
-newtype TestingMonadT m a = TestingMonad
-  { runTestingMonadT :: ExceptT (BalanceTxError C.ConwayEra) (MockchainT C.ConwayEra m) a
+newtype TestingMonadT m a = TestingMonadT
+  { unTestingMonadT :: ExceptT (BalanceTxError C.ConwayEra) (MockchainT C.ConwayEra m) a
   }
   deriving newtype
     ( Functor
@@ -219,12 +215,19 @@ newtype TestingMonadT m a = TestingMonad
     , MonadMockchain C.ConwayEra
     )
 
+runTestingMonadT
+  :: NodeParams C.ConwayEra
+  -> TestingMonadT m a
+  -> m (Either (BalanceTxError C.ConwayEra) a, MockChainState C.ConwayEra)
+runTestingMonadT params (TestingMonadT action) =
+  runMockchainT (runExceptT action) params (initialStateFor params Wallet.initialUTxOs)
+
 -- Let the TestingMonad fail in IO
 instance (MonadIO m) => MonadFail (TestingMonadT m) where
   fail s = liftIO $ fail s
 
 instance MonadTrans TestingMonadT where
-  lift = TestingMonad . lift . lift
+  lift = TestingMonadT . lift . lift
 
 -- | Opaque wrapper for model state
 newtype ModelState state = ModelState {unModelState :: state}
@@ -235,36 +238,6 @@ Key is the threat model name, value is the list of outcomes (one per iteration).
 -}
 type ThreatModelResults = Map.Map String [ThreatModelOutcome]
 
--- | A sequence of actions to perform
-newtype Actions state = Actions_ [Action state]
-
-newtype InvalidActions state = InvalidActions (Actions state, Action state)
-
-instance (TestingInterface state, Show (Action state)) => Show (InvalidActions state) where
-  show (InvalidActions (Actions prefix, bad)) =
-    "InvalidActions " ++ show prefix ++ " then " ++ show bad
-
-pattern Actions :: [Action state] -> Actions state
-pattern Actions as = Actions_ as
-{-# COMPLETE Actions #-}
-
-instance (TestingInterface state, Show (Action state)) => Show (Actions state) where
-  show (Actions acts) = "Actions " ++ show acts
-
-instance (TestingInterface state) => Arbitrary (Actions state) where
-  arbitrary = Actions <$> genActions initialState 10
-
-instance (TestingInterface state) => Arbitrary (InvalidActions state) where
-  arbitrary = do
-    -- Generate a valid prefix (builds up state)
-    prefix <- genActions initialState 10
-    let finalState = foldl nextState initialState prefix
-    -- Generate an action that VIOLATES the precondition in that state
-    maybeInvalid <- arbitraryAction finalState `suchThatMaybe` (not . precondition finalState)
-    case maybeInvalid of
-      Nothing -> discard -- tell QuickCheck to skip this case
-      Just bad -> pure $ InvalidActions (Actions_ prefix, bad)
-
 -- | Try up to 100 times to generate a value satisfying a predicate
 suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a)
 suchThatMaybe gen p = go (100 :: Int)
@@ -359,26 +332,32 @@ negativeTest
   :: forall state
    . (TestingInterface state, Show (Action state))
   => RunOptions
-  -> InvalidActions state
   -> Property
-negativeTest opts (InvalidActions (Actions actions, badAction)) = monadicIO $ do
+negativeTest opts = monadicIO $ do
   let RunOptions{mcOptions = Options{coverageRef, params}} = opts
-      initialSt = initialState @state
+  -- Phase 1: Run the valid prefix, capturing the final mockchain state
+  (prefixResult, prefixState) <- runTestingMonadT params $ do
+    initialState <- runInitialization @state opts
 
-  when (verbose opts) $
-    monitor (counterexample $ "Initial state: " ++ show initialSt)
+    (actions, badAction) <- lift $ pick $ do
+      -- Generate a valid prefix (builds up state)
+      prefix <- genActions initialState 10
+      let finalState = foldl nextState initialState prefix
+      -- Generate an action that VIOLATES the precondition in that state
+      maybeInvalid <- arbitraryAction finalState `suchThatMaybe` (not . precondition finalState)
+      case maybeInvalid of
+        Nothing -> discard -- tell QuickCheck to skip this case
+        Just bad -> pure (prefix, bad)
 
-  -- Phase 1: Run the valid prefix, capturing the final mockchain state
-  (prefixResult, prefixState) <- run $ runMockchain0IOWith Wallet.initialUTxOs params $ runExceptT $ runTestingMonadT $ do
-    foldM (runAction opts) initialSt actions
+    ((,) badAction) <$> foldM (runAction opts) initialState actions
 
   -- Phase 2: Run the bad action starting from the state left by the valid prefix
   case prefixResult of
     Left err -> do
       monitor (counterexample $ "Valid prefix failed: " ++ show err)
       pure (property False)
-    Right finalState -> do
-      let monadAction = runExceptT $ runTestingMonadT $ perform finalState badAction
+    Right (badAction, finalState) -> do
+      let monadAction = runExceptT $ unTestingMonadT $ perform finalState badAction
       result' <- run $ try @SomeException $ runMockchainIO monadAction params prefixState
       -- We distinguish between validation errors and user errors:
       -- if the action failed at the off-chain level (e.g. balancing), we discard the test,
@@ -413,17 +392,14 @@ positiveTest
   -- ^ Threat models (early-stop on TMFailed)
   -> [ThreatModel ()]
   -- ^ Expected vulnerabilities (never early-stop)
-  -> Actions state
   -> Property
-positiveTest opts mGetTmResultsRef tms evs (Actions actions) = monadicIO $ do
+positiveTest opts mGetTmResultsRef tms evs = monadicIO $ do
   let RunOptions{mcOptions = Options{coverageRef, params}} = opts
-      initialSt = initialState @state
-
-  when (verbose opts) $
-    monitor (counterexample $ "Initial state: " ++ show initialSt)
+  result <- runTestingMonadT params $ do
+    initialState <- runInitialization @state opts
+    actions <- lift $ pick $ genActions initialState 10
 
-  result <- run $ runMockchain0IOWith Wallet.initialUTxOs params $ runExceptT $ runTestingMonadT $ do
-    finalState <- foldM (runAction opts) initialSt actions
+    finalState <- foldM (runAction opts) initialState actions
 
     -- Run threat models in isolation
     -- Note: runThreatModelCheck handles rebalancing failures internally (returns TMSkipped)
@@ -652,6 +628,25 @@ runAction opts modelState action = do
 
   pure modelState'
 
+-- | Initialize the blockchain and validate the model state
+runInitialization
+  :: forall state m
+   . (TestingInterface state, MonadIO m)
+  => RunOptions
+  -> TestingMonadT (PropertyM m) state
+runInitialization opts = do
+  initialState <- initialize @state
+
+  when (verbose opts) $
+    lift $
+      monitor (counterexample $ "Initial state: " ++ show initialState)
+
+  valid <- validate initialState
+  unless valid $
+    fail "Blockchain state does not match model state after initialization"
+
+  pure initialState
+
 {- | Configuration for coverage collection and reporting.
 
 Use with 'withCoverage' to set up coverage tracking for your test suite.
@@ -870,7 +865,7 @@ modifyTransactionLimits opts@Options{params = Defaults.pParams -> pp} newVal =
 -- | Run the 'TestingMonadT' action with the given options and fail if there is an error
 mockchainSucceedsWithOptions :: Options C.ConwayEra -> TestingMonadT IO a -> Assertion
 mockchainSucceedsWithOptions Options{params, coverageRef} action =
-  runMockchain0IOWith Wallet.initialUTxOs params (runExceptT (runTestingMonadT action))
+  runTestingMonadT params action
     >>= \(res, st) -> do
       let covData = st ^. coverageData
       for_ coverageRef $ \ref -> modifyIORef ref (<> covData)
@@ -885,7 +880,7 @@ mockchainSucceedsWithOptions Options{params, coverageRef} action =
 -}
 mockchainFailsWithOptions :: Options C.ConwayEra -> TestingMonadT IO a -> (BalanceTxError C.ConwayEra -> Assertion) -> Assertion
 mockchainFailsWithOptions Options{params, coverageRef} action handleError =
-  runMockchain0IOWith Wallet.initialUTxOs params (runExceptT (runTestingMonadT action))
+  runTestingMonadT params action
     >>= \(res, st) -> do
       let covData = st ^. coverageData
       for_ coverageRef $ \ref -> modifyIORef ref (<> covData)

src/testing-interface/test/AikenBankSpec.hs

@@ -881,64 +881,52 @@ aikenBank03UnitTests =
 
 -- | Model state for the Bank contract
 data BankModel = BankModel
-  { bmBankTxIn :: Maybe C.TxIn
+  { bmBankTxIn :: C.TxIn
   -- ^ Bank UTxO
   , bmBankValue :: C.Lovelace
   -- ^ Bank's pooled funds
-  , bmAccountTxIn :: Maybe C.TxIn
+  , bmAccountTxIn :: C.TxIn
   -- ^ Account UTxO
   , bmAccountBalance :: Integer
   -- ^ Account balance
-  , bmAccountOwner :: Maybe PlutusTx.BuiltinByteString
+  , bmAccountOwner :: PlutusTx.BuiltinByteString
   -- ^ Account owner
-  , bmInitialized :: Bool
   }
   deriving stock (Show, Eq)
 
 instance TestingInterface BankModel where
   data Action BankModel
-    = InitBankAction
-    | DepositAction C.Lovelace
+    = DepositAction C.Lovelace
     | WithdrawAction C.Lovelace
     deriving stock (Show, Eq)
 
-  initialState =
-    BankModel
-      { bmBankTxIn = Nothing
-      , bmBankValue = 0
-      , bmAccountTxIn = Nothing
-      , bmAccountBalance = 0
-      , bmAccountOwner = Nothing
-      , bmInitialized = False
-      }
+  initialize = do
+    let txBody = execBuildTx $ initBank bankLevel00 Defaults.networkId Wallet.w1 100_000_000
+    void $ balanceAndSubmit mempty Wallet.w1 txBody TrailingChange []
+    let ownerBytes = PlutusTx.toBuiltin $ C.serialiseToRawBytes (verificationKeyHash Wallet.w1)
+    pure $
+      BankModel
+        { bmBankTxIn = C.TxIn dummyTxId (C.TxIx 0)
+        , bmBankValue = 100_000_000
+        , bmAccountTxIn = C.TxIn dummyTxId (C.TxIx 1)
+        , bmAccountBalance = 0
+        , bmAccountOwner = ownerBytes
+        }
 
   -- Generate actions following PingPong pattern:
   -- - Init actions: TIGHT (only when not initialized) - creates fresh UTxOs
   -- - Non-init actions: BROAD (generate invalid variants for negative testing)
-  arbitraryAction model
-    | not (bmInitialized model) = pure InitBankAction
-    | otherwise =
-        QC.frequency
-          [ (3, DepositAction <$> (fromInteger <$> QC.choose (1_000_000, 20_000_000)))
-          , (7, WithdrawAction <$> (fromInteger <$> QC.choose (1_000_000, 20_000_000))) -- May overdraw for negative testing
-          ]
-
-  precondition model InitBankAction = not (bmInitialized model)
-  precondition model (DepositAction _) = bmInitialized model
+  arbitraryAction _model =
+    QC.frequency
+      [ (3, DepositAction <$> (fromInteger <$> QC.choose (1_000_000, 20_000_000)))
+      , (7, WithdrawAction <$> (fromInteger <$> QC.choose (1_000_000, 20_000_000))) -- May overdraw for negative testing
+      ]
+
+  precondition _model (DepositAction _) = True
   precondition model (WithdrawAction amt) =
-    bmInitialized model && bmAccountBalance model >= fromIntegral amt
+    bmAccountBalance model >= fromIntegral amt
 
   nextState model action = case action of
-    InitBankAction ->
-      let ownerBytes = PlutusTx.toBuiltin $ C.serialiseToRawBytes (verificationKeyHash Wallet.w1)
-       in model
-            { bmBankTxIn = Just (C.TxIn dummyTxId (C.TxIx 0))
-            , bmBankValue = 100_000_000
-            , bmAccountTxIn = Just (C.TxIn dummyTxId (C.TxIx 1))
-            , bmAccountBalance = 0
-            , bmAccountOwner = Just ownerBytes
-            , bmInitialized = True
-            }
     DepositAction amt ->
       model
         { bmBankValue = bmBankValue model + amt
@@ -951,9 +939,6 @@ instance TestingInterface BankModel where
         }
 
   perform _model action = case action of
-    InitBankAction -> do
-      let txBody = execBuildTx $ initBank bankLevel00 Defaults.networkId Wallet.w1 100_000_000
-      void $ balanceAndSubmit mempty Wallet.w1 txBody TrailingChange []
     DepositAction amt -> do
       [(bankTxIn, bankValue)] <- findBankUtxos bankLevel00
       [(accountTxIn, accountValue, accountDatum)] <- findAccountUtxos bankLevel00

src/testing-interface/test/AikenHelloWorldSpec.hs

@@ -319,12 +319,13 @@ instance TestingInterface HelloWorldModel where
     -- \^ Unlock with correct password "Hello CTF!"
     deriving stock (Show, Eq)
 
-  initialState =
-    HelloWorldModel
-      { hwLocked = False
-      , hwValue = 0
-      , hwTxIn = Nothing
-      }
+  initialize =
+    pure $
+      HelloWorldModel
+        { hwLocked = False
+        , hwValue = 0
+        , hwTxIn = Nothing
+        }
 
   -- Generate actions following PingPong pattern:
   -- - LockFunds: TIGHT (only when not locked) - creates fresh UTxO, always succeeds on-chain