{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# 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 (..),

  -- * Redeemer tagging (Tier 2)
  RedeemerTagger (..),
  RedeemerTag (..),
  autoRedeemerTag,
  labelRedeemer,

  -- * Address labeling
  AddressLabeler (..),
  mockWalletAddressLabeler,

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

  -- * Trace recording
  TraceRecorder (..),

  -- * Threat model coverage policy
  zeroCoverageVerdict,
  ThreatModelCategory (..),
  ZeroCoverageKind (..),
  zeroCoverageKind,
  skippedMessage,

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

  -- * Coverage helpers

  -- ** Coverage with tasty-streaming
  withCoverageIndices,
  covDataToSrcLocRanges,

  -- ** Coverage without tasty-streaming
  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 Convex.Tasty.QuickCheck (testProperty)
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, localOption, sequentialTestGroup, testGroup, withResource)
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.HUnit (assertFailure, testCaseSteps)

import Cardano.Api qualified as C
import Cardano.Ledger.Core qualified as L
import Control.Exception (SomeException, catch, evaluate, throwIO, try)
import Control.Lens ((&), (.~), (^.))
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.Reader (ReaderT (..))
import Control.Monad.State.Class (MonadState, get)
import Control.Monad.Trans (MonadTrans (..))
import Convex.Class (MonadBlockchain, MonadMockchain, MonadUtxoQuery, coverageData, getMockChainState, getTxs, getUtxo)
import Convex.CoinSelection (BalanceTxError (..), BalancingError (..), coverageFromBalanceTxError)
import Convex.CoinSelection.Class (BalancingT (..), MonadBalance)
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.SrcLoc (SrcLocRange (..), withSrcLoc)
import Convex.Tasty.Streaming.TMSummary (CoverageIndexStorage (..), Fault (..), TMRecorder, ThreatModelCategory (..), ThreatModelSummary (..), TraceRecorder (..), faultLabel, threatModelGroupName, tmRecord)
import Convex.Tasty.Streaming.Types (withMaxTxSizeHint)
import Convex.TestingInterface.Options (defaultMainTestingInterface)
import Convex.TestingInterface.Trace (
  AddressLabeler (..),
  IterationStatus (..),
  IterationTrace (..),
  RedeemerTag (..),
  RedeemerTagger (..),
  ThreatModelTrace (..),
  ThreatModelTraceOutcome (..),
  ThreatModelValidation (..),
  Transition (..),
  TransitionResult (..),
  TxSummary (..),
 )
import Convex.TestingInterface.Trace.RedeemerTag (autoRedeemerTag, labelRedeemer)
import Convex.TestingInterface.Trace.TxSummary (summarizeTx)
import Convex.ThreatModel (SigningWallet (AutoSign), ThreatModel (..), ThreatModelCheckEntry (..), ThreatModelOutcome (..), TxValidity (..), ValidityReport (..), getThreatModelName, runThreatModelCheckTraced, threatModelEnvs)
import Convex.ThreatModel.All (allThreatModels)
import Convex.ThreatModel.TxModifier (TxModifier (..), renderTxMod)
import Convex.Wallet (verificationKeyHash)
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.Containers.ListUtils (nubOrd)
import Data.Foldable (foldl', for_, traverse_)
import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
import Data.List (deleteFirstsBy, isPrefixOf)
import Data.Map qualified as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Word (Word32)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack, withFrozenCallStack)
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.
  Any transactions submitted during initialization will not be subjected to tests.
  If you want to test the initialization transactions, you can add an initialization action,
  and keep the 'initialize' method minimal.
  -}
  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

  {- | Optional 'RedeemerTagger' (Tier 2) that maps a script input's parsed
  Plutus redeemer 'Data' to a human-readable 'RedeemerTag' (label +
  optional JSON payload). The label surfaces in the streamed
  'TxInputSummary' as @redeemerKind@ / @redeemerPayload@.

  Default: a no-op tagger, so Tier 1 ('redeemerRaw' / 'redeemerConstr')
  is still streamed and Tier 2 fields stay @Nothing@. See
  'autoRedeemerTag' and 'labelRedeemer' for ergonomics.
  -}
  redeemerTagger :: RedeemerTagger
  redeemerTagger = (Data -> Maybe RedeemerTag) -> RedeemerTagger
RedeemerTagger (Maybe RedeemerTag -> Data -> Maybe RedeemerTag
forall a b. a -> b -> a
const Maybe RedeemerTag
forall a. Maybe a
Nothing)

  {- | Optional 'AddressLabeler' that maps an address's credential hash to a
  human-readable label. The label surfaces in the streamed
  'TxInputSummary' \/ 'TxOutputSummary' as @addressLabel@.

  Default: 'mockWalletAddressLabeler', which labels the standard mock
  wallets ('Convex.Wallet.MockWallet.mockWallets') as @"Wallet 1".."Wallet
  10"@. Since those are the wallets nearly every test already uses, this
  default costs nothing and rarely needs overriding — extend it with
  '(<>)' to add labels for a model's own script hashes or extra keys.
  -}
  addressLabeler :: AddressLabeler
  addressLabeler = AddressLabeler
mockWalletAddressLabeler

class (TestingInterface state) => ThreatModelsFor state where
  {- | Threat models the contract claims to resist. This is a coverage
  claim, checked in both directions: a listed model that never applies to
  any generated transaction fails the suite (the claim is unverifiable), and
  one that finds a vulnerability fails it too (the claim is false).

  Default: nothing claimed. Listing a model here is the outcome of triage —
  you ran it, saw that it applies, and saw the contract hold. Models you
  have not triaged belong in 'candidateModels', which is where they start.
  -}
  threatModels :: [ThreatModel ()]
  threatModels = []

  {- | Threat models run for information rather than as a claim: reported,
  but never failed for not applying. This is where every model starts, and
  what an empty instance runs.

  Default: every parameterless threat model not already spoken for by
  another slot. A detection still fails — a finding is a finding, whether or
  not you asked for the model — but the message asks you to triage it into
  'threatModels', 'expectedVulnerabilities', 'acceptedFindings' or
  'notApplicable' rather than accusing the contract of a broken promise.

  Set to @[]@ to opt out of the survey entirely.
  -}
  candidateModels :: [ThreatModel ()]
  candidateModels =
    [ThreatModel ()] -> [ThreatModel ()]
defaultThreatModelsExcluding
      ( forall state. ThreatModelsFor state => [ThreatModel ()]
threatModels @state
          [ThreatModel ()] -> [ThreatModel ()] -> [ThreatModel ()]
forall a. Semigroup a => a -> a -> a
<> ((ThreatModel (), String) -> ThreatModel ())
-> [(ThreatModel (), String)] -> [ThreatModel ()]
forall a b. (a -> b) -> [a] -> [b]
map (ThreatModel (), String) -> ThreatModel ()
forall a b. (a, b) -> a
fst (forall state. ThreatModelsFor state => [(ThreatModel (), String)]
expectedVulnerabilities @state)
          [ThreatModel ()] -> [ThreatModel ()] -> [ThreatModel ()]
forall a. Semigroup a => a -> a -> a
<> ((ThreatModel (), String) -> ThreatModel ())
-> [(ThreatModel (), String)] -> [ThreatModel ()]
forall a b. (a -> b) -> [a] -> [b]
map (ThreatModel (), String) -> ThreatModel ()
forall a b. (a, b) -> a
fst (forall state. ThreatModelsFor state => [(ThreatModel (), String)]
acceptedFindings @state)
          [ThreatModel ()] -> [ThreatModel ()] -> [ThreatModel ()]
forall a. Semigroup a => a -> a -> a
<> ((ThreatModel (), String) -> ThreatModel ())
-> [(ThreatModel (), String)] -> [ThreatModel ()]
forall a b. (a -> b) -> [a] -> [b]
map (ThreatModel (), String) -> ThreatModel ()
forall a b. (a, b) -> a
fst (forall state. ThreatModelsFor state => [(ThreatModel (), String)]
notApplicable @state)
      )

  {- | Vulnerabilities the contract is known to have, each with the reason
  it is declared. Inverted pass/fail: detecting one is the required outcome,
  and failing to detect it means the contract (or the attack) improved and
  this declaration is now stale.

  The reason travels into the failure message and the streamed summary, so a
  stale entry explains itself. Write what a reader six months from now needs
  in order to tell a deliberate declaration from an unexamined one.

  Use this only for *genuine* vulnerabilities. A benign finding — an attack
  that "succeeds" against a design artifact that is not exploitable —
  belongs in 'acceptedFindings': listing it here advertises the contract as
  vulnerable, and fails the suite the moment the finding stops being
  reproduced.
  -}
  expectedVulnerabilities :: [(ThreatModel (), String)]
  expectedVulnerabilities = []

  {- | Findings that are known, accepted artifacts of the contract's design
  rather than exploitable bugs, each with the reason it is accepted. A
  detection is the required outcome, and the report labels it as accepted by
  design rather than as a vulnerability.

  Judged exactly like 'expectedVulnerabilities' - an acceptance is a
  declaration too, so the case fails when the run disproves it ("NO LONGER
  DETECTED") or never verifies it. What differs is only what the
  declaration means: this slot says the attack lands on something harmless,
  where 'expectedVulnerabilities' says the contract has a bug nobody has
  fixed. Prefer this one for anything that is not genuinely exploitable -
  the other advertises the contract as vulnerable in every report.
  -}
  acceptedFindings :: [(ThreatModel (), String)]
  acceptedFindings = []

  {- | Threat models reviewed and found not to apply to this contract, each
  with the reason. The inverse claim to 'threatModels': these must /not/
  apply, and one that starts applying fails the suite.

  That is the point of the slot. "Does not apply here" is a prediction about
  the contract's transaction shapes, and predictions break — a contract that
  grows a script output, or a harness change that widens what counts as
  applicable, should tell you rather than pass in silence. Deleting a model
  from the lists instead records the same triage where nothing can check it.
  -}
  notApplicable :: [(ThreatModel (), String)]
  notApplicable = []

{- | Default 'AddressLabeler': labels the credential hashes of the standard
mock wallets ('Convex.Wallet.MockWallet.mockWallets') as @"Wallet 1".."Wallet
10"@.
-}

{- | The default 'candidateModels' survey: every parameterless threat model
except the given ones, which is how a slot excludes the models it has
already spoken for.

Models are compared by name, totally: an unnamed model is never equal to
anything (not even another unnamed model), so an unnamed entry in the
excluded list simply excludes nothing. It must not error on unnamed models -
they are legal in the triaged slots, where they get index-based fallback
names before anything runs (see 'nameFallbacks').
-}
defaultThreatModelsExcluding :: [ThreatModel ()] -> [ThreatModel ()]
defaultThreatModelsExcluding :: [ThreatModel ()] -> [ThreatModel ()]
defaultThreatModelsExcluding [ThreatModel ()]
excluded = (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 [ThreatModel ()]
excluded
 where
  eqName :: ThreatModel a -> ThreatModel a -> Bool
eqName ThreatModel a
a ThreatModel a
b = case (ThreatModel a -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName ThreatModel a
a, ThreatModel a -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName ThreatModel a
b) of
    (Just String
s, Just String
t) -> String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
t
    (Maybe String, Maybe String)
_ -> Bool
False

mockWalletAddressLabeler :: AddressLabeler
mockWalletAddressLabeler :: AddressLabeler
mockWalletAddressLabeler = (Text -> Maybe Text) -> AddressLabeler
AddressLabeler (Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Text Text
table)
 where
  table :: Map Text Text
table =
    [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Hash PaymentKey -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText (Wallet -> Hash PaymentKey
verificationKeyHash Wallet
w), Text
"Wallet " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i))
      | (Int
i, Wallet
w) <- [Int] -> [Wallet] -> [(Int, Wallet)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [Wallet]
Wallet.mockWallets
      ]

{- | 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
    , MonadState (MockChainState C.ConwayEra)
    , 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
    , Monad (TestingMonadT m)
Monad (TestingMonadT m) =>
(Set PaymentCredential
 -> TestingMonadT m (UtxoSet CtxUTxO (Maybe HashableScriptData)))
-> MonadUtxoQuery (TestingMonadT m)
Set PaymentCredential
-> TestingMonadT m (UtxoSet CtxUTxO (Maybe HashableScriptData))
forall (m :: * -> *). Monad m => Monad (TestingMonadT m)
forall (m :: * -> *).
Monad m =>
Set PaymentCredential
-> TestingMonadT m (UtxoSet CtxUTxO (Maybe HashableScriptData))
forall (m :: * -> *).
Monad m =>
(Set PaymentCredential
 -> m (UtxoSet CtxUTxO (Maybe HashableScriptData)))
-> MonadUtxoQuery m
$cutxosByPaymentCredentials :: forall (m :: * -> *).
Monad m =>
Set PaymentCredential
-> TestingMonadT m (UtxoSet CtxUTxO (Maybe HashableScriptData))
utxosByPaymentCredentials :: Set PaymentCredential
-> TestingMonadT m (UtxoSet CtxUTxO (Maybe HashableScriptData))
MonadUtxoQuery
    )

deriving via (BalancingT (TestingMonadT m)) instance (Monad m) => MonadBalance C.ConwayEra (TestingMonadT m)

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 -> ShowS
[ModelState state] -> ShowS
ModelState state -> String
(Int -> ModelState state -> ShowS)
-> (ModelState state -> String)
-> ([ModelState state] -> ShowS)
-> Show (ModelState state)
forall state. Show state => Int -> ModelState state -> ShowS
forall state. Show state => [ModelState state] -> ShowS
forall state. Show state => ModelState state -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall state. Show state => Int -> ModelState state -> ShowS
showsPrec :: Int -> ModelState state -> ShowS
$cshow :: forall state. Show state => ModelState state -> String
show :: ModelState state -> String
$cshowList :: forall state. Show state => [ModelState state] -> ShowS
showList :: [ModelState state] -> ShowS
Show)

{- | Per-threat-model accumulated results across all QuickCheck iterations.
Key is the threat model name, value is the list of iteration results.
Each iteration result is a pair of the threat model outcome and related error messages.
-}

{- | Identity of a threat model within one suite run: the slot it was
declared in, plus its name.

The name alone is not an identity. Parameterised variants share one
('largeValueAttackWith' 10 and 1000 are both "Large Value Attack"), so a
variant listed as an accepted finding used to record its 'TMFailed'
outcomes under the same key as a same-named model in 'threatModels' -
failing the claimed model's test case, and then suppressing it via the
early-stop check. Slot-qualifying the key keeps the two apart.

Two models with the same name in the /same/ slot still collide; that is a
declaration mistake rather than a harness one.
-}
data ThreatModelId = ThreatModelId
  { ThreatModelId -> ThreatModelCategory
tmiCategory :: ThreatModelCategory
  , ThreatModelId -> String
tmiName :: String
  }
  deriving (ThreatModelId -> ThreatModelId -> Bool
(ThreatModelId -> ThreatModelId -> Bool)
-> (ThreatModelId -> ThreatModelId -> Bool) -> Eq ThreatModelId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThreatModelId -> ThreatModelId -> Bool
== :: ThreatModelId -> ThreatModelId -> Bool
$c/= :: ThreatModelId -> ThreatModelId -> Bool
/= :: ThreatModelId -> ThreatModelId -> Bool
Eq, Eq ThreatModelId
Eq ThreatModelId =>
(ThreatModelId -> ThreatModelId -> Ordering)
-> (ThreatModelId -> ThreatModelId -> Bool)
-> (ThreatModelId -> ThreatModelId -> Bool)
-> (ThreatModelId -> ThreatModelId -> Bool)
-> (ThreatModelId -> ThreatModelId -> Bool)
-> (ThreatModelId -> ThreatModelId -> ThreatModelId)
-> (ThreatModelId -> ThreatModelId -> ThreatModelId)
-> Ord ThreatModelId
ThreatModelId -> ThreatModelId -> Bool
ThreatModelId -> ThreatModelId -> Ordering
ThreatModelId -> ThreatModelId -> ThreatModelId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ThreatModelId -> ThreatModelId -> Ordering
compare :: ThreatModelId -> ThreatModelId -> Ordering
$c< :: ThreatModelId -> ThreatModelId -> Bool
< :: ThreatModelId -> ThreatModelId -> Bool
$c<= :: ThreatModelId -> ThreatModelId -> Bool
<= :: ThreatModelId -> ThreatModelId -> Bool
$c> :: ThreatModelId -> ThreatModelId -> Bool
> :: ThreatModelId -> ThreatModelId -> Bool
$c>= :: ThreatModelId -> ThreatModelId -> Bool
>= :: ThreatModelId -> ThreatModelId -> Bool
$cmax :: ThreatModelId -> ThreatModelId -> ThreatModelId
max :: ThreatModelId -> ThreatModelId -> ThreatModelId
$cmin :: ThreatModelId -> ThreatModelId -> ThreatModelId
min :: ThreatModelId -> ThreatModelId -> ThreatModelId
Ord, Int -> ThreatModelId -> ShowS
[ThreatModelId] -> ShowS
ThreatModelId -> String
(Int -> ThreatModelId -> ShowS)
-> (ThreatModelId -> String)
-> ([ThreatModelId] -> ShowS)
-> Show ThreatModelId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThreatModelId -> ShowS
showsPrec :: Int -> ThreatModelId -> ShowS
$cshow :: ThreatModelId -> String
show :: ThreatModelId -> String
$cshowList :: [ThreatModelId] -> ShowS
showList :: [ThreatModelId] -> ShowS
Show)

type ThreatModelResults = Map.Map ThreatModelId [(ThreatModelOutcome, [String])]

{- | A model together with the reason its slot records for it. The three
triaged slots require a reason; 'threatModels' and 'candidateModels' carry
none, and the test cases built for those two never read the field.
-}
type DeclaredModel = (ThreatModel (), String)

-- | Models from a slot that carries no reason.
withoutReason :: [ThreatModel ()] -> [DeclaredModel]
withoutReason :: [ThreatModel ()] -> [(ThreatModel (), String)]
withoutReason = (ThreatModel () -> (ThreatModel (), String))
-> [ThreatModel ()] -> [(ThreatModel (), String)]
forall a b. (a -> b) -> [a] -> [b]
map (\ThreatModel ()
tm -> (ThreatModel ()
tm, String
""))

-- | Models from a slot that carries a reason, given fallback names.
declaredWith :: String -> [(ThreatModel (), String)] -> [DeclaredModel]
declaredWith :: String -> [(ThreatModel (), String)] -> [(ThreatModel (), String)]
declaredWith String
prefix [(ThreatModel (), String)]
ms = [ThreatModel ()] -> [String] -> [(ThreatModel (), String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (String -> [ThreatModel ()] -> [ThreatModel ()]
nameFallbacks String
prefix (((ThreatModel (), String) -> ThreatModel ())
-> [(ThreatModel (), String)] -> [ThreatModel ()]
forall a b. (a -> b) -> [a] -> [b]
map (ThreatModel (), String) -> ThreatModel ()
forall a b. (a, b) -> a
fst [(ThreatModel (), String)]
ms)) (((ThreatModel (), String) -> String)
-> [(ThreatModel (), String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ThreatModel (), String) -> String
forall a b. (a, b) -> b
snd [(ThreatModel (), String)]
ms)

-- | 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@.
  -}
  , RunOptions -> [String]
threatModelFilter :: [String]
  {- ^ If non-empty, run only threat models whose names start with any value
  in this list. The filter applies to every slot of 'ThreatModelsFor', so a
  narrowed run builds test cases for the matching models only. If empty, all
  threat models run. Default: @[]@.
  -}
  }

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
    , threatModelFilter :: [String]
threatModelFilter = []
    }

{- | Give every unnamed model in a group its index-based fallback name, so
that recording, filtering, and reporting all use one and the same name.
'positiveTest' records outcomes under the model's name and the per-model
test cases look their results up by name again - an unnamed model would be
recorded under a shared literal "Unnamed" key that no test case ever looks
up, making e.g. an unnamed expected vulnerability pass silently without its
assertion ever running.
-}
nameFallbacks :: String -> [ThreatModel ()] -> [ThreatModel ()]
nameFallbacks :: String -> [ThreatModel ()] -> [ThreatModel ()]
nameFallbacks String
prefix = (Int -> ThreatModel () -> ThreatModel ())
-> [Int] -> [ThreatModel ()] -> [ThreatModel ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ThreatModel () -> ThreatModel ()
giveName [Int
1 :: Int ..]
 where
  giveName :: Int -> ThreatModel () -> ThreatModel ()
giveName Int
i ThreatModel ()
tm = case ThreatModel () -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName ThreatModel ()
tm of
    Just String
_ -> ThreatModel ()
tm
    Maybe String
Nothing -> String -> ThreatModel () -> ThreatModel ()
forall a. String -> ThreatModel a -> ThreatModel a
Named (String
prefix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i) ThreatModel ()
tm

{- | The name of a model that went through 'nameFallbacks'. Every model
reaching the run/record/report machinery is Named; if a code path ever
bypasses the normalization, trip loudly here instead of silently recording
outcomes under a name no test case looks up.
-}
modelName :: ThreatModel () -> String
modelName :: ThreatModel () -> String
modelName ThreatModel ()
tm =
  String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe
    (ShowS
forall a. HasCallStack => String -> a
error String
"modelName: unnamed threat model - models must go through nameFallbacks before running")
    (ThreatModel () -> Maybe String
forall a. ThreatModel a -> Maybe String
getThreatModelName ThreatModel ()
tm)

{- | Does this model pass @--threat-model-name@? An empty filter admits
everything; otherwise the model's rendered name must start with one of the
given prefixes.
-}
matchesThreatModelFilter :: RunOptions -> ThreatModel () -> Bool
matchesThreatModelFilter :: RunOptions -> ThreatModel () -> Bool
matchesThreatModelFilter RunOptions{[String]
threatModelFilter :: RunOptions -> [String]
threatModelFilter :: [String]
threatModelFilter} ThreatModel ()
tm =
  case [String]
threatModelFilter of
    [] -> Bool
True
    [String]
names -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` ThreatModel () -> String
modelName ThreatModel ()
tm) [String]
names

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

-- | Run testing interface tests with custom options
propRunActionsWithOptions
  :: forall state
   . (HasCallStack, ThreatModelsFor state)
  => String
  -> RunOptions
  -> TestTree
propRunActionsWithOptions :: forall state.
(HasCallStack, ThreatModelsFor state) =>
String -> RunOptions -> TestTree
propRunActionsWithOptions String
groupName RunOptions
opts =
  (HasCallStack => TestTree) -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => TestTree) -> TestTree)
-> (HasCallStack => TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$
    HasCallStack => TestTree -> TestTree
TestTree -> TestTree
withSrcLoc (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
      (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) ->
        -- Fallback names are assigned before filtering, so an unnamed model's
        -- index does not shift with the filter.
        let keep :: [(ThreatModel (), String)] -> [(ThreatModel (), String)]
keep = ((ThreatModel (), String) -> Bool)
-> [(ThreatModel (), String)] -> [(ThreatModel (), String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (RunOptions -> ThreatModel () -> Bool
matchesThreatModelFilter RunOptions
opts (ThreatModel () -> Bool)
-> ((ThreatModel (), String) -> ThreatModel ())
-> (ThreatModel (), String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreatModel (), String) -> ThreatModel ()
forall a b. (a, b) -> a
fst)
            tms :: [(ThreatModel (), String)]
tms = [(ThreatModel (), String)] -> [(ThreatModel (), String)]
keep ([ThreatModel ()] -> [(ThreatModel (), String)]
withoutReason (String -> [ThreatModel ()] -> [ThreatModel ()]
nameFallbacks String
"Threat model" (forall state. ThreatModelsFor state => [ThreatModel ()]
threatModels @state)))
            cands :: [(ThreatModel (), String)]
cands = [(ThreatModel (), String)] -> [(ThreatModel (), String)]
keep ([ThreatModel ()] -> [(ThreatModel (), String)]
withoutReason (String -> [ThreatModel ()] -> [ThreatModel ()]
nameFallbacks String
"Candidate model" (forall state. ThreatModelsFor state => [ThreatModel ()]
candidateModels @state)))
            evs :: [(ThreatModel (), String)]
evs = [(ThreatModel (), String)] -> [(ThreatModel (), String)]
keep (String -> [(ThreatModel (), String)] -> [(ThreatModel (), String)]
declaredWith String
"Expected vulnerability" (forall state. ThreatModelsFor state => [(ThreatModel (), String)]
expectedVulnerabilities @state))
            afs :: [(ThreatModel (), String)]
afs = [(ThreatModel (), String)] -> [(ThreatModel (), String)]
keep (String -> [(ThreatModel (), String)] -> [(ThreatModel (), String)]
declaredWith String
"Accepted finding" (forall state. ThreatModelsFor state => [(ThreatModel (), String)]
acceptedFindings @state))
            nas :: [(ThreatModel (), String)]
nas = [(ThreatModel (), String)] -> [(ThreatModel (), String)]
keep (String -> [(ThreatModel (), String)] -> [(ThreatModel (), String)]
declaredWith String
"Not applicable" (forall state. ThreatModelsFor state => [(ThreatModel (), String)]
notApplicable @state))
            {- The one place a model is tagged with what the suite claims
            about it: the claim decides how the model's outcomes are tallied
            and reported, which Tasty group its test
            case lands in, the category that travels into the model's trace
            entries, and whether zero attack coverage fails the case.

            Which slot a model was declared in *is* the claim - there is
            nothing left to infer about it. -}
            categorized :: [(ThreatModelCategory, [(ThreatModel (), String)],
  ThreatModelCategory
  -> IO (IORef ThreatModelResults)
  -> String
  -> (ThreatModel (), String)
  -> TestTree)]
categorized =
              [ (ThreatModelCategory
Claimed, [(ThreatModel (), String)]
tms, ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> (ThreatModel (), String)
-> TestTree
threatModelTestCase)
              , (ThreatModelCategory
Surveyed, [(ThreatModel (), String)]
cands, ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> (ThreatModel (), String)
-> TestTree
threatModelTestCase)
              , (ThreatModelCategory
Expected, [(ThreatModel (), String)]
evs, ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> (ThreatModel (), String)
-> TestTree
triagedFindingTestCase)
              , (ThreatModelCategory
Accepted, [(ThreatModel (), String)]
afs, ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> (ThreatModel (), String)
-> TestTree
triagedFindingTestCase)
              , (ThreatModelCategory
NotApplicable, [(ThreatModel (), String)]
nas, ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> (ThreatModel (), String)
-> TestTree
notApplicableTestCase)
              ]
            modelsToRun :: [(ThreatModelCategory, ThreatModel ())]
modelsToRun = [[(ThreatModelCategory, ThreatModel ())]]
-> [(ThreatModelCategory, ThreatModel ())]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [((ThreatModel (), String) -> (ThreatModelCategory, ThreatModel ()))
-> [(ThreatModel (), String)]
-> [(ThreatModelCategory, ThreatModel ())]
forall a b. (a -> b) -> [a] -> [b]
map ((,) ThreatModelCategory
claim (ThreatModel () -> (ThreatModelCategory, ThreatModel ()))
-> ((ThreatModel (), String) -> ThreatModel ())
-> (ThreatModel (), String)
-> (ThreatModelCategory, ThreatModel ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreatModel (), String) -> ThreatModel ()
forall a b. (a, b) -> a
fst) [(ThreatModel (), String)]
models | (ThreatModelCategory
claim, [(ThreatModel (), String)]
models, ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> (ThreatModel (), String)
-> TestTree
_) <- [(ThreatModelCategory, [(ThreatModel (), String)],
  ThreatModelCategory
  -> IO (IORef ThreatModelResults)
  -> String
  -> (ThreatModel (), String)
  -> TestTree)]
categorized]
         in if ([(ThreatModel (), String)] -> Bool)
-> [[(ThreatModel (), String)]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [(ThreatModel (), String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[(ThreatModel (), String)]
tms, [(ThreatModel (), String)]
cands, [(ThreatModel (), String)]
evs, [(ThreatModel (), String)]
afs, [(ThreatModel (), String)]
nas]
              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. (HasCallStack, Testable a) => String -> a -> TestTree
testProperty String
"Positive tests" (forall state.
TestingInterface state =>
RunOptions
-> String
-> Maybe (IO (IORef ThreatModelResults))
-> [(ThreatModelCategory, 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)
                      , HasCallStack => TraceRecorder -> IO (IORef Int) -> TestTree
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
$
                        [ -- Every category's models run in this one property:
                          -- claimed models stop early on a detection, expected
                          -- vulnerabilities and accepted findings always run,
                          -- quietly. They differ only in reporting, below.
                          String -> Property -> TestTree
forall a. (HasCallStack, Testable a) => String -> a -> TestTree
testProperty String
"Positive tests" (forall state.
TestingInterface state =>
RunOptions
-> String
-> Maybe (IO (IORef ThreatModelResults))
-> [(ThreatModelCategory, 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) [(ThreatModelCategory, ThreatModel ())]
modelsToRun TraceRecorder
recorder IO (IORef Int)
getPosRef)
                        , HasCallStack => TraceRecorder -> IO (IORef Int) -> TestTree
TraceRecorder -> IO (IORef Int) -> TestTree
negativeTestTree TraceRecorder
recorder IO (IORef Int)
getNegRef
                        ]
                          [TestTree] -> [TestTree] -> [TestTree]
forall a. Semigroup a => a -> a -> a
<> [(ThreatModelCategory, [(ThreatModel (), String)],
  ThreatModelCategory
  -> IO (IORef ThreatModelResults)
  -> String
  -> (ThreatModel (), String)
  -> TestTree)]
-> IO (IORef ThreatModelResults) -> [TestTree]
forall {a} {t}.
[(ThreatModelCategory, [a],
  ThreatModelCategory -> t -> String -> a -> TestTree)]
-> t -> [TestTree]
perCategoryGroups [(ThreatModelCategory, [(ThreatModel (), String)],
  ThreatModelCategory
  -> IO (IORef ThreatModelResults)
  -> String
  -> (ThreatModel (), String)
  -> TestTree)]
categorized IO (IORef ThreatModelResults)
getTmResultsRef
 where
  negativeTestTree :: (HasCallStack) => TraceRecorder -> IO (IORef Int) -> TestTree
  negativeTestTree :: HasCallStack => TraceRecorder -> IO (IORef Int) -> TestTree
negativeTestTree TraceRecorder
recorder IO (IORef Int)
getNegRef =
    (HasCallStack => TestTree) -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => TestTree) -> TestTree)
-> (HasCallStack => TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$
      case RunOptions -> Maybe String
disableNegativeTesting RunOptions
opts of
        Maybe String
Nothing -> String -> Property -> TestTree
forall a. (HasCallStack, 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. (HasCallStack, 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)

  -- One per-model group per non-empty category, each reporting its own
  -- models' outcomes once the positive tests have recorded them.
  perCategoryGroups :: [(ThreatModelCategory, [a],
  ThreatModelCategory -> t -> String -> a -> TestTree)]
-> t -> [TestTree]
perCategoryGroups [(ThreatModelCategory, [a],
  ThreatModelCategory -> t -> String -> a -> TestTree)]
categorized t
getTmResultsRef =
    [ String -> [TestTree] -> TestTree
testGroup String
group ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$ (a -> TestTree) -> [a] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map (ThreatModelCategory -> t -> String -> a -> TestTree
testCaseFor ThreatModelCategory
claim t
getTmResultsRef String
group) [a]
models
    | (ThreatModelCategory
claim, [a]
models, ThreatModelCategory -> t -> String -> a -> TestTree
testCaseFor) <- [(ThreatModelCategory, [a],
  ThreatModelCategory -> t -> String -> a -> TestTree)]
categorized
    , Bool -> Bool
not ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
models)
    , let group :: String
group = ThreatModelCategory -> String
threatModelGroupName ThreatModelCategory
claim
    ]

{- | The models to run on one iteration of the positive property, given what
earlier iterations already recorded.

A detection fails the test case for a 'Claimed' or a 'Surveyed' model, so
once one has failed there is nothing left to learn from re-running it and it
is dropped. The triaged slots always run: their verdict depends on whether
the finding reproduces consistently, not on a single hit.

The caller has already applied the @--threat-model-name@ filter (see
'propRunActionsWithOptions'), so this does not re-apply it.
-}
modelsForIteration
  :: ThreatModelResults
  -> [(ThreatModelCategory, ThreatModel ())]
  -> [(ThreatModelCategory, ThreatModel ())]
modelsForIteration :: ThreatModelResults
-> [(ThreatModelCategory, ThreatModel ())]
-> [(ThreatModelCategory, ThreatModel ())]
modelsForIteration ThreatModelResults
existingResults = ((ThreatModelCategory, ThreatModel ()) -> Bool)
-> [(ThreatModelCategory, ThreatModel ())]
-> [(ThreatModelCategory, ThreatModel ())]
forall a. (a -> Bool) -> [a] -> [a]
filter (ThreatModelCategory, ThreatModel ()) -> Bool
keep
 where
  isTMFailed :: ThreatModelOutcome -> Bool
isTMFailed (TMFailed String
_) = Bool
True
  isTMFailed ThreatModelOutcome
_ = Bool
False
  alreadyFailed :: ThreatModelId -> Bool
alreadyFailed ThreatModelId
tmid = ((ThreatModelOutcome, [String]) -> Bool)
-> [(ThreatModelOutcome, [String])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ThreatModelOutcome -> Bool
isTMFailed (ThreatModelOutcome -> Bool)
-> ((ThreatModelOutcome, [String]) -> ThreatModelOutcome)
-> (ThreatModelOutcome, [String])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreatModelOutcome, [String]) -> ThreatModelOutcome
forall a b. (a, b) -> a
fst) ([(ThreatModelOutcome, [String])]
-> Maybe [(ThreatModelOutcome, [String])]
-> [(ThreatModelOutcome, [String])]
forall a. a -> Maybe a -> a
fromMaybe [] (ThreatModelId
-> ThreatModelResults -> Maybe [(ThreatModelOutcome, [String])]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreatModelId
tmid ThreatModelResults
existingResults))
  keep :: (ThreatModelCategory, ThreatModel ()) -> Bool
keep (ThreatModelCategory
cat, ThreatModel ()
tm)
    | ThreatModelCategory
cat ThreatModelCategory -> ThreatModelCategory -> Bool
forall a. Eq a => a -> a -> Bool
== ThreatModelCategory
Claimed Bool -> Bool -> Bool
|| ThreatModelCategory
cat ThreatModelCategory -> ThreatModelCategory -> Bool
forall a. Eq a => a -> a -> Bool
== ThreatModelCategory
Surveyed = Bool -> Bool
not (ThreatModelId -> Bool
alreadyFailed (ThreatModelCategory -> String -> ThreatModelId
ThreatModelId ThreatModelCategory
cat (ThreatModel () -> String
modelName ThreatModel ()
tm)))
    | Bool
otherwise = Bool
True

-- | 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
-> state -> TestingMonadT (PropertyM IO) (state, [Transition])
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions
-> state -> TestingMonadT (PropertyM m) (state, [Transition])
runActionsTraced RunOptions
opts 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 -> ShowS
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 -> [SrcLocRange] -> 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 -> [SrcLocRange] -> 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 -> [SrcLocRange] -> 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{CoverageData
mcsCoverageData :: CoverageData
mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData}) -> do
              let covData :: CoverageData
covData = CoverageData
mcsCoverageData CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> BalanceTxError ConwayEra -> CoverageData
forall e. BalanceTxError e -> CoverageData
coverageFromBalanceTxError BalanceTxError ConwayEra
err
              -- 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)
              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 -> [SrcLocRange] -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"negative" (CoverageData -> [SrcLocRange]
covDataToSrcLocRanges CoverageData
covData) (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 -> [SrcLocRange] -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"negative" (CoverageData -> [SrcLocRange]
covDataToSrcLocRanges CoverageData
covData) (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 -> state -> TestingMonadT (PropertyM IO) state
forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> state -> TestingMonadT (PropertyM m) state
runActions RunOptions
opts 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 -> ShowS
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)
  -> [(ThreatModelCategory, ThreatModel ())]
  {- ^ The threat models to run, each tagged with the @ThreatModelsFor@ list it
  came from. Only 'Claimed' ones early-stop on TMFailed and honour the
  @--threat-model@ filter; 'Expected' and 'Accepted' ones always run.
  -}
  -> 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))
-> [(ThreatModelCategory, ThreatModel ())]
-> TraceRecorder
-> IO (IORef Int)
-> Property
positiveTest RunOptions
opts String
groupName Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [(ThreatModelCategory, ThreatModel ())]
tms 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))
-> [(ThreatModelCategory, ThreatModel ())]
-> TraceRecorder
-> Int
-> PropertyM IO Property
positiveTestTraced @state RunOptions
opts String
groupName Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [(ThreatModelCategory, ThreatModel ())]
tms TraceRecorder
recorder Int
iterIdx
    else forall state.
TestingInterface state =>
RunOptions
-> Maybe (IO (IORef ThreatModelResults))
-> [(ThreatModelCategory, ThreatModel ())]
-> PropertyM IO Property
positiveTestFast @state RunOptions
opts Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [(ThreatModelCategory, ThreatModel ())]
tms

-- | Traced path: runs 'runActionsTraced', builds 'IterationTrace', records it.
positiveTestTraced
  :: forall state
   . (TestingInterface state)
  => RunOptions
  -> String
  -> Maybe (IO (IORef ThreatModelResults))
  -> [(ThreatModelCategory, ThreatModel ())]
  -> TraceRecorder
  -> Int
  -> PropertyM IO Property
positiveTestTraced :: forall state.
TestingInterface state =>
RunOptions
-> String
-> Maybe (IO (IORef ThreatModelResults))
-> [(ThreatModelCategory, ThreatModel ())]
-> TraceRecorder
-> Int
-> PropertyM IO Property
positiveTestTraced RunOptions
opts String
groupName Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [(ThreatModelCategory, ThreatModel ())]
tms 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],
    [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
      [ThreatModelCheckEntry], CoverageData, Property -> Property)]),
 MockChainState ConwayEra)
result <- NodeParams ConwayEra
-> TestingMonadT
     (PropertyM IO)
     (state, [Transition],
      [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
        [ThreatModelCheckEntry], CoverageData, Property -> Property)])
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra)
        (state, [Transition],
         [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
           [ThreatModelCheckEntry], CoverageData, Property -> Property)]),
      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],
    [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
      [ThreatModelCheckEntry], CoverageData, Property -> Property)])
 -> PropertyM
      IO
      (Either
         (BalanceTxError ConwayEra)
         (state, [Transition],
          [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
            [ThreatModelCheckEntry], CoverageData, Property -> Property)]),
       MockChainState ConwayEra))
-> TestingMonadT
     (PropertyM IO)
     (state, [Transition],
      [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
        [ThreatModelCheckEntry], CoverageData, Property -> Property)])
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra)
        (state, [Transition],
         [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
           [ThreatModelCheckEntry], CoverageData, Property -> Property)]),
      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
    [Tx ConwayEra]
initTxs <- TestingMonadT (PropertyM IO) [Tx ConwayEra]
forall era (m :: * -> *).
(MonadMockchain era m, IsShelleyBasedEra era) =>
m [Tx era]
getTxs
    MockChainState ConwayEra
state0 <- TestingMonadT (PropertyM IO) (MockChainState ConwayEra)
forall s (m :: * -> *). MonadState s m => m s
get

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

    [Tx ConwayEra]
allTxs <- TestingMonadT (PropertyM IO) [Tx ConwayEra]
forall era (m :: * -> *).
(MonadMockchain era m, IsShelleyBasedEra era) =>
m [Tx era]
getTxs
    let envs :: [ThreatModelEnv]
envs = NodeParams ConwayEra
-> [Tx ConwayEra] -> MockChainState ConwayEra -> [ThreatModelEnv]
threatModelEnvs NodeParams ConwayEra
params (Int -> [Tx ConwayEra] -> [Tx ConwayEra]
forall a. Int -> [a] -> [a]
drop ([Tx ConwayEra] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx ConwayEra]
initTxs) ([Tx ConwayEra] -> [Tx ConwayEra])
-> [Tx ConwayEra] -> [Tx ConwayEra]
forall a b. (a -> b) -> a -> b
$ [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 allToRun :: [(ThreatModelCategory, ThreatModel ())]
allToRun = ThreatModelResults
-> [(ThreatModelCategory, ThreatModel ())]
-> [(ThreatModelCategory, ThreatModel ())]
modelsForIteration ThreatModelResults
existingResults [(ThreatModelCategory, ThreatModel ())]
tms
    -- An iteration that generated no transactions records no outcomes at
    -- all: running the models over an empty env list would record a
    -- TMSkipped per model, indistinguishable from a genuine precondition
    -- miss, and the vacuity check would blame model applicability for what
    -- is a test-generation issue. With nothing recorded, an all-empty run
    -- reports "No tests were generated by positive tests" instead.
    [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData, Property -> Property)]
tmResultsWithCov <-
      if [ThreatModelEnv] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ThreatModelEnv]
envs
        then [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData, Property -> Property)]
-> TestingMonadT
     (PropertyM IO)
     [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
       [ThreatModelCheckEntry], CoverageData, Property -> Property)]
forall a. a -> TestingMonadT (PropertyM IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        else IO
  [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
    [ThreatModelCheckEntry], CoverageData, Property -> Property)]
-> TestingMonadT
     (PropertyM IO)
     [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
       [ThreatModelCheckEntry], CoverageData, Property -> Property)]
forall a. IO a -> TestingMonadT (PropertyM IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
     [ThreatModelCheckEntry], CoverageData, Property -> Property)]
 -> TestingMonadT
      (PropertyM IO)
      [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
        [ThreatModelCheckEntry], CoverageData, Property -> Property)])
-> IO
     [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
       [ThreatModelCheckEntry], CoverageData, Property -> Property)]
-> TestingMonadT
     (PropertyM IO)
     [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
       [ThreatModelCheckEntry], CoverageData, Property -> Property)]
forall a b. (a -> b) -> a -> b
$ [(ThreatModelCategory, ThreatModel ())]
-> ((ThreatModelCategory, ThreatModel ())
    -> IO
         (ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
          [ThreatModelCheckEntry], CoverageData, Property -> Property))
-> IO
     [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
       [ThreatModelCheckEntry], CoverageData, Property -> Property)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ThreatModelCategory, ThreatModel ())]
allToRun (((ThreatModelCategory, ThreatModel ())
  -> IO
       (ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
        [ThreatModelCheckEntry], CoverageData, Property -> Property))
 -> IO
      [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
        [ThreatModelCheckEntry], CoverageData, Property -> Property)])
-> ((ThreatModelCategory, ThreatModel ())
    -> IO
         (ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
          [ThreatModelCheckEntry], CoverageData, Property -> Property))
-> IO
     [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
       [ThreatModelCheckEntry], CoverageData, Property -> Property)]
forall a b. (a -> b) -> a -> b
$ \(ThreatModelCategory
category, ThreatModel ()
tm) -> do
          let tmid :: ThreatModelId
tmid = ThreatModelCategory -> String -> ThreatModelId
ThreatModelId ThreatModelCategory
category (ThreatModel () -> String
modelName ThreatModel ()
tm)
          ((ThreatModelOutcome
outcome, [ThreatModelCheckEntry]
traceEntries, Property -> Property
monitors), MockChainState ConwayEra
tmFinalState) <-
            MockchainIO
  ConwayEra
  (ThreatModelOutcome, [ThreatModelCheckEntry], Property -> Property)
-> NodeParams ConwayEra
-> MockChainState ConwayEra
-> IO
     ((ThreatModelOutcome, [ThreatModelCheckEntry],
       Property -> Property),
      MockChainState ConwayEra)
forall era a.
MockchainIO era a
-> NodeParams era
-> MockChainState era
-> IO (a, MockChainState era)
runMockchainIO (SigningWallet
-> ThreatModel ()
-> [ThreatModelEnv]
-> MockchainIO
     ConwayEra
     (ThreatModelOutcome, [ThreatModelCheckEntry], Property -> Property)
forall (m :: * -> *) a.
(MonadMockchain ConwayEra m, MonadFail m, MonadIO m) =>
SigningWallet
-> ThreatModel a
-> [ThreatModelEnv]
-> m (ThreatModelOutcome, [ThreatModelCheckEntry],
      Property -> Property)
runThreatModelCheckTraced SigningWallet
AutoSign ThreatModel ()
tm [ThreatModelEnv]
envs) NodeParams ConwayEra
params MockChainState ConwayEra
state0
          (ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
 [ThreatModelCheckEntry], CoverageData, Property -> Property)
-> IO
     (ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
      [ThreatModelCheckEntry], CoverageData, Property -> Property)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreatModelId
tmid, ThreatModelCategory
category, ThreatModelOutcome
outcome, [ThreatModelCheckEntry]
traceEntries, MockChainState ConwayEra -> CoverageData
forall era. MockChainState era -> CoverageData
mcsCoverageData MockChainState ConwayEra
tmFinalState, Property -> Property
monitors)

    (state, [Transition],
 [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
   [ThreatModelCheckEntry], CoverageData, Property -> Property)])
-> TestingMonadT
     (PropertyM IO)
     (state, [Transition],
      [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
        [ThreatModelCheckEntry], CoverageData, Property -> Property)])
forall a. a -> TestingMonadT (PropertyM IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (state
finalState, [Transition]
transitions, [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData, Property -> Property)]
tmResultsWithCov)

  case (Either
   (BalanceTxError ConwayEra)
   (state, [Transition],
    [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
      [ThreatModelCheckEntry], CoverageData, Property -> Property)]),
 MockChainState ConwayEra)
result of
    (Left BalanceTxError ConwayEra
err, MockChainState{CoverageData
mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData :: CoverageData
mcsCoverageData}) -> do
      let covData :: CoverageData
covData = CoverageData
mcsCoverageData CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> BalanceTxError ConwayEra -> CoverageData
forall e. BalanceTxError e -> CoverageData
coverageFromBalanceTxError BalanceTxError ConwayEra
err
      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)
      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 -> [SrcLocRange] -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"positive" (CoverageData -> [SrcLocRange]
covDataToSrcLocRanges CoverageData
covData) (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, [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData, Property -> Property)]
tmResultsWithCov), MockChainState{CoverageData
mcsCoverageData :: forall era. MockChainState era -> CoverageData
mcsCoverageData :: CoverageData
mcsCoverageData}) -> do
      let covData :: CoverageData
covData = CoverageData
mcsCoverageData CoverageData -> CoverageData -> CoverageData
forall a. Semigroup a => a -> a -> a
<> [CoverageData] -> CoverageData
forall a. Monoid a => [a] -> a
mconcat [CoverageData
cov | (ThreatModelId
_, ThreatModelCategory
_, ThreatModelOutcome
_, [ThreatModelCheckEntry]
_, CoverageData
cov, Property -> Property
_) <- [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData, Property -> Property)]
tmResultsWithCov]
      (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 -> ShowS
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)) 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
          let tmResults :: [(ThreatModelId, (ThreatModelOutcome, [String]))]
tmResults = [(ThreatModelId
n, ThreatModelOutcome
-> [ThreatModelCheckEntry] -> (ThreatModelOutcome, [String])
summarizeThreatModelIteration ThreatModelOutcome
o [ThreatModelCheckEntry]
entries) | (ThreatModelId
n, ThreatModelCategory
_, ThreatModelOutcome
o, [ThreatModelCheckEntry]
entries, CoverageData
_, Property -> Property
_) <- [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData, Property -> Property)]
tmResultsWithCov]
          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
 -> (ThreatModelId, (ThreatModelOutcome, [String]))
 -> ThreatModelResults)
-> ThreatModelResults
-> [(ThreatModelId, (ThreatModelOutcome, [String]))]
-> 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 (ThreatModelId
name, (ThreatModelOutcome, [String])
outcomeAndEntries) -> ([(ThreatModelOutcome, [String])]
 -> [(ThreatModelOutcome, [String])]
 -> [(ThreatModelOutcome, [String])])
-> ThreatModelId
-> [(ThreatModelOutcome, [String])]
-> ThreatModelResults
-> ThreatModelResults
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(ThreatModelOutcome, [String])]
-> [(ThreatModelOutcome, [String])]
-> [(ThreatModelOutcome, [String])]
forall a. Semigroup a => a -> a -> a
(<>) ThreatModelId
name [(ThreatModelOutcome, [String])
outcomeAndEntries] ThreatModelResults
m)
              ThreatModelResults
existing
              [(ThreatModelId, (ThreatModelOutcome, [String]))]
tmResults
        Maybe (IO (IORef ThreatModelResults))
Nothing -> () -> PropertyM IO ()
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      [ThreatModelTrace]
tmTraces <- IO [ThreatModelTrace] -> PropertyM IO [ThreatModelTrace]
forall a. IO a -> PropertyM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ThreatModelTrace] -> PropertyM IO [ThreatModelTrace])
-> IO [ThreatModelTrace] -> PropertyM IO [ThreatModelTrace]
forall a b. (a -> b) -> a -> b
$ (String -> IO (Maybe Int))
-> RedeemerTagger
-> AddressLabeler
-> [(String, ThreatModelCategory, ThreatModelOutcome,
     [ThreatModelCheckEntry], CoverageData)]
-> IO [ThreatModelTrace]
toThreatModelTraces (TraceRecorder -> String -> String -> IO (Maybe Int)
findTestIdIO TraceRecorder
recorder String
groupName) (forall state. TestingInterface state => RedeemerTagger
redeemerTagger @state) (forall state. TestingInterface state => AddressLabeler
addressLabeler @state) [(ThreatModelId -> String
tmiName ThreatModelId
n, ThreatModelCategory
cat, ThreatModelOutcome
o, [ThreatModelCheckEntry]
e, CoverageData
c) | (ThreatModelId
n, ThreatModelCategory
cat, ThreatModelOutcome
o, [ThreatModelCheckEntry]
e, CoverageData
c, Property -> Property
_) <- [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData, Property -> Property)]
tmResultsWithCov]
      let 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 -> [SrcLocRange] -> Value -> IO ()
recordIteration TraceRecorder
recorder String
groupName String
"positive" (CoverageData -> [SrcLocRange]
covDataToSrcLocRanges CoverageData
mcsCoverageData) (IterationTrace -> Value
forall a. ToJSON a => a -> Value
toJSON IterationTrace
trace)
      let allMonitors :: Property -> Property
allMonitors = ((Property -> Property)
 -> (Property -> Property) -> Property -> Property)
-> (Property -> Property)
-> [Property -> Property]
-> Property
-> Property
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) Property -> Property
forall a. a -> a
id [Property -> Property
m | (ThreatModelId
_, ThreatModelCategory
_, ThreatModelOutcome
_, [ThreatModelCheckEntry]
_, CoverageData
_, Property -> Property
m) <- [(ThreatModelId, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData, Property -> Property)]
tmResultsWithCov]
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor Property -> Property
allMonitors
      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))
  -> [(ThreatModelCategory, ThreatModel ())]
  -> PropertyM IO Property
positiveTestFast :: forall state.
TestingInterface state =>
RunOptions
-> Maybe (IO (IORef ThreatModelResults))
-> [(ThreatModelCategory, ThreatModel ())]
-> PropertyM IO Property
positiveTestFast RunOptions
opts Maybe (IO (IORef ThreatModelResults))
mGetTmResultsRef [(ThreatModelCategory, ThreatModel ())]
tms = 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, [(ThreatModelId, (ThreatModelOutcome, [String]))],
    CoverageData, [Property -> Property]),
 MockChainState ConwayEra)
result <- NodeParams ConwayEra
-> TestingMonadT
     (PropertyM IO)
     (state, [(ThreatModelId, (ThreatModelOutcome, [String]))],
      CoverageData, [Property -> Property])
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra)
        (state, [(ThreatModelId, (ThreatModelOutcome, [String]))],
         CoverageData, [Property -> Property]),
      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, [(ThreatModelId, (ThreatModelOutcome, [String]))],
    CoverageData, [Property -> Property])
 -> PropertyM
      IO
      (Either
         (BalanceTxError ConwayEra)
         (state, [(ThreatModelId, (ThreatModelOutcome, [String]))],
          CoverageData, [Property -> Property]),
       MockChainState ConwayEra))
-> TestingMonadT
     (PropertyM IO)
     (state, [(ThreatModelId, (ThreatModelOutcome, [String]))],
      CoverageData, [Property -> Property])
-> PropertyM
     IO
     (Either
        (BalanceTxError ConwayEra)
        (state, [(ThreatModelId, (ThreatModelOutcome, [String]))],
         CoverageData, [Property -> Property]),
      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
    [Tx ConwayEra]
initTxs <- TestingMonadT (PropertyM IO) [Tx ConwayEra]
forall era (m :: * -> *).
(MonadMockchain era m, IsShelleyBasedEra era) =>
m [Tx era]
getTxs
    MockChainState ConwayEra
state0 <- TestingMonadT (PropertyM IO) (MockChainState ConwayEra)
forall s (m :: * -> *). MonadState s m => m s
get

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

    [Tx ConwayEra]
allTxs <- TestingMonadT (PropertyM IO) [Tx ConwayEra]
forall era (m :: * -> *).
(MonadMockchain era m, IsShelleyBasedEra era) =>
m [Tx era]
getTxs
    let envs :: [ThreatModelEnv]
envs = NodeParams ConwayEra
-> [Tx ConwayEra] -> MockChainState ConwayEra -> [ThreatModelEnv]
threatModelEnvs NodeParams ConwayEra
params (Int -> [Tx ConwayEra] -> [Tx ConwayEra]
forall a. Int -> [a] -> [a]
drop ([Tx ConwayEra] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx ConwayEra]
initTxs) ([Tx ConwayEra] -> [Tx ConwayEra])
-> [Tx ConwayEra] -> [Tx ConwayEra]
forall a b. (a -> b) -> a -> b
$ [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 allToRun :: [(ThreatModelCategory, ThreatModel ())]
allToRun = ThreatModelResults
-> [(ThreatModelCategory, ThreatModel ())]
-> [(ThreatModelCategory, ThreatModel ())]
modelsForIteration ThreatModelResults
existingResults [(ThreatModelCategory, ThreatModel ())]
tms
    -- An iteration that generated no transactions records no outcomes at
    -- all: running the models over an empty env list would record a
    -- TMSkipped per model, indistinguishable from a genuine precondition
    -- miss, and the vacuity check would blame model applicability for what
    -- is a test-generation issue. With nothing recorded, an all-empty run
    -- reports "No tests were generated by positive tests" instead.
    [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
  Property -> Property)]
tmResultsWithCov <-
      if [ThreatModelEnv] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ThreatModelEnv]
envs
        then [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
  Property -> Property)]
-> TestingMonadT
     (PropertyM IO)
     [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
       Property -> Property)]
forall a. a -> TestingMonadT (PropertyM IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        else IO
  [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
    Property -> Property)]
-> TestingMonadT
     (PropertyM IO)
     [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
       Property -> Property)]
forall a. IO a -> TestingMonadT (PropertyM IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
     Property -> Property)]
 -> TestingMonadT
      (PropertyM IO)
      [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
        Property -> Property)])
-> IO
     [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
       Property -> Property)]
-> TestingMonadT
     (PropertyM IO)
     [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
       Property -> Property)]
forall a b. (a -> b) -> a -> b
$ [(ThreatModelCategory, ThreatModel ())]
-> ((ThreatModelCategory, ThreatModel ())
    -> IO
         (ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
          Property -> Property))
-> IO
     [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
       Property -> Property)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ThreatModelCategory, ThreatModel ())]
allToRun (((ThreatModelCategory, ThreatModel ())
  -> IO
       (ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
        Property -> Property))
 -> IO
      [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
        Property -> Property)])
-> ((ThreatModelCategory, ThreatModel ())
    -> IO
         (ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
          Property -> Property))
-> IO
     [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
       Property -> Property)]
forall a b. (a -> b) -> a -> b
$ \(ThreatModelCategory
category, ThreatModel ()
tm) -> do
          let tmid :: ThreatModelId
tmid = ThreatModelCategory -> String -> ThreatModelId
ThreatModelId ThreatModelCategory
category (ThreatModel () -> String
modelName ThreatModel ()
tm)
          ((ThreatModelOutcome
outcome, [ThreatModelCheckEntry]
traceEntries, Property -> Property
monitors), MockChainState ConwayEra
tmFinalState) <-
            MockchainIO
  ConwayEra
  (ThreatModelOutcome, [ThreatModelCheckEntry], Property -> Property)
-> NodeParams ConwayEra
-> MockChainState ConwayEra
-> IO
     ((ThreatModelOutcome, [ThreatModelCheckEntry],
       Property -> Property),
      MockChainState ConwayEra)
forall era a.
MockchainIO era a
-> NodeParams era
-> MockChainState era
-> IO (a, MockChainState era)
runMockchainIO (SigningWallet
-> ThreatModel ()
-> [ThreatModelEnv]
-> MockchainIO
     ConwayEra
     (ThreatModelOutcome, [ThreatModelCheckEntry], Property -> Property)
forall (m :: * -> *) a.
(MonadMockchain ConwayEra m, MonadFail m, MonadIO m) =>
SigningWallet
-> ThreatModel a
-> [ThreatModelEnv]
-> m (ThreatModelOutcome, [ThreatModelCheckEntry],
      Property -> Property)
runThreatModelCheckTraced SigningWallet
AutoSign ThreatModel ()
tm [ThreatModelEnv]
envs) NodeParams ConwayEra
params MockChainState ConwayEra
state0
          -- Summarise here, not at the use site. This path keeps no trace,
          -- so nothing downstream reads the entries - but each one holds two
          -- transactions and two UTxO sets, and left as a thunk they would
          -- stay reachable from the results 'IORef' until the per-model test
          -- cases run, long after the last iteration.
          (ThreatModelOutcome, [String])
summary <- (ThreatModelOutcome, [String]) -> IO (ThreatModelOutcome, [String])
forall a. a -> IO a
evaluate (ThreatModelOutcome
-> [ThreatModelCheckEntry] -> (ThreatModelOutcome, [String])
summarizeThreatModelIteration ThreatModelOutcome
outcome [ThreatModelCheckEntry]
traceEntries)
          (ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
 Property -> Property)
-> IO
     (ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
      Property -> Property)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreatModelId
tmid, (ThreatModelOutcome, [String])
summary, MockChainState ConwayEra -> CoverageData
forall era. MockChainState era -> CoverageData
mcsCoverageData MockChainState ConwayEra
tmFinalState, Property -> Property
monitors)

    let tmResults :: [(ThreatModelId, (ThreatModelOutcome, [String]))]
tmResults = [(ThreatModelId
n, (ThreatModelOutcome, [String])
summary) | (ThreatModelId
n, (ThreatModelOutcome, [String])
summary, CoverageData
_, Property -> Property
_) <- [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
  Property -> Property)]
tmResultsWithCov]
        tmCoverage :: CoverageData
tmCoverage = [CoverageData] -> CoverageData
forall a. Monoid a => [a] -> a
mconcat [CoverageData
cov | (ThreatModelId
_, (ThreatModelOutcome, [String])
_, CoverageData
cov, Property -> Property
_) <- [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
  Property -> Property)]
tmResultsWithCov]
        tmMonitors :: [Property -> Property]
tmMonitors = [Property -> Property
m | (ThreatModelId
_, (ThreatModelOutcome, [String])
_, CoverageData
_, Property -> Property
m) <- [(ThreatModelId, (ThreatModelOutcome, [String]), CoverageData,
  Property -> Property)]
tmResultsWithCov]

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

  case (Either
   (BalanceTxError ConwayEra)
   (state, [(ThreatModelId, (ThreatModelOutcome, [String]))],
    CoverageData, [Property -> Property]),
 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, [(ThreatModelId, (ThreatModelOutcome, [String]))]
tmResults, CoverageData
tmCoverage, [Property -> Property]
tmMonitors), 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 -> ShowS
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
 -> (ThreatModelId, (ThreatModelOutcome, [String]))
 -> ThreatModelResults)
-> ThreatModelResults
-> [(ThreatModelId, (ThreatModelOutcome, [String]))]
-> 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 (ThreatModelId
name, (ThreatModelOutcome, [String])
outcomeAndEntries) -> ([(ThreatModelOutcome, [String])]
 -> [(ThreatModelOutcome, [String])]
 -> [(ThreatModelOutcome, [String])])
-> ThreatModelId
-> [(ThreatModelOutcome, [String])]
-> ThreatModelResults
-> ThreatModelResults
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(ThreatModelOutcome, [String])]
-> [(ThreatModelOutcome, [String])]
-> [(ThreatModelOutcome, [String])]
forall a. Semigroup a => a -> a -> a
(<>) ThreatModelId
name [(ThreatModelOutcome, [String])
outcomeAndEntries] ThreatModelResults
m)
              ThreatModelResults
existing
              [(ThreatModelId, (ThreatModelOutcome, [String]))]
tmResults
        Maybe (IO (IORef ThreatModelResults))
Nothing -> () -> PropertyM IO ()
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      let allMonitors :: Property -> Property
allMonitors = ((Property -> Property)
 -> (Property -> Property) -> Property -> Property)
-> (Property -> Property)
-> [Property -> Property]
-> Property
-> Property
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) Property -> Property
forall a. a -> a
id [Property -> Property]
tmMonitors
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor Property -> Property
allMonitors
      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)

{- | The part every per-model test case does the same way: look the model's
recorded outcomes up under its slot-qualified key, tally them, surface any
errors as warnings, record the summary, and dispatch the two cases that mean
the same thing in every slot — no transactions at all, and none the model
could be tried on.

Only the tested case differs by slot, so that is all a caller supplies:
zero coverage is reported the same way everywhere, by 'reportZeroCoverage',
which is where the per-slot meaning of "nothing applied" lives. The summary
is recorded here, before the verdict runs, so that a verdict which fails
can re-record it with a fault (see 'failWithFault') and win.
-}
perModelCase
  :: ThreatModelCategory
  -> IO (IORef ThreatModelResults)
  -> String
  -- ^ Tasty group name (for keying summaries)
  -> ThreatModel ()
  -> ((String -> IO ()) -> TMRecorder -> String -> ThreatModelSummary -> [(ThreatModelOutcome, [String])] -> IO ())
  -- ^ What to do when the model was actually tested
  -> TestTree
perModelCase :: ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> ThreatModel ()
-> ((String -> IO ())
    -> TMRecorder
    -> String
    -> ThreatModelSummary
    -> [(ThreatModelOutcome, [String])]
    -> IO ())
-> TestTree
perModelCase ThreatModelCategory
claim IO (IORef ThreatModelResults)
getTmResultsRef String
groupName ThreatModel ()
tm (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
onTested =
  let name :: String
name = ThreatModel () -> String
modelName ThreatModel ()
tm
      key :: String
key = String
groupName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
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 outcomeEntries :: [(ThreatModelOutcome, [String])]
outcomeEntries = [(ThreatModelOutcome, [String])]
-> Maybe [(ThreatModelOutcome, [String])]
-> [(ThreatModelOutcome, [String])]
forall a. a -> Maybe a -> a
fromMaybe [] (ThreatModelId
-> ThreatModelResults -> Maybe [(ThreatModelOutcome, [String])]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ThreatModelCategory -> String -> ThreatModelId
ThreatModelId ThreatModelCategory
claim String
name) ThreatModelResults
allResults)
              outcomes :: [ThreatModelOutcome]
outcomes = ((ThreatModelOutcome, [String]) -> ThreatModelOutcome)
-> [(ThreatModelOutcome, [String])] -> [ThreatModelOutcome]
forall a b. (a -> b) -> [a] -> [b]
map (ThreatModelOutcome, [String]) -> ThreatModelOutcome
forall a b. (a, b) -> a
fst [(ThreatModelOutcome, [String])]
outcomeEntries
              summary :: ThreatModelSummary
summary = ThreatModelCategory
-> String -> [ThreatModelOutcome] -> ThreatModelSummary
tallyOutcomes ThreatModelCategory
claim String
name [ThreatModelOutcome]
outcomes
              ThreatModelSummary{tmsTotal :: ThreatModelSummary -> Int
tmsTotal = Int
total, tmsTested :: ThreatModelSummary -> Int
tmsTested = Int
tested} = ThreatModelSummary
summary

          -- Errors are warnings: they say nothing either way about the verdict.
          (String -> IO ()) -> [ThreatModelOutcome] -> IO ()
reportErrors String -> IO ()
step [ThreatModelOutcome]
outcomes
          TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary

          if Int
total Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
            then String -> IO ()
step String
"No tests were generated by positive tests"
            else
              if Int
tested Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                then (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelCategory
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
reportZeroCoverage String -> IO ()
step TMRecorder
recorder String
key ThreatModelCategory
claim ThreatModelSummary
summary [(ThreatModelOutcome, [String])]
outcomeEntries
                else (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
onTested String -> IO ()
step TMRecorder
recorder String
key ThreatModelSummary
summary [(ThreatModelOutcome, [String])]
outcomeEntries

-- | Create a test case for displaying threat model results
threatModelTestCase
  :: ThreatModelCategory
  {- ^ Which slot the model was declared in, which is what the suite claims
  about it (see 'propRunActionsWithOptions')
  -}
  -> IO (IORef ThreatModelResults)
  -> String
  -- ^ Tasty group name (for keying summaries)
  -> DeclaredModel
  -- ^ The threat model, and the reason its slot records
  -> TestTree
threatModelTestCase :: ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> (ThreatModel (), String)
-> TestTree
threatModelTestCase ThreatModelCategory
claim IO (IORef ThreatModelResults)
getTmResultsRef String
groupName (ThreatModel ()
tm, String
_noReason) =
  ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> ThreatModel ()
-> ((String -> IO ())
    -> TMRecorder
    -> String
    -> ThreatModelSummary
    -> [(ThreatModelOutcome, [String])]
    -> IO ())
-> TestTree
perModelCase ThreatModelCategory
claim IO (IORef ThreatModelResults)
getTmResultsRef String
groupName ThreatModel ()
tm (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
onTested
 where
  onTested :: (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
onTested String -> IO ()
step TMRecorder
recorder String
key ThreatModelSummary
summary [(ThreatModelOutcome, [String])]
outcomeEntries = do
    let outcomes :: [ThreatModelOutcome]
outcomes = ((ThreatModelOutcome, [String]) -> ThreatModelOutcome)
-> [(ThreatModelOutcome, [String])] -> [ThreatModelOutcome]
forall a b. (a -> b) -> [a] -> [b]
map (ThreatModelOutcome, [String]) -> ThreatModelOutcome
forall a b. (a, b) -> a
fst [(ThreatModelOutcome, [String])]
outcomeEntries
        ThreatModelSummary{tmsTotal :: ThreatModelSummary -> Int
tmsTotal = Int
total, tmsPassed :: ThreatModelSummary -> Int
tmsPassed = Int
numPassed} = ThreatModelSummary
summary
    String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Tested " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numPassed String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
total String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" tests (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ThreatModelSummary -> String
skipCounts ThreatModelSummary
summary String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
    case [String
msg | TMFailed String
msg <- [ThreatModelOutcome]
outcomes] of
      [] ->
        -- The contract held, but a surveyed model claims nothing until it
        -- is triaged: point at the slot that turns this run into a check.
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ThreatModelCategory
claim ThreatModelCategory -> ThreatModelCategory -> Bool
forall a. Eq a => a -> a -> Bool
== ThreatModelCategory
Surveyed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> IO ()
step String
"  Untriaged: the contract resisted it - move it to 'threatModels' to claim that resistance."
      (String
firstFailure : [String]
rest) ->
        TMRecorder
-> String -> ThreatModelSummary -> Fault -> [String] -> IO ()
failWithFault TMRecorder
recorder String
key ThreatModelSummary
summary (if ThreatModelCategory
claim ThreatModelCategory -> ThreatModelCategory -> Bool
forall a. Eq a => a -> a -> Bool
== ThreatModelCategory
Surveyed then Fault
Declaration else Fault
Contract) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [ if ThreatModelCategory
claim ThreatModelCategory -> ThreatModelCategory -> Bool
forall a. Eq a => a -> a -> Bool
== ThreatModelCategory
Surveyed
              then String
"an untriaged model detected a vulnerability after " String -> ShowS
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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" tests."
              else String
"vulnerability detected after " String -> ShowS
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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" tests."
          , case ThreatModelCategory
claim of
              -- Nobody asked for this model, so the run demands a triage
              -- decision rather than a contract fix.
              ThreatModelCategory
Surveyed ->
                String
"  It is in 'candidateModels'. Move it to 'threatModels' if the contract should resist it, or to 'expectedVulnerabilities' / 'acceptedFindings' with a reason."
              ThreatModelCategory
_ ->
                String
"  'threatModels' claims the contract resists this."
          , String
""
          , String
firstFailure
          ]
            [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"... and " String -> ShowS
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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" more similar failure(s) suppressed" | Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
rest)]

{- | Build a test case for a finding the suite has already triaged: an
expected vulnerability ('ThreatModelsFor.expectedVulnerabilities') or an
accepted finding ('ThreatModelsFor.acceptedFindings').

Both are declarations of the same shape — "this attack lands here, and I
have decided what that means" — so they are judged identically: inverted
pass/fail (a detection is the required outcome), always run against every
transaction rather than early-stopping, quiet output, and a 'Declaration'
failure when the run disproves the declaration or never verifies it.

What differs is only what the declaration *means*, and that has to stay
legible: an expected vulnerability says the contract has a bug nobody has
fixed, an accepted finding says the attack lands on something harmless. The
slot carries that distinction into the reports and into the streamed
'ThreatModelCategory', and it picks the wording below; it must not decide
the policy, or the two drift apart again.
-}
triagedFindingTestCase
  :: ThreatModelCategory
  {- ^ Which slot the model was declared in, which is what the suite claims
  about it (see 'propRunActionsWithOptions')
  -}
  -> IO (IORef ThreatModelResults)
  -> String
  -- ^ Tasty group name (for keying summaries)
  -> DeclaredModel
  -- ^ The triaged model, and the reason its slot records
  -> TestTree
triagedFindingTestCase :: ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> (ThreatModel (), String)
-> TestTree
triagedFindingTestCase ThreatModelCategory
claim IO (IORef ThreatModelResults)
getTmResultsRef String
groupName (ThreatModel ()
tm, String
why) =
  ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> ThreatModel ()
-> ((String -> IO ())
    -> TMRecorder
    -> String
    -> ThreatModelSummary
    -> [(ThreatModelOutcome, [String])]
    -> IO ())
-> TestTree
perModelCase ThreatModelCategory
claim IO (IORef ThreatModelResults)
getTmResultsRef String
groupName ThreatModel ()
tm (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
onTested
 where
  accepted :: Bool
accepted = ThreatModelCategory
claim ThreatModelCategory -> ThreatModelCategory -> Bool
forall a. Eq a => a -> a -> Bool
== ThreatModelCategory
Accepted
  onTested :: (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
onTested String -> IO ()
step TMRecorder
recorder String
key ThreatModelSummary
summary [(ThreatModelOutcome, [String])]
outcomeEntries = do
    let ThreatModelSummary{tmsTotal :: ThreatModelSummary -> Int
tmsTotal = Int
total, tmsFailed :: ThreatModelSummary -> Int
tmsFailed = Int
numFound, tmsTested :: ThreatModelSummary -> Int
tmsTested = Int
tested} = ThreatModelSummary
summary
        validationErrors :: [String]
validationErrors = [(ThreatModelOutcome, [String])] -> [String]
distinctValidationErrors [(ThreatModelOutcome, [String])]
outcomeEntries
        validationErrorLines :: [String]
validationErrorLines = case [String]
validationErrors of
          [] -> []
          [String]
_ ->
            let ([String]
shown, [String]
remaining) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
3 [String]
validationErrors
             in [String
"Validation errors:"]
                  [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [String]
shown
                  [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"  ... and " String -> ShowS
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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" more" | Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
remaining)]
    if Int
numFound Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then
        String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          if Bool
accepted
            then String
"Finding detected (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numFound String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
tested String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" tests, " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ThreatModelSummary -> String
skipCounts ThreatModelSummary
summary String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") - accepted by design, not counted as a vulnerability: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
why
            else String
"Vulnerability detected (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numFound String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
total String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" tests, " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ThreatModelSummary -> String
skipCounts ThreatModelSummary
summary String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
      else
        -- The run disproves the declaration: the attack no longer lands. Same
        -- fault in both slots; only the consequence for the reader differs.
        TMRecorder
-> String -> ThreatModelSummary -> Fault -> [String] -> IO ()
failWithFault TMRecorder
recorder String
key ThreatModelSummary
summary Fault
Declaration ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
          ( if Bool
accepted
              then
                [ String
"NO LONGER DETECTED - this finding no longer occurs (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
tested String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
total String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" transactions attacked)."
                , String
"  It was accepted as a benign artifact; that acceptance is now stale."
                , String
"  Remove it from 'acceptedFindings', or move it to 'threatModels' to"
                , String
"  assert the contract resists it."
                , String
"  Accepted because: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
why
                ]
              else
                [ String
"RESOLVED - this vulnerability is no longer detected (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
tested String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
total String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" transactions attacked)."
                , String
"  Good news for the contract; this declaration is now stale."
                , String
"  Move it to 'threatModels' if the contract now resists it, to"
                , String
"  'acceptedFindings' if the finding was benign, or remove it."
                , String
"  Declared because: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
why
                ]
          )
            [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
validationErrorLines

{- | Tally one threat model's per-iteration outcomes into its summary. The
category records which 'ThreatModelsFor' list the model came from, so that a
consumer of the summary can tell a 'tmsFailed' count that means
"vulnerability" ('Claimed') from one that means "detected as expected"
('Expected') or "accepted by design" ('Accepted'). Shared by all three
per-model test cases.
-}
tallyOutcomes :: ThreatModelCategory -> String -> [ThreatModelOutcome] -> ThreatModelSummary
tallyOutcomes :: ThreatModelCategory
-> String -> [ThreatModelOutcome] -> ThreatModelSummary
tallyOutcomes ThreatModelCategory
category String
name [ThreatModelOutcome]
outcomes =
  ThreatModelSummary
    { tmsName :: Text
tmsName = String -> Text
T.pack String
name
    , tmsCategory :: ThreatModelCategory
tmsCategory = ThreatModelCategory
category
    , tmsTested :: Int
tmsTested = Int
numPassed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numFailed
    , tmsTotal :: Int
tmsTotal = [ThreatModelOutcome] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ThreatModelOutcome]
outcomes
    , tmsPassed :: Int
tmsPassed = Int
numPassed
    , tmsFailed :: Int
tmsFailed = Int
numFailed
    , tmsSkipped :: Int
tmsSkipped = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | ThreatModelOutcome
TMSkipped <- [ThreatModelOutcome]
outcomes]
    , tmsSkippedPhase1 :: Int
tmsSkippedPhase1 = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | ThreatModelOutcome
TMSkippedPhase1 <- [ThreatModelOutcome]
outcomes]
    , tmsErrors :: Int
tmsErrors = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | TMError String
_ <- [ThreatModelOutcome]
outcomes]
    , tmsFault :: Maybe Fault
tmsFault = Maybe Fault
forall a. Maybe a
Nothing
    }
 where
  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]

{- | Fail a threat-model test case, naming whose fault it is on the first
line of the message and on the recorded summary — or naming none, when the
run does not yet establish one.

A detection on a 'Surveyed' model is the declaration's fault, not the
contract's: whatever the triage later concludes, the action the run demands
is to put the model in a slot. Attributing it to the contract would page
whoever routes on @fault@ for a finding nobody has classified yet.

A detection on a 'NotApplicable' model is the contract's, and the
difference is what each slot knows. 'Surveyed' carries no prior, so the
finding may always have been there and may be benign. 'NotApplicable'
records that the model could not apply here at all, so a detection means
both that it now applies and that the contract accepted the attack - which
is what introducing a vulnerability looks like. Making the two agree would
throw that prior away.

Only one cell of the slot-by-outcome matrix is the contract's fault, so a
bare failure is routinely misread as "the contract is broken" when it means
"this declaration is stale". Recording it too lets a dashboard route the
two apart without parsing prose.
-}
failWithFault :: TMRecorder -> String -> ThreatModelSummary -> Fault -> [String] -> IO ()
failWithFault :: TMRecorder
-> String -> ThreatModelSummary -> Fault -> [String] -> IO ()
failWithFault TMRecorder
recorder String
key ThreatModelSummary
summary Fault
fault [String]
ls = do
  TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord TMRecorder
recorder String
key ThreatModelSummary
summary{tmsFault = Just fault}
  String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ case [String]
ls of
    (String
firstLine : [String]
rest) -> (Fault -> String
faultLabel Fault
fault String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
firstLine) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rest
    [] -> [Fault -> String
faultLabel Fault
fault]

{- | Report the errors among the outcomes as warning steps, never failing the
test: the count, the first three messages, and how many more there were.
-}
reportErrors :: (String -> IO ()) -> [ThreatModelOutcome] -> IO ()
reportErrors :: (String -> IO ()) -> [ThreatModelOutcome] -> IO ()
reportErrors String -> IO ()
step [ThreatModelOutcome]
outcomes = case [String
msg | TMError String
msg <- [ThreatModelOutcome]
outcomes] of
  [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  [String]
errors -> do
    -- Count the erroring iterations, not the distinct messages: 100
    -- iterations failing the same way is a systematic fault, and the status
    -- line below reports the same 100 via 'skipCounts'. Only what is
    -- printed is deduplicated.
    String -> IO ()
step (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: " String -> ShowS
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]
errors) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" error(s) during threat model execution"
    let distinct :: [String]
distinct = [ThreatModelOutcome] -> [String]
modelErrors [ThreatModelOutcome]
outcomes
    (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 ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
3 [String]
distinct)
    case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
3 [String]
distinct 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 -> ShowS
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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" more"

{- | The distinct messages of the errors the model itself raised, as opposed
to the ledger's verdicts on the modified transactions: these come from
'TMError', which is reached before any precondition is evaluated.
-}
modelErrors :: [ThreatModelOutcome] -> [String]
modelErrors :: [ThreatModelOutcome] -> [String]
modelErrors [ThreatModelOutcome]
outcomes = [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String
msg | TMError String
msg <- [ThreatModelOutcome]
outcomes]

-- | The skip and error counts as they appear inside every status line's parentheses.
skipCounts :: ThreatModelSummary -> String
skipCounts :: ThreatModelSummary -> String
skipCounts ThreatModelSummary
summary =
  Int -> String
forall a. Show a => a -> String
show (ThreatModelSummary -> Int
tmsSkipped ThreatModelSummary
summary)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" precondition skipped, "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ThreatModelSummary -> Int
tmsSkippedPhase1 ThreatModelSummary
summary)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" phase 1/rebalance skipped, "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ThreatModelSummary -> Int
tmsErrors ThreatModelSummary
summary)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" errors"

{- | The status line for a run where the model was never tested: every
outcome was a precondition miss, an environmental skip (phase 1
invalidation / rebalancing failure), or an error. Shared by all three
per-model test cases; the wording says which of the three it was.
-}
skippedMessage :: ThreatModelSummary -> String
skippedMessage :: ThreatModelSummary -> String
skippedMessage ThreatModelSummary
summary = case ThreatModelSummary -> ZeroCoverageKind
zeroCoverageKind ThreatModelSummary
summary of
  ZeroCoverageKind
PreconditionNeverMet -> String -> ShowS
line String
"Precondition never met" String
"applicable"
  ZeroCoverageKind
AttackNeverCarriedOut -> String -> ShowS
line String
"Attack never carried out" String
"carried out"
  ZeroCoverageKind
ModelErrored -> String -> ShowS
line String
"Threat model errored" String
"completed"
 where
  -- The verb carries the distinction: only in the first case was nothing
  -- "applicable". In the other two the model DID apply to some transaction,
  -- so saying nothing was applicable would name the wrong fault.
  line :: String -> ShowS
line String
headline String
verb =
    String
"SKIPPED: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
headline
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" ("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ThreatModelSummary -> String
skipCounts ThreatModelSummary
summary
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", 0/"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ThreatModelSummary -> Int
tmsTotal ThreatModelSummary
summary)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" tests "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
verb
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

-- | The three ways a model ends up with zero attack coverage.
data ZeroCoverageKind
  = -- | The model applied to no generated transaction at all
    PreconditionNeverMet
  | {- | The model applied to some transaction, but every attempt ended in a
    Phase 1 invalidation or a rebalancing failure
    -}
    AttackNeverCarriedOut
  | {- | The model itself errored (e.g. no signing wallet could be detected),
    which happens before any precondition is evaluated
    -}
    ModelErrored

{- | Which of the three it was. An environmental skip proves the precondition
held at least once, so it outranks an error, which says nothing either way.
-}
zeroCoverageKind :: ThreatModelSummary -> ZeroCoverageKind
zeroCoverageKind :: ThreatModelSummary -> ZeroCoverageKind
zeroCoverageKind ThreatModelSummary
summary
  | ThreatModelSummary -> Int
tmsSkippedPhase1 ThreatModelSummary
summary Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = ZeroCoverageKind
AttackNeverCarriedOut
  | ThreatModelSummary -> Int
tmsErrors ThreatModelSummary
summary Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = ZeroCoverageKind
ModelErrored
  | Bool
otherwise = ZeroCoverageKind
PreconditionNeverMet

{- | Build a test case for a model declared not to apply (see
'ThreatModelsFor.notApplicable'). The inverse of 'threatModelTestCase':
never applying is the passing outcome, and applying at all fails, because
the declaration predicted that it could not.

That is the whole value of the slot. Deleting a model from the lists
records the same triage decision somewhere nothing can check it, so a
contract that later grows the surface the model looks for - or a harness
change that widens what counts as applicable - goes unnoticed.
-}
notApplicableTestCase
  :: ThreatModelCategory
  {- ^ Which slot the model was declared in, which is what the suite claims
  about it (see 'propRunActionsWithOptions')
  -}
  -> IO (IORef ThreatModelResults)
  -> String
  -- ^ Tasty group name (for keying summaries)
  -> DeclaredModel
  -- ^ The threat model declared not to apply, and why
  -> TestTree
notApplicableTestCase :: ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> (ThreatModel (), String)
-> TestTree
notApplicableTestCase ThreatModelCategory
claim IO (IORef ThreatModelResults)
getTmResultsRef String
groupName (ThreatModel ()
tm, String
why) =
  ThreatModelCategory
-> IO (IORef ThreatModelResults)
-> String
-> ThreatModel ()
-> ((String -> IO ())
    -> TMRecorder
    -> String
    -> ThreatModelSummary
    -> [(ThreatModelOutcome, [String])]
    -> IO ())
-> TestTree
perModelCase ThreatModelCategory
claim IO (IORef ThreatModelResults)
getTmResultsRef String
groupName ThreatModel ()
tm (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
onTested
 where
  {- Unlike a 'Surveyed' hit, this slot carries a prior: the model was
  recorded as unable to apply here. A detection therefore means two things
  changed at once - the model now applies, and the contract accepted the
  attack - which in practice is someone having introduced the vulnerability.
  So this is the contract's fault, where an untriaged survey hit (which
  carries no prior, and may always have been benign) is the declaration's.
  Detection here is 'tmsFailed', i.e. the mutated transaction still
  validated. -}
  onTested :: (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
onTested String -> IO ()
_step TMRecorder
recorder String
key ThreatModelSummary
summary [(ThreatModelOutcome, [String])]
_entries
    | ThreatModelSummary -> Int
tmsFailed ThreatModelSummary
summary Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
        TMRecorder
-> String -> ThreatModelSummary -> Fault -> [String] -> IO ()
failWithFault TMRecorder
recorder String
key ThreatModelSummary
summary Fault
Contract ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [ String
"VULNERABLE - a model recorded as not applicable now applies, and the contract"
          , String
"  accepted its attack (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ThreatModelSummary -> Int
tmsFailed ThreatModelSummary
summary) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ThreatModelSummary -> Int
tmsTested ThreatModelSummary
summary) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" attacked transactions)."
          , String
"  This contract previously had no surface for it, so the likely cause is a"
          , String
"  change that introduced the vulnerability. Fix the contract."
          , String
"  Once it resists the attack, move the model to 'threatModels'."
          , String
"  Declared not applicable because: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
why
          ]
    | Bool
otherwise =
        TMRecorder
-> String -> ThreatModelSummary -> Fault -> [String] -> IO ()
failWithFault TMRecorder
recorder String
key ThreatModelSummary
summary Fault
Declaration ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [ String
"APPLIES NOW - tested on " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ThreatModelSummary -> Int
tmsTested ThreatModelSummary
summary) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ThreatModelSummary -> Int
tmsTotal ThreatModelSummary
summary) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" transactions, but listed in 'notApplicable'."
          , String
"  The contract resisted the attack, so this is a stale declaration rather"
          , String
"  than a bug: the contract grew a surface this model looks for, or the"
          , String
"  harness widened what counts as applicable."
          , String
"  Move it to 'threatModels' to claim that resistance."
          , String
"  Declared not applicable because: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
why
          ]

{- | The coverage policy for a model that was never tested (no outcome was
'TMPassed' or 'TMFailed'): 'Left' a failure message, or 'Right' the status
lines to report instead.

A claimed model promises that the contract resists the attack, an expected
vulnerability that it does not; either promise is unchecked when the attack
was never carried out, whatever the reason:

* 'PreconditionNeverMet': the model does not apply to any generated
  transaction. For a model the suite declared - 'Claimed', 'Expected' or
  'Accepted' - that is a fault in the test setup (it advertises coverage it
  cannot have), so it fails. A 'Surveyed' model was never declared, so there
  it is only reported, and for 'NotApplicable' it is the confirming outcome.

* 'AttackNeverCarriedOut': the precondition held somewhere, but every
  attempt hit a Phase 1 invalidation or a rebalancing failure. Per
  iteration these are environmental skips and never fail anything (a
  harness limit is not a contract bug), but a model skipped this way on
  EVERY iteration provides exactly as much coverage as one never run.

* 'ModelErrored': the model never got as far as a precondition, so the
  suite learned nothing at all.

In the latter two the declared slots fail, naming the distinct reasons so
the setup can be fixed; a 'Surveyed' model gets a loud warning instead,
since the user did not opt into it and failing would block them on a
limitation they may not be able to lift.

An 'Accepted' finding is judged exactly like an 'Expected' one: the
acceptance is a declaration too, so a run that never verifies it fails,
naming the same reasons.

Before this policy, the failure was guarded by "every skip was a
precondition miss", so a single environmental skip silenced it and a model
that never rebalanced stayed green forever.
-}
zeroCoverageVerdict :: ThreatModelCategory -> ThreatModelSummary -> [String] -> Either (Fault, String) [String]
zeroCoverageVerdict :: ThreatModelCategory
-> ThreatModelSummary
-> [String]
-> Either (Fault, String) [String]
zeroCoverageVerdict ThreatModelCategory
claim ThreatModelSummary
summary [String]
reasons = case ThreatModelCategory
claim of
  -- A surveyed model was never declared, so one that simply does not apply
  -- to this contract is reported, not failed; the other kinds still warn,
  -- since the user did not opt in and may not be able to lift a harness
  -- limitation.
  --
  -- Either way the model is still untriaged, so the status lines end with
  -- where it should go next - the same nudge a surveyed detection gets.
  ThreatModelCategory
Surveyed
    | ZeroCoverageKind
PreconditionNeverMet <- ZeroCoverageKind
kind ->
        [String] -> Either (Fault, String) [String]
forall a b. b -> Either a b
Right
          [ ThreatModelSummary -> String
skippedMessage ThreatModelSummary
summary
          , String
"  Untriaged: move it to 'notApplicable' with a reason if it cannot apply to this contract, or make the positive tests generate transactions it applies to."
          ]
    | Bool
otherwise ->
        [String] -> Either (Fault, String) [String]
forall a b. b -> Either a b
Right ([String] -> Either (Fault, String) [String])
-> [String] -> Either (Fault, String) [String]
forall a b. (a -> b) -> a -> b
$
          (String
"WARNING: zero attack coverage - " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
headline String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".")
            String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
withReasons String
"  The model provides no evidence about this contract"
              [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"  Untriaged: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
untriagedRemedy]
  -- Never applying is what this slot predicts, so only a precondition miss
  -- confirms it. An environmental skip proves the precondition held at least
  -- once, which falsifies the declaration; an error leaves it unverified.
  ThreatModelCategory
NotApplicable -> case ZeroCoverageKind
kind of
    ZeroCoverageKind
PreconditionNeverMet -> [String] -> Either (Fault, String) [String]
forall a b. b -> Either a b
Right [String
"Confirmed not applicable: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
headline]
    ZeroCoverageKind
ModelErrored ->
      [String] -> Either (Fault, String) [String]
forall a b. b -> Either a b
Right ([String] -> Either (Fault, String) [String])
-> [String] -> Either (Fault, String) [String]
forall a b. (a -> b) -> a -> b
$
        (String
"WARNING: not confirmed - " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
headline String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".")
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
withReasons String
"  The model never reached a precondition, so nothing here shows whether it applies"
    ZeroCoverageKind
AttackNeverCarriedOut ->
      (Fault, String) -> Either (Fault, String) [String]
forall a b. a -> Either a b
Left
        ( Fault
Declaration
        , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            (String
"APPLIES NOW - the precondition held, but no attack was carried out: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
headline String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".")
              String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
withReasons String
"  The model applies here, which is what 'notApplicable' denies. Move it to 'threatModels' and fix whatever stops the attack being built, or keep it here only if you can say why the precondition is spurious"
        )
  ThreatModelCategory
Claimed ->
    String -> String -> Either (Fault, String) [String]
failure
      (String -> ShowS
lead String
"Threat model never applied" String
"Threat model never tested")
      (String
"Zero attack coverage means the claim in 'threatModels' is unchecked. " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
remedy String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", move it to 'notApplicable' with a reason, or remove it")
  ThreatModelCategory
Expected ->
    String -> String -> Either (Fault, String) [String]
failure
      (String -> ShowS
lead String
"Expected vulnerability never exercised" String
"Expected vulnerability never tested")
      (String
"Nothing confirms the vulnerability listed in 'expectedVulnerabilities'. " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
remedy String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", or remove it")
  ThreatModelCategory
Accepted ->
    String -> String -> Either (Fault, String) [String]
failure
      (String -> ShowS
lead String
"Accepted finding never applied" String
"Accepted finding never tested")
      (String
"Nothing confirms the finding listed in 'acceptedFindings', so the acceptance suppresses a model that proves nothing. " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
remedy String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", or remove it")
 where
  kind :: ZeroCoverageKind
kind = ThreatModelSummary -> ZeroCoverageKind
zeroCoverageKind ThreatModelSummary
summary
  -- A model that never applied is a claim you cannot have; one that applied
  -- but could not be attacked is a limit of the generator or the harness.
  faultOfKind :: Fault
faultOfKind = case ZeroCoverageKind
kind of
    ZeroCoverageKind
PreconditionNeverMet -> Fault
Declaration
    ZeroCoverageKind
_ -> Fault
Setup
  failure :: String -> String -> Either (Fault, String) [String]
failure String
opening String
advice = (Fault, String) -> Either (Fault, String) [String]
forall a b. a -> Either a b
Left (Fault
faultOfKind, [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String
opening String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
headline String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
withReasons String
advice)
  -- A model that never applied is a different fault from one that applied and
  -- could not be attacked, and the opening line is what a reader sees first.
  lead :: String -> ShowS
lead String
neverApplied String
neverTested = case ZeroCoverageKind
kind of
    ZeroCoverageKind
PreconditionNeverMet -> String
neverApplied
    ZeroCoverageKind
_ -> String
neverTested
  counts :: String
counts = String
" on any of the " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ThreatModelSummary -> Int
tmsTotal ThreatModelSummary
summary) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" generated transactions (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ThreatModelSummary -> String
skipCounts ThreatModelSummary
summary String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  headline :: String
headline = case ZeroCoverageKind
kind of
    ZeroCoverageKind
PreconditionNeverMet -> String
"the precondition was not met" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
counts
    ZeroCoverageKind
AttackNeverCarriedOut -> String
"the precondition held, but the attack could not be carried out" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
counts
    ZeroCoverageKind
ModelErrored -> String
"the model errored before it could attack anything" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
counts
  remedy :: String
remedy = case ZeroCoverageKind
kind of
    ZeroCoverageKind
PreconditionNeverMet -> String
"Make the positive tests generate transactions it applies to"
    ZeroCoverageKind
AttackNeverCarriedOut -> String
"Make the positive tests produce transactions the attack can be built on"
    ZeroCoverageKind
ModelErrored -> String
"Fix the error so the model can run"
  -- 'notApplicable' is deliberately not offered for an environmental skip:
  -- the precondition held, so that declaration would fail as APPLIES NOW.
  untriagedRemedy :: String
untriagedRemedy = case ZeroCoverageKind
kind of
    ZeroCoverageKind
AttackNeverCarriedOut -> String
remedy String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", then move it to 'threatModels' (not 'notApplicable': its precondition does hold)."
    ZeroCoverageKind
_ -> String
remedy String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."
  -- Never leave the sentence hanging on a colon: a Phase 1 rejection can
  -- carry no error message at all.
  withReasons :: String -> [String]
withReasons String
line
    | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
reasons = [String
line String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."]
    | Bool
otherwise =
        (String
line String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":")
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: let ([String]
shown, [String]
remaining) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
5 [String]
reasons
             in ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  - " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [String]
shown
                  [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"  ... and " String -> ShowS
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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" more" | Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
remaining)]

{- | Apply the zero-coverage policy and report it: a failure fails the test
case, status lines are reported as steps. The single place that says what
counts as a reason - the model's own errors, plus the ledger's verdicts on
whatever it did manage to submit.
-}
reportZeroCoverage :: (String -> IO ()) -> TMRecorder -> String -> ThreatModelCategory -> ThreatModelSummary -> [(ThreatModelOutcome, [String])] -> IO ()
reportZeroCoverage :: (String -> IO ())
-> TMRecorder
-> String
-> ThreatModelCategory
-> ThreatModelSummary
-> [(ThreatModelOutcome, [String])]
-> IO ()
reportZeroCoverage String -> IO ()
step TMRecorder
recorder String
key ThreatModelCategory
claim ThreatModelSummary
summary [(ThreatModelOutcome, [String])]
outcomeEntries =
  ((Fault, String) -> IO ())
-> ([String] -> IO ()) -> Either (Fault, String) [String] -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (\(Fault
fault, String
msg) -> TMRecorder
-> String -> ThreatModelSummary -> Fault -> [String] -> IO ()
failWithFault TMRecorder
recorder String
key ThreatModelSummary
summary Fault
fault (String -> [String]
lines String
msg))
    ((String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
step)
    (Either (Fault, String) [String] -> IO ())
-> Either (Fault, String) [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreatModelCategory
-> ThreatModelSummary
-> [String]
-> Either (Fault, String) [String]
zeroCoverageVerdict ThreatModelCategory
claim ThreatModelSummary
summary
    ([String] -> Either (Fault, String) [String])
-> [String] -> Either (Fault, String) [String]
forall a b. (a -> b) -> a -> b
$ [ThreatModelOutcome] -> [String]
modelErrors (((ThreatModelOutcome, [String]) -> ThreatModelOutcome)
-> [(ThreatModelOutcome, [String])] -> [ThreatModelOutcome]
forall a b. (a -> b) -> [a] -> [b]
map (ThreatModelOutcome, [String]) -> ThreatModelOutcome
forall a b. (a, b) -> a
fst [(ThreatModelOutcome, [String])]
outcomeEntries) [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [(ThreatModelOutcome, [String])] -> [String]
distinctValidationErrors [(ThreatModelOutcome, [String])]
outcomeEntries

{- | Reduce an iteration's trace entries to the outcome and the distinct
error strings they yielded.

Forcing the result to WHNF forces the strings too, which is what lets a
caller that has no further use for the entries drop them: they are the only
thing holding the iteration's transactions and UTxO sets alive.
-}
summarizeThreatModelIteration :: ThreatModelOutcome -> [ThreatModelCheckEntry] -> (ThreatModelOutcome, [String])
summarizeThreatModelIteration :: ThreatModelOutcome
-> [ThreatModelCheckEntry] -> (ThreatModelOutcome, [String])
summarizeThreatModelIteration ThreatModelOutcome
outcome [ThreatModelCheckEntry]
entries =
  Int
totalLength Int
-> (ThreatModelOutcome, [String]) -> (ThreatModelOutcome, [String])
forall a b. a -> b -> b
`seq` (ThreatModelOutcome
outcome, [String]
msgs)
 where
  msgs :: [String]
msgs = [ThreatModelCheckEntry] -> [String]
distinctValidationErrorsFromEntries [ThreatModelCheckEntry]
entries
  totalLength :: Int
totalLength = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
msgs)

distinctValidationErrorsFromEntries :: [ThreatModelCheckEntry] -> [String]
distinctValidationErrorsFromEntries :: [ThreatModelCheckEntry] -> [String]
distinctValidationErrorsFromEntries [ThreatModelCheckEntry]
entries =
  [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd
    [ String
msg
    | ThreatModelCheckEntry
entry <- [ThreatModelCheckEntry]
entries
    , String
msg <-
        [String]
-> (ValidityReport -> [String]) -> Maybe ValidityReport -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ValidityReport -> [String]
errors (ThreatModelCheckEntry -> Maybe ValidityReport
tmceValidation ThreatModelCheckEntry
entry)
          [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
e -> [String
"Rebalancing failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e]) (ThreatModelCheckEntry -> Maybe String
tmceRebalanceError ThreatModelCheckEntry
entry)
    ]

distinctValidationErrors :: [(ThreatModelOutcome, [String])] -> [String]
distinctValidationErrors :: [(ThreatModelOutcome, [String])] -> [String]
distinctValidationErrors [(ThreatModelOutcome, [String])]
outcomeEntries =
  [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String
msg | (ThreatModelOutcome
_, [String]
msgs) <- [(ThreatModelOutcome, [String])]
outcomeEntries, String
msg <- [String]
msgs]

{- | Generate up to 'maxActions' actions and run them. Stops early when no
action satisfying the precondition can be generated.
-}
runActions
  :: (TestingInterface state, MonadIO m)
  => RunOptions
  -> state
  -> TestingMonadT (PropertyM m) state
runActions :: forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions -> state -> TestingMonadT (PropertyM m) state
runActions RunOptions
opts = Int -> state -> TestingMonadT (PropertyM m) state
go (RunOptions -> Int
maxActions RunOptions
opts)
 where
  go :: Int -> state -> TestingMonadT (PropertyM m) state
go 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
  go 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
>>= Int -> state -> TestingMonadT (PropertyM m) state
go (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 -> ShowS
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 -> ShowS
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
  :: forall state m
   . (TestingInterface state, MonadIO m)
  => RunOptions
  -> state
  -> TestingMonadT (PropertyM m) (state, [Transition])
runActionsTraced :: forall state (m :: * -> *).
(TestingInterface state, MonadIO m) =>
RunOptions
-> state -> TestingMonadT (PropertyM m) (state, [Transition])
runActionsTraced RunOptions
opts state
initialState = Int
-> state
-> [Transition]
-> TestingMonadT (PropertyM m) (state, [Transition])
go Int
0 state
initialState []
 where
  tagger :: RedeemerTagger
tagger = forall state. TestingInterface state => RedeemerTagger
redeemerTagger @state
  labeler :: AddressLabeler
labeler = forall state. TestingInterface state => AddressLabeler
addressLabeler @state
  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
>= RunOptions -> Int
maxActions RunOptions
opts = (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 <- RedeemerTagger
-> AddressLabeler
-> Map TxId (Tx ConwayEra)
-> UTxO ConwayEra
-> TestingMonadT (PropertyM m) (Maybe TxSummary)
forall (m :: * -> *).
MonadMockchain ConwayEra m =>
RedeemerTagger
-> AddressLabeler
-> Map TxId (Tx ConwayEra)
-> UTxO ConwayEra
-> m (Maybe TxSummary)
getLastTxSummary RedeemerTagger
tagger AddressLabeler
labeler 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)
  => RedeemerTagger
  -> AddressLabeler
  -> 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 =>
RedeemerTagger
-> AddressLabeler
-> Map TxId (Tx ConwayEra)
-> UTxO ConwayEra
-> m (Maybe TxSummary)
getLastTxSummary RedeemerTagger
tagger AddressLabeler
labeler 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 (RedeemerTagger
-> AddressLabeler -> Tx ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTx RedeemerTagger
tagger AddressLabeler
labeler 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 -> IO (Maybe Int))
  -> RedeemerTagger
  -> AddressLabeler
  -> [(String, ThreatModelCategory, ThreatModelOutcome, [ThreatModelCheckEntry], CoverageData)]
  -> IO [ThreatModelTrace]
toThreatModelTraces :: (String -> IO (Maybe Int))
-> RedeemerTagger
-> AddressLabeler
-> [(String, ThreatModelCategory, ThreatModelOutcome,
     [ThreatModelCheckEntry], CoverageData)]
-> IO [ThreatModelTrace]
toThreatModelTraces String -> IO (Maybe Int)
findTestId RedeemerTagger
tagger AddressLabeler
labeler [(String, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData)]
results = [[ThreatModelTrace]] -> [ThreatModelTrace]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ThreatModelTrace]] -> [ThreatModelTrace])
-> IO [[ThreatModelTrace]] -> IO [ThreatModelTrace]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData)
 -> IO [ThreatModelTrace])
-> [(String, ThreatModelCategory, ThreatModelOutcome,
     [ThreatModelCheckEntry], CoverageData)]
-> IO [[ThreatModelTrace]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String, ThreatModelCategory, ThreatModelOutcome,
 [ThreatModelCheckEntry], CoverageData)
-> IO [ThreatModelTrace]
go [(String, ThreatModelCategory, ThreatModelOutcome,
  [ThreatModelCheckEntry], CoverageData)]
results
 where
  go :: (String, ThreatModelCategory, ThreatModelOutcome,
 [ThreatModelCheckEntry], CoverageData)
-> IO [ThreatModelTrace]
go (String
name, ThreatModelCategory
category, ThreatModelOutcome
outcome, [], CoverageData
covData) = do
    Maybe Int
mtestId <- String -> IO (Maybe Int)
findTestId String
name
    -- No Validate calls: emit a single lightweight trace with just the outcome
    [ThreatModelTrace] -> IO [ThreatModelTrace]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [ ThreatModelTrace
          { tmtName :: Text
tmtName = String -> Text
T.pack String
name
          , tmtCategory :: ThreatModelCategory
tmtCategory = ThreatModelCategory
category
          , tmtTestId :: Int
tmtTestId = Int
testId
          , tmtTargetTxIndex :: Int
tmtTargetTxIndex = Int
0
          , tmtModifications :: [Value]
tmtModifications = []
          , tmtOriginalTx :: TxSummary
tmtOriginalTx = TxSummary
emptyTxSummary
          , tmtModifiedTx :: Maybe TxSummary
tmtModifiedTx = Maybe TxSummary
forall a. Maybe a
Nothing
          , tmtValidation :: Maybe ThreatModelValidation
tmtValidation = Maybe ThreatModelValidation
forall a. Maybe a
Nothing
          , tmtOutcome :: ThreatModelTraceOutcome
tmtOutcome = ThreatModelOutcome -> ThreatModelTraceOutcome
outcomeToTrace ThreatModelOutcome
outcome
          , tmtCovered :: [SrcLocRange]
tmtCovered = CoverageData -> [SrcLocRange]
covDataToSrcLocRanges CoverageData
covData
          }
      | Just Int
testId <- [Maybe Int
mtestId] -- when no test id is found, the test is filtered out and we also don't want to output a trace.
      ]
  go (String
name, ThreatModelCategory
category, ThreatModelOutcome
outcome, [ThreatModelCheckEntry]
entries, CoverageData
covData) = do
    Maybe Int
mtestId <- String -> IO (Maybe Int)
findTestId String
name
    -- One ThreatModelTrace per Validate call
    [ThreatModelTrace] -> IO [ThreatModelTrace]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [ ThreatModelTrace
          { tmtName :: Text
tmtName = String -> Text
T.pack String
name
          , tmtCategory :: ThreatModelCategory
tmtCategory = ThreatModelCategory
category
          , tmtTestId :: Int
tmtTestId = Int
testId
          , tmtTargetTxIndex :: Int
tmtTargetTxIndex = ThreatModelCheckEntry -> Int
tmceEnvIndex ThreatModelCheckEntry
entry
          , tmtModifications :: [Value]
tmtModifications = TxModifier -> [Value]
renderModifications (ThreatModelCheckEntry -> TxModifier
tmceModifications ThreatModelCheckEntry
entry)
          , tmtOriginalTx :: TxSummary
tmtOriginalTx = RedeemerTagger
-> AddressLabeler -> Tx ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTx RedeemerTagger
tagger AddressLabeler
labeler (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 (RedeemerTagger
-> AddressLabeler -> Tx ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTx RedeemerTagger
tagger AddressLabeler
labeler Tx ConwayEra
tx (ThreatModelCheckEntry -> UTxO ConwayEra
tmceModifiedUtxo ThreatModelCheckEntry
entry))
              Maybe (Tx ConwayEra)
Nothing -> Maybe TxSummary
forall a. Maybe a
Nothing
          , tmtValidation :: Maybe ThreatModelValidation
tmtValidation = ThreatModelCheckEntry -> Maybe ThreatModelValidation
entryValidation ThreatModelCheckEntry
entry
          , tmtOutcome :: ThreatModelTraceOutcome
tmtOutcome = ThreatModelOutcome -> ThreatModelTraceOutcome
outcomeToTrace ThreatModelOutcome
outcome
          , tmtCovered :: [SrcLocRange]
tmtCovered = CoverageData -> [SrcLocRange]
covDataToSrcLocRanges CoverageData
covData
          }
      | ThreatModelCheckEntry
entry <- [ThreatModelCheckEntry]
entries
      , Just Int
testId <- [Maybe Int
mtestId] -- when no test id is found, the test is filtered out and we also don't want to output a trace.
      ]

  entryValidation :: ThreatModelCheckEntry -> Maybe ThreatModelValidation
entryValidation ThreatModelCheckEntry
entry = case (ThreatModelCheckEntry -> Maybe ValidityReport
tmceValidation ThreatModelCheckEntry
entry, ThreatModelCheckEntry -> Maybe String
tmceRebalanceError ThreatModelCheckEntry
entry) of
    (Just ValidityReport
report, Maybe String
_) ->
      -- Deduplicated like every other rendering of this list
      -- ('distinctValidationErrorsFromEntries', and the counterexample in
      -- 'Convex.ThreatModel'): n inputs locked by the same script report the
      -- same multi-hundred-byte error n times.
      let distinctErrors :: [Text]
distinctErrors = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd (ValidityReport -> [String]
errors ValidityReport
report))
       in ThreatModelValidation -> Maybe ThreatModelValidation
forall a. a -> Maybe a
Just (ThreatModelValidation -> Maybe ThreatModelValidation)
-> ThreatModelValidation -> Maybe ThreatModelValidation
forall a b. (a -> b) -> a -> b
$ case ValidityReport -> TxValidity
validity ValidityReport
report of
            TxValidity
Valid -> ThreatModelValidation
TMVValid
            TxValidity
Phase1Invalid -> [Text] -> ThreatModelValidation
TMVPhase1Invalid [Text]
distinctErrors
            TxValidity
Phase2Invalid -> [Text] -> ThreatModelValidation
TMVPhase2Invalid [Text]
distinctErrors
    (Maybe ValidityReport
Nothing, Just String
err) -> ThreatModelValidation -> Maybe ThreatModelValidation
forall a. a -> Maybe a
Just (Text -> ThreatModelValidation
TMVRebalanceFailed (String -> Text
T.pack String
err))
    -- Not expected: 'runThreatModelCheckTraced' always sets exactly one of the
    -- two. Report the verdict as unknown rather than inventing one.
    (Maybe ValidityReport
Nothing, Maybe String
Nothing) -> Maybe ThreatModelValidation
forall a. Maybe a
Nothing

  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 ThreatModelOutcome
TMSkippedPhase1 = Text -> ThreatModelTraceOutcome
TMTOSkippedPhase1 Text
"phase 1 invalidation or rebalancing failure"
  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 (AddressLabeler -> TxMod -> Value
renderTxMod AddressLabeler
labeler) [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
      , txsWithdrawals :: [TxWithdrawalSummary]
txsWithdrawals = []
      }

{- | 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
withMaxTxSizeHint (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ 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 = Text -> Text
withMaxTxSizeHint (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ 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 -> ShowS
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

{- | Pass coverage index data to tasty-streaming.

@
main = defaultMainStreaming $ withCoverageIndices [covIdx] tests
@
-}
withCoverageIndices :: [CoverageIndex] -> TestTree -> TestTree
withCoverageIndices :: [CoverageIndex] -> TestTree -> TestTree
withCoverageIndices [CoverageIndex]
idxs = CoverageIndexStorage -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (CoverageIndexStorage -> TestTree -> TestTree)
-> CoverageIndexStorage -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ [SrcLocRange] -> CoverageIndexStorage
CoverageIndexStorage ([SrcLocRange] -> CoverageIndexStorage)
-> [SrcLocRange] -> CoverageIndexStorage
forall a b. (a -> b) -> a -> b
$ CoverageData -> [SrcLocRange]
covDataToSrcLocRanges (CoverageData -> [SrcLocRange]) -> CoverageData -> [SrcLocRange]
forall a b. (a -> b) -> a -> b
$ Set CoverageAnnotation -> CoverageData
CoverageData (Set CoverageAnnotation -> CoverageData)
-> Set CoverageAnnotation -> CoverageData
forall a b. (a -> b) -> a -> b
$ [CoverageIndex] -> CoverageIndex
forall a. Monoid a => [a] -> a
mconcat [CoverageIndex]
idxs 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

-- | Convert Plutus coverage data to a format suitable for tasty-streaming.
covDataToSrcLocRanges :: CoverageData -> [SrcLocRange]
covDataToSrcLocRanges :: CoverageData -> [SrcLocRange]
covDataToSrcLocRanges (CoverageData Set CoverageAnnotation
anns) = [Maybe SrcLocRange] -> [SrcLocRange]
forall a. [Maybe a] -> [a]
catMaybes ((CoverageAnnotation -> Maybe SrcLocRange)
-> [CoverageAnnotation] -> [Maybe SrcLocRange]
forall a b. (a -> b) -> [a] -> [b]
map CoverageAnnotation -> Maybe SrcLocRange
toSrcLocRange ([CoverageAnnotation] -> [Maybe SrcLocRange])
-> [CoverageAnnotation] -> [Maybe SrcLocRange]
forall a b. (a -> b) -> a -> b
$ Set CoverageAnnotation -> [CoverageAnnotation]
forall a. Set a -> [a]
Set.toList Set CoverageAnnotation
anns)
 where
  toSrcLocRange :: CoverageAnnotation -> Maybe SrcLocRange
toSrcLocRange (CoverLocation (CovLoc String
f Int
sl Int
el Int
sc Int
ec)) = SrcLocRange -> Maybe SrcLocRange
forall a. a -> Maybe a
Just (Text -> Int -> Int -> Int -> Int -> SrcLocRange
SrcLocRange (String -> Text
T.pack String
f) Int
sl Int
sc Int
el Int
ec)
  toSrcLocRange (CoverBool CovLoc
_ Bool
_) = Maybe SrcLocRange
forall a. Maybe a
Nothing

{- | 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 -> ShowS
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
      -- Don't do anything if there's no coverage data.
      -- Then maybe no tests ran (f.e. with --list-tests-json),
      -- or the coverage has been handled differently (f.e. with --streaming-json).
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CoverageData
covData CoverageData -> CoverageData -> Bool
forall a. Eq a => a -> a -> Bool
== CoverageData
forall a. Monoid a => a
mempty) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
withMaxTxSizeHint (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
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