{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Convex.TestingInterface (
  -- * Testing interface
  TestingInterface (..),
  ModelState,
  ThreatModelsFor (..),

  -- * Running Tests
  propRunActions,
  propRunActionsWithOptions,
  RunOptions (..),
  defaultRunOptions,
  genAction,
  runActions,

  -- * Trace recording
  TraceRecorder (..),

  -- * The Testing Monad
  TestingMonadT (..),
  runTestingMonadT,
  mockchainSucceedsWithOptions,
  mockchainFailsWithOptions,
  Options (..),
  defaultOptions,
  modifyTransactionLimits,

  -- * Coverage helpers
  withCoverage,
  CoverageConfig (..),
  printCoverageReport,
  writeCoverageReport,
  silentCoverageReport,
  printCoverageJSON,
  writeCoverageJSON,
  printCoverageJSONPretty,
  writeCoverageJSONPretty,
  CoverageSummary (..),
  coverageSummary,

  -- * Re-exports from QuickCheck
  Gen,
  Arbitrary (..),
  frequency,
  oneof,
  elements,

  -- * Re-exports from Tasty
  TestTree,
) where

import Control.Monad (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 (PropertyM, monadicIO, monitor, pick, run)
import Test.Tasty (DependencyType (..), TestTree, askOption, sequentialTestGroup, testGroup, withResource)
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.HUnit (assertFailure, testCaseSteps)
import Test.Tasty.QuickCheck (testProperty)

import Cardano.Api qualified as C
import Cardano.Ledger.Core qualified as L
import Control.Exception (SomeException, catch, throwIO, try)
import Control.Lens ((&), (.~), (^.))
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.Trans (MonadTrans (..))
import Convex.Class (MonadBlockchain, MonadMockchain, coverageData, getMockChainState, getTxs, getUtxo)
import Convex.CoinSelection (BalanceTxError (..), BalancingError (..), coverageFromBalanceTxError)
import Convex.MockChain (MockChainState (..), MockchainT, fromLedgerUTxO, initialStateFor, runMockchainIO, runMockchainT)
import Convex.MockChain.Defaults qualified as Defaults
import Convex.MonadLog (MonadLog)
import Convex.NodeParams (NodeParams (..))
import Convex.Tasty.Streaming.TMSummary (TMRecorder, ThreatModelSummary (..), TraceRecorder (..), tmRecord)
import Convex.TestingInterface.Trace (
  IterationStatus (..),
  IterationTrace (..),
  ThreatModelTrace (..),
  ThreatModelTraceOutcome (..),
  Transition (..),
  TransitionResult (..),
  TxSummary (..),
 )
import Convex.TestingInterface.Trace.TxSummary (summarizeTx)
import Convex.ThreatModel (SigningWallet (AutoSign), ThreatModel (..), ThreatModelCheckEntry (..), ThreatModelOutcome (..), getThreatModelName, runThreatModelCheckTraced, threatModelEnvs)
import Convex.ThreatModel.All (allThreatModels)
import Convex.ThreatModel.TxModifier (TxModifier (..))
import Convex.Wallet.MockWallet qualified as Wallet
import Data.Aeson (ToJSON (..), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Foldable (foldl', for_, traverse_)
import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
import Data.List (deleteFirstsBy)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)

import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Word (Word32)
import GHC.Generics (Generic)
import PlutusTx.Coverage (
  CovLoc (..),
  CoverageAnnotation (..),
  CoverageData,
  CoverageIndex,
  CoverageReport (..),
  Metadata (..),
  coverageAnnotations,
  coverageMetadata,
  coveredAnnotations,
  ignoredAnnotations,
  _metadataSet,
 )
import Prettyprinter qualified as Pretty
import System.Exit (ExitCode)

{- | A testing interface defines the state and behavior of one or more smart contracts.

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', 'initialize', 'arbitraryAction', 'perform'
-}
class (Show state, Eq state, Show (Action state), ToJSON state) => TestingInterface state where
  {- | Actions that can be performed on the contract.
  This is typically a data type with one constructor per contract operation.
  -}
  data Action state

  -- | The initial state of the model, before any actions are performed.
  initialize :: (MonadIO m) => TestingMonadT m state

  {- | Generate a random action given the current state.
  The generated action should be appropriate for the current state.
  -}
  arbitraryAction :: state -> Gen (Action state)

  {- | Precondition that must hold before an action can be executed.
  Return 'False' to indicate that an action is not valid in the current state.
  Default: all actions are always valid.
  -}
  precondition :: state -> Action state -> Bool
  precondition state
_ Action state
_ = Bool
True

  {- | Perform the action on the real blockchain (mockchain).
  This should execute the actual transaction(s) that implement the action.
  The current model state is provided to allow access to tracked blockchain state.
  The returned state should reflect the expected effect of the action on the contract state.
  -}
  perform :: (MonadIO m) => state -> Action state -> TestingMonadT m state

  {- | Validate that the blockchain state matches the model state.
  Default: no validation (always succeeds).
  -}
  validate :: (MonadIO m) => state -> TestingMonadT m Bool
  validate state
_ = Bool -> TestingMonadT m Bool
forall a. a -> TestingMonadT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  {- | Called after each successful action to wrap the enclosing QuickCheck property.
  This hook runs only after 'perform' and 'validate' succeed. Use it for
  property-level checks, labels, and counterexamples that should be attached to
  valid state transitions.
  Default: no additional checks.
  -}
  monitoring :: state -> Action state -> Property -> Property
  monitoring state
_ Action state
_ = Property -> Property
forall a. a -> a
id

  {- | Whether to discard (skip) test cases where the invalid action fails due to
  a user-level error (e.g., off-chain balancing failure) rather than an
  on-chain validator rejection during negative testing.

  When 'True', negative tests that throw user exceptions are discarded
  (via QuickCheck's 'discard'), so only on-chain rejections count as
  successful negative tests.

  When 'False' (the default), user exceptions also cause the test case
  to be discarded — meaning both off-chain and on-chain failures are
  treated the same way.

  Override this in your 'TestingInterface' instance if you need finer
  control over which failure modes are accepted in negative testing.
  -}
  discardNegativeTestForUserExceptions :: Bool
  discardNegativeTestForUserExceptions = Bool
False

class (TestingInterface state) => ThreatModelsFor state where
  {- | Threat models to run against the transactions.
  Each threat model will be evaluated against the transaction generated by a
  succesful test run with the UTxO state captured before each transaction executed.
  Default: the list of all threat models that don't take parameters.
  -}
  threatModels :: [ThreatModel ()]
  threatModels = (ThreatModel () -> ThreatModel () -> Bool)
-> [ThreatModel ()] -> [ThreatModel ()] -> [ThreatModel ()]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy ThreatModel () -> ThreatModel () -> Bool
forall {a} {a}. ThreatModel a -> ThreatModel a -> Bool
eqName [ThreatModel ()]
allThreatModels (forall state. ThreatModelsFor state => [ThreatModel ()]
expectedVulnerabilities @state)
   where
    eqName :: ThreatModel a -> ThreatModel a -> Bool
eqName (Named String
s ThreatModel a
_) (Named String
t ThreatModel a
_) = String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
t
    eqName ThreatModel a
_ ThreatModel a
_ =
      String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$
        String
"Unexpected unnamed threat model."
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"please override the default implementation of `ThreatModelsFor.threatModels`"

  {- | Threat models that are expected to find vulnerabilities.
  These are run like 'threatModels' but with inverted pass/fail semantics:

  * OK when a vulnerability IS detected
  * FAIL when a vulnerability is NOT detected

  Output is quiet — no verbose transaction dumps.
  Default: empty, backward compatible.
  -}
  expectedVulnerabilities :: [ThreatModel ()]
  expectedVulnerabilities = []

{- | Tests run in the mockchain monad extended with balancing error handling.

Leaving handling of balancing errors to the testing interface is important because
the errors can contain data for code coverage.
-}
newtype TestingMonadT m a = TestingMonadT
  { forall (m :: * -> *) a.
TestingMonadT m a
-> ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
unTestingMonadT :: ExceptT (BalanceTxError C.ConwayEra) (MockchainT C.ConwayEra m) a
  }
  deriving newtype
    ( (forall a b. (a -> b) -> TestingMonadT m a -> TestingMonadT m b)
-> (forall a b. a -> TestingMonadT m b -> TestingMonadT m a)
-> Functor (TestingMonadT m)
forall a b. a -> TestingMonadT m b -> TestingMonadT m a
forall a b. (a -> b) -> TestingMonadT m a -> TestingMonadT m b
forall (m :: * -> *) a b.
Functor m =>
a -> TestingMonadT m b -> TestingMonadT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TestingMonadT m a -> TestingMonadT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TestingMonadT m a -> TestingMonadT m b
fmap :: forall a b. (a -> b) -> TestingMonadT m a -> TestingMonadT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> TestingMonadT m b -> TestingMonadT m a
<$ :: forall a b. a -> TestingMonadT m b -> TestingMonadT m a
Functor
    , Functor (TestingMonadT m)
Functor (TestingMonadT m) =>
(forall a. a -> TestingMonadT m a)
-> (forall a b.
    TestingMonadT m (a -> b) -> TestingMonadT m a -> TestingMonadT m b)
-> (forall a b c.
    (a -> b -> c)
    -> TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m c)
-> (forall a b.
    TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b)
-> (forall a b.
    TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m a)
-> Applicative (TestingMonadT m)
forall a. a -> TestingMonadT m a
forall a b.
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m a
forall a b.
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b
forall a b.
TestingMonadT m (a -> b) -> TestingMonadT m a -> TestingMonadT m b
forall a b c.
(a -> b -> c)
-> TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m c
forall (m :: * -> *). Monad m => Functor (TestingMonadT m)
forall (m :: * -> *) a. Monad m => a -> TestingMonadT m a
forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m a
forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b
forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m (a -> b) -> TestingMonadT m a -> TestingMonadT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> TestingMonadT m a
pure :: forall a. a -> TestingMonadT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m (a -> b) -> TestingMonadT m a -> TestingMonadT m b
<*> :: forall a b.
TestingMonadT m (a -> b) -> TestingMonadT m a -> TestingMonadT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m c
liftA2 :: forall a b c.
(a -> b -> c)
-> TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b
*> :: forall a b.
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m a
<* :: forall a b.
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m a
Applicative
    , Applicative (TestingMonadT m)
Applicative (TestingMonadT m) =>
(forall a b.
 TestingMonadT m a -> (a -> TestingMonadT m b) -> TestingMonadT m b)
-> (forall a b.
    TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b)
-> (forall a. a -> TestingMonadT m a)
-> Monad (TestingMonadT m)
forall a. a -> TestingMonadT m a
forall a b.
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b
forall a b.
TestingMonadT m a -> (a -> TestingMonadT m b) -> TestingMonadT m b
forall (m :: * -> *). Monad m => Applicative (TestingMonadT m)
forall (m :: * -> *) a. Monad m => a -> TestingMonadT m a
forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b
forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m a -> (a -> TestingMonadT m b) -> TestingMonadT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m a -> (a -> TestingMonadT m b) -> TestingMonadT m b
>>= :: forall a b.
TestingMonadT m a -> (a -> TestingMonadT m b) -> TestingMonadT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b
>> :: forall a b.
TestingMonadT m a -> TestingMonadT m b -> TestingMonadT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> TestingMonadT m a
return :: forall a. a -> TestingMonadT m a
Monad
    , C.MonadError (BalanceTxError C.ConwayEra)
    , Monad (TestingMonadT m)
Monad (TestingMonadT m) =>
(forall a. IO a -> TestingMonadT m a) -> MonadIO (TestingMonadT m)
forall a. IO a -> TestingMonadT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (TestingMonadT m)
forall (m :: * -> *) a. MonadIO m => IO a -> TestingMonadT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> TestingMonadT m a
liftIO :: forall a. IO a -> TestingMonadT m a
C.MonadIO
    , Monad (TestingMonadT m)
Monad (TestingMonadT m) =>
(Doc Void -> TestingMonadT m ())
-> (Doc Void -> TestingMonadT m ())
-> (Doc Void -> TestingMonadT m ())
-> MonadLog (TestingMonadT m)
Doc Void -> TestingMonadT m ()
forall (m :: * -> *).
Monad m =>
(Doc Void -> m ())
-> (Doc Void -> m ()) -> (Doc Void -> m ()) -> MonadLog m
forall (m :: * -> *). MonadLog m => Monad (TestingMonadT m)
forall (m :: * -> *). MonadLog m => Doc Void -> TestingMonadT m ()
$clogInfo' :: forall (m :: * -> *). MonadLog m => Doc Void -> TestingMonadT m ()
logInfo' :: Doc Void -> TestingMonadT m ()
$clogWarn' :: forall (m :: * -> *). MonadLog m => Doc Void -> TestingMonadT m ()
logWarn' :: Doc Void -> TestingMonadT m ()
$clogDebug' :: forall (m :: * -> *). MonadLog m => Doc Void -> TestingMonadT m ()
logDebug' :: Doc Void -> TestingMonadT m ()
MonadLog
    , MonadBlockchain C.ConwayEra
    , MonadMockchain C.ConwayEra
    )

runTestingMonadT
  :: NodeParams C.ConwayEra
  -> TestingMonadT m a
  -> m (Either (BalanceTxError C.ConwayEra) a, MockChainState C.ConwayEra)
runTestingMonadT :: forall (m :: * -> *) a.
NodeParams ConwayEra
-> TestingMonadT m a
-> m (Either (BalanceTxError ConwayEra) a,
      MockChainState ConwayEra)
runTestingMonadT NodeParams ConwayEra
params (TestingMonadT ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
action) =
  MockchainT ConwayEra m (Either (BalanceTxError ConwayEra) a)
-> NodeParams ConwayEra
-> MockChainState ConwayEra
-> m (Either (BalanceTxError ConwayEra) a,
      MockChainState ConwayEra)
forall era (m :: * -> *) a.
MockchainT era m a
-> NodeParams era
-> MockChainState era
-> m (a, MockChainState era)
runMockchainT (ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
-> MockchainT ConwayEra m (Either (BalanceTxError ConwayEra) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
action) NodeParams ConwayEra
params (NodeParams ConwayEra -> InitialUTXOs -> MockChainState ConwayEra
forall era.
IsShelleyBasedEra era =>
NodeParams era -> InitialUTXOs -> MockChainState era
initialStateFor NodeParams ConwayEra
params InitialUTXOs
Wallet.initialUTxOs)

-- Let the TestingMonad fail in IO
instance (MonadIO m) => MonadFail (TestingMonadT m) where
  fail :: forall a. String -> TestingMonadT m a
fail String
s = IO a -> TestingMonadT m a
forall a. IO a -> TestingMonadT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> TestingMonadT m a) -> IO a -> TestingMonadT m a
forall a b. (a -> b) -> a -> b
$ String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s

instance MonadTrans TestingMonadT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> TestingMonadT m a
lift = ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
-> TestingMonadT m a
forall (m :: * -> *) a.
ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
-> TestingMonadT m a
TestingMonadT (ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
 -> TestingMonadT m a)
-> (m a
    -> ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a)
-> m a
-> TestingMonadT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockchainT ConwayEra m a
-> ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (BalanceTxError ConwayEra) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MockchainT ConwayEra m a
 -> ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a)
-> (m a -> MockchainT ConwayEra m a)
-> m a
-> ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> MockchainT ConwayEra m a
forall (m :: * -> *) a. Monad m => m a -> MockchainT ConwayEra m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Opaque wrapper for model state
newtype ModelState state = ModelState {forall state. ModelState state -> state
unModelState :: state}
  deriving (ModelState state -> ModelState state -> Bool
(ModelState state -> ModelState state -> Bool)
-> (ModelState state -> ModelState state -> Bool)
-> Eq (ModelState state)
forall state.
Eq state =>
ModelState state -> ModelState state -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall state.
Eq state =>
ModelState state -> ModelState state -> Bool
== :: ModelState state -> ModelState state -> Bool
$c/= :: forall state.
Eq state =>
ModelState state -> ModelState state -> Bool
/= :: ModelState state -> ModelState state -> Bool
Eq, Int -> ModelState state -> String -> String
[ModelState state] -> String -> String
ModelState state -> String
(Int -> ModelState state -> String -> String)
-> (ModelState state -> String)
-> ([ModelState state] -> String -> String)
-> Show (ModelState state)
forall state.
Show state =>
Int -> ModelState state -> String -> String
forall state. Show state => [ModelState state] -> String -> String
forall state. Show state => ModelState state -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall state.
Show state =>
Int -> ModelState state -> String -> String
showsPrec :: Int -> ModelState state -> String -> String
$cshow :: forall state. Show state => ModelState state -> String
show :: ModelState state -> String
$cshowList :: forall state. Show state => [ModelState state] -> String -> String
showList :: [ModelState state] -> String -> String
Show)

{- | Per-threat-model accumulated results across all QuickCheck iterations.
Key is the threat model name, value is the list of outcomes (one per iteration).
-}
type ThreatModelResults = Map.Map String [ThreatModelOutcome]

-- | Try up to 100 times to generate a value satisfying a predicate
suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a)
suchThatMaybe :: forall a. Gen a -> (a -> Bool) -> Gen (Maybe a)
suchThatMaybe Gen a
gen a -> Bool
p = Int -> Gen (Maybe a)
go (Int
100 :: Int)
 where
  go :: Int -> Gen (Maybe a)
go Int
0 = Maybe a -> Gen (Maybe a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  go Int
retries = do
    a
a <- Gen a
gen
    if a -> Bool
p a
a then Maybe a -> Gen (Maybe a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a) else Int -> Gen (Maybe a)
go (Int
retries Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- | Generate a valid actions
genAction :: (TestingInterface state, Monad m) => state -> PropertyM m (Maybe (Action state))
genAction :: forall state (m :: * -> *).
(TestingInterface state, Monad m) =>
state -> PropertyM m (Maybe (Action state))
genAction state
s = Gen (Maybe (Action state)) -> PropertyM m (Maybe (Action state))
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen (Maybe (Action state)) -> PropertyM m (Maybe (Action state)))
-> Gen (Maybe (Action state)) -> PropertyM m (Maybe (Action state))
forall a b. (a -> b) -> a -> b
$ state -> Gen (Action state)
forall state. TestingInterface state => state -> Gen (Action state)
arbitraryAction state
s Gen (Action state)
-> (Action state -> Bool) -> Gen (Maybe (Action state))
forall a. Gen a -> (a -> Bool) -> Gen (Maybe a)
`suchThatMaybe` state -> Action state -> Bool
forall state.
TestingInterface state =>
state -> Action state -> Bool
precondition state
s

-- | Options for running property tests
data RunOptions = RunOptions
  { RunOptions -> Bool
verbose :: Bool
  -- ^ Print actions as they are executed
  , RunOptions -> Int
maxActions :: Int
  -- ^ Maximum number of actions to generate
  , RunOptions -> Options ConwayEra
mcOptions :: Options C.ConwayEra
  , RunOptions -> Maybe String
disableNegativeTesting :: Maybe String
  {- ^ If @Just reason@, negative tests are skipped (shown as IGNORED) with the given reason.
  If @Nothing@, negative tests run normally. Default: @Nothing@.
  -}
  }

defaultRunOptions :: RunOptions
defaultRunOptions :: RunOptions
defaultRunOptions =
  RunOptions
    { verbose :: Bool
verbose = Bool
False
    , maxActions :: Int
maxActions = Int
10
    , mcOptions :: Options ConwayEra
mcOptions = Options ConwayEra
defaultOptions
    , disableNegativeTesting :: Maybe String
disableNegativeTesting = Maybe String
forall a. Maybe a
Nothing
    }

{- | Main property for testing a testing interface.
Generates random action sequences and checks that the implementation matches the model.
-}
propRunActions :: forall state. (ThreatModelsFor state) => String -> TestTree
propRunActions :: forall state. ThreatModelsFor state => String -> TestTree
propRunActions String
name = forall state.
ThreatModelsFor state =>
String -> RunOptions -> TestTree
propRunActionsWithOptions @state String
name RunOptions
defaultRunOptions

-- | Run testing interface tests with custom options
propRunActionsWithOptions
  :: forall state
   . (ThreatModelsFor state)
  => String
  -> RunOptions
  -> TestTree
propRunActionsWithOptions :: forall state.
ThreatModelsFor state =>
String -> RunOptions -> TestTree
propRunActionsWithOptions String
groupName RunOptions
opts =
  (TraceRecorder -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((TraceRecorder -> TestTree) -> TestTree)
-> (TraceRecorder -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(TraceRecorder
recorder :: TraceRecorder) ->
    let tms :: [ThreatModel ()]
tms = forall state. ThreatModelsFor state => [ThreatModel ()]
threatModels @state
        evs :: [ThreatModel ()]
evs = forall state. ThreatModelsFor state => [ThreatModel ()]
expectedVulnerabilities @state
     in if [ThreatModel ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ThreatModel ()]
tms Bool -> Bool -> Bool
&& [ThreatModel ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ThreatModel ()]
evs
          then
            -- No threat models: simple structure (backward compatible)
            IO (IORef Int)
-> (IORef Int -> IO ()) -> (IO (IORef Int) -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)) (\IORef Int
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((IO (IORef Int) -> TestTree) -> TestTree)
-> (IO (IORef Int) -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \IO (IORef Int)
getPosRef ->
              IO (IORef Int)
-> (IORef Int -> IO ()) -> (IO (IORef Int) -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)) (\IORef Int
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((IO (IORef Int) -> TestTree) -> TestTree)
-> (IO (IORef Int) -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \IO (IORef Int)
getNegRef ->
                String -> [TestTree] -> TestTree
testGroup
                  String
groupName
                  [ String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Positive tests" (forall state.
TestingInterface state =>
RunOptions
-> String
-> Maybe (IO (IORef ThreatModelResults))
-> [ThreatModel ()]
-> [ThreatModel ()]
-> TraceRecorder
-> IO (IORef Int)
-> Property
positiveTest @state RunOptions
opts String
groupName Maybe (IO (IORef ThreatModelResults))
forall a. Maybe a
Nothing [] [] TraceRecorder
recorder IO (IORef Int)
getPosRef)
                  , TraceRecorder -> IO (IORef Int) -> TestTree
negativeTestTree TraceRecorder
recorder IO (IORef Int)
getNegRef
                  ]
          else
            -- Has threat models: two-phase approach with IORef
            IO (IORef ThreatModelResults)
-> (IORef ThreatModelResults -> IO ())
-> (IO (IORef ThreatModelResults) -> TestTree)
-> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource (ThreatModelResults -> IO (IORef ThreatModelResults)
forall a. a -> IO (IORef a)
newIORef ThreatModelResults
forall k a. Map k a
Map.empty) (\IORef ThreatModelResults
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((IO (IORef ThreatModelResults) -> TestTree) -> TestTree)
-> (IO (IORef ThreatModelResults) -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \IO (IORef ThreatModelResults)
getTmResultsRef ->
              IO (IORef Int)
-> (IORef Int -> IO ()) -> (IO (IORef Int) -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)) (\IORef Int
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((IO (IORef Int) -> TestTree) -> TestTree)
-> (IO (IORef Int) -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \IO (IORef Int)
getPosRef ->
                IO (IORef Int)
-> (IORef Int -> IO ()) -> (IO (IORef Int) -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)) (\IORef Int
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((IO (IORef Int) -> TestTree) -> TestTree)
-> (IO (IORef Int) -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \IO (IORef Int)
getNegRef ->
                  String -> DependencyType -> [TestTree] -> TestTree
sequentialTestGroup String
groupName DependencyType
AllFinish ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
                    [ String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Positive tests" (forall state.
TestingInterface state =>
RunOptions
-> String
-> Maybe (IO (IORef ThreatModelResults))
-> [ThreatModel ()]
-> [ThreatModel ()]
-> TraceRecorder
-> IO (IORef Int)
-> Property
positiveTest @state RunOptions
opts String
groupName (IO (IORef ThreatModelResults)
-> Maybe (IO (IORef ThreatModelResults))
forall a. a -> Maybe a
Just IO (IORef ThreatModelResults)
getTmResultsRef) [ThreatModel ()]
tms [ThreatModel ()]
evs TraceRecorder
recorder IO (IORef Int)
getPosRef)
                    , TraceRecorder -> IO (IORef Int) -> TestTree
negativeTestTree TraceRecorder
recorder IO (IORef Int)
getNegRef
                    ]
                      [TestTree] -> [TestTree] -> [TestTree]
forall a. Semigroup a => a -> a -> a
<> IO (IORef ThreatModelResults) -> [ThreatModel ()] -> [TestTree]
threatModelGroup IO (IORef ThreatModelResults)
getTmResultsRef [ThreatModel ()]
tms
                      [TestTree] -> [TestTree] -> [TestTree]
forall a. Semigroup a => a -> a -> a
<> IO (IORef ThreatModelResults) -> [ThreatModel ()] -> [TestTree]
expectedVulnGroup IO (IORef ThreatModelResults)
getTmResultsRef [ThreatModel ()]
evs
 where
  negativeTestTree :: TraceRecorder -> IO (IORef Int) -> TestTree
negativeTestTree TraceRecorder
recorder IO (IORef Int)
getNegRef = case RunOptions -> Maybe String
disableNegativeTesting RunOptions
opts of
    Maybe String
Nothing -> String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Negative tests" (forall state.
TestingInterface state =>
RunOptions -> String -> TraceRecorder -> IO (IORef Int) -> Property
negativeTest @state RunOptions
opts String
groupName TraceRecorder
recorder IO (IORef Int)
getNegRef)
    Just String
reason -> String -> TestTree -> TestTree
ignoreTestBecause String
reason (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Negative tests" (forall state.
TestingInterface state =>
RunOptions -> String -> TraceRecorder -> IO (IORef Int) -> Property
negativeTest @state RunOptions
opts String
groupName TraceRecorder
recorder IO (IORef Int)
getNegRef)

  threatModelGroup :: IO (IORef ThreatModelResults) -> [ThreatModel ()] -> [TestTree]
threatModelGroup IO (IORef ThreatModelResults)
_ [] = []
  threatModelGroup IO (IORef ThreatModelResults)
getTmResultsRef [ThreatModel ()]
tms' =
    [String -> [TestTree] -> TestTree
testGroup String
"Threat models" ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$ (Int -> ThreatModel () -> TestTree)
-> [Int] -> [ThreatModel ()] -> [TestTree]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (IO (IORef ThreatModelResults)
-> String -> Int -> ThreatModel () -> TestTree
threatModelTestCase IO (IORef ThreatModelResults)
getTmResultsRef String
"Threat models") [Int
1 ..] [ThreatModel ()]
tms']

  expectedVulnGroup :: IO (IORef ThreatModelResults) -> [ThreatModel ()] -> [TestTree]
expectedVulnGroup IO (IORef ThreatModelResults)
_ [] = []
  expectedVulnGroup IO (IORef ThreatModelResults)
getTmResultsRef [ThreatModel ()]
evs' =
    [String -> [TestTree] -> TestTree
testGroup String
"Expected vulnerabilities" ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$ (Int -> ThreatModel () -> TestTree)
-> [Int] -> [ThreatModel ()] -> [TestTree]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (IO (IORef ThreatModelResults)
-> String -> Int -> ThreatModel () -> TestTree
expectedVulnTestCase IO (IORef ThreatModelResults)
getTmResultsRef String
"Expected vulnerabilities") [Int
1 ..] [ThreatModel ()]
evs']

-- | Negative test: check that invalid actions fail
negativeTest
  :: forall state
   . (TestingInterface state)
  => RunOptions
  -> String
  -- ^ Group name for test ID resolution
  -> TraceRecorder
  -- ^ Callback for recording iteration traces
  -> IO (IORef Int)
  -- ^ Iteration counter accessor
  -> Property
negativeTest :: forall state.
TestingInterface state =>
RunOptions -> String -> TraceRecorder -> IO (IORef Int) -> Property
negativeTest RunOptions
opts String
groupName TraceRecorder
recorder IO (IORef Int)
getIterRef = PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  -- Bump and read iteration index
  Int
iterIdx <- IO Int -> PropertyM IO Int
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO Int -> PropertyM IO Int) -> IO Int -> PropertyM IO Int
forall a b. (a -> b) -> a -> b
$ do
    IORef Int
iterRef <- IO (IORef Int)
getIterRef
    Int
idx <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
iterRef
    IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Int
iterRef (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
idx
  Bool
enabled <- IO Bool -> PropertyM IO Bool
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO Bool -> PropertyM IO Bool) -> IO Bool -> PropertyM IO Bool
forall a b. (a -> b) -> a -> b
$ TraceRecorder -> IO Bool
trEnabled TraceRecorder
recorder
  if Bool
enabled
    then forall state.
TestingInterface state =>
RunOptions
-> String -> TraceRecorder -> Int -> PropertyM IO Property
negativeTestTraced @state RunOptions
opts String
groupName TraceRecorder
recorder Int
iterIdx
    else forall state.
TestingInterface state =>
RunOptions -> PropertyM IO Property
negativeTestFast @state RunOptions
opts

-- | Traced path for negative tests: runs 'runActionsTraced', builds traces.
negativeTestTraced
  :: forall state
   . (TestingInterface state)
  => RunOptions
  -> String
  -> TraceRecorder
  -> Int
  -> PropertyM IO Property
negativeTestTraced :: forall state.
TestingInterface state =>
RunOptions
-> String -> TraceRecorder -> Int -> PropertyM IO Property
negativeTestTraced RunOptions
opts String
groupName TraceRecorder
recorder Int
iterIdx = do
  let RunOptions{mcOptions :: RunOptions -> Options ConwayEra
mcOptions = Options{Maybe (IORef CoverageData)
coverageRef :: Maybe (IORef CoverageData)
coverageRef :: forall era. Options era -> Maybe (IORef CoverageData)
coverageRef, NodeParams ConwayEra
params :: NodeParams ConwayEra
params :: forall era. Options era -> NodeParams era
params}} = RunOptions
opts
  -- Phase 1: Run the valid prefix, capturing the final mockchain state
  (Either
  (BalanceTxError ConwayEra) ((Action state, state), [Transition])
prefixResult, MockChainState ConwayEra
prefixState) <- NodeParams ConwayEra
-> TestingMonadT
     (PropertyM IO) ((Action state, state), [Transition])
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra) ((Action state, state), [Transition]),
      MockChainState ConwayEra)
forall (m :: * -> *) a.
NodeParams ConwayEra
-> TestingMonadT m a
-> m (Either (BalanceTxError ConwayEra) a,
      MockChainState ConwayEra)
runTestingMonadT NodeParams ConwayEra
params (TestingMonadT (PropertyM IO) ((Action state, state), [Transition])
 -> PropertyM
      IO
      (Either
         (BalanceTxError ConwayEra) ((Action state, state), [Transition]),
       MockChainState ConwayEra))
-> TestingMonadT
     (PropertyM IO) ((Action state, state), [Transition])
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra) ((Action state, state), [Transition]),
      MockChainState ConwayEra)
forall a b. (a -> b) -> a -> b
$ do
    state
initialState <- forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> TestingMonadT (PropertyM m) state
runInitialization @state RunOptions
opts

    (state
finalState, [Transition]
transitions) <- RunOptions
-> Int
-> state
-> TestingMonadT (PropertyM IO) (state, [Transition])
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions
-> Int
-> state
-> TestingMonadT (PropertyM m) (state, [Transition])
runActionsTraced RunOptions
opts Int
10 state
initialState

    -- Generate an action that VIOLATES the precondition in that state
    (Action state, state)
result <- PropertyM IO (Action state, state)
-> TestingMonadT (PropertyM IO) (Action state, state)
forall (m :: * -> *) a. Monad m => m a -> TestingMonadT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PropertyM IO (Action state, state)
 -> TestingMonadT (PropertyM IO) (Action state, state))
-> PropertyM IO (Action state, state)
-> TestingMonadT (PropertyM IO) (Action state, state)
forall a b. (a -> b) -> a -> b
$ Gen (Action state, state) -> PropertyM IO (Action state, state)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen (Action state, state) -> PropertyM IO (Action state, state))
-> Gen (Action state, state) -> PropertyM IO (Action state, state)
forall a b. (a -> b) -> a -> b
$ do
      Maybe (Action state)
maybeInvalid <- state -> Gen (Action state)
forall state. TestingInterface state => state -> Gen (Action state)
arbitraryAction state
finalState Gen (Action state)
-> (Action state -> Bool) -> Gen (Maybe (Action state))
forall a. Gen a -> (a -> Bool) -> Gen (Maybe a)
`suchThatMaybe` (Bool -> Bool
not (Bool -> Bool) -> (Action state -> Bool) -> Action state -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state -> Action state -> Bool
forall state.
TestingInterface state =>
state -> Action state -> Bool
precondition state
finalState)
      case Maybe (Action state)
maybeInvalid of
        Maybe (Action state)
Nothing -> Gen (Action state, state)
forall a. a
discard -- tell QuickCheck to skip this case
        Just Action state
bad -> (Action state, state) -> Gen (Action state, state)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Action state
bad, state
finalState)
    ((Action state, state), [Transition])
-> TestingMonadT
     (PropertyM IO) ((Action state, state), [Transition])
forall a. a -> TestingMonadT (PropertyM IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Action state, state)
result, [Transition]
transitions)

  -- Phase 2: Run the bad action starting from the state left by the valid prefix
  case Either
  (BalanceTxError ConwayEra) ((Action state, state), [Transition])
prefixResult of
    Left BalanceTxError ConwayEra
err -> do
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Valid prefix failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BalanceTxError ConwayEra -> String
forall a. Show a => a -> String
show BalanceTxError ConwayEra
err)
      -- Record failed iteration trace
      let trace :: IterationTrace
trace =
            IterationTrace
              { itIndex :: Int
itIndex = Int
iterIdx
              , itStatus :: IterationStatus
itStatus = Text -> IterationStatus
IterationFailure (BalanceTxError ConwayEra -> Text
formatBalanceTxError BalanceTxError ConwayEra
err)
              , itTransitions :: [Transition]
itTransitions = []
              , itThreatModels :: [ThreatModelTrace]
itThreatModels = []
              }
      IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ TraceRecorder -> String -> String -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"negative" (IterationTrace -> Value
forall a. ToJSON a => a -> Value
toJSON IterationTrace
trace)
      Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)
    Right ((Action state
badAction, state
finalState), [Transition]
transitions) -> do
      let monadAction :: MockchainT ConwayEra IO (Either (BalanceTxError ConwayEra) state)
monadAction = ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
-> MockchainT
     ConwayEra IO (Either (BalanceTxError ConwayEra) state)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
 -> MockchainT
      ConwayEra IO (Either (BalanceTxError ConwayEra) state))
-> ExceptT
     (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
-> MockchainT
     ConwayEra IO (Either (BalanceTxError ConwayEra) state)
forall a b. (a -> b) -> a -> b
$ TestingMonadT IO state
-> ExceptT
     (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
forall (m :: * -> *) a.
TestingMonadT m a
-> ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
unTestingMonadT (TestingMonadT IO state
 -> ExceptT
      (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state)
-> TestingMonadT IO state
-> ExceptT
     (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
forall a b. (a -> b) -> a -> b
$ state -> Action state -> TestingMonadT IO state
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
state -> Action state -> TestingMonadT m state
forall (m :: * -> *).
MonadIO m =>
state -> Action state -> TestingMonadT m state
perform state
finalState Action state
badAction
      Either
  SomeException
  (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
result' <- IO
  (Either
     SomeException
     (Either (BalanceTxError ConwayEra) state,
      MockChainState ConwayEra))
-> PropertyM
     IO
     (Either
        SomeException
        (Either (BalanceTxError ConwayEra) state,
         MockChainState ConwayEra))
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO
   (Either
      SomeException
      (Either (BalanceTxError ConwayEra) state,
       MockChainState ConwayEra))
 -> PropertyM
      IO
      (Either
         SomeException
         (Either (BalanceTxError ConwayEra) state,
          MockChainState ConwayEra)))
-> IO
     (Either
        SomeException
        (Either (BalanceTxError ConwayEra) state,
         MockChainState ConwayEra))
-> PropertyM
     IO
     (Either
        SomeException
        (Either (BalanceTxError ConwayEra) state,
         MockChainState ConwayEra))
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO
   (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
 -> IO
      (Either
         SomeException
         (Either (BalanceTxError ConwayEra) state,
          MockChainState ConwayEra)))
-> IO
     (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
-> IO
     (Either
        SomeException
        (Either (BalanceTxError ConwayEra) state,
         MockChainState ConwayEra))
forall a b. (a -> b) -> a -> b
$ MockchainT ConwayEra IO (Either (BalanceTxError ConwayEra) state)
-> NodeParams ConwayEra
-> MockChainState ConwayEra
-> IO
     (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
forall era a.
MockchainIO era a
-> NodeParams era
-> MockChainState era
-> IO (a, MockChainState era)
runMockchainIO MockchainT ConwayEra IO (Either (BalanceTxError ConwayEra) state)
monadAction NodeParams ConwayEra
params MockChainState ConwayEra
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,
      -- but if it failed after submission (i.e. validator rejection), we count it as a success.
      let badActionText :: Text
badActionText = String -> Text
T.pack (Action state -> String
forall a. Show a => a -> String
show Action state
badAction)
          badTransition :: TransitionResult -> Transition
badTransition TransitionResult
status =
            Transition
              { trStepIndex :: Int
trStepIndex = [Transition] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Transition]
transitions
              , trAction :: Text
trAction = Text
badActionText
              , trStateBefore :: Value
trStateBefore = state -> Value
forall a. ToJSON a => a -> Value
toJSON state
finalState
              , trStateAfter :: Value
trStateAfter = state -> Value
forall a. ToJSON a => a -> Value
toJSON state
finalState
              , trTransaction :: Maybe TxSummary
trTransaction = Maybe TxSummary
forall a. Maybe a
Nothing
              , trResult :: TransitionResult
trResult = TransitionResult
status
              }
      case Either
  SomeException
  (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
result' of
        -- we try another round of bad actions
        Left SomeException
ex | forall state. TestingInterface state => Bool
discardNegativeTestForUserExceptions @state -> do
          let trace :: IterationTrace
trace =
                IterationTrace
                  { itIndex :: Int
itIndex = Int
iterIdx
                  , itStatus :: IterationStatus
itStatus = Text -> IterationStatus
IterationDiscarded (String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
ex))
                  , itTransitions :: [Transition]
itTransitions = [Transition]
transitions [Transition] -> [Transition] -> [Transition]
forall a. Semigroup a => a -> a -> a
<> [TransitionResult -> Transition
badTransition (Text -> TransitionResult
TransitionFailure (String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
ex)))]
                  , itThreatModels :: [ThreatModelTrace]
itThreatModels = []
                  }
          IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ TraceRecorder -> String -> String -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"negative" (IterationTrace -> Value
forall a. ToJSON a => a -> Value
toJSON IterationTrace
trace)
          PropertyM IO Property
forall a. a
discard
        Left SomeException
ex -> do
          let trace :: IterationTrace
trace =
                IterationTrace
                  { itIndex :: Int
itIndex = Int
iterIdx
                  , itStatus :: IterationStatus
itStatus = IterationStatus
IterationSuccess
                  , itTransitions :: [Transition]
itTransitions = [Transition]
transitions [Transition] -> [Transition] -> [Transition]
forall a. Semigroup a => a -> a -> a
<> [TransitionResult -> Transition
badTransition (Text -> TransitionResult
TransitionFailure (String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
ex)))]
                  , itThreatModels :: [ThreatModelTrace]
itThreatModels = []
                  }
          IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ TraceRecorder -> String -> String -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"negative" (IterationTrace -> Value
forall a. ToJSON a => a -> Value
toJSON IterationTrace
trace)
          Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)
        Right (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
result ->
          case (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
result of
            (Left BalanceTxError ConwayEra
err, MockChainState{mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData = CoverageData
covData}) -> do
              -- Good: the invalid action failed via BalanceTxError (validator rejection)
              Maybe (IORef CoverageData)
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ())
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IO () -> PropertyM IO ()
forall a. IO a -> PropertyM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> (CoverageData
covData CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> BalanceTxError ConwayEra -> CoverageData
forall e. BalanceTxError e -> CoverageData
coverageFromBalanceTxError BalanceTxError ConwayEra
err))
              let trace :: IterationTrace
trace =
                    IterationTrace
                      { itIndex :: Int
itIndex = Int
iterIdx
                      , itStatus :: IterationStatus
itStatus = IterationStatus
IterationSuccess
                      , itTransitions :: [Transition]
itTransitions = [Transition]
transitions [Transition] -> [Transition] -> [Transition]
forall a. Semigroup a => a -> a -> a
<> [TransitionResult -> Transition
badTransition (Text -> TransitionResult
TransitionFailure (BalanceTxError ConwayEra -> Text
formatBalanceTxError BalanceTxError ConwayEra
err))]
                      , itThreatModels :: [ThreatModelTrace]
itThreatModels = []
                      }
              IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ TraceRecorder -> String -> String -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"negative" (IterationTrace -> Value
forall a. ToJSON a => a -> Value
toJSON IterationTrace
trace)
              Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)
            (Right state
_, MockChainState{mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData = CoverageData
covData}) -> do
              -- Bad: the invalid action succeeded — contract is too permissive
              Maybe (IORef CoverageData)
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ())
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IO () -> PropertyM IO ()
forall a. IO a -> PropertyM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> CoverageData
covData)
              (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Expected failure for invalid action but it succeeded")
              let trace :: IterationTrace
trace =
                    IterationTrace
                      { itIndex :: Int
itIndex = Int
iterIdx
                      , itStatus :: IterationStatus
itStatus = Text -> IterationStatus
IterationFailure Text
"Invalid action succeeded unexpectedly"
                      , itTransitions :: [Transition]
itTransitions = [Transition]
transitions [Transition] -> [Transition] -> [Transition]
forall a. Semigroup a => a -> a -> a
<> [TransitionResult -> Transition
badTransition (Text -> TransitionResult
TransitionSuccess Text
T.empty)]
                      , itThreatModels :: [ThreatModelTrace]
itThreatModels = []
                      }
              IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ TraceRecorder -> String -> String -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"negative" (IterationTrace -> Value
forall a. ToJSON a => a -> Value
toJSON IterationTrace
trace)
              Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)

-- | Fast path for negative tests: runs 'runActions' (no tracing overhead).
negativeTestFast
  :: forall state
   . (TestingInterface state)
  => RunOptions
  -> PropertyM IO Property
negativeTestFast :: forall state.
TestingInterface state =>
RunOptions -> PropertyM IO Property
negativeTestFast RunOptions
opts = do
  let RunOptions{mcOptions :: RunOptions -> Options ConwayEra
mcOptions = Options{Maybe (IORef CoverageData)
coverageRef :: forall era. Options era -> Maybe (IORef CoverageData)
coverageRef :: Maybe (IORef CoverageData)
coverageRef, NodeParams ConwayEra
params :: forall era. Options era -> NodeParams era
params :: NodeParams ConwayEra
params}} = RunOptions
opts
  -- Phase 1: Run the valid prefix, capturing the final mockchain state
  (Either (BalanceTxError ConwayEra) (Action state, state)
prefixResult, MockChainState ConwayEra
prefixState) <- NodeParams ConwayEra
-> TestingMonadT (PropertyM IO) (Action state, state)
-> PropertyM
     IO
     (Either (BalanceTxError ConwayEra) (Action state, state),
      MockChainState ConwayEra)
forall (m :: * -> *) a.
NodeParams ConwayEra
-> TestingMonadT m a
-> m (Either (BalanceTxError ConwayEra) a,
      MockChainState ConwayEra)
runTestingMonadT NodeParams ConwayEra
params (TestingMonadT (PropertyM IO) (Action state, state)
 -> PropertyM
      IO
      (Either (BalanceTxError ConwayEra) (Action state, state),
       MockChainState ConwayEra))
-> TestingMonadT (PropertyM IO) (Action state, state)
-> PropertyM
     IO
     (Either (BalanceTxError ConwayEra) (Action state, state),
      MockChainState ConwayEra)
forall a b. (a -> b) -> a -> b
$ do
    state
initialState <- forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> TestingMonadT (PropertyM m) state
runInitialization @state RunOptions
opts

    state
finalState <- RunOptions -> Int -> state -> TestingMonadT (PropertyM IO) state
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> Int -> state -> TestingMonadT (PropertyM m) state
runActions RunOptions
opts Int
10 state
initialState

    -- Generate an action that VIOLATES the precondition in that state
    (Action state, state)
result <- PropertyM IO (Action state, state)
-> TestingMonadT (PropertyM IO) (Action state, state)
forall (m :: * -> *) a. Monad m => m a -> TestingMonadT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PropertyM IO (Action state, state)
 -> TestingMonadT (PropertyM IO) (Action state, state))
-> PropertyM IO (Action state, state)
-> TestingMonadT (PropertyM IO) (Action state, state)
forall a b. (a -> b) -> a -> b
$ Gen (Action state, state) -> PropertyM IO (Action state, state)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen (Action state, state) -> PropertyM IO (Action state, state))
-> Gen (Action state, state) -> PropertyM IO (Action state, state)
forall a b. (a -> b) -> a -> b
$ do
      Maybe (Action state)
maybeInvalid <- state -> Gen (Action state)
forall state. TestingInterface state => state -> Gen (Action state)
arbitraryAction state
finalState Gen (Action state)
-> (Action state -> Bool) -> Gen (Maybe (Action state))
forall a. Gen a -> (a -> Bool) -> Gen (Maybe a)
`suchThatMaybe` (Bool -> Bool
not (Bool -> Bool) -> (Action state -> Bool) -> Action state -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state -> Action state -> Bool
forall state.
TestingInterface state =>
state -> Action state -> Bool
precondition state
finalState)
      case Maybe (Action state)
maybeInvalid of
        Maybe (Action state)
Nothing -> Gen (Action state, state)
forall a. a
discard
        Just Action state
bad -> (Action state, state) -> Gen (Action state, state)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Action state
bad, state
finalState)
    (Action state, state)
-> TestingMonadT (PropertyM IO) (Action state, state)
forall a. a -> TestingMonadT (PropertyM IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Action state, state)
result

  -- Phase 2: Run the bad action starting from the state left by the valid prefix
  case Either (BalanceTxError ConwayEra) (Action state, state)
prefixResult of
    Left BalanceTxError ConwayEra
err -> do
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Valid prefix failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BalanceTxError ConwayEra -> String
forall a. Show a => a -> String
show BalanceTxError ConwayEra
err)
      Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)
    Right (Action state
badAction, state
finalState) -> do
      let monadAction :: MockchainT ConwayEra IO (Either (BalanceTxError ConwayEra) state)
monadAction = ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
-> MockchainT
     ConwayEra IO (Either (BalanceTxError ConwayEra) state)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
 -> MockchainT
      ConwayEra IO (Either (BalanceTxError ConwayEra) state))
-> ExceptT
     (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
-> MockchainT
     ConwayEra IO (Either (BalanceTxError ConwayEra) state)
forall a b. (a -> b) -> a -> b
$ TestingMonadT IO state
-> ExceptT
     (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
forall (m :: * -> *) a.
TestingMonadT m a
-> ExceptT (BalanceTxError ConwayEra) (MockchainT ConwayEra m) a
unTestingMonadT (TestingMonadT IO state
 -> ExceptT
      (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state)
-> TestingMonadT IO state
-> ExceptT
     (BalanceTxError ConwayEra) (MockchainT ConwayEra IO) state
forall a b. (a -> b) -> a -> b
$ state -> Action state -> TestingMonadT IO state
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
state -> Action state -> TestingMonadT m state
forall (m :: * -> *).
MonadIO m =>
state -> Action state -> TestingMonadT m state
perform state
finalState Action state
badAction
      Either
  SomeException
  (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
result' <- IO
  (Either
     SomeException
     (Either (BalanceTxError ConwayEra) state,
      MockChainState ConwayEra))
-> PropertyM
     IO
     (Either
        SomeException
        (Either (BalanceTxError ConwayEra) state,
         MockChainState ConwayEra))
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO
   (Either
      SomeException
      (Either (BalanceTxError ConwayEra) state,
       MockChainState ConwayEra))
 -> PropertyM
      IO
      (Either
         SomeException
         (Either (BalanceTxError ConwayEra) state,
          MockChainState ConwayEra)))
-> IO
     (Either
        SomeException
        (Either (BalanceTxError ConwayEra) state,
         MockChainState ConwayEra))
-> PropertyM
     IO
     (Either
        SomeException
        (Either (BalanceTxError ConwayEra) state,
         MockChainState ConwayEra))
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO
   (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
 -> IO
      (Either
         SomeException
         (Either (BalanceTxError ConwayEra) state,
          MockChainState ConwayEra)))
-> IO
     (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
-> IO
     (Either
        SomeException
        (Either (BalanceTxError ConwayEra) state,
         MockChainState ConwayEra))
forall a b. (a -> b) -> a -> b
$ MockchainT ConwayEra IO (Either (BalanceTxError ConwayEra) state)
-> NodeParams ConwayEra
-> MockChainState ConwayEra
-> IO
     (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
forall era a.
MockchainIO era a
-> NodeParams era
-> MockChainState era
-> IO (a, MockChainState era)
runMockchainIO MockchainT ConwayEra IO (Either (BalanceTxError ConwayEra) state)
monadAction NodeParams ConwayEra
params MockChainState ConwayEra
prefixState
      case Either
  SomeException
  (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
result' of
        Left SomeException
_ | forall state. TestingInterface state => Bool
discardNegativeTestForUserExceptions @state -> PropertyM IO Property
forall a. a
discard
        Left SomeException
_ -> Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)
        Right (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
result ->
          case (Either (BalanceTxError ConwayEra) state, MockChainState ConwayEra)
result of
            (Left BalanceTxError ConwayEra
err, MockChainState{mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData = CoverageData
covData}) -> do
              Maybe (IORef CoverageData)
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ())
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IO () -> PropertyM IO ()
forall a. IO a -> PropertyM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> (CoverageData
covData CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> BalanceTxError ConwayEra -> CoverageData
forall e. BalanceTxError e -> CoverageData
coverageFromBalanceTxError BalanceTxError ConwayEra
err))
              Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)
            (Right state
_, MockChainState{mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData = CoverageData
covData}) -> do
              Maybe (IORef CoverageData)
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ())
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IO () -> PropertyM IO ()
forall a. IO a -> PropertyM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> CoverageData
covData)
              (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Expected failure for invalid action but it succeeded")
              Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)

{- | Positive test with optional threat model outcome collection.
When threat models list is empty, it behaves as a simple positive test.
When threat models are present, each is run in isolation with exception handling.
-}
positiveTest
  :: forall state
   . (TestingInterface state)
  => RunOptions
  -> String
  -- ^ Group name for test ID resolution
  -> Maybe (IO (IORef ThreatModelResults))
  -- ^ IORef for collecting results (Nothing = no threat models, don't collect)
  -> [ThreatModel ()]
  -- ^ Threat models (early-stop on TMFailed)
  -> [ThreatModel ()]
  -- ^ Expected vulnerabilities (never early-stop)
  -> TraceRecorder
  -- ^ Callback for recording iteration traces
  -> IO (IORef Int)
  -- ^ Iteration counter accessor (bumped each QuickCheck iteration)
  -> Property
positiveTest :: forall state.
TestingInterface state =>
RunOptions
-> String
-> Maybe (IO (IORef ThreatModelResults))
-> [ThreatModel ()]
-> [ThreatModel ()]
-> TraceRecorder
-> IO (IORef Int)
-> Property
positiveTest RunOptions
opts String
groupName Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [ThreatModel ()]
tms [ThreatModel ()]
evs TraceRecorder
recorder IO (IORef Int)
getIterRef = PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  -- Bump and read iteration index
  Int
iterIdx <- IO Int -> PropertyM IO Int
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO Int -> PropertyM IO Int) -> IO Int -> PropertyM IO Int
forall a b. (a -> b) -> a -> b
$ do
    IORef Int
iterRef <- IO (IORef Int)
getIterRef
    Int
idx <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
iterRef
    IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Int
iterRef (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
idx
  Bool
enabled <- IO Bool -> PropertyM IO Bool
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO Bool -> PropertyM IO Bool) -> IO Bool -> PropertyM IO Bool
forall a b. (a -> b) -> a -> b
$ TraceRecorder -> IO Bool
trEnabled TraceRecorder
recorder
  if Bool
enabled
    then forall state.
TestingInterface state =>
RunOptions
-> String
-> Maybe (IO (IORef ThreatModelResults))
-> [ThreatModel ()]
-> [ThreatModel ()]
-> TraceRecorder
-> Int
-> PropertyM IO Property
positiveTestTraced @state RunOptions
opts String
groupName Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [ThreatModel ()]
tms [ThreatModel ()]
evs TraceRecorder
recorder Int
iterIdx
    else forall state.
TestingInterface state =>
RunOptions
-> Maybe (IO (IORef ThreatModelResults))
-> [ThreatModel ()]
-> [ThreatModel ()]
-> PropertyM IO Property
positiveTestFast @state RunOptions
opts Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [ThreatModel ()]
tms [ThreatModel ()]
evs

-- | Traced path: runs 'runActionsTraced', builds 'IterationTrace', records it.
positiveTestTraced
  :: forall state
   . (TestingInterface state)
  => RunOptions
  -> String
  -> Maybe (IO (IORef ThreatModelResults))
  -> [ThreatModel ()]
  -> [ThreatModel ()]
  -> TraceRecorder
  -> Int
  -> PropertyM IO Property
positiveTestTraced :: forall state.
TestingInterface state =>
RunOptions
-> String
-> Maybe (IO (IORef ThreatModelResults))
-> [ThreatModel ()]
-> [ThreatModel ()]
-> TraceRecorder
-> Int
-> PropertyM IO Property
positiveTestTraced RunOptions
opts String
groupName Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [ThreatModel ()]
tms [ThreatModel ()]
evs TraceRecorder
recorder Int
iterIdx = do
  let RunOptions{mcOptions :: RunOptions -> Options ConwayEra
mcOptions = Options{Maybe (IORef CoverageData)
coverageRef :: forall era. Options era -> Maybe (IORef CoverageData)
coverageRef :: Maybe (IORef CoverageData)
coverageRef, NodeParams ConwayEra
params :: forall era. Options era -> NodeParams era
params :: NodeParams ConwayEra
params}} = RunOptions
opts
  (Either
   (BalanceTxError ConwayEra)
   (state, [Transition], [(String, ThreatModelOutcome)],
    [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
    CoverageData),
 MockChainState ConwayEra)
result <- NodeParams ConwayEra
-> TestingMonadT
     (PropertyM IO)
     (state, [Transition], [(String, ThreatModelOutcome)],
      [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
      CoverageData)
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra)
        (state, [Transition], [(String, ThreatModelOutcome)],
         [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
         CoverageData),
      MockChainState ConwayEra)
forall (m :: * -> *) a.
NodeParams ConwayEra
-> TestingMonadT m a
-> m (Either (BalanceTxError ConwayEra) a,
      MockChainState ConwayEra)
runTestingMonadT NodeParams ConwayEra
params (TestingMonadT
   (PropertyM IO)
   (state, [Transition], [(String, ThreatModelOutcome)],
    [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
    CoverageData)
 -> PropertyM
      IO
      (Either
         (BalanceTxError ConwayEra)
         (state, [Transition], [(String, ThreatModelOutcome)],
          [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
          CoverageData),
       MockChainState ConwayEra))
-> TestingMonadT
     (PropertyM IO)
     (state, [Transition], [(String, ThreatModelOutcome)],
      [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
      CoverageData)
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra)
        (state, [Transition], [(String, ThreatModelOutcome)],
         [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
         CoverageData),
      MockChainState ConwayEra)
forall a b. (a -> b) -> a -> b
$ do
    state
initialState <- forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> TestingMonadT (PropertyM m) state
runInitialization @state RunOptions
opts

    (state
finalState, [Transition]
transitions) <- RunOptions
-> Int
-> state
-> TestingMonadT (PropertyM IO) (state, [Transition])
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions
-> Int
-> state
-> TestingMonadT (PropertyM m) (state, [Transition])
runActionsTraced RunOptions
opts Int
10 state
initialState

    [Tx ConwayEra]
allTxs <- TestingMonadT (PropertyM IO) [Tx ConwayEra]
forall era (m :: * -> *).
(MonadMockchain era m, IsShelleyBasedEra era) =>
m [Tx era]
getTxs
    let state0 :: MockChainState ConwayEra
state0 = NodeParams ConwayEra -> InitialUTXOs -> MockChainState ConwayEra
forall era.
IsShelleyBasedEra era =>
NodeParams era -> InitialUTXOs -> MockChainState era
initialStateFor NodeParams ConwayEra
params InitialUTXOs
Wallet.initialUTxOs
        envs :: [ThreatModelEnv]
envs = NodeParams ConwayEra
-> [Tx ConwayEra] -> MockChainState ConwayEra -> [ThreatModelEnv]
threatModelEnvs NodeParams ConwayEra
params ([Tx ConwayEra] -> [Tx ConwayEra]
forall a. [a] -> [a]
reverse [Tx ConwayEra]
allTxs) MockChainState ConwayEra
state0
    ThreatModelResults
existingResults <- case Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef of
      Just IO (IORef ThreatModelResults)
getTmRef -> IO ThreatModelResults
-> TestingMonadT (PropertyM IO) ThreatModelResults
forall a. IO a -> TestingMonadT (PropertyM IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreatModelResults
 -> TestingMonadT (PropertyM IO) ThreatModelResults)
-> IO ThreatModelResults
-> TestingMonadT (PropertyM IO) ThreatModelResults
forall a b. (a -> b) -> a -> b
$ do
        IORef ThreatModelResults
tmRef <- IO (IORef ThreatModelResults)
getTmRef
        IORef ThreatModelResults -> IO ThreatModelResults
forall a. IORef a -> IO a
readIORef IORef ThreatModelResults
tmRef
      Maybe (IO (IORef ThreatModelResults))
Nothing -> ThreatModelResults
-> TestingMonadT (PropertyM IO) ThreatModelResults
forall a. a -> TestingMonadT (PropertyM IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThreatModelResults
forall k a. Map k a
Map.empty
    let isTMFailed :: ThreatModelOutcome -> Bool
isTMFailed (TMFailed String
_) = Bool
True
        isTMFailed ThreatModelOutcome
_ = Bool
False
        alreadyFailed :: String -> Bool
alreadyFailed String
name = (ThreatModelOutcome -> Bool) -> [ThreatModelOutcome] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ThreatModelOutcome -> Bool
isTMFailed ([ThreatModelOutcome]
-> Maybe [ThreatModelOutcome] -> [ThreatModelOutcome]
forall a. a -> Maybe a -> a
fromMaybe [] (String -> ThreatModelResults -> Maybe [ThreatModelOutcome]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name ThreatModelResults
existingResults))
        tmsToRun :: [ThreatModel ()]
tmsToRun = (ThreatModel () -> Bool) -> [ThreatModel ()] -> [ThreatModel ()]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (ThreatModel () -> Bool) -> ThreatModel () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
alreadyFailed (String -> Bool)
-> (ThreatModel () -> String) -> ThreatModel () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Unnamed" (Maybe String -> String)
-> (ThreatModel () -> Maybe String) -> ThreatModel () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreatModel () -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName) [ThreatModel ()]
tms
        allToRun :: [ThreatModel ()]
allToRun = [ThreatModel ()]
tmsToRun [ThreatModel ()] -> [ThreatModel ()] -> [ThreatModel ()]
forall a. Semigroup a => a -> a -> a
<> [ThreatModel ()]
evs
    [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
  CoverageData)]
tmResultsWithCov <- IO
  [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
    CoverageData)]
-> TestingMonadT
     (PropertyM IO)
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
forall a. IO a -> TestingMonadT (PropertyM IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
     CoverageData)]
 -> TestingMonadT
      (PropertyM IO)
      [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
        CoverageData)])
-> IO
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
-> TestingMonadT
     (PropertyM IO)
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
forall a b. (a -> b) -> a -> b
$ [ThreatModel ()]
-> (ThreatModel ()
    -> IO
         (String, ThreatModelOutcome, [ThreatModelCheckEntry],
          CoverageData))
-> IO
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ThreatModel ()]
allToRun ((ThreatModel ()
  -> IO
       (String, ThreatModelOutcome, [ThreatModelCheckEntry],
        CoverageData))
 -> IO
      [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
        CoverageData)])
-> (ThreatModel ()
    -> IO
         (String, ThreatModelOutcome, [ThreatModelCheckEntry],
          CoverageData))
-> IO
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
forall a b. (a -> b) -> a -> b
$ \ThreatModel ()
tm -> do
      let name :: String
name = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Unnamed" (ThreatModel () -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName ThreatModel ()
tm)
      ((ThreatModelOutcome
outcome, [ThreatModelCheckEntry]
traceEntries), MockChainState ConwayEra
tmFinalState) <-
        MockchainIO ConwayEra (ThreatModelOutcome, [ThreatModelCheckEntry])
-> NodeParams ConwayEra
-> MockChainState ConwayEra
-> IO
     ((ThreatModelOutcome, [ThreatModelCheckEntry]),
      MockChainState ConwayEra)
forall era a.
MockchainIO era a
-> NodeParams era
-> MockChainState era
-> IO (a, MockChainState era)
runMockchainIO (SigningWallet
-> ThreatModel ()
-> [ThreatModelEnv]
-> MockchainIO
     ConwayEra (ThreatModelOutcome, [ThreatModelCheckEntry])
forall (m :: * -> *) a.
(MonadMockchain ConwayEra m, MonadFail m, MonadIO m) =>
SigningWallet
-> ThreatModel a
-> [ThreatModelEnv]
-> m (ThreatModelOutcome, [ThreatModelCheckEntry])
runThreatModelCheckTraced SigningWallet
AutoSign ThreatModel ()
tm [ThreatModelEnv]
envs) NodeParams ConwayEra
params MockChainState ConwayEra
state0
      (String, ThreatModelOutcome, [ThreatModelCheckEntry], CoverageData)
-> IO
     (String, ThreatModelOutcome, [ThreatModelCheckEntry], CoverageData)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
name, ThreatModelOutcome
outcome, [ThreatModelCheckEntry]
traceEntries, MockChainState ConwayEra -> CoverageData
forall era. MockChainState era -> CoverageData
mcsCoverageData MockChainState ConwayEra
tmFinalState)

    let tmResults :: [(String, ThreatModelOutcome)]
tmResults = [(String
n, ThreatModelOutcome
o) | (String
n, ThreatModelOutcome
o, [ThreatModelCheckEntry]
_, CoverageData
_) <- [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
  CoverageData)]
tmResultsWithCov]
        tmTracedResults :: [(String, ThreatModelOutcome, [ThreatModelCheckEntry])]
tmTracedResults = [(String
n, ThreatModelOutcome
o, [ThreatModelCheckEntry]
entries) | (String
n, ThreatModelOutcome
o, [ThreatModelCheckEntry]
entries, CoverageData
_) <- [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
  CoverageData)]
tmResultsWithCov]
        tmCoverage :: CoverageData
tmCoverage = [CoverageData] -> CoverageData
forall a. Monoid a => [a] -> a
mconcat [CoverageData
cov | (String
_, ThreatModelOutcome
_, [ThreatModelCheckEntry]
_, CoverageData
cov) <- [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
  CoverageData)]
tmResultsWithCov]

    (state, [Transition], [(String, ThreatModelOutcome)],
 [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
 CoverageData)
-> TestingMonadT
     (PropertyM IO)
     (state, [Transition], [(String, ThreatModelOutcome)],
      [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
      CoverageData)
forall a. a -> TestingMonadT (PropertyM IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (state
finalState, [Transition]
transitions, [(String, ThreatModelOutcome)]
tmResults, [(String, ThreatModelOutcome, [ThreatModelCheckEntry])]
tmTracedResults, CoverageData
tmCoverage)

  case (Either
   (BalanceTxError ConwayEra)
   (state, [Transition], [(String, ThreatModelOutcome)],
    [(String, ThreatModelOutcome, [ThreatModelCheckEntry])],
    CoverageData),
 MockChainState ConwayEra)
result of
    (Left BalanceTxError ConwayEra
err, MockChainState{mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData = CoverageData
covData}) -> do
      Maybe (IORef CoverageData)
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ())
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IO () -> PropertyM IO ()
forall a. IO a -> PropertyM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> (CoverageData
covData CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> BalanceTxError ConwayEra -> CoverageData
forall e. BalanceTxError e -> CoverageData
coverageFromBalanceTxError BalanceTxError ConwayEra
err))
      let trace :: IterationTrace
trace =
            IterationTrace
              { itIndex :: Int
itIndex = Int
iterIdx
              , itStatus :: IterationStatus
itStatus = Text -> IterationStatus
IterationFailure (BalanceTxError ConwayEra -> Text
formatBalanceTxError BalanceTxError ConwayEra
err)
              , itTransitions :: [Transition]
itTransitions = []
              , itThreatModels :: [ThreatModelTrace]
itThreatModels = []
              }
      IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ TraceRecorder -> String -> String -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"positive" (IterationTrace -> Value
forall a. ToJSON a => a -> Value
toJSON IterationTrace
trace)
      Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)
    (Right (state
finalState, [Transition]
transitions, [(String, ThreatModelOutcome)]
tmResults, [(String, ThreatModelOutcome, [ThreatModelCheckEntry])]
tmTracedResults, CoverageData
tmCoverage), MockChainState{mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData = CoverageData
covData}) -> do
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Final state: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ state -> String
forall a. Show a => a -> String
show state
finalState)
      (IORef CoverageData -> PropertyM IO ())
-> Maybe (IORef CoverageData) -> PropertyM IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\IORef CoverageData
ref -> IO () -> PropertyM IO ()
forall a. IO a -> PropertyM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> CoverageData
covData CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> CoverageData
tmCoverage)) Maybe (IORef CoverageData)
coverageRef
      case Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef of
        Just IO (IORef ThreatModelResults)
getTmResultsRef -> IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ do
          IORef ThreatModelResults
tmRef <- IO (IORef ThreatModelResults)
getTmResultsRef
          IORef ThreatModelResults
-> (ThreatModelResults -> ThreatModelResults) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ThreatModelResults
tmRef ((ThreatModelResults -> ThreatModelResults) -> IO ())
-> (ThreatModelResults -> ThreatModelResults) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ThreatModelResults
existing ->
            (ThreatModelResults
 -> (String, ThreatModelOutcome) -> ThreatModelResults)
-> ThreatModelResults
-> [(String, ThreatModelOutcome)]
-> ThreatModelResults
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
              (\ThreatModelResults
m (String
name, ThreatModelOutcome
outcome) -> ([ThreatModelOutcome]
 -> [ThreatModelOutcome] -> [ThreatModelOutcome])
-> String
-> [ThreatModelOutcome]
-> ThreatModelResults
-> ThreatModelResults
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [ThreatModelOutcome]
-> [ThreatModelOutcome] -> [ThreatModelOutcome]
forall a. Semigroup a => a -> a -> a
(<>) String
name [ThreatModelOutcome
outcome] ThreatModelResults
m)
              ThreatModelResults
existing
              [(String, ThreatModelOutcome)]
tmResults
        Maybe (IO (IORef ThreatModelResults))
Nothing -> () -> PropertyM IO ()
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      let tmTraces :: [ThreatModelTrace]
tmTraces = [(String, ThreatModelOutcome, [ThreatModelCheckEntry])]
-> [ThreatModelTrace]
toThreatModelTraces [(String, ThreatModelOutcome, [ThreatModelCheckEntry])]
tmTracedResults
          trace :: IterationTrace
trace =
            IterationTrace
              { itIndex :: Int
itIndex = Int
iterIdx
              , itStatus :: IterationStatus
itStatus = IterationStatus
IterationSuccess
              , itTransitions :: [Transition]
itTransitions = [Transition]
transitions
              , itThreatModels :: [ThreatModelTrace]
itThreatModels = [ThreatModelTrace]
tmTraces
              }
      IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ TraceRecorder -> String -> String -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"positive" (IterationTrace -> Value
forall a. ToJSON a => a -> Value
toJSON IterationTrace
trace)
      Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)

-- | Fast path: runs 'runActions' (no UTxO snapshots, no tx summaries, no JSON).
positiveTestFast
  :: forall state
   . (TestingInterface state)
  => RunOptions
  -> Maybe (IO (IORef ThreatModelResults))
  -> [ThreatModel ()]
  -> [ThreatModel ()]
  -> PropertyM IO Property
positiveTestFast :: forall state.
TestingInterface state =>
RunOptions
-> Maybe (IO (IORef ThreatModelResults))
-> [ThreatModel ()]
-> [ThreatModel ()]
-> PropertyM IO Property
positiveTestFast RunOptions
opts Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [ThreatModel ()]
tms [ThreatModel ()]
evs = do
  let RunOptions{mcOptions :: RunOptions -> Options ConwayEra
mcOptions = Options{Maybe (IORef CoverageData)
coverageRef :: forall era. Options era -> Maybe (IORef CoverageData)
coverageRef :: Maybe (IORef CoverageData)
coverageRef, NodeParams ConwayEra
params :: forall era. Options era -> NodeParams era
params :: NodeParams ConwayEra
params}} = RunOptions
opts
  (Either
   (BalanceTxError ConwayEra)
   (state, [(String, ThreatModelOutcome)], CoverageData),
 MockChainState ConwayEra)
result <- NodeParams ConwayEra
-> TestingMonadT
     (PropertyM IO)
     (state, [(String, ThreatModelOutcome)], CoverageData)
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra)
        (state, [(String, ThreatModelOutcome)], CoverageData),
      MockChainState ConwayEra)
forall (m :: * -> *) a.
NodeParams ConwayEra
-> TestingMonadT m a
-> m (Either (BalanceTxError ConwayEra) a,
      MockChainState ConwayEra)
runTestingMonadT NodeParams ConwayEra
params (TestingMonadT
   (PropertyM IO)
   (state, [(String, ThreatModelOutcome)], CoverageData)
 -> PropertyM
      IO
      (Either
         (BalanceTxError ConwayEra)
         (state, [(String, ThreatModelOutcome)], CoverageData),
       MockChainState ConwayEra))
-> TestingMonadT
     (PropertyM IO)
     (state, [(String, ThreatModelOutcome)], CoverageData)
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra)
        (state, [(String, ThreatModelOutcome)], CoverageData),
      MockChainState ConwayEra)
forall a b. (a -> b) -> a -> b
$ do
    state
initialState <- forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> TestingMonadT (PropertyM m) state
runInitialization @state RunOptions
opts

    state
finalState <- RunOptions -> Int -> state -> TestingMonadT (PropertyM IO) state
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> Int -> state -> TestingMonadT (PropertyM m) state
runActions RunOptions
opts Int
10 state
initialState

    [Tx ConwayEra]
allTxs <- TestingMonadT (PropertyM IO) [Tx ConwayEra]
forall era (m :: * -> *).
(MonadMockchain era m, IsShelleyBasedEra era) =>
m [Tx era]
getTxs
    let state0 :: MockChainState ConwayEra
state0 = NodeParams ConwayEra -> InitialUTXOs -> MockChainState ConwayEra
forall era.
IsShelleyBasedEra era =>
NodeParams era -> InitialUTXOs -> MockChainState era
initialStateFor NodeParams ConwayEra
params InitialUTXOs
Wallet.initialUTxOs
        envs :: [ThreatModelEnv]
envs = NodeParams ConwayEra
-> [Tx ConwayEra] -> MockChainState ConwayEra -> [ThreatModelEnv]
threatModelEnvs NodeParams ConwayEra
params ([Tx ConwayEra] -> [Tx ConwayEra]
forall a. [a] -> [a]
reverse [Tx ConwayEra]
allTxs) MockChainState ConwayEra
state0
    ThreatModelResults
existingResults <- case Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef of
      Just IO (IORef ThreatModelResults)
getTmRef -> IO ThreatModelResults
-> TestingMonadT (PropertyM IO) ThreatModelResults
forall a. IO a -> TestingMonadT (PropertyM IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreatModelResults
 -> TestingMonadT (PropertyM IO) ThreatModelResults)
-> IO ThreatModelResults
-> TestingMonadT (PropertyM IO) ThreatModelResults
forall a b. (a -> b) -> a -> b
$ do
        IORef ThreatModelResults
tmRef <- IO (IORef ThreatModelResults)
getTmRef
        IORef ThreatModelResults -> IO ThreatModelResults
forall a. IORef a -> IO a
readIORef IORef ThreatModelResults
tmRef
      Maybe (IO (IORef ThreatModelResults))
Nothing -> ThreatModelResults
-> TestingMonadT (PropertyM IO) ThreatModelResults
forall a. a -> TestingMonadT (PropertyM IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThreatModelResults
forall k a. Map k a
Map.empty
    let isTMFailed :: ThreatModelOutcome -> Bool
isTMFailed (TMFailed String
_) = Bool
True
        isTMFailed ThreatModelOutcome
_ = Bool
False
        alreadyFailed :: String -> Bool
alreadyFailed String
name = (ThreatModelOutcome -> Bool) -> [ThreatModelOutcome] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ThreatModelOutcome -> Bool
isTMFailed ([ThreatModelOutcome]
-> Maybe [ThreatModelOutcome] -> [ThreatModelOutcome]
forall a. a -> Maybe a -> a
fromMaybe [] (String -> ThreatModelResults -> Maybe [ThreatModelOutcome]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name ThreatModelResults
existingResults))
        tmsToRun :: [ThreatModel ()]
tmsToRun = (ThreatModel () -> Bool) -> [ThreatModel ()] -> [ThreatModel ()]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (ThreatModel () -> Bool) -> ThreatModel () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
alreadyFailed (String -> Bool)
-> (ThreatModel () -> String) -> ThreatModel () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Unnamed" (Maybe String -> String)
-> (ThreatModel () -> Maybe String) -> ThreatModel () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreatModel () -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName) [ThreatModel ()]
tms
        allToRun :: [ThreatModel ()]
allToRun = [ThreatModel ()]
tmsToRun [ThreatModel ()] -> [ThreatModel ()] -> [ThreatModel ()]
forall a. Semigroup a => a -> a -> a
<> [ThreatModel ()]
evs
    [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
  CoverageData)]
tmResultsWithCov <- IO
  [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
    CoverageData)]
-> TestingMonadT
     (PropertyM IO)
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
forall a. IO a -> TestingMonadT (PropertyM IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
     CoverageData)]
 -> TestingMonadT
      (PropertyM IO)
      [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
        CoverageData)])
-> IO
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
-> TestingMonadT
     (PropertyM IO)
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
forall a b. (a -> b) -> a -> b
$ [ThreatModel ()]
-> (ThreatModel ()
    -> IO
         (String, ThreatModelOutcome, [ThreatModelCheckEntry],
          CoverageData))
-> IO
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ThreatModel ()]
allToRun ((ThreatModel ()
  -> IO
       (String, ThreatModelOutcome, [ThreatModelCheckEntry],
        CoverageData))
 -> IO
      [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
        CoverageData)])
-> (ThreatModel ()
    -> IO
         (String, ThreatModelOutcome, [ThreatModelCheckEntry],
          CoverageData))
-> IO
     [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
       CoverageData)]
forall a b. (a -> b) -> a -> b
$ \ThreatModel ()
tm -> do
      let name :: String
name = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Unnamed" (ThreatModel () -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName ThreatModel ()
tm)
      ((ThreatModelOutcome
outcome, [ThreatModelCheckEntry]
traceEntries), MockChainState ConwayEra
tmFinalState) <-
        MockchainIO ConwayEra (ThreatModelOutcome, [ThreatModelCheckEntry])
-> NodeParams ConwayEra
-> MockChainState ConwayEra
-> IO
     ((ThreatModelOutcome, [ThreatModelCheckEntry]),
      MockChainState ConwayEra)
forall era a.
MockchainIO era a
-> NodeParams era
-> MockChainState era
-> IO (a, MockChainState era)
runMockchainIO (SigningWallet
-> ThreatModel ()
-> [ThreatModelEnv]
-> MockchainIO
     ConwayEra (ThreatModelOutcome, [ThreatModelCheckEntry])
forall (m :: * -> *) a.
(MonadMockchain ConwayEra m, MonadFail m, MonadIO m) =>
SigningWallet
-> ThreatModel a
-> [ThreatModelEnv]
-> m (ThreatModelOutcome, [ThreatModelCheckEntry])
runThreatModelCheckTraced SigningWallet
AutoSign ThreatModel ()
tm [ThreatModelEnv]
envs) NodeParams ConwayEra
params MockChainState ConwayEra
state0
      (String, ThreatModelOutcome, [ThreatModelCheckEntry], CoverageData)
-> IO
     (String, ThreatModelOutcome, [ThreatModelCheckEntry], CoverageData)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
name, ThreatModelOutcome
outcome, [ThreatModelCheckEntry]
traceEntries, MockChainState ConwayEra -> CoverageData
forall era. MockChainState era -> CoverageData
mcsCoverageData MockChainState ConwayEra
tmFinalState)

    let tmResults :: [(String, ThreatModelOutcome)]
tmResults = [(String
n, ThreatModelOutcome
o) | (String
n, ThreatModelOutcome
o, [ThreatModelCheckEntry]
_, CoverageData
_) <- [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
  CoverageData)]
tmResultsWithCov]
        tmCoverage :: CoverageData
tmCoverage = [CoverageData] -> CoverageData
forall a. Monoid a => [a] -> a
mconcat [CoverageData
cov | (String
_, ThreatModelOutcome
_, [ThreatModelCheckEntry]
_, CoverageData
cov) <- [(String, ThreatModelOutcome, [ThreatModelCheckEntry],
  CoverageData)]
tmResultsWithCov]

    (state, [(String, ThreatModelOutcome)], CoverageData)
-> TestingMonadT
     (PropertyM IO)
     (state, [(String, ThreatModelOutcome)], CoverageData)
forall a. a -> TestingMonadT (PropertyM IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (state
finalState, [(String, ThreatModelOutcome)]
tmResults, CoverageData
tmCoverage)

  case (Either
   (BalanceTxError ConwayEra)
   (state, [(String, ThreatModelOutcome)], CoverageData),
 MockChainState ConwayEra)
result of
    (Left BalanceTxError ConwayEra
err, MockChainState{mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData = CoverageData
covData}) -> do
      Maybe (IORef CoverageData)
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ())
-> (IORef CoverageData -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IO () -> PropertyM IO ()
forall a. IO a -> PropertyM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> (CoverageData
covData CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> BalanceTxError ConwayEra -> CoverageData
forall e. BalanceTxError e -> CoverageData
coverageFromBalanceTxError BalanceTxError ConwayEra
err))
      Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)
    (Right (state
finalState, [(String, ThreatModelOutcome)]
tmResults, CoverageData
tmCoverage), MockChainState{mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData = CoverageData
covData}) -> do
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Final state: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ state -> String
forall a. Show a => a -> String
show state
finalState)
      (IORef CoverageData -> PropertyM IO ())
-> Maybe (IORef CoverageData) -> PropertyM IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\IORef CoverageData
ref -> IO () -> PropertyM IO ()
forall a. IO a -> PropertyM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> CoverageData
covData CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> CoverageData
tmCoverage)) Maybe (IORef CoverageData)
coverageRef
      case Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef of
        Just IO (IORef ThreatModelResults)
getTmResultsRef -> IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ do
          IORef ThreatModelResults
tmRef <- IO (IORef ThreatModelResults)
getTmResultsRef
          IORef ThreatModelResults
-> (ThreatModelResults -> ThreatModelResults) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ThreatModelResults
tmRef ((ThreatModelResults -> ThreatModelResults) -> IO ())
-> (ThreatModelResults -> ThreatModelResults) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ThreatModelResults
existing ->
            (ThreatModelResults
 -> (String, ThreatModelOutcome) -> ThreatModelResults)
-> ThreatModelResults
-> [(String, ThreatModelOutcome)]
-> ThreatModelResults
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
              (\ThreatModelResults
m (String
name, ThreatModelOutcome
outcome) -> ([ThreatModelOutcome]
 -> [ThreatModelOutcome] -> [ThreatModelOutcome])
-> String
-> [ThreatModelOutcome]
-> ThreatModelResults
-> ThreatModelResults
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [ThreatModelOutcome]
-> [ThreatModelOutcome] -> [ThreatModelOutcome]
forall a. Semigroup a => a -> a -> a
(<>) String
name [ThreatModelOutcome
outcome] ThreatModelResults
m)
              ThreatModelResults
existing
              [(String, ThreatModelOutcome)]
tmResults
        Maybe (IO (IORef ThreatModelResults))
Nothing -> () -> PropertyM IO ()
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)

-- | Create a test case for displaying threat model results
threatModelTestCase
  :: IO (IORef ThreatModelResults)
  -> String
  -- ^ Tasty group name (for keying summaries)
  -> Int
  -- ^ Index for fallback naming
  -> ThreatModel ()
  -- ^ The threat model
  -> TestTree
threatModelTestCase :: IO (IORef ThreatModelResults)
-> String -> Int -> ThreatModel () -> TestTree
threatModelTestCase IO (IORef ThreatModelResults)
getTmResultsRef String
groupName Int
idx ThreatModel ()
tm =
  let name :: String
name = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String
"Threat model " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
idx) (ThreatModel () -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName ThreatModel ()
tm)
      key :: String
key = String
groupName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
   in (TMRecorder -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((TMRecorder -> TestTree) -> TestTree)
-> (TMRecorder -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(TMRecorder
recorder :: TMRecorder) ->
        String -> ((String -> IO ()) -> IO ()) -> TestTree
testCaseSteps String
name (((String -> IO ()) -> IO ()) -> TestTree)
-> ((String -> IO ()) -> IO ()) -> TestTree
forall a b. (a -> b) -> a -> b
$ \String -> IO ()
step -> do
          IORef ThreatModelResults
tmRef <- IO (IORef ThreatModelResults)
getTmResultsRef
          ThreatModelResults
allResults <- IORef ThreatModelResults -> IO ThreatModelResults
forall a. IORef a -> IO a
readIORef IORef ThreatModelResults
tmRef
          let outcomes :: [ThreatModelOutcome]
outcomes = [ThreatModelOutcome]
-> Maybe [ThreatModelOutcome] -> [ThreatModelOutcome]
forall a. a -> Maybe a -> a
fromMaybe [] (String -> ThreatModelResults -> Maybe [ThreatModelOutcome]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name ThreatModelResults
allResults)
              total :: Int
total = [ThreatModelOutcome] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ThreatModelOutcome]
outcomes
              numPassed :: Int
numPassed = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | ThreatModelOutcome
TMPassed <- [ThreatModelOutcome]
outcomes]
              numFailed :: Int
numFailed = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | TMFailed String
_ <- [ThreatModelOutcome]
outcomes]
              numSkipped :: Int
numSkipped = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | ThreatModelOutcome
TMSkipped <- [ThreatModelOutcome]
outcomes]
              numErrors :: Int
numErrors = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | TMError String
_ <- [ThreatModelOutcome]
outcomes]
              errors :: [String]
errors = [String
msg | TMError String
msg <- [ThreatModelOutcome]
outcomes]
              tested :: Int
tested = Int
numPassed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numFailed
              summary :: ThreatModelSummary
summary =
                ThreatModelSummary
                  { tmsName :: Text
tmsName = String -> Text
T.pack String
name
                  , tmsTested :: Int
tmsTested = Int
tested
                  , tmsTotal :: Int
tmsTotal = Int
total
                  , tmsPassed :: Int
tmsPassed = Int
numPassed
                  , tmsFailed :: Int
tmsFailed = Int
numFailed
                  , tmsSkipped :: Int
tmsSkipped = Int
numSkipped
                  , tmsErrors :: Int
tmsErrors = Int
numErrors
                  }

          -- Report errors as warnings (don't fail the test)
          case [String]
errors of
            [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            [String]
_ -> do
              String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numErrors String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" error(s) during threat model execution"
              (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
step (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
3 [String]
errors)
              case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
3 [String]
errors of
                [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                [String]
remaining -> String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  ... and " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
remaining) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" more"

          if Int
total Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
            then do
              String -> IO ()
step String
"No transactions were generated by positive tests"
              TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary
            else
              if Int
numSkipped Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numErrors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
total
                then do
                  String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String
"SKIPPED: Precondition never met (0/"
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
total
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" transactions applicable)"
                  TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary
                else do
                  String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String
"Tested "
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numPassed
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/"
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
total
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" transactions ("
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numSkipped
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" skipped, "
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numErrors
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" errors)"
                  TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary
                  case [String
msg | TMFailed String
msg <- [ThreatModelOutcome]
outcomes] of
                    [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    (String
firstFailure : [String]
rest) ->
                      String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                        [String] -> String
unlines
                          [ String
"FAILED (after " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
numPassed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" tests): Vulnerability detected"
                          , String
""
                          , String
firstFailure
                          , if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
rest
                              then String
""
                              else String
"... and " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
rest) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" more similar failure(s) suppressed"
                          ]

{- | Create a test case for expected vulnerabilities with inverted pass/fail semantics.
TMFailed = GOOD (vulnerability was correctly detected)
TMPassed = BAD (vulnerability was NOT found when expected)
TMError = WARNING (threat model crashed, doesn't count as found or not found)
Output is quiet — no verbose transaction dump details, just stats.
-}
expectedVulnTestCase
  :: IO (IORef ThreatModelResults)
  -> String
  -- ^ Tasty group name (for keying summaries)
  -> Int
  -- ^ Index for fallback naming
  -> ThreatModel ()
  -- ^ The threat model expected to find vulnerabilities
  -> TestTree
expectedVulnTestCase :: IO (IORef ThreatModelResults)
-> String -> Int -> ThreatModel () -> TestTree
expectedVulnTestCase IO (IORef ThreatModelResults)
getTmResultsRef String
groupName Int
idx ThreatModel ()
tm =
  let name :: String
name = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String
"Expected vulnerability " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
idx) (ThreatModel () -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName ThreatModel ()
tm)
      key :: String
key = String
groupName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
   in (TMRecorder -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((TMRecorder -> TestTree) -> TestTree)
-> (TMRecorder -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(TMRecorder
recorder :: TMRecorder) ->
        String -> ((String -> IO ()) -> IO ()) -> TestTree
testCaseSteps String
name (((String -> IO ()) -> IO ()) -> TestTree)
-> ((String -> IO ()) -> IO ()) -> TestTree
forall a b. (a -> b) -> a -> b
$ \String -> IO ()
step -> do
          IORef ThreatModelResults
tmRef <- IO (IORef ThreatModelResults)
getTmResultsRef
          ThreatModelResults
allResults <- IORef ThreatModelResults -> IO ThreatModelResults
forall a. IORef a -> IO a
readIORef IORef ThreatModelResults
tmRef
          let outcomes :: [ThreatModelOutcome]
outcomes = [ThreatModelOutcome]
-> Maybe [ThreatModelOutcome] -> [ThreatModelOutcome]
forall a. a -> Maybe a -> a
fromMaybe [] (String -> ThreatModelResults -> Maybe [ThreatModelOutcome]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name ThreatModelResults
allResults)
              total :: Int
total = [ThreatModelOutcome] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ThreatModelOutcome]
outcomes
              -- In expected vulnerability context:
              -- TMFailed = vulnerability detected = GOOD
              -- TMPassed = no vulnerability found = BAD
              -- TMError = crashed, doesn't count either way
              numFound :: Int
numFound = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | TMFailed String
_ <- [ThreatModelOutcome]
outcomes] -- Good: vulnerability detected
              numNotFound :: Int
numNotFound = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | ThreatModelOutcome
TMPassed <- [ThreatModelOutcome]
outcomes] -- Bad: expected vuln not found
              numSkipped :: Int
numSkipped = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | ThreatModelOutcome
TMSkipped <- [ThreatModelOutcome]
outcomes]
              numErrors :: Int
numErrors = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | TMError String
_ <- [ThreatModelOutcome]
outcomes]
              errors :: [String]
errors = [String
msg | TMError String
msg <- [ThreatModelOutcome]
outcomes]
              tested :: Int
tested = Int
numFound Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numNotFound
              summary :: ThreatModelSummary
summary =
                ThreatModelSummary
                  { tmsName :: Text
tmsName = String -> Text
T.pack String
name
                  , tmsTested :: Int
tmsTested = Int
tested
                  , tmsTotal :: Int
tmsTotal = Int
total
                  , tmsPassed :: Int
tmsPassed = Int
numNotFound -- TMPassed count
                  , tmsFailed :: Int
tmsFailed = Int
numFound -- TMFailed count
                  , tmsSkipped :: Int
tmsSkipped = Int
numSkipped
                  , tmsErrors :: Int
tmsErrors = Int
numErrors
                  }

          -- Report errors as warnings (don't fail the test for errors alone)
          case [String]
errors of
            [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            [String]
_ -> do
              String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numErrors String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" error(s) during threat model execution"
              (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
step (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
3 [String]
errors)
              case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
3 [String]
errors of
                [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                [String]
remaining -> String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  ... and " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
remaining) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" more"

          if Int
total Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
            then do
              String -> IO ()
step String
"No transactions were generated by positive tests"
              TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary
            else
              if Int
numSkipped Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numErrors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
total
                then do
                  String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String
"SKIPPED: Precondition never met (0/"
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
total
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" transactions applicable)"
                  TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary
                else
                  if Int
numFound Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                    then do
                      -- Good: at least one vulnerability was found
                      String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                        String
"Vulnerability detected ("
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numFound
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/"
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
tested
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" transactions, "
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numSkipped
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" skipped, "
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numErrors
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" errors)"
                      TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary
                    else
                      if Int
tested Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                        then do
                          -- Bad: transactions were tested but no vulnerability found
                          TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary
                          String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String
"Expected vulnerability NOT found in "
                              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
tested
                              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" tested transactions"
                        else do
                          -- Edge case: all were skipped/errored (same as numSkipped + numErrors == total, but defensive)
                          String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String
"SKIPPED: Precondition never met (0/"
                              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
total
                              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" transactions applicable)"
                          TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary

-- | Generate a number of actions (with a given maximum) and run them.
runActions
  :: (TestingInterface state, MonadIO m)
  => RunOptions
  -> Int
  -> state
  -> TestingMonadT (PropertyM m) state
runActions :: forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> Int -> state -> TestingMonadT (PropertyM m) state
runActions RunOptions
_ Int
0 state
s = state -> TestingMonadT (PropertyM m) state
forall a. a -> TestingMonadT (PropertyM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure state
s
runActions RunOptions
opts Int
i state
s = do
  Maybe (Action state)
mAction <- PropertyM m (Maybe (Action state))
-> TestingMonadT (PropertyM m) (Maybe (Action state))
forall (m :: * -> *) a. Monad m => m a -> TestingMonadT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PropertyM m (Maybe (Action state))
 -> TestingMonadT (PropertyM m) (Maybe (Action state)))
-> PropertyM m (Maybe (Action state))
-> TestingMonadT (PropertyM m) (Maybe (Action state))
forall a b. (a -> b) -> a -> b
$ state -> PropertyM m (Maybe (Action state))
forall state (m :: * -> *).
(TestingInterface state, Monad m) =>
state -> PropertyM m (Maybe (Action state))
genAction state
s
  case Maybe (Action state)
mAction of
    Just Action state
action -> RunOptions
-> state -> Action state -> TestingMonadT (PropertyM m) state
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions
-> state -> Action state -> TestingMonadT (PropertyM m) state
runAction RunOptions
opts state
s Action state
action TestingMonadT (PropertyM m) state
-> (state -> TestingMonadT (PropertyM m) state)
-> TestingMonadT (PropertyM m) state
forall a b.
TestingMonadT (PropertyM m) a
-> (a -> TestingMonadT (PropertyM m) b)
-> TestingMonadT (PropertyM m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RunOptions -> Int -> state -> TestingMonadT (PropertyM m) state
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> Int -> state -> TestingMonadT (PropertyM m) state
runActions RunOptions
opts (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Maybe (Action state)
Nothing -> state -> TestingMonadT (PropertyM m) state
forall a. a -> TestingMonadT (PropertyM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure state
s

-- | Execute a single action and update the model state
runAction
  :: (TestingInterface state, MonadIO m)
  => RunOptions
  -> state
  -> Action state
  -> TestingMonadT (PropertyM m) state
runAction :: forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions
-> state -> Action state -> TestingMonadT (PropertyM m) state
runAction RunOptions
opts state
modelState Action state
action = do
  Bool
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RunOptions -> Bool
verbose RunOptions
opts) (TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ())
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall a b. (a -> b) -> a -> b
$
    IO () -> TestingMonadT (PropertyM m) ()
forall a. IO a -> TestingMonadT (PropertyM m) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TestingMonadT (PropertyM m) ())
-> IO () -> TestingMonadT (PropertyM m) ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Performing: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Action state -> String
forall a. Show a => a -> String
show Action state
action

  -- Check precondition
  Bool
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (state -> Action state -> Bool
forall state.
TestingInterface state =>
state -> Action state -> Bool
precondition state
modelState Action state
action) (TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ())
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall a b. (a -> b) -> a -> b
$
    String -> TestingMonadT (PropertyM m) ()
forall a. String -> TestingMonadT (PropertyM m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TestingMonadT (PropertyM m) ())
-> String -> TestingMonadT (PropertyM m) ()
forall a b. (a -> b) -> a -> b
$
      String
"Precondition failed for action: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Action state -> String
forall a. Show a => a -> String
show Action state
action

  -- Perform the action on the blockchain
  state
modelState' <- state -> Action state -> TestingMonadT (PropertyM m) state
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
state -> Action state -> TestingMonadT m state
forall (m :: * -> *).
MonadIO m =>
state -> Action state -> TestingMonadT m state
perform state
modelState Action state
action

  -- Validate blockchain state matches model
  Bool
valid <- state -> TestingMonadT (PropertyM m) Bool
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
state -> TestingMonadT m Bool
forall (m :: * -> *). MonadIO m => state -> TestingMonadT m Bool
validate state
modelState'
  Bool
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
valid (TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ())
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall a b. (a -> b) -> a -> b
$
    String -> TestingMonadT (PropertyM m) ()
forall a. String -> TestingMonadT (PropertyM m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Blockchain state does not match model state"

  PropertyM m () -> TestingMonadT (PropertyM m) ()
forall (m :: * -> *) a. Monad m => m a -> TestingMonadT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PropertyM m () -> TestingMonadT (PropertyM m) ())
-> PropertyM m () -> TestingMonadT (PropertyM m) ()
forall a b. (a -> b) -> a -> b
$ (Property -> Property) -> PropertyM m ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (state -> Action state -> Property -> Property
forall state.
TestingInterface state =>
state -> Action state -> Property -> Property
monitoring state
modelState' Action state
action)

  state -> TestingMonadT (PropertyM m) state
forall a. a -> TestingMonadT (PropertyM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure state
modelState'

{- | Like 'runActions' but accumulates a trace of each transition.
The trace captures the model state before\/after each action and
a summary of the transaction produced. If an action fails (via
@ExceptT@ or @MonadFail@), the monad short-circuits and the
partial trace is lost — use the 'IORef' variant in 'positiveTest'
for partial-failure capture if needed.
-}
runActionsTraced
  :: (TestingInterface state, MonadIO m)
  => RunOptions
  -> Int
  -> state
  -> TestingMonadT (PropertyM m) (state, [Transition])
runActionsTraced :: forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions
-> Int
-> state
-> TestingMonadT (PropertyM m) (state, [Transition])
runActionsTraced RunOptions
opts Int
maxSteps state
initialState = Int
-> state
-> [Transition]
-> TestingMonadT (PropertyM m) (state, [Transition])
go Int
0 state
initialState []
 where
  go :: Int
-> state
-> [Transition]
-> TestingMonadT (PropertyM m) (state, [Transition])
go Int
stepIdx state
state [Transition]
acc
    | Int
stepIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxSteps = (state, [Transition])
-> TestingMonadT (PropertyM m) (state, [Transition])
forall a. a -> TestingMonadT (PropertyM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (state
state, [Transition] -> [Transition]
forall a. [a] -> [a]
reverse [Transition]
acc)
    | Bool
otherwise = do
        Maybe (Action state)
mAction <- PropertyM m (Maybe (Action state))
-> TestingMonadT (PropertyM m) (Maybe (Action state))
forall (m :: * -> *) a. Monad m => m a -> TestingMonadT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PropertyM m (Maybe (Action state))
 -> TestingMonadT (PropertyM m) (Maybe (Action state)))
-> PropertyM m (Maybe (Action state))
-> TestingMonadT (PropertyM m) (Maybe (Action state))
forall a b. (a -> b) -> a -> b
$ state -> PropertyM m (Maybe (Action state))
forall state (m :: * -> *).
(TestingInterface state, Monad m) =>
state -> PropertyM m (Maybe (Action state))
genAction state
state
        case Maybe (Action state)
mAction of
          Maybe (Action state)
Nothing -> (state, [Transition])
-> TestingMonadT (PropertyM m) (state, [Transition])
forall a. a -> TestingMonadT (PropertyM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (state
state, [Transition] -> [Transition]
forall a. [a] -> [a]
reverse [Transition]
acc)
          Just Action state
action -> do
            let stateBefore :: Value
stateBefore = state -> Value
forall a. ToJSON a => a -> Value
toJSON state
state
                actionText :: Text
actionText = String -> Text
T.pack (Action state -> String
forall a. Show a => a -> String
show Action state
action)
            -- Snapshot the UTxO and txById map before running the action
            UTxO ConwayEra
utxoBefore <- ShelleyBasedEra ConwayEra -> UTxO ConwayEra -> UTxO ConwayEra
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> UTxO ledgerera -> UTxO era
fromLedgerUTxO ShelleyBasedEra ConwayEra
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
C.shelleyBasedEra (UTxO ConwayEra -> UTxO ConwayEra)
-> TestingMonadT (PropertyM m) (UTxO ConwayEra)
-> TestingMonadT (PropertyM m) (UTxO ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestingMonadT (PropertyM m) (UTxO (ShelleyLedgerEra ConwayEra))
TestingMonadT (PropertyM m) (UTxO ConwayEra)
forall era (m :: * -> *).
(MonadMockchain era m, IsShelleyBasedEra era) =>
m (UTxO (ShelleyLedgerEra era))
getUtxo
            Map TxId (Tx ConwayEra)
txByIdBefore <- MockChainState ConwayEra -> Map TxId (Tx ConwayEra)
forall era. MockChainState era -> Map TxId (Tx era)
mcsTxById (MockChainState ConwayEra -> Map TxId (Tx ConwayEra))
-> TestingMonadT (PropertyM m) (MockChainState ConwayEra)
-> TestingMonadT (PropertyM m) (Map TxId (Tx ConwayEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestingMonadT (PropertyM m) (MockChainState ConwayEra)
forall era (m :: * -> *).
MonadMockchain era m =>
m (MockChainState era)
getMockChainState
            -- Run the action (may throw, short-circuiting the monad)
            state
newState <- RunOptions
-> state -> Action state -> TestingMonadT (PropertyM m) state
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions
-> state -> Action state -> TestingMonadT (PropertyM m) state
runAction RunOptions
opts state
state Action state
action
            -- If we get here, the action succeeded
            Maybe TxSummary
mTxSummary <- Map TxId (Tx ConwayEra)
-> UTxO ConwayEra -> TestingMonadT (PropertyM m) (Maybe TxSummary)
forall (m :: * -> *).
MonadMockchain ConwayEra m =>
Map TxId (Tx ConwayEra) -> UTxO ConwayEra -> m (Maybe TxSummary)
getLastTxSummary Map TxId (Tx ConwayEra)
txByIdBefore UTxO ConwayEra
utxoBefore
            let transition :: Transition
transition =
                  Transition
                    { trStepIndex :: Int
trStepIndex = Int
stepIdx
                    , trAction :: Text
trAction = Text
actionText
                    , trStateBefore :: Value
trStateBefore = Value
stateBefore
                    , trStateAfter :: Value
trStateAfter = state -> Value
forall a. ToJSON a => a -> Value
toJSON state
newState
                    , trTransaction :: Maybe TxSummary
trTransaction = Maybe TxSummary
mTxSummary
                    , trResult :: TransitionResult
trResult = Text -> TransitionResult
TransitionSuccess (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
T.empty (Maybe TxSummary
mTxSummary Maybe TxSummary -> (TxSummary -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TxSummary -> Maybe Text
txsId))
                    }
            Int
-> state
-> [Transition]
-> TestingMonadT (PropertyM m) (state, [Transition])
go (Int
stepIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) state
newState (Transition
transition Transition -> [Transition] -> [Transition]
forall a. a -> [a] -> [a]
: [Transition]
acc)

{- | Check whether a new transaction appeared in the mockchain since
the given snapshot, and if so, return a compact summary.
-}
getLastTxSummary
  :: (MonadMockchain C.ConwayEra m)
  => Map.Map C.TxId (C.Tx C.ConwayEra)
  -- ^ @mcsTxById@ snapshot taken before the action
  -> C.UTxO C.ConwayEra
  -- ^ UTxO snapshot taken before the action
  -> m (Maybe TxSummary)
getLastTxSummary :: forall (m :: * -> *).
MonadMockchain ConwayEra m =>
Map TxId (Tx ConwayEra) -> UTxO ConwayEra -> m (Maybe TxSummary)
getLastTxSummary Map TxId (Tx ConwayEra)
txByIdBefore UTxO ConwayEra
utxoBefore = do
  MockChainState ConwayEra
st <- m (MockChainState ConwayEra)
forall era (m :: * -> *).
MonadMockchain era m =>
m (MockChainState era)
getMockChainState
  let txByIdAfter :: Map TxId (Tx ConwayEra)
txByIdAfter = MockChainState ConwayEra -> Map TxId (Tx ConwayEra)
forall era. MockChainState era -> Map TxId (Tx era)
mcsTxById MockChainState ConwayEra
st
      newTxIds :: [TxId]
newTxIds = Map TxId (Tx ConwayEra) -> [TxId]
forall k a. Map k a -> [k]
Map.keys (Map TxId (Tx ConwayEra)
-> Map TxId (Tx ConwayEra) -> Map TxId (Tx ConwayEra)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map TxId (Tx ConwayEra)
txByIdAfter Map TxId (Tx ConwayEra)
txByIdBefore)
  case [TxId]
newTxIds of
    [] -> Maybe TxSummary -> m (Maybe TxSummary)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TxSummary
forall a. Maybe a
Nothing
    (TxId
txId : [TxId]
_) ->
      case TxId -> Map TxId (Tx ConwayEra) -> Maybe (Tx ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxId
txId Map TxId (Tx ConwayEra)
txByIdAfter of
        Maybe (Tx ConwayEra)
Nothing -> Maybe TxSummary -> m (Maybe TxSummary)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TxSummary
forall a. Maybe a
Nothing
        Just Tx ConwayEra
tx -> Maybe TxSummary -> m (Maybe TxSummary)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxSummary -> Maybe TxSummary
forall a. a -> Maybe a
Just (Tx ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTx Tx ConwayEra
tx UTxO ConwayEra
utxoBefore))

{- | Convert traced threat model results into 'ThreatModelTrace' values
suitable for inclusion in an 'IterationTrace'.

Each 'ThreatModelCheckEntry' (one per 'Validate' call) produces a
'ThreatModelTrace' with the actual modifications, original\/modified
transactions, and outcome.
-}
toThreatModelTraces :: [(String, ThreatModelOutcome, [ThreatModelCheckEntry])] -> [ThreatModelTrace]
toThreatModelTraces :: [(String, ThreatModelOutcome, [ThreatModelCheckEntry])]
-> [ThreatModelTrace]
toThreatModelTraces [(String, ThreatModelOutcome, [ThreatModelCheckEntry])]
results = ((String, ThreatModelOutcome, [ThreatModelCheckEntry])
 -> [ThreatModelTrace])
-> [(String, ThreatModelOutcome, [ThreatModelCheckEntry])]
-> [ThreatModelTrace]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, ThreatModelOutcome, [ThreatModelCheckEntry])
-> [ThreatModelTrace]
go [(String, ThreatModelOutcome, [ThreatModelCheckEntry])]
results
 where
  go :: (String, ThreatModelOutcome, [ThreatModelCheckEntry])
-> [ThreatModelTrace]
go (String
name, ThreatModelOutcome
outcome, []) =
    -- No Validate calls: emit a single lightweight trace with just the outcome
    [ ThreatModelTrace
        { tmtName :: Text
tmtName = String -> Text
T.pack String
name
        , tmtTargetTxIndex :: Int
tmtTargetTxIndex = Int
0
        , tmtModifications :: [Value]
tmtModifications = []
        , tmtOriginalTx :: TxSummary
tmtOriginalTx = TxSummary
emptyTxSummary
        , tmtModifiedTx :: Maybe TxSummary
tmtModifiedTx = Maybe TxSummary
forall a. Maybe a
Nothing
        , tmtOutcome :: ThreatModelTraceOutcome
tmtOutcome = ThreatModelOutcome -> ThreatModelTraceOutcome
outcomeToTrace ThreatModelOutcome
outcome
        }
    ]
  go (String
name, ThreatModelOutcome
outcome, [ThreatModelCheckEntry]
entries) =
    -- One ThreatModelTrace per Validate call
    [ ThreatModelTrace
        { tmtName :: Text
tmtName = String -> Text
T.pack String
name
        , tmtTargetTxIndex :: Int
tmtTargetTxIndex = ThreatModelCheckEntry -> Int
tmceEnvIndex ThreatModelCheckEntry
entry
        , tmtModifications :: [Value]
tmtModifications = TxModifier -> [Value]
renderModifications (ThreatModelCheckEntry -> TxModifier
tmceModifications ThreatModelCheckEntry
entry)
        , tmtOriginalTx :: TxSummary
tmtOriginalTx = Tx ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTx (ThreatModelCheckEntry -> Tx ConwayEra
tmceOriginalTx ThreatModelCheckEntry
entry) (ThreatModelCheckEntry -> UTxO ConwayEra
tmceOriginalUtxo ThreatModelCheckEntry
entry)
        , tmtModifiedTx :: Maybe TxSummary
tmtModifiedTx = case ThreatModelCheckEntry -> Maybe (Tx ConwayEra)
tmceModifiedTx ThreatModelCheckEntry
entry of
            Just Tx ConwayEra
tx -> TxSummary -> Maybe TxSummary
forall a. a -> Maybe a
Just (Tx ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTx Tx ConwayEra
tx (ThreatModelCheckEntry -> UTxO ConwayEra
tmceModifiedUtxo ThreatModelCheckEntry
entry))
            Maybe (Tx ConwayEra)
Nothing -> Maybe TxSummary
forall a. Maybe a
Nothing
        , tmtOutcome :: ThreatModelTraceOutcome
tmtOutcome = ThreatModelOutcome -> ThreatModelTraceOutcome
outcomeToTrace ThreatModelOutcome
outcome
        }
    | ThreatModelCheckEntry
entry <- [ThreatModelCheckEntry]
entries
    ]

  outcomeToTrace :: ThreatModelOutcome -> ThreatModelTraceOutcome
outcomeToTrace ThreatModelOutcome
TMPassed = ThreatModelTraceOutcome
TMTOPassed
  outcomeToTrace (TMFailed String
msg) = Text -> ThreatModelTraceOutcome
TMTOFailed (String -> Text
T.pack String
msg)
  outcomeToTrace ThreatModelOutcome
TMSkipped = Text -> ThreatModelTraceOutcome
TMTOSkipped Text
"precondition not met"
  outcomeToTrace (TMError String
msg) = Text -> ThreatModelTraceOutcome
TMTOError (String -> Text
T.pack String
msg)

  renderModifications :: TxModifier -> [Value]
renderModifications (TxModifier [TxMod]
mods) = (TxMod -> Value) -> [TxMod] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map TxMod -> Value
forall a. ToJSON a => a -> Value
toJSON [TxMod]
mods

  emptyTxSummary :: TxSummary
emptyTxSummary =
    TxSummary
      { txsId :: Maybe Text
txsId = Maybe Text
forall a. Maybe a
Nothing
      , txsInputs :: [TxInputSummary]
txsInputs = []
      , txsOutputs :: [TxOutputSummary]
txsOutputs = []
      , txsMint :: Maybe ValueSummary
txsMint = Maybe ValueSummary
forall a. Maybe a
Nothing
      , txsFee :: Integer
txsFee = Integer
0
      , txsSigners :: [Text]
txsSigners = []
      , txsValidRange :: Maybe Text
txsValidRange = Maybe Text
forall a. Maybe a
Nothing
      }

{- | Format a 'BalanceTxError' for display in trace output.
For script execution errors, extracts just the error message and
the last non-coverage log entry (typically the user's trace message),
filtering out coverage annotation noise (CoverLocation/CoverBool).
-}
formatBalanceTxError :: BalanceTxError C.ConwayEra -> T.Text
formatBalanceTxError :: BalanceTxError ConwayEra -> Text
formatBalanceTxError (ABalancingError (ScriptExecutionErr [(ScriptWitnessIndex, Text, [Text])]
errs)) =
  Text -> [Text] -> Text
T.intercalate Text
"; " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((ScriptWitnessIndex, Text, [Text]) -> Text)
-> [(ScriptWitnessIndex, Text, [Text])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ScriptWitnessIndex, Text, [Text]) -> Text
forall {a}. (a, Text, [Text]) -> Text
formatScriptErr [(ScriptWitnessIndex, Text, [Text])]
errs
 where
  formatScriptErr :: (a, Text, [Text]) -> Text
formatScriptErr (a
_witness, Text
errMsg, [Text]
logs) =
    let
      -- Filter out coverage annotation log messages
      userLogs :: [Text]
userLogs = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isCoverageAnnotation) [Text]
logs
      -- Show the last user log (most informative) alongside the error
      suffix :: Text
suffix = case [Text]
userLogs of
        [] -> Text
""
        [Text]
_ -> Text
" | " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
userLogs
     in
      Text
errMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix
  isCoverageAnnotation :: Text -> Bool
isCoverageAnnotation Text
msg =
    Text
"CoverLocation (" Text -> Text -> Bool
`T.isPrefixOf` Text
msg
      Bool -> Bool -> Bool
|| Text
"CoverBool (" Text -> Text -> Bool
`T.isPrefixOf` Text
msg
formatBalanceTxError BalanceTxError ConwayEra
err = String -> Text
T.pack (BalanceTxError ConwayEra -> String
forall a. Show a => a -> String
show BalanceTxError ConwayEra
err)

-- | Initialize the blockchain and validate the model state
runInitialization
  :: forall state m
   . (TestingInterface state, MonadIO m)
  => RunOptions
  -> TestingMonadT (PropertyM m) state
runInitialization :: forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> TestingMonadT (PropertyM m) state
runInitialization RunOptions
opts = do
  state
initialState <- forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
TestingMonadT m state
initialize @state

  Bool
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RunOptions -> Bool
verbose RunOptions
opts) (TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ())
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall a b. (a -> b) -> a -> b
$
    PropertyM m () -> TestingMonadT (PropertyM m) ()
forall (m :: * -> *) a. Monad m => m a -> TestingMonadT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PropertyM m () -> TestingMonadT (PropertyM m) ())
-> PropertyM m () -> TestingMonadT (PropertyM m) ()
forall a b. (a -> b) -> a -> b
$
      (Property -> Property) -> PropertyM m ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Initial state: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ state -> String
forall a. Show a => a -> String
show state
initialState)

  Bool
valid <- state -> TestingMonadT (PropertyM m) Bool
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
state -> TestingMonadT m Bool
forall (m :: * -> *). MonadIO m => state -> TestingMonadT m Bool
validate state
initialState
  Bool
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
valid (TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ())
-> TestingMonadT (PropertyM m) () -> TestingMonadT (PropertyM m) ()
forall a b. (a -> b) -> a -> b
$
    String -> TestingMonadT (PropertyM m) ()
forall a. String -> TestingMonadT (PropertyM m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Blockchain state does not match model state after initialization"

  state -> TestingMonadT (PropertyM m) state
forall a. a -> TestingMonadT (PropertyM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure state
initialState

{- | Configuration for coverage collection and reporting.

Use with 'withCoverage' to set up coverage tracking for your test suite.
-}
data CoverageConfig = CoverageConfig
  { CoverageConfig -> [CoverageIndex]
coverageIndices :: [CoverageIndex]
  {- ^ Coverage indices from compiled scripts (obtained via @'PlutusTx.Code.getCovIdx'@).
  Multiple indices are combined with @'<>'@.
  -}
  , CoverageConfig -> CoverageReport -> IO ()
coverageReport :: CoverageReport -> IO ()
  {- ^ Action to perform with the final coverage report.
  Use 'printCoverageReport', 'writeCoverageReport', or 'silentCoverageReport'.
  -}
  }

-- | Print a coverage report to stdout using prettyprinter.
printCoverageReport :: CoverageReport -> IO ()
printCoverageReport :: CoverageReport -> IO ()
printCoverageReport = Doc Any -> IO ()
forall a. Show a => a -> IO ()
print (Doc Any -> IO ())
-> (CoverageReport -> Doc Any) -> CoverageReport -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageReport -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. CoverageReport -> Doc ann
Pretty.pretty

-- | Write a coverage report to a file.
writeCoverageReport :: FilePath -> CoverageReport -> IO ()
writeCoverageReport :: String -> CoverageReport -> IO ()
writeCoverageReport String
fp CoverageReport
cr = do
  String -> String -> IO ()
writeFile String
fp (Doc Any -> String
forall a. Show a => a -> String
show (CoverageReport -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. CoverageReport -> Doc ann
Pretty.pretty CoverageReport
cr))
  String -> IO ()
printCoveragePath String
fp

printCoveragePath :: FilePath -> IO ()
printCoveragePath :: String -> IO ()
printCoveragePath String
fp = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Coverage report available at: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp

-- | Collect coverage data but discard the report.
silentCoverageReport :: CoverageReport -> IO ()
silentCoverageReport :: CoverageReport -> IO ()
silentCoverageReport CoverageReport
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Compact representation of a source location for JSON output.
data JsonCovLoc = JsonCovLoc
  { JsonCovLoc -> String
jclFile :: String
  , JsonCovLoc -> Int
jclStartLine :: Int
  , JsonCovLoc -> Int
jclStartCol :: Int
  , JsonCovLoc -> Int
jclEndLine :: Int
  , JsonCovLoc -> Int
jclEndCol :: Int
  }
  deriving ((forall x. JsonCovLoc -> Rep JsonCovLoc x)
-> (forall x. Rep JsonCovLoc x -> JsonCovLoc) -> Generic JsonCovLoc
forall x. Rep JsonCovLoc x -> JsonCovLoc
forall x. JsonCovLoc -> Rep JsonCovLoc x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JsonCovLoc -> Rep JsonCovLoc x
from :: forall x. JsonCovLoc -> Rep JsonCovLoc x
$cto :: forall x. Rep JsonCovLoc x -> JsonCovLoc
to :: forall x. Rep JsonCovLoc x -> JsonCovLoc
Generic)

instance ToJSON JsonCovLoc where
  toJSON :: JsonCovLoc -> Value
toJSON (JsonCovLoc String
f Int
sl Int
sc Int
el Int
ec) =
    [Pair] -> Value
Aeson.object
      [ String -> Key
Key.fromString String
"file" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
f
      , String -> Key
Key.fromString String
"startLine" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
sl
      , String -> Key
Key.fromString String
"startCol" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
sc
      , String -> Key
Key.fromString String
"endLine" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
el
      , String -> Key
Key.fromString String
"endCol" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
ec
      ]

-- | Compact representation of a coverage annotation for JSON output.
data JsonAnnotation
  = JsonLocation JsonCovLoc
  | JsonBool JsonCovLoc Bool

instance ToJSON JsonAnnotation where
  toJSON :: JsonAnnotation -> Value
toJSON (JsonLocation JsonCovLoc
loc) =
    [Pair] -> Value
Aeson.object
      [ String -> Key
Key.fromString String
"type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"location" :: String)
      , String -> Key
Key.fromString String
"loc" Key -> JsonCovLoc -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JsonCovLoc
loc
      ]
  toJSON (JsonBool JsonCovLoc
loc Bool
b) =
    [Pair] -> Value
Aeson.object
      [ String -> Key
Key.fromString String
"type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"bool" :: String)
      , String -> Key
Key.fromString String
"loc" Key -> JsonCovLoc -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JsonCovLoc
loc
      , String -> Key
Key.fromString String
"value" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
b
      ]

-- | A covered annotation with optional function name metadata.
data JsonCovered = JsonCovered
  { JsonCovered -> JsonAnnotation
jcAnnotation :: JsonAnnotation
  , JsonCovered -> [String]
jcSymbols :: [String]
  }
  deriving ((forall x. JsonCovered -> Rep JsonCovered x)
-> (forall x. Rep JsonCovered x -> JsonCovered)
-> Generic JsonCovered
forall x. Rep JsonCovered x -> JsonCovered
forall x. JsonCovered -> Rep JsonCovered x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JsonCovered -> Rep JsonCovered x
from :: forall x. JsonCovered -> Rep JsonCovered x
$cto :: forall x. Rep JsonCovered x -> JsonCovered
to :: forall x. Rep JsonCovered x -> JsonCovered
Generic)

instance ToJSON JsonCovered where
  toJSON :: JsonCovered -> Value
toJSON (JsonCovered JsonAnnotation
ann [String]
syms) =
    [Pair] -> Value
Aeson.object
      [ String -> Key
Key.fromString String
"annotation" Key -> JsonAnnotation -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JsonAnnotation
ann
      , String -> Key
Key.fromString String
"symbols" Key -> [String] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [String]
syms
      ]

-- | Minimal coverage summary matching what Pretty.pretty shows.
data CoverageSummary = CoverageSummary
  { CoverageSummary -> [JsonCovered]
csCovered :: [JsonCovered]
  , CoverageSummary -> [JsonAnnotation]
csUncovered :: [JsonAnnotation]
  , CoverageSummary -> [JsonAnnotation]
csIgnored :: [JsonAnnotation]
  }
  deriving ((forall x. CoverageSummary -> Rep CoverageSummary x)
-> (forall x. Rep CoverageSummary x -> CoverageSummary)
-> Generic CoverageSummary
forall x. Rep CoverageSummary x -> CoverageSummary
forall x. CoverageSummary -> Rep CoverageSummary x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CoverageSummary -> Rep CoverageSummary x
from :: forall x. CoverageSummary -> Rep CoverageSummary x
$cto :: forall x. Rep CoverageSummary x -> CoverageSummary
to :: forall x. Rep CoverageSummary x -> CoverageSummary
Generic)

instance ToJSON CoverageSummary where
  toJSON :: CoverageSummary -> Value
toJSON (CoverageSummary [JsonCovered]
cov [JsonAnnotation]
uncov [JsonAnnotation]
ign) =
    [Pair] -> Value
Aeson.object
      [ String -> Key
Key.fromString String
"covered" Key -> [JsonCovered] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [JsonCovered]
cov
      , String -> Key
Key.fromString String
"uncovered" Key -> [JsonAnnotation] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [JsonAnnotation]
uncov
      , String -> Key
Key.fromString String
"ignored" Key -> [JsonAnnotation] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [JsonAnnotation]
ign
      ]

-- | Convert a CovLoc to compact JSON representation.
toJsonCovLoc :: CovLoc -> JsonCovLoc
toJsonCovLoc :: CovLoc -> JsonCovLoc
toJsonCovLoc (CovLoc String
f Int
sl Int
el Int
sc Int
ec) = String -> Int -> Int -> Int -> Int -> JsonCovLoc
JsonCovLoc String
f Int
sl Int
sc Int
el Int
ec

-- | Convert a CoverageAnnotation to compact JSON representation.
toJsonAnnotation :: CoverageAnnotation -> JsonAnnotation
toJsonAnnotation :: CoverageAnnotation -> JsonAnnotation
toJsonAnnotation (CoverLocation CovLoc
loc) = JsonCovLoc -> JsonAnnotation
JsonLocation (CovLoc -> JsonCovLoc
toJsonCovLoc CovLoc
loc)
toJsonAnnotation (CoverBool CovLoc
loc Bool
b) = JsonCovLoc -> Bool -> JsonAnnotation
JsonBool (CovLoc -> JsonCovLoc
toJsonCovLoc CovLoc
loc) Bool
b

-- | Extract symbol names from Metadata.
extractSymbols :: Set.Set Metadata -> [String]
extractSymbols :: Set Metadata -> [String]
extractSymbols = (Metadata -> [String] -> [String])
-> [String] -> Set Metadata -> [String]
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Metadata -> [String] -> [String]
go []
 where
  go :: Metadata -> [String] -> [String]
go (ApplicationHeadSymbol String
s) [String]
acc = String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc
  go Metadata
IgnoredAnnotation [String]
acc = [String]
acc

-- | Convert a CoverageReport to a compact summary (same info as Pretty.pretty shows).
coverageSummary :: CoverageReport -> CoverageSummary
coverageSummary :: CoverageReport -> CoverageSummary
coverageSummary (CoverageReport CoverageIndex
idx CoverageData
covData) =
  CoverageSummary
    { csCovered :: [JsonCovered]
csCovered =
        [ JsonAnnotation -> [String] -> JsonCovered
JsonCovered (CoverageAnnotation -> JsonAnnotation
toJsonAnnotation CoverageAnnotation
ann) (Set Metadata -> [String]
extractSymbols (Set Metadata -> [String]) -> Set Metadata -> [String]
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation -> Set Metadata
metadataFor CoverageAnnotation
ann)
        | CoverageAnnotation
ann <- Set CoverageAnnotation -> [CoverageAnnotation]
forall a. Set a -> [a]
Set.toList (Set CoverageAnnotation -> [CoverageAnnotation])
-> Set CoverageAnnotation -> [CoverageAnnotation]
forall a b. (a -> b) -> a -> b
$ Set CoverageAnnotation
allAnns Set CoverageAnnotation
-> Set CoverageAnnotation -> Set CoverageAnnotation
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set CoverageAnnotation
coveredAnns'
        ]
    , csUncovered :: [JsonAnnotation]
csUncovered = (CoverageAnnotation -> JsonAnnotation)
-> [CoverageAnnotation] -> [JsonAnnotation]
forall a b. (a -> b) -> [a] -> [b]
map CoverageAnnotation -> JsonAnnotation
toJsonAnnotation ([CoverageAnnotation] -> [JsonAnnotation])
-> (Set CoverageAnnotation -> [CoverageAnnotation])
-> Set CoverageAnnotation
-> [JsonAnnotation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set CoverageAnnotation -> [CoverageAnnotation]
forall a. Set a -> [a]
Set.toList (Set CoverageAnnotation -> [JsonAnnotation])
-> Set CoverageAnnotation -> [JsonAnnotation]
forall a b. (a -> b) -> a -> b
$ Set CoverageAnnotation
uncoveredAnns
    , csIgnored :: [JsonAnnotation]
csIgnored = (CoverageAnnotation -> JsonAnnotation)
-> [CoverageAnnotation] -> [JsonAnnotation]
forall a b. (a -> b) -> [a] -> [b]
map CoverageAnnotation -> JsonAnnotation
toJsonAnnotation ([CoverageAnnotation] -> [JsonAnnotation])
-> (Set CoverageAnnotation -> [CoverageAnnotation])
-> Set CoverageAnnotation
-> [JsonAnnotation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set CoverageAnnotation -> [CoverageAnnotation]
forall a. Set a -> [a]
Set.toList (Set CoverageAnnotation -> [JsonAnnotation])
-> Set CoverageAnnotation -> [JsonAnnotation]
forall a b. (a -> b) -> a -> b
$ Set CoverageAnnotation
ignoredAnns' Set CoverageAnnotation
-> Set CoverageAnnotation -> Set CoverageAnnotation
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set CoverageAnnotation
coveredAnns'
    }
 where
  allAnns :: Set CoverageAnnotation
allAnns = CoverageIndex
idx CoverageIndex
-> Getting
     (Set CoverageAnnotation) CoverageIndex (Set CoverageAnnotation)
-> Set CoverageAnnotation
forall s a. s -> Getting a s a -> a
^. Getting
  (Set CoverageAnnotation) CoverageIndex (Set CoverageAnnotation)
Getter CoverageIndex (Set CoverageAnnotation)
coverageAnnotations
  coveredAnns' :: Set CoverageAnnotation
coveredAnns' = CoverageData
covData CoverageData
-> Getting
     (Set CoverageAnnotation) CoverageData (Set CoverageAnnotation)
-> Set CoverageAnnotation
forall s a. s -> Getting a s a -> a
^. Getting
  (Set CoverageAnnotation) CoverageData (Set CoverageAnnotation)
Iso' CoverageData (Set CoverageAnnotation)
coveredAnnotations
  ignoredAnns' :: Set CoverageAnnotation
ignoredAnns' = CoverageIndex
idx CoverageIndex
-> Getting
     (Set CoverageAnnotation) CoverageIndex (Set CoverageAnnotation)
-> Set CoverageAnnotation
forall s a. s -> Getting a s a -> a
^. Getting
  (Set CoverageAnnotation) CoverageIndex (Set CoverageAnnotation)
Getter CoverageIndex (Set CoverageAnnotation)
ignoredAnnotations
  uncoveredAnns :: Set CoverageAnnotation
uncoveredAnns = Set CoverageAnnotation
allAnns Set CoverageAnnotation
-> Set CoverageAnnotation -> Set CoverageAnnotation
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ (Set CoverageAnnotation
coveredAnns' Set CoverageAnnotation
-> Set CoverageAnnotation -> Set CoverageAnnotation
forall a. Semigroup a => a -> a -> a
<> Set CoverageAnnotation
ignoredAnns')
  metadataFor :: CoverageAnnotation -> Set Metadata
metadataFor CoverageAnnotation
ann = Set Metadata
-> (CoverageMetadata -> Set Metadata)
-> Maybe CoverageMetadata
-> Set Metadata
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Metadata
forall a. Set a
Set.empty CoverageMetadata -> Set Metadata
_metadataSet (Maybe CoverageMetadata -> Set Metadata)
-> Maybe CoverageMetadata -> Set Metadata
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation
-> Map CoverageAnnotation CoverageMetadata
-> Maybe CoverageMetadata
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CoverageAnnotation
ann (CoverageIndex
idx CoverageIndex
-> Getting
     (Map CoverageAnnotation CoverageMetadata)
     CoverageIndex
     (Map CoverageAnnotation CoverageMetadata)
-> Map CoverageAnnotation CoverageMetadata
forall s a. s -> Getting a s a -> a
^. Getting
  (Map CoverageAnnotation CoverageMetadata)
  CoverageIndex
  (Map CoverageAnnotation CoverageMetadata)
Iso' CoverageIndex (Map CoverageAnnotation CoverageMetadata)
coverageMetadata)

-- | Print a coverage report as compact JSON to stdout.
printCoverageJSON :: CoverageReport -> IO ()
printCoverageJSON :: CoverageReport -> IO ()
printCoverageJSON = ByteString -> IO ()
LBS.putStrLn (ByteString -> IO ())
-> (CoverageReport -> ByteString) -> CoverageReport -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageSummary -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (CoverageSummary -> ByteString)
-> (CoverageReport -> CoverageSummary)
-> CoverageReport
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageReport -> CoverageSummary
coverageSummary

-- | Write a coverage report as compact JSON to a file.
writeCoverageJSON :: FilePath -> CoverageReport -> IO ()
writeCoverageJSON :: String -> CoverageReport -> IO ()
writeCoverageJSON String
fp CoverageReport
report = do
  String -> ByteString -> IO ()
LBS.writeFile String
fp (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ CoverageSummary -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (CoverageSummary -> ByteString) -> CoverageSummary -> ByteString
forall a b. (a -> b) -> a -> b
$ CoverageReport -> CoverageSummary
coverageSummary CoverageReport
report
  String -> IO ()
printCoveragePath String
fp

-- | Print a coverage report as pretty-printed JSON to stdout.
printCoverageJSONPretty :: CoverageReport -> IO ()
printCoverageJSONPretty :: CoverageReport -> IO ()
printCoverageJSONPretty = ByteString -> IO ()
LBS.putStrLn (ByteString -> IO ())
-> (CoverageReport -> ByteString) -> CoverageReport -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageSummary -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty (CoverageSummary -> ByteString)
-> (CoverageReport -> CoverageSummary)
-> CoverageReport
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageReport -> CoverageSummary
coverageSummary

-- | Write a coverage report as pretty-printed JSON to a file.
writeCoverageJSONPretty :: FilePath -> CoverageReport -> IO ()
writeCoverageJSONPretty :: String -> CoverageReport -> IO ()
writeCoverageJSONPretty String
fp CoverageReport
report = do
  String -> ByteString -> IO ()
LBS.writeFile String
fp (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ CoverageSummary -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty (CoverageSummary -> ByteString) -> CoverageSummary -> ByteString
forall a b. (a -> b) -> a -> b
$ CoverageReport -> CoverageSummary
coverageSummary CoverageReport
report
  String -> IO ()
printCoveragePath String
fp

{- | Run a test suite with Plutus script coverage collection.

Creates the coverage 'IORef', wires it into 'Options' and 'RunOptions',
runs the user's action, and on exit produces a 'CoverageReport' from the
accumulated data.

The report is generated when the inner action throws an 'ExitCode' exception
(which is how @tasty@'s 'Test.Tasty.defaultMain' signals completion). The
original exception is re-thrown after the report action runs.

@
main :: IO ()
main = withCoverage config $ \\opts runOpts ->
  defaultMain $ testGroup \"my tests\"
    [ testCase \"t1\" (mockchainSucceedsWithOptions opts myTest)
    , myPropertyTests runOpts
    ]
 where
  config = CoverageConfig
    { coverageIndices = [myScriptCovIdx]
    , coverageReport  = printCoverageReport
    }
@
-}
withCoverage
  :: CoverageConfig
  -> (Options C.ConwayEra -> RunOptions -> IO ())
  -> IO ()
withCoverage :: CoverageConfig
-> (Options ConwayEra -> RunOptions -> IO ()) -> IO ()
withCoverage CoverageConfig{[CoverageIndex]
coverageIndices :: CoverageConfig -> [CoverageIndex]
coverageIndices :: [CoverageIndex]
coverageIndices, coverageReport :: CoverageConfig -> CoverageReport -> IO ()
coverageReport = CoverageReport -> IO ()
reportAction} Options ConwayEra -> RunOptions -> IO ()
k = do
  IORef CoverageData
ref <- CoverageData -> IO (IORef CoverageData)
forall a. a -> IO (IORef a)
newIORef CoverageData
forall a. Monoid a => a
mempty
  let opts :: Options ConwayEra
opts = Options ConwayEra
defaultOptions{coverageRef = Just ref}
      runOpts :: RunOptions
runOpts = RunOptions
defaultRunOptions{mcOptions = opts}
  Options ConwayEra -> RunOptions -> IO ()
k Options ConwayEra
opts RunOptions
runOpts
    IO () -> (ExitCode -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(ExitCode
e :: ExitCode) -> do
      CoverageData
covData <- IORef CoverageData -> IO CoverageData
forall a. IORef a -> IO a
readIORef IORef CoverageData
ref
      let combinedIdx :: CoverageIndex
combinedIdx = [CoverageIndex] -> CoverageIndex
forall a. Monoid a => [a] -> a
mconcat [CoverageIndex]
coverageIndices
          report :: CoverageReport
report = CoverageIndex -> CoverageData -> CoverageReport
CoverageReport CoverageIndex
combinedIdx CoverageData
covData
      CoverageReport -> IO ()
reportAction CoverageReport
report
      ExitCode -> IO ()
forall e a. Exception e => e -> IO a
throwIO ExitCode
e

-- | Options for running the testing monad.
data Options era = Options
  { forall era. Options era -> NodeParams era
params :: NodeParams era
  , forall era. Options era -> Maybe (IORef CoverageData)
coverageRef :: Maybe (IORef CoverageData)
  }

defaultOptions :: Options C.ConwayEra
defaultOptions :: Options ConwayEra
defaultOptions =
  Options
    { params :: NodeParams ConwayEra
params = NodeParams ConwayEra
Defaults.nodeParams
    , coverageRef :: Maybe (IORef CoverageData)
coverageRef = Maybe (IORef CoverageData)
forall a. Maybe a
Nothing
    }

-- | Modify the maximum transaction size in the protocol parameters of the given options
modifyTransactionLimits :: Options C.ConwayEra -> Word32 -> Options C.ConwayEra
modifyTransactionLimits :: Options ConwayEra -> Word32 -> Options ConwayEra
modifyTransactionLimits opts :: Options ConwayEra
opts@Options{params :: forall era. Options era -> NodeParams era
params = NodeParams ConwayEra -> PParams (ShelleyLedgerEra ConwayEra)
forall era. NodeParams era -> PParams (ShelleyLedgerEra era)
Defaults.pParams -> PParams (ShelleyLedgerEra ConwayEra)
pp} Word32
newVal =
  -- TODO: use lenses to make this cleaner
  Options ConwayEra
opts
    { params = (params opts){npProtocolParameters = C.LedgerProtocolParameters $ pp & L.ppMaxTxSizeL .~ 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 :: forall a. Options ConwayEra -> TestingMonadT IO a -> IO ()
mockchainSucceedsWithOptions Options{NodeParams ConwayEra
params :: forall era. Options era -> NodeParams era
params :: NodeParams ConwayEra
params, Maybe (IORef CoverageData)
coverageRef :: forall era. Options era -> Maybe (IORef CoverageData)
coverageRef :: Maybe (IORef CoverageData)
coverageRef} TestingMonadT IO a
action =
  NodeParams ConwayEra
-> TestingMonadT IO a
-> IO
     (Either (BalanceTxError ConwayEra) a, MockChainState ConwayEra)
forall (m :: * -> *) a.
NodeParams ConwayEra
-> TestingMonadT m a
-> m (Either (BalanceTxError ConwayEra) a,
      MockChainState ConwayEra)
runTestingMonadT NodeParams ConwayEra
params TestingMonadT IO a
action
    IO (Either (BalanceTxError ConwayEra) a, MockChainState ConwayEra)
-> ((Either (BalanceTxError ConwayEra) a, MockChainState ConwayEra)
    -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Either (BalanceTxError ConwayEra) a
res, MockChainState ConwayEra
st) -> do
      let covData :: CoverageData
covData = MockChainState ConwayEra
st MockChainState ConwayEra
-> Getting CoverageData (MockChainState ConwayEra) CoverageData
-> CoverageData
forall s a. s -> Getting a s a -> a
^. Getting CoverageData (MockChainState ConwayEra) CoverageData
forall era (f :: * -> *).
Functor f =>
(CoverageData -> f CoverageData)
-> MockChainState era -> f (MockChainState era)
coverageData
      Maybe (IORef CoverageData)
-> (IORef CoverageData -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> IO ()) -> IO ())
-> (IORef CoverageData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> CoverageData
covData)
      case Either (BalanceTxError ConwayEra) a
res of
        Right a
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left BalanceTxError ConwayEra
err -> do
          Maybe (IORef CoverageData)
-> (IORef CoverageData -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> IO ()) -> IO ())
-> (IORef CoverageData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> BalanceTxError ConwayEra -> CoverageData
forall e. BalanceTxError e -> CoverageData
coverageFromBalanceTxError BalanceTxError ConwayEra
err)
          String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ BalanceTxError ConwayEra -> String
forall a. Show a => a -> String
show BalanceTxError ConwayEra
err

{- | Run the 'TestingMonadT' action with the given options, fail if it
    succeeds, and handle the error appropriately.
-}
mockchainFailsWithOptions :: Options C.ConwayEra -> TestingMonadT IO a -> (BalanceTxError C.ConwayEra -> Assertion) -> Assertion
mockchainFailsWithOptions :: forall a.
Options ConwayEra
-> TestingMonadT IO a
-> (BalanceTxError ConwayEra -> IO ())
-> IO ()
mockchainFailsWithOptions Options{NodeParams ConwayEra
params :: forall era. Options era -> NodeParams era
params :: NodeParams ConwayEra
params, Maybe (IORef CoverageData)
coverageRef :: forall era. Options era -> Maybe (IORef CoverageData)
coverageRef :: Maybe (IORef CoverageData)
coverageRef} TestingMonadT IO a
action BalanceTxError ConwayEra -> IO ()
handleError =
  NodeParams ConwayEra
-> TestingMonadT IO a
-> IO
     (Either (BalanceTxError ConwayEra) a, MockChainState ConwayEra)
forall (m :: * -> *) a.
NodeParams ConwayEra
-> TestingMonadT m a
-> m (Either (BalanceTxError ConwayEra) a,
      MockChainState ConwayEra)
runTestingMonadT NodeParams ConwayEra
params TestingMonadT IO a
action
    IO (Either (BalanceTxError ConwayEra) a, MockChainState ConwayEra)
-> ((Either (BalanceTxError ConwayEra) a, MockChainState ConwayEra)
    -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Either (BalanceTxError ConwayEra) a
res, MockChainState ConwayEra
st) -> do
      let covData :: CoverageData
covData = MockChainState ConwayEra
st MockChainState ConwayEra
-> Getting CoverageData (MockChainState ConwayEra) CoverageData
-> CoverageData
forall s a. s -> Getting a s a -> a
^. Getting CoverageData (MockChainState ConwayEra) CoverageData
forall era (f :: * -> *).
Functor f =>
(CoverageData -> f CoverageData)
-> MockChainState era -> f (MockChainState era)
coverageData
      Maybe (IORef CoverageData)
-> (IORef CoverageData -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> IO ()) -> IO ())
-> (IORef CoverageData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> CoverageData
covData)
      case Either (BalanceTxError ConwayEra) a
res of
        Right a
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mockchainFailsWithOptions: Did not fail"
        Left BalanceTxError ConwayEra
err -> do
          Maybe (IORef CoverageData)
-> (IORef CoverageData -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IORef CoverageData)
coverageRef ((IORef CoverageData -> IO ()) -> IO ())
-> (IORef CoverageData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IORef CoverageData
ref -> IORef CoverageData -> (CoverageData -> CoverageData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CoverageData
ref (CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> BalanceTxError ConwayEra -> CoverageData
forall e. BalanceTxError e -> CoverageData
coverageFromBalanceTxError BalanceTxError ConwayEra
err)
          BalanceTxError ConwayEra -> IO ()
handleError BalanceTxError ConwayEra
err