{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.Chain.Direct.HandlersSpec where

import Hydra.Prelude hiding (label)

import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
import Control.Tracer (nullTracer)
import Hydra.Cardano.Api (
  BlockHeader (..),
  ChainPoint (..),
  ExecutionUnits (..),
  ScriptExecutionError (..),
  ScriptWitnessIndex (..),
  SerialiseAsCBOR (serialiseToCBOR),
  SlotNo (..),
  Tx,
  UTxO,
  fromLedgerTx,
  getChainPoint,
  toLedgerTx,
 )
import Hydra.Cardano.Api.Gen (genTxIn)
import Test.Gen.Cardano.Api.Typed (genBlockHeader)
import Test.QuickCheck.Hedgehog (hedgehog)

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Api (IsValid (..), isValidTxL, ppMaxTxSizeL)
import Control.Lens ((.~))
import Data.ByteString qualified as BS
import Data.Map.Strict qualified as Map
import Hydra.Chain (ChainEvent (..), OnChainTx (..), PostTxError (..), currentState, initHistory, maximumNumberOfParties)
import Hydra.Chain.ChainState (chainStateSlot)
import Hydra.Chain.Direct.Handlers (
  ChainSyncHandler (..),
  GetTimeHandle,
  TimeConversionException (..),
  chainSyncHandler,
  findFittingFanoutTx,
  findLargestFitting,
  fitsTx,
  getLatest,
  history,
  newLocalChainState,
  rejectOversizedDeposit,
 )
import Hydra.Chain.Direct.State (
  ChainContext (..),
  ChainStateAt (..),
  ClosedState (..),
  OpenState (..),
  chainSlotFromPoint,
  ctxNetworkId,
  getKnownUTxO,
  initialChainState,
  initialize,
 )
import Hydra.Chain.Direct.TimeHandle (TimeHandle (slotToUTCTime), TimeHandleParams (..), mkTimeHandle)
import Hydra.Chain.Direct.Wallet (TinyWallet (..))
import Hydra.Ledger.Cardano.Evaluate (EvaluationError (..), EvaluationReport)
import Hydra.Ledger.Cardano.Time (slotNoToUTCTime)
import Hydra.Tx (ConfirmedSnapshot (..), mkSimpleBlueprintTx)
import Hydra.Tx.Deposit (depositTx)
import Hydra.Tx.Observe (InitObservation (..), observeInitTx)
import System.IO.Error (ioeGetErrorString, userError)
import Test.Hydra.Chain ()
import Test.Hydra.Chain.Direct.State (
  ctxHeadParameters,
  ctxParticipants,
  deriveChainContexts,
  genChainStateWithTx,
  genClosedStateForFanout,
  genDepositTx,
  genDepositTxWith,
  genHydraContext,
  pickChainContext,
 )
import Test.Hydra.Chain.Direct.State qualified as Transition
import Test.Hydra.Chain.Direct.TimeHandle (genTimeParams)
import Test.Hydra.Ledger.Cardano.Fixtures (evaluateTx, maxTxSize, pparamsWithMainnetValueLimit)
import Test.Hydra.Node.Fixture qualified as Fixture
import Test.Hydra.Prelude
import Test.Hydra.Tx.Fixture (defaultPParams)
import Test.Hydra.Tx.Gen (genUTxOAdaOnlyOfSize, genUTxOWithUniquePolicyTokensOfSize)
import Test.QuickCheck (
  NonNegative (..),
  Positive (..),
  choose,
  chooseEnum,
  counterexample,
  cover,
  elements,
  forAll,
  forAllBlind,
  generate,
  label,
  listOf,
  oneof,
  property,
  suchThat,
  (===),
 )
import Test.QuickCheck.Monadic (
  assert,
  monadicIO,
  monitor,
  pick,
  run,
  stop,
 )

genTimeHandleWithSlotInsideHorizon :: Gen (TimeHandle, SlotNo)
genTimeHandleWithSlotInsideHorizon :: Gen (TimeHandle, SlotNo)
genTimeHandleWithSlotInsideHorizon = do
  TimeHandleParams{SystemStart
systemStart :: SystemStart
$sel:systemStart:TimeHandleParams :: TimeHandleParams -> SystemStart
systemStart, EraHistory
eraHistory :: EraHistory
$sel:eraHistory:TimeHandleParams :: TimeHandleParams -> EraHistory
eraHistory, SlotNo
horizonSlot :: SlotNo
$sel:horizonSlot:TimeHandleParams :: TimeHandleParams -> SlotNo
horizonSlot, SlotNo
currentSlot :: SlotNo
$sel:currentSlot:TimeHandleParams :: TimeHandleParams -> SlotNo
currentSlot} <- Gen TimeHandleParams
genTimeParams
  let timeHandle :: TimeHandle
timeHandle = SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
currentSlot SystemStart
systemStart EraHistory
eraHistory
  (TimeHandle, SlotNo) -> Gen (TimeHandle, SlotNo)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandle
timeHandle, SlotNo
horizonSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
1)

genTimeHandleWithSlotPastHorizon :: Gen (TimeHandle, SlotNo)
genTimeHandleWithSlotPastHorizon :: Gen (TimeHandle, SlotNo)
genTimeHandleWithSlotPastHorizon = do
  TimeHandleParams{SystemStart
$sel:systemStart:TimeHandleParams :: TimeHandleParams -> SystemStart
systemStart :: SystemStart
systemStart, EraHistory
$sel:eraHistory:TimeHandleParams :: TimeHandleParams -> EraHistory
eraHistory :: EraHistory
eraHistory, SlotNo
$sel:horizonSlot:TimeHandleParams :: TimeHandleParams -> SlotNo
horizonSlot :: SlotNo
horizonSlot, SlotNo
$sel:currentSlot:TimeHandleParams :: TimeHandleParams -> SlotNo
currentSlot :: SlotNo
currentSlot} <- Gen TimeHandleParams
genTimeParams
  let timeHandle :: TimeHandle
timeHandle = SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
currentSlot SystemStart
systemStart EraHistory
eraHistory
  (TimeHandle, SlotNo) -> Gen (TimeHandle, SlotNo)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandle
timeHandle, SlotNo
horizonSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)

spec :: Spec
spec :: Spec
spec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"chainSyncHandler" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"roll forward results in Tick events" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
        (TimeHandle
timeHandle, SlotNo
slot) <- Gen (TimeHandle, SlotNo) -> PropertyM IO (TimeHandle, SlotNo)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen (TimeHandle, SlotNo)
genTimeHandleWithSlotInsideHorizon
        TestBlock BlockHeader
header [Tx]
txs <- Gen TestBlock -> PropertyM IO TestBlock
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen TestBlock -> PropertyM IO TestBlock)
-> Gen TestBlock -> PropertyM IO TestBlock
forall a b. (a -> b) -> a -> b
$ SlotNo -> [Tx] -> Gen TestBlock
genBlockAt SlotNo
slot []

        ChainContext
chainContext <- Gen ChainContext -> PropertyM IO ChainContext
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen ChainContext
forall a. Arbitrary a => Gen a
arbitrary
        ChainStateAt
chainState <- Gen ChainStateAt -> PropertyM IO ChainStateAt
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen ChainStateAt
forall a. Arbitrary a => Gen a
arbitrary

        (ChainSyncHandler IO
handler, IO [ChainEvent Tx]
getEvents) <- IO (ChainSyncHandler IO, IO [ChainEvent Tx])
-> PropertyM IO (ChainSyncHandler IO, IO [ChainEvent Tx])
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (ChainSyncHandler IO, IO [ChainEvent Tx])
 -> PropertyM IO (ChainSyncHandler IO, IO [ChainEvent Tx]))
-> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
-> PropertyM IO (ChainSyncHandler IO, IO [ChainEvent Tx])
forall a b. (a -> b) -> a -> b
$ ChainContext
-> ChainStateAt
-> (SlotNo -> GetTimeHandle IO)
-> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
recordEventsHandler ChainContext
chainContext ChainStateAt
chainState (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. a -> b -> a
const (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO)
-> GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. (a -> b) -> a -> b
$ TimeHandle -> GetTimeHandle IO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeHandle
timeHandle)

        Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> BlockHeader -> [Tx] -> Expectation
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler IO
handler BlockHeader
header [Tx]
txs

        [ChainEvent Tx]
events <- IO [ChainEvent Tx] -> PropertyM IO [ChainEvent Tx]
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run IO [ChainEvent Tx]
getEvents
        (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"events: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ChainEvent Tx] -> String
forall b a. (Show a, IsString b) => a -> b
show [ChainEvent Tx]
events)

        UTCTime
expectedUTCTime <-
          IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO UTCTime -> PropertyM IO UTCTime)
-> IO UTCTime -> PropertyM IO UTCTime
forall a b. (a -> b) -> a -> b
$
            (Text -> IO UTCTime)
-> (UTCTime -> IO UTCTime) -> Either Text UTCTime -> IO UTCTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO UTCTime
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO UTCTime) -> (Text -> String) -> Text -> IO UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Time conversion failed: " <>) (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString) UTCTime -> IO UTCTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text UTCTime -> IO UTCTime)
-> Either Text UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$
              TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime TimeHandle
timeHandle SlotNo
slot
        let (BlockHeader SlotNo
_ Hash BlockHeader
blockHash BlockNo
_) = BlockHeader
header
        PropertyM IO Any -> PropertyM IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PropertyM IO Any -> PropertyM IO ())
-> (Property -> PropertyM IO Any) -> Property -> PropertyM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> PropertyM IO Any
forall prop (m :: * -> *) a.
(Testable prop, Monad m) =>
prop -> PropertyM m a
stop (Property -> PropertyM IO ()) -> Property -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ [ChainEvent Tx]
events [ChainEvent Tx] -> [ChainEvent Tx] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [UTCTime -> ChainPointType Tx -> ChainEvent Tx
forall tx. UTCTime -> ChainPointType tx -> ChainEvent tx
Tick UTCTime
expectedUTCTime (SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
slot Hash BlockHeader
blockHash)]

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"roll forward fails with outdated TimeHandle" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
        (TimeHandle
timeHandle, SlotNo
slot) <- Gen (TimeHandle, SlotNo) -> PropertyM IO (TimeHandle, SlotNo)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen (TimeHandle, SlotNo)
genTimeHandleWithSlotPastHorizon
        TestBlock BlockHeader
header [Tx]
txs <- Gen TestBlock -> PropertyM IO TestBlock
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen TestBlock -> PropertyM IO TestBlock)
-> Gen TestBlock -> PropertyM IO TestBlock
forall a b. (a -> b) -> a -> b
$ SlotNo -> [Tx] -> Gen TestBlock
genBlockAt SlotNo
slot []

        ChainContext
chainContext <- Gen ChainContext -> PropertyM IO ChainContext
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen ChainContext
forall a. Arbitrary a => Gen a
arbitrary
        ChainStateHistory Tx
chainState <- Gen (ChainStateHistory Tx) -> PropertyM IO (ChainStateHistory Tx)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen (ChainStateHistory Tx)
forall a. Arbitrary a => Gen a
arbitrary
        LocalChainState IO Tx
localChainState <- IO (LocalChainState IO Tx) -> PropertyM IO (LocalChainState IO Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (LocalChainState IO Tx)
 -> PropertyM IO (LocalChainState IO Tx))
-> IO (LocalChainState IO Tx)
-> PropertyM IO (LocalChainState IO Tx)
forall a b. (a -> b) -> a -> b
$ ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory Tx
chainState
        let chainSyncCallback :: ChainEvent Tx -> IO ()
            chainSyncCallback :: ChainEvent Tx -> Expectation
chainSyncCallback = Expectation -> ChainEvent Tx -> Expectation
forall a b. a -> b -> a
const (Expectation -> ChainEvent Tx -> Expectation)
-> Expectation -> ChainEvent Tx -> Expectation
forall a b. (a -> b) -> a -> b
$ String -> Expectation
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Unexpected callback"
            handler :: ChainSyncHandler IO
handler =
              Tracer IO CardanoChainLog
-> (ChainEvent Tx -> Expectation)
-> (SlotNo -> GetTimeHandle IO)
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
                Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                ChainEvent Tx -> Expectation
chainSyncCallback
                (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. a -> b -> a
const (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO)
-> GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. (a -> b) -> a -> b
$ TimeHandle -> GetTimeHandle IO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeHandle
timeHandle)
                ChainContext
chainContext
                LocalChainState IO Tx
localChainState
        Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
          ChainSyncHandler IO -> BlockHeader -> [Tx] -> Expectation
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler IO
handler BlockHeader
header [Tx]
txs
            Expectation -> Selector TimeConversionException -> Expectation
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \TimeConversionException{SlotNo
slotNo :: SlotNo
$sel:slotNo:TimeConversionException :: TimeConversionException -> SlotNo
slotNo} -> SlotNo
slotNo SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
slot

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"emits observations before Tick within the same block" (Property -> Spec)
-> (PropertyM IO () -> Property) -> PropertyM IO () -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Spec) -> PropertyM IO () -> Spec
forall a b. (a -> b) -> a -> b
$ do
      -- Ordering matters: 'onOpenChainTick' in HeadLogic uses the post-observation
      -- state to decide whether to broadcast the next 'ReqSn'. If Tick fired
      -- before the in-block observation (e.g. 'OnIncrementTx' that bumps the
      -- snapshot version), followers would receive a 'ReqSn' carrying the new
      -- version while their local version is still stale, causing
      -- 'ReqSvNumberInvalid'.
      (ChainContext
ctx, ChainState
st, UTxO
utxo', Tx
tx, ChainTransition
transition) <- Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> PropertyM
     IO (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genChainStateWithTx
      let utxo :: UTxO
utxo = ChainState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxo'
      TestBlock BlockHeader
header [Tx]
txs <- Gen TestBlock -> PropertyM IO TestBlock
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen TestBlock -> PropertyM IO TestBlock)
-> Gen TestBlock -> PropertyM IO TestBlock
forall a b. (a -> b) -> a -> b
$ SlotNo -> [Tx] -> Gen TestBlock
genBlockAt SlotNo
1 [Tx
tx]
      TimeHandle
timeHandle <- Gen TimeHandle -> PropertyM IO TimeHandle
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen TimeHandle
forall a. Arbitrary a => Gen a
arbitrary
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ ChainTransition -> String
forall b a. (Show a, IsString b) => a -> b
show ChainTransition
transition)

      (ChainSyncHandler IO
handler, IO [ChainEvent Tx]
getEvents) <-
        IO (ChainSyncHandler IO, IO [ChainEvent Tx])
-> PropertyM IO (ChainSyncHandler IO, IO [ChainEvent Tx])
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (ChainSyncHandler IO, IO [ChainEvent Tx])
 -> PropertyM IO (ChainSyncHandler IO, IO [ChainEvent Tx]))
-> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
-> PropertyM IO (ChainSyncHandler IO, IO [ChainEvent Tx])
forall a b. (a -> b) -> a -> b
$
          ChainContext
-> ChainStateAt
-> (SlotNo -> GetTimeHandle IO)
-> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
recordEventsHandler
            ChainContext
ctx
            ChainStateAt{$sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
utxo, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = Maybe ChainPoint
forall a. Maybe a
Nothing}
            (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. a -> b -> a
const (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO)
-> GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. (a -> b) -> a -> b
$ TimeHandle -> GetTimeHandle IO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeHandle
timeHandle)

      Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> BlockHeader -> [Tx] -> Expectation
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler IO
handler BlockHeader
header [Tx]
txs

      [ChainEvent Tx]
events <- IO [ChainEvent Tx] -> PropertyM IO [ChainEvent Tx]
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run IO [ChainEvent Tx]
getEvents
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"events (insertion-order reversed): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ChainEvent Tx] -> String
forall b a. (Show a, IsString b) => a -> b
show [ChainEvent Tx]
events)

      let tag :: ChainEvent Tx -> String
          tag :: ChainEvent Tx -> String
tag = \case
            Observation{} -> String
"obs"
            Tick{} -> String
"tick"
            Rollback{} -> String
"roll"
            PostTxError{} -> String
"err"
          callOrder :: [ChainEvent Tx]
callOrder = [ChainEvent Tx] -> [ChainEvent Tx]
forall a. [a] -> [a]
reverse [ChainEvent Tx]
events
          pattern' :: String
pattern' = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((ChainEvent Tx -> String) -> [ChainEvent Tx] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ChainEvent Tx -> String
tag [ChainEvent Tx]
callOrder)
      -- 'genChainStateWithTx' does not always produce an observable tx; in those
      -- cases we just see a single "tick". When an observation does occur, it
      -- must precede the Tick: pattern shape is "obs*,tick".
      PropertyM IO Any -> PropertyM IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PropertyM IO Any -> PropertyM IO ())
-> (Expectation -> PropertyM IO Any)
-> Expectation
-> PropertyM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expectation -> PropertyM IO Any
forall prop (m :: * -> *) a.
(Testable prop, Monad m) =>
prop -> PropertyM m a
stop (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String
pattern' String -> (String -> Bool) -> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` (String -> [String] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [String
"tick", String
"obs,tick"])

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"observes valid transactions onRollForward" (Property -> Spec)
-> (PropertyM IO () -> Property) -> PropertyM IO () -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Spec) -> PropertyM IO () -> Spec
forall a b. (a -> b) -> a -> b
$ do
      -- Generate a state and related transaction and a block containing it
      (ChainContext
ctx, ChainState
st, UTxO
utxo', Tx
tx, ChainTransition
transition) <- Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> PropertyM
     IO (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genChainStateWithTx
      let utxo :: UTxO
utxo = ChainState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxo'
      TestBlock BlockHeader
header [Tx]
txs <- Gen TestBlock -> PropertyM IO TestBlock
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen TestBlock -> PropertyM IO TestBlock)
-> Gen TestBlock -> PropertyM IO TestBlock
forall a b. (a -> b) -> a -> b
$ SlotNo -> [Tx] -> Gen TestBlock
genBlockAt SlotNo
1 [Tx
tx]
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ ChainTransition -> String
forall b a. (Show a, IsString b) => a -> b
show ChainTransition
transition)
      LocalChainState IO Tx
localChainState <-
        IO (LocalChainState IO Tx) -> PropertyM IO (LocalChainState IO Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (LocalChainState IO Tx)
 -> PropertyM IO (LocalChainState IO Tx))
-> IO (LocalChainState IO Tx)
-> PropertyM IO (LocalChainState IO Tx)
forall a b. (a -> b) -> a -> b
$ ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateAt{$sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
utxo, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = Maybe ChainPoint
forall a. Maybe a
Nothing})
      TimeHandle
timeHandle <- Gen TimeHandle -> PropertyM IO TimeHandle
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen TimeHandle
forall a. Arbitrary a => Gen a
arbitrary
      let callback :: ChainEvent Tx -> Expectation
callback = \case
            Rollback{} -> String -> Expectation
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"rolled back but expected roll forward."
            PostTxError{} -> String -> Expectation
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Unexpected PostTxError event"
            Tick{} -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Observation{OnChainTx Tx
observedTx :: OnChainTx Tx
$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx} -> do
              case OnChainTx Tx
observedTx of
                OnInitTx{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` ChainTransition
Transition.Init
                OnDepositTx{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` ChainTransition
Transition.Deposit
                OnRecoverTx{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` ChainTransition
Transition.Recover
                OnDecrementTx{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` ChainTransition
Transition.Decrement
                OnIncrementTx{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` ChainTransition
Transition.Increment
                OnCloseTx{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` ChainTransition
Transition.Close
                OnContestTx{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` ChainTransition
Transition.Contest
                OnPartialFanoutTx{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` ChainTransition
Transition.PartialFanout
                -- FinalPartialFanout is observed as OnFanoutTx (same terminal effect)
                OnFanoutTx{} -> ChainTransition
transition ChainTransition -> (ChainTransition -> Bool) -> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` (ChainTransition -> [ChainTransition] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [ChainTransition
Transition.Fanout, ChainTransition
Transition.FinalPartialFanout])

      let handler :: ChainSyncHandler IO
handler =
            Tracer IO CardanoChainLog
-> (ChainEvent Tx -> Expectation)
-> (SlotNo -> GetTimeHandle IO)
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
              Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              ChainEvent Tx -> Expectation
callback
              (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. a -> b -> a
const (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO)
-> GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. (a -> b) -> a -> b
$ TimeHandle -> GetTimeHandle IO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeHandle
timeHandle)
              ChainContext
ctx
              LocalChainState IO Tx
localChainState
      Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> BlockHeader -> [Tx] -> Expectation
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler IO
handler BlockHeader
header [Tx]
txs

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores invalid transactions onRollForward" (Property -> Spec)
-> (PropertyM IO () -> Property) -> PropertyM IO () -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Spec) -> PropertyM IO () -> Spec
forall a b. (a -> b) -> a -> b
$ do
      -- NOTE: Generate a valid state transition, but then mark it as invalid.
      -- This is sufficient to simulate an where and adversary would create a
      -- transaction that looks like a proper transaction, but not entirely and
      -- scripts would fail, but deliberately marks the tx as invalid (only at
      -- the expense of collateral) to trick the hydra-node into thinking the
      -- state transition happened.
      (ChainContext
ctx, ChainState
st, UTxO
utxo', Tx
validTx, ChainTransition
transition) <- Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> PropertyM
     IO (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genChainStateWithTx
      let tx :: Tx
tx = Tx TopTx (ShelleyLedgerEra Era) -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx TopTx (ShelleyLedgerEra Era) -> Tx)
-> Tx TopTx (ShelleyLedgerEra Era) -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> Tx TopTx (ShelleyLedgerEra Era)
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
validTx Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (IsValid -> Identity IsValid)
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx ConwayEra) IsValid
isValidTxL ((IsValid -> Identity IsValid)
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> IsValid -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
IsValid Bool
False
      let utxo :: UTxO
utxo = ChainState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxo'

      TestBlock BlockHeader
header [Tx]
txs <- Gen TestBlock -> PropertyM IO TestBlock
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen TestBlock -> PropertyM IO TestBlock)
-> Gen TestBlock -> PropertyM IO TestBlock
forall a b. (a -> b) -> a -> b
$ SlotNo -> [Tx] -> Gen TestBlock
genBlockAt SlotNo
1 [Tx
tx]
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ ChainTransition -> String
forall b a. (Show a, IsString b) => a -> b
show ChainTransition
transition)

      LocalChainState IO Tx
localChainState <-
        IO (LocalChainState IO Tx) -> PropertyM IO (LocalChainState IO Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (LocalChainState IO Tx)
 -> PropertyM IO (LocalChainState IO Tx))
-> IO (LocalChainState IO Tx)
-> PropertyM IO (LocalChainState IO Tx)
forall a b. (a -> b) -> a -> b
$ ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateAt{$sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
utxo, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = Maybe ChainPoint
forall a. Maybe a
Nothing})
      TimeHandle
timeHandle <- Gen TimeHandle -> PropertyM IO TimeHandle
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen TimeHandle
forall a. Arbitrary a => Gen a
arbitrary
      let callback :: ChainEvent Tx -> Expectation
callback = \case
            Rollback{} -> String -> Expectation
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"rolled back but expected roll forward."
            PostTxError{} -> String -> Expectation
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Unexpected PostTxError event"
            Tick{} -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Observation{OnChainTx Tx
$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx :: OnChainTx Tx
observedTx} -> String -> Expectation
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Unexpected observation: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> OnChainTx Tx -> String
forall b a. (Show a, IsString b) => a -> b
show OnChainTx Tx
observedTx

      let handler :: ChainSyncHandler IO
handler =
            Tracer IO CardanoChainLog
-> (ChainEvent Tx -> Expectation)
-> (SlotNo -> GetTimeHandle IO)
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
              Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              ChainEvent Tx -> Expectation
callback
              (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. a -> b -> a
const (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO)
-> GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. (a -> b) -> a -> b
$ TimeHandle -> GetTimeHandle IO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeHandle
timeHandle)
              ChainContext
ctx
              LocalChainState IO Tx
localChainState
      Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> BlockHeader -> [Tx] -> Expectation
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler IO
handler BlockHeader
header [Tx]
txs

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"rollbacks state onRollBackward" (Property -> Spec)
-> (PropertyM IO Property -> Property)
-> PropertyM IO Property
-> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Spec) -> PropertyM IO Property -> Spec
forall a b. (a -> b) -> a -> b
$ do
      (ChainContext
chainContext, ChainStateAt
chainStateAt, [TestBlock]
blocks) <- Gen (ChainContext, ChainStateAt, [TestBlock])
-> PropertyM IO (ChainContext, ChainStateAt, [TestBlock])
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen (ChainContext, ChainStateAt, [TestBlock])
genSequenceOfObservableBlocks
      ChainPoint
rollbackPoint <- Gen ChainPoint -> PropertyM IO ChainPoint
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen ChainPoint -> PropertyM IO ChainPoint)
-> Gen ChainPoint -> PropertyM IO ChainPoint
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> Gen ChainPoint
genRollbackPoint [TestBlock]
blocks
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label (String
"Rollback to: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ChainSlot -> String
forall b a. (Show a, IsString b) => a -> b
show (ChainPoint -> ChainSlot
chainSlotFromPoint ChainPoint
rollbackPoint) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" / " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestBlock]
blocks))
      TimeHandle
timeHandle <- Gen TimeHandle -> PropertyM IO TimeHandle
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen TimeHandle
forall a. Arbitrary a => Gen a
arbitrary

      -- Stub for recording Rollback events
      TMVar (ChainStateHistory Tx)
rolledBackTo <- IO (TMVar (ChainStateHistory Tx))
-> PropertyM IO (TMVar (ChainStateHistory Tx))
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (TMVar (ChainStateHistory Tx))
 -> PropertyM IO (TMVar (ChainStateHistory Tx)))
-> IO (TMVar (ChainStateHistory Tx))
-> PropertyM IO (TMVar (ChainStateHistory Tx))
forall a b. (a -> b) -> a -> b
$ String -> IO (TMVar IO (ChainStateHistory Tx))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TMVar m a)
newLabelledEmptyTMVarIO String
"rolled-back-to"
      let callback :: ChainEvent Tx -> Expectation
callback = \case
            Rollback{ChainStateType Tx
rolledBackChainState :: ChainStateType Tx
$sel:rolledBackChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
rolledBackChainState} ->
              STM IO () -> Expectation
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> Expectation) -> STM IO () -> Expectation
forall a b. (a -> b) -> a -> b
$ TMVar IO (ChainStateHistory Tx)
-> ChainStateHistory Tx -> STM IO ()
forall a. TMVar IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
putTMVar TMVar (ChainStateHistory Tx)
TMVar IO (ChainStateHistory Tx)
rolledBackTo (ChainStateType Tx -> ChainStateHistory Tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
rolledBackChainState)
            ChainEvent Tx
_ -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      LocalChainState IO Tx
localChainState <- IO (LocalChainState IO Tx) -> PropertyM IO (LocalChainState IO Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (LocalChainState IO Tx)
 -> PropertyM IO (LocalChainState IO Tx))
-> IO (LocalChainState IO Tx)
-> PropertyM IO (LocalChainState IO Tx)
forall a b. (a -> b) -> a -> b
$ ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
ChainStateAt
chainStateAt)
      let handler :: ChainSyncHandler IO
handler =
            Tracer IO CardanoChainLog
-> (ChainEvent Tx -> Expectation)
-> (SlotNo -> GetTimeHandle IO)
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
              Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              ChainEvent Tx -> Expectation
callback
              (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. a -> b -> a
const (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO)
-> GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. (a -> b) -> a -> b
$ TimeHandle -> GetTimeHandle IO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeHandle
timeHandle)
              ChainContext
chainContext
              LocalChainState IO Tx
localChainState

      -- Simulate some chain following
      Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> (TestBlock -> Expectation) -> Expectation
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestBlock]
blocks ((TestBlock -> Expectation) -> Expectation)
-> (TestBlock -> Expectation) -> Expectation
forall a b. (a -> b) -> a -> b
$ \(TestBlock BlockHeader
header [Tx]
txs) -> ChainSyncHandler IO -> BlockHeader -> [Tx] -> Expectation
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler IO
handler BlockHeader
header [Tx]
txs
      -- Inject the rollback to somewhere between any of the previous state
      Either SomeException ()
result <- IO (Either SomeException ())
-> PropertyM IO (Either SomeException ())
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (Either SomeException ())
 -> PropertyM IO (Either SomeException ()))
-> IO (Either SomeException ())
-> PropertyM IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException (Expectation -> IO (Either SomeException ()))
-> Expectation -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> ChainPoint -> Expectation
forall (m :: * -> *). ChainSyncHandler m -> ChainPoint -> m ()
onRollBackward ChainSyncHandler IO
handler ChainPoint
rollbackPoint
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (String -> Property -> Property) -> String -> PropertyM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> PropertyM IO ()) -> String -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String
"try onRollBackward: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either SomeException () -> String
forall b a. (Show a, IsString b) => a -> b
show Either SomeException ()
result
      Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Either SomeException () -> Bool
forall a b. Either a b -> Bool
isRight Either SomeException ()
result

      Maybe (ChainStateHistory Tx)
mRolledBackChainStateHistory <- IO (Maybe (ChainStateHistory Tx))
-> PropertyM IO (Maybe (ChainStateHistory Tx))
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (Maybe (ChainStateHistory Tx))
 -> PropertyM IO (Maybe (ChainStateHistory Tx)))
-> (STM (Maybe (ChainStateHistory Tx))
    -> IO (Maybe (ChainStateHistory Tx)))
-> STM (Maybe (ChainStateHistory Tx))
-> PropertyM IO (Maybe (ChainStateHistory Tx))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe (ChainStateHistory Tx))
-> IO (Maybe (ChainStateHistory Tx))
STM IO (Maybe (ChainStateHistory Tx))
-> IO (Maybe (ChainStateHistory Tx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (Maybe (ChainStateHistory Tx))
 -> PropertyM IO (Maybe (ChainStateHistory Tx)))
-> STM (Maybe (ChainStateHistory Tx))
-> PropertyM IO (Maybe (ChainStateHistory Tx))
forall a b. (a -> b) -> a -> b
$ TMVar IO (ChainStateHistory Tx)
-> STM IO (Maybe (ChainStateHistory Tx))
forall a. TMVar IO a -> STM IO (Maybe a)
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m (Maybe a)
tryReadTMVar TMVar (ChainStateHistory Tx)
TMVar IO (ChainStateHistory Tx)
rolledBackTo
      let mRolledBackChainState :: Maybe ChainStateAt
mRolledBackChainState = (ChainStateHistory Tx -> ChainStateAt)
-> Maybe (ChainStateHistory Tx) -> Maybe ChainStateAt
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainStateHistory Tx -> ChainStateType Tx
ChainStateHistory Tx -> ChainStateAt
forall tx. ChainStateHistory tx -> ChainStateType tx
currentState Maybe (ChainStateHistory Tx)
mRolledBackChainStateHistory
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (String -> Property -> Property) -> String -> PropertyM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> PropertyM IO ()) -> String -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String
"rolledBackTo: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe ChainStateAt -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe ChainStateAt
mRolledBackChainState
      Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$ (ChainStateType Tx -> ChainSlot
ChainStateAt -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot (ChainStateAt -> ChainSlot)
-> Maybe ChainStateAt -> Maybe ChainSlot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ChainStateAt
mRolledBackChainState) Maybe ChainSlot -> Maybe ChainSlot -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainSlot -> Maybe ChainSlot
forall a. a -> Maybe a
Just (ChainPoint -> ChainSlot
chainSlotFromPoint ChainPoint
rollbackPoint)

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"LocalChainState" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"can resume from chain state" (Property -> Spec)
-> (PropertyM IO Property -> Property)
-> PropertyM IO Property
-> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Spec) -> PropertyM IO Property -> Spec
forall a b. (a -> b) -> a -> b
$ do
      (ChainContext
chainContext, ChainStateAt
chainStateAt, [TestBlock]
blocks) <- Gen (ChainContext, ChainStateAt, [TestBlock])
-> PropertyM IO (ChainContext, ChainStateAt, [TestBlock])
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen (ChainContext, ChainStateAt, [TestBlock])
genSequenceOfObservableBlocks
      TimeHandle
timeHandle <- Gen TimeHandle -> PropertyM IO TimeHandle
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen TimeHandle
forall a. Arbitrary a => Gen a
arbitrary

      -- Use the handler to evolve the chain state to some new, latest version
      LocalChainState IO Tx
localChainState <- IO (LocalChainState IO Tx) -> PropertyM IO (LocalChainState IO Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (LocalChainState IO Tx)
 -> PropertyM IO (LocalChainState IO Tx))
-> IO (LocalChainState IO Tx)
-> PropertyM IO (LocalChainState IO Tx)
forall a b. (a -> b) -> a -> b
$ ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
ChainStateAt
chainStateAt)
      let handler :: ChainSyncHandler IO
handler =
            Tracer IO CardanoChainLog
-> (ChainEvent Tx -> Expectation)
-> (SlotNo -> GetTimeHandle IO)
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
              Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              (\ChainEvent Tx
_ -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. a -> b -> a
const (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO)
-> GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. (a -> b) -> a -> b
$ TimeHandle -> GetTimeHandle IO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeHandle
timeHandle)
              ChainContext
chainContext
              LocalChainState IO Tx
localChainState
      Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> (TestBlock -> Expectation) -> Expectation
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestBlock]
blocks ((TestBlock -> Expectation) -> Expectation)
-> (TestBlock -> Expectation) -> Expectation
forall a b. (a -> b) -> a -> b
$ \(TestBlock BlockHeader
header [Tx]
txs) -> ChainSyncHandler IO -> BlockHeader -> [Tx] -> Expectation
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler IO
handler BlockHeader
header [Tx]
txs
      ChainStateAt
latestChainState <- IO ChainStateAt -> PropertyM IO ChainStateAt
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO ChainStateAt -> PropertyM IO ChainStateAt)
-> (STM ChainStateAt -> IO ChainStateAt)
-> STM ChainStateAt
-> PropertyM IO ChainStateAt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM ChainStateAt -> IO ChainStateAt
STM IO ChainStateAt -> IO ChainStateAt
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM ChainStateAt -> PropertyM IO ChainStateAt)
-> STM ChainStateAt -> PropertyM IO ChainStateAt
forall a b. (a -> b) -> a -> b
$ LocalChainState IO Tx -> STM IO (ChainStateType Tx)
forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateType tx)
getLatest LocalChainState IO Tx
localChainState
      Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ ChainStateAt
latestChainState ChainStateAt -> ChainStateAt -> Bool
forall a. Eq a => a -> a -> Bool
/= ChainStateAt
chainStateAt

      -- Provided the latest chain state the LocalChainState must be able to
      -- rollback and forward
      ChainStateHistory Tx
prevAdvancedChainState <- IO (ChainStateHistory Tx) -> PropertyM IO (ChainStateHistory Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (ChainStateHistory Tx) -> PropertyM IO (ChainStateHistory Tx))
-> (STM (ChainStateHistory Tx) -> IO (ChainStateHistory Tx))
-> STM (ChainStateHistory Tx)
-> PropertyM IO (ChainStateHistory Tx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (ChainStateHistory Tx) -> IO (ChainStateHistory Tx)
STM IO (ChainStateHistory Tx) -> IO (ChainStateHistory Tx)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (ChainStateHistory Tx) -> PropertyM IO (ChainStateHistory Tx))
-> STM (ChainStateHistory Tx)
-> PropertyM IO (ChainStateHistory Tx)
forall a b. (a -> b) -> a -> b
$ LocalChainState IO Tx -> STM IO (ChainStateHistory Tx)
forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateHistory tx)
history LocalChainState IO Tx
localChainState
      LocalChainState IO Tx
resumedLocalChainState <- IO (LocalChainState IO Tx) -> PropertyM IO (LocalChainState IO Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (LocalChainState IO Tx)
 -> PropertyM IO (LocalChainState IO Tx))
-> IO (LocalChainState IO Tx)
-> PropertyM IO (LocalChainState IO Tx)
forall a b. (a -> b) -> a -> b
$ ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory Tx
prevAdvancedChainState
      let resumedHandler :: ChainSyncHandler IO
resumedHandler =
            Tracer IO CardanoChainLog
-> (ChainEvent Tx -> Expectation)
-> (SlotNo -> GetTimeHandle IO)
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
              Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              (\ChainEvent Tx
_ -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. a -> b -> a
const (GetTimeHandle IO -> SlotNo -> GetTimeHandle IO)
-> GetTimeHandle IO -> SlotNo -> GetTimeHandle IO
forall a b. (a -> b) -> a -> b
$ TimeHandle -> GetTimeHandle IO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeHandle
timeHandle)
              ChainContext
chainContext
              LocalChainState IO Tx
resumedLocalChainState

      (ChainPoint
rollbackPoint, [TestBlock]
blocksAfter) <- Gen (ChainPoint, [TestBlock])
-> PropertyM IO (ChainPoint, [TestBlock])
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen (ChainPoint, [TestBlock])
 -> PropertyM IO (ChainPoint, [TestBlock]))
-> Gen (ChainPoint, [TestBlock])
-> PropertyM IO (ChainPoint, [TestBlock])
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> Gen (ChainPoint, [TestBlock])
genRollbackBlocks [TestBlock]
blocks
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Rollback " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestBlock]
blocksAfter) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" blocks"

      Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> ChainPoint -> Expectation
forall (m :: * -> *). ChainSyncHandler m -> ChainPoint -> m ()
onRollBackward ChainSyncHandler IO
resumedHandler ChainPoint
rollbackPoint
      -- NOTE: Sanity check that the rollback was affecting the local state
      ChainStateAt
rolledBackChainState <- IO ChainStateAt -> PropertyM IO ChainStateAt
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO ChainStateAt -> PropertyM IO ChainStateAt)
-> (STM ChainStateAt -> IO ChainStateAt)
-> STM ChainStateAt
-> PropertyM IO ChainStateAt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM ChainStateAt -> IO ChainStateAt
STM IO ChainStateAt -> IO ChainStateAt
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM ChainStateAt -> PropertyM IO ChainStateAt)
-> STM ChainStateAt -> PropertyM IO ChainStateAt
forall a b. (a -> b) -> a -> b
$ LocalChainState IO Tx -> STM IO (ChainStateType Tx)
forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateType tx)
getLatest LocalChainState IO Tx
resumedLocalChainState
      Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestBlock]
blocksAfter Bool -> Bool -> Bool
|| ChainStateAt
rolledBackChainState ChainStateAt -> ChainStateAt -> Bool
forall a. Eq a => a -> a -> Bool
/= ChainStateAt
latestChainState
      Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> (TestBlock -> Expectation) -> Expectation
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestBlock]
blocksAfter ((TestBlock -> Expectation) -> Expectation)
-> (TestBlock -> Expectation) -> Expectation
forall a b. (a -> b) -> a -> b
$ \(TestBlock BlockHeader
header [Tx]
txs) -> ChainSyncHandler IO -> BlockHeader -> [Tx] -> Expectation
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler IO
resumedHandler BlockHeader
header [Tx]
txs
      ChainStateAt
latestResumedChainState <- IO ChainStateAt -> PropertyM IO ChainStateAt
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO ChainStateAt -> PropertyM IO ChainStateAt)
-> (STM ChainStateAt -> IO ChainStateAt)
-> STM ChainStateAt
-> PropertyM IO ChainStateAt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM ChainStateAt -> IO ChainStateAt
STM IO ChainStateAt -> IO ChainStateAt
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM ChainStateAt -> PropertyM IO ChainStateAt)
-> STM ChainStateAt -> PropertyM IO ChainStateAt
forall a b. (a -> b) -> a -> b
$ LocalChainState IO Tx -> STM IO (ChainStateType Tx)
forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateType tx)
getLatest LocalChainState IO Tx
resumedLocalChainState
      Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$ ChainStateAt
latestResumedChainState ChainStateAt -> ChainStateAt -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainStateAt
latestChainState

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTxO splitting" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"splits UTxO into n and remaining" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
      let utxo :: UTxO
utxo = Gen UTxO -> Int -> UTxO
forall a. Gen a -> Int -> a
generateWith (Gen UTxO
forall a. Arbitrary a => Gen a
arbitrary Gen UTxO -> (UTxO -> Bool) -> Gen UTxO
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` \UTxO
u -> UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) Int
42
          n :: Int
n = Int
2
          pairs :: [(TxIn, TxOut CtxUTxO Era)]
pairs = UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
utxo
          (UTxO
first', UTxO
rest) = ([(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
take Int
n [(TxIn, TxOut CtxUTxO Era)]
pairs), [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
drop Int
n [(TxIn, TxOut CtxUTxO Era)]
pairs))
      UTxO -> Int
forall era. UTxO era -> Int
UTxO.size (UTxO
first' :: UTxO) Int -> Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Int
n
      UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
rest Int -> Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
utxo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"fitsTx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    -- Each test measures the real serialised byte size of a generated tx and
    -- compares it against a randomly chosen limit so that both outcomes (fits /
    -- does not fit) occur naturally rather than being hardcoded.  'cover'
    -- assertions verify that QuickCheck actually exercises both branches.

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"skips script evaluation and returns False when tx exceeds size limit" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen Tx -> (Tx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Tx
forall a. Arbitrary a => Gen a
arbitrary ((Tx -> Property) -> Property) -> (Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx
tx ->
        Gen Int -> (Int -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Tx -> Gen Int
sizeLimit Tx
tx) ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
limit -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
          let txBytes :: Int
              txBytes :: Int
txBytes = ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
tx)
              sizeOk :: Bool
sizeOk = Int
txBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
          let sizeCheck :: Tx -> IO Bool
              sizeCheck :: Tx -> IO Bool
sizeCheck Tx
t = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
t) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
              -- When size fails the short-circuit must prevent evalCosts from
              -- being called at all; the throw proves it.
              evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
              evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts =
                if Bool
sizeOk
                  then \Tx
_ UTxO
_ -> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> IO (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
forall k a. Map k a
Map.empty
                  else \Tx
_ UTxO
_ -> IOError -> IO (Either EvaluationError EvaluationReport)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError -> IO (Either EvaluationError EvaluationReport))
-> IOError -> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"evalCosts must not be called when size check fails"
          Bool
result <- 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
$ Tracer IO CardanoChainLog
-> (Tx -> IO Bool)
-> (Tx -> UTxO -> IO (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> IO Bool
forall (m :: * -> *).
Monad m =>
Tracer m CardanoChainLog
-> (Tx -> m Bool)
-> (Tx -> UTxO -> m (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> m Bool
fitsTx Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Tx -> IO Bool
sizeCheck Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts UTxO
forall a. Monoid a => a
mempty Tx
tx
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ 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
"txBytes=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
txBytes String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", limit=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
limit String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", result=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall b a. (Show a, IsString b) => a -> b
show Bool
result
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
40 Bool
sizeOk String
"size passes"
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
40 (Bool -> Bool
not Bool
sizeOk) String
"size fails"
          Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Bool
result Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
sizeOk

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns False when script evaluation returns a budget error" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen Tx -> (Tx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Tx
forall a. Arbitrary a => Gen a
arbitrary ((Tx -> Property) -> Property) -> (Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx
tx ->
        Gen Int -> (Int -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Tx -> Gen Int
sizeLimit Tx
tx) ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
limit -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
          let txBytes :: Int
              txBytes :: Int
txBytes = ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
tx)
              sizeOk :: Bool
sizeOk = Int
txBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
          let sizeCheck :: Tx -> IO Bool
              sizeCheck :: Tx -> IO Bool
sizeCheck Tx
t = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
t) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
              evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
              evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts Tx
_ UTxO
_ =
                Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> IO (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ EvaluationError -> Either EvaluationError EvaluationReport
forall a b. a -> Either a b
Left (EvaluationError -> Either EvaluationError EvaluationReport)
-> EvaluationError -> Either EvaluationError EvaluationReport
forall a b. (a -> b) -> a -> b
$ ExecutionUnits -> ExecutionUnits -> EvaluationError
TransactionBudgetOverspent (Natural -> Natural -> ExecutionUnits
ExecutionUnits Natural
100 Natural
100) (Natural -> Natural -> ExecutionUnits
ExecutionUnits Natural
50 Natural
50)
          Bool
result <- 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
$ Tracer IO CardanoChainLog
-> (Tx -> IO Bool)
-> (Tx -> UTxO -> IO (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> IO Bool
forall (m :: * -> *).
Monad m =>
Tracer m CardanoChainLog
-> (Tx -> m Bool)
-> (Tx -> UTxO -> m (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> m Bool
fitsTx Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Tx -> IO Bool
sizeCheck Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts UTxO
forall a. Monoid a => a
mempty Tx
tx
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ 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
"txBytes=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
txBytes String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", limit=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
limit String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", result=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall b a. (Show a, IsString b) => a -> b
show Bool
result
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
40 Bool
sizeOk String
"size passes"
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
40 (Bool -> Bool
not Bool
sizeOk) String
"size fails"
          -- Budget overrun is transient; always False regardless of size.
          Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
result

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns False when report contains a script execution failure" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen Tx -> (Tx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Tx
forall a. Arbitrary a => Gen a
arbitrary ((Tx -> Property) -> Property) -> (Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx
tx ->
        Gen Int -> (Int -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Tx -> Gen Int
sizeLimit Tx
tx) ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
limit ->
          Gen EvaluationReport -> (EvaluationReport -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen EvaluationReport
genFailingReport ((EvaluationReport -> Property) -> Property)
-> (EvaluationReport -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \EvaluationReport
report -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
            let txBytes :: Int
                txBytes :: Int
txBytes = ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
tx)
                sizeOk :: Bool
sizeOk = Int
txBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
            let sizeCheck :: Tx -> IO Bool
                sizeCheck :: Tx -> IO Bool
sizeCheck Tx
t = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
t) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
                evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
                evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts Tx
_ UTxO
_ = Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> IO (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
report
            Bool
result <- 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
$ Tracer IO CardanoChainLog
-> (Tx -> IO Bool)
-> (Tx -> UTxO -> IO (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> IO Bool
forall (m :: * -> *).
Monad m =>
Tracer m CardanoChainLog
-> (Tx -> m Bool)
-> (Tx -> UTxO -> m (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> m Bool
fitsTx Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Tx -> IO Bool
sizeCheck Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts UTxO
forall a. Monoid a => a
mempty Tx
tx
            (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ 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
"txBytes=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
txBytes String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", limit=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
limit String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", report=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
report String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", result=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall b a. (Show a, IsString b) => a -> b
show Bool
result
            (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
40 Bool
sizeOk String
"size passes"
            (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
40 (Bool -> Bool
not Bool
sizeOk) String
"size fails"
            Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
result

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns True when size passes and all scripts succeed" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen Tx -> (Tx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Tx
forall a. Arbitrary a => Gen a
arbitrary ((Tx -> Property) -> Property) -> (Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx
tx ->
        Gen Int -> (Int -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Tx -> Gen Int
sizeLimit Tx
tx) ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
limit -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
          let txBytes :: Int
              txBytes :: Int
txBytes = ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
tx)
              sizeOk :: Bool
sizeOk = Int
txBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
          let sizeCheck :: Tx -> IO Bool
              sizeCheck :: Tx -> IO Bool
sizeCheck Tx
t = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
t) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
              evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
              evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts Tx
_ UTxO
_ = Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> IO (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
forall k a. Map k a
Map.empty
          Bool
result <- 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
$ Tracer IO CardanoChainLog
-> (Tx -> IO Bool)
-> (Tx -> UTxO -> IO (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> IO Bool
forall (m :: * -> *).
Monad m =>
Tracer m CardanoChainLog
-> (Tx -> m Bool)
-> (Tx -> UTxO -> m (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> m Bool
fitsTx Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Tx -> IO Bool
sizeCheck Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts UTxO
forall a. Monoid a => a
mempty Tx
tx
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ 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
"txBytes=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
txBytes String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", limit=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
limit String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", result=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall b a. (Show a, IsString b) => a -> b
show Bool
result
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
40 Bool
sizeOk String
"size passes"
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
40 (Bool -> Bool
not Bool
sizeOk) String
"size fails"
          -- Empty report means all scripts pass; result tracks whether size passed.
          Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Bool
result Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
sizeOk

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"result matches real Cardano protocol size limit and evaluateTx" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen Tx -> (Tx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Tx
forall a. Arbitrary a => Gen a
arbitrary ((Tx -> Property) -> Property) -> (Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx
tx -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
        let txBytes :: Int
txBytes = ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
tx)
            sizeOk :: Bool
sizeOk = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
txBytes Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxTxSize
            sizeCheck :: Tx -> IO Bool
            sizeCheck :: Tx -> IO Bool
sizeCheck Tx
t = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
t)) Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxTxSize
            evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
            evalCosts :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts Tx
t UTxO
u = Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> IO (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
t UTxO
u
            evalResult :: Either EvaluationError EvaluationReport
evalResult = Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
forall a. Monoid a => a
mempty
            evalOk :: Bool
evalOk = case Either EvaluationError EvaluationReport
evalResult of
              Right EvaluationReport
report -> (Either ScriptExecutionError ExecutionUnits -> Bool)
-> [Either ScriptExecutionError ExecutionUnits] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isRight (EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
report)
              Left EvaluationError
_ -> Bool
False
        Bool
result <- 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
$ Tracer IO CardanoChainLog
-> (Tx -> IO Bool)
-> (Tx -> UTxO -> IO (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> IO Bool
forall (m :: * -> *).
Monad m =>
Tracer m CardanoChainLog
-> (Tx -> m Bool)
-> (Tx -> UTxO -> m (Either EvaluationError EvaluationReport))
-> UTxO
-> Tx
-> m Bool
fitsTx Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Tx -> IO Bool
sizeCheck Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evalCosts UTxO
forall a. Monoid a => a
mempty Tx
tx
        (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
          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
"txBytes="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
txBytes
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", maxTxSize="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
maxTxSize
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", sizeOk="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall b a. (Show a, IsString b) => a -> b
show Bool
sizeOk
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", evalOk="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall b a. (Show a, IsString b) => a -> b
show Bool
evalOk
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", result="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall b a. (Show a, IsString b) => a -> b
show Bool
result
        (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
50 Bool
sizeOk String
"within real protocol size limit"
        Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Bool
result Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Bool
sizeOk Bool -> Bool -> Bool
&& Bool
evalOk)

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"findLargestFitting" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns Left () when upper bound is 0" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
      Either () Int
result <- (Int -> IO (Maybe Int)) -> Int -> IO (Either () Int)
forall (m :: * -> *) tx.
Monad m =>
(Int -> m (Maybe tx)) -> Int -> m (Either () tx)
findLargestFitting (Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> IO (Maybe Int))
-> (Int -> Maybe Int) -> Int -> IO (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just :: Int -> IO (Maybe Int)) Int
0
      Either () Int
result Either () Int -> Either () Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` () -> Either () Int
forall a b. a -> Either a b
Left ()

    String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns Left () when tryTx never fits" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
      Either () Int
result <- (Int -> IO (Maybe Int)) -> Int -> IO (Either () Int)
forall (m :: * -> *) tx.
Monad m =>
(Int -> m (Maybe tx)) -> Int -> m (Either () tx)
findLargestFitting (IO (Maybe Int) -> Int -> IO (Maybe Int)
forall a b. a -> b -> a
const (IO (Maybe Int) -> Int -> IO (Maybe Int))
-> IO (Maybe Int) -> Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing :: Int -> IO (Maybe Int)) Int
10
      Either () Int
result Either () Int -> Either () Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` () -> Either () Int
forall a b. a -> Either a b
Left ()

    String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns Right upper bound when tryTx always fits" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
      Either () Int
result <- (Int -> IO (Maybe Int)) -> Int -> IO (Either () Int)
forall (m :: * -> *) tx.
Monad m =>
(Int -> m (Maybe tx)) -> Int -> m (Either () tx)
findLargestFitting (Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> IO (Maybe Int))
-> (Int -> Maybe Int) -> Int -> IO (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just :: Int -> IO (Maybe Int)) Int
10
      Either () Int
result Either () Int -> Either () Int -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Int -> Either () Int
forall a b. b -> Either a b
Right Int
10

    String -> (Positive Int -> NonNegative Int -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns the largest n where tryTx fits" ((Positive Int -> NonNegative Int -> Property) -> Spec)
-> (Positive Int -> NonNegative Int -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
      \(Positive Int
maxChunk) (NonNegative Int
threshold) ->
        -- k is the threshold in [0..maxChunk]: fits for [1..k], fails for [k+1..maxChunk]
        let k :: Int
k = Int
threshold Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
maxChunk Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
         in PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
              (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ 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
"maxChunk=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
maxChunk String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", k=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
k
              Either () Int
result <- IO (Either () Int) -> PropertyM IO (Either () Int)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (Either () Int) -> PropertyM IO (Either () Int))
-> IO (Either () Int) -> PropertyM IO (Either () Int)
forall a b. (a -> b) -> a -> b
$ (Int -> IO (Maybe Int)) -> Int -> IO (Either () Int)
forall (m :: * -> *) tx.
Monad m =>
(Int -> m (Maybe tx)) -> Int -> m (Either () tx)
findLargestFitting (\Int
n -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> IO (Maybe Int)) -> Maybe Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n else Maybe Int
forall a. Maybe a
Nothing) Int
maxChunk
              let expected :: Either () Int
expected = if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then () -> Either () Int
forall a b. a -> Either a b
Left () else Int -> Either () Int
forall a b. b -> Either a b
Right Int
k
              (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ 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=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either () Int -> String
forall b a. (Show a, IsString b) => a -> b
show Either () Int
expected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", got=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either () Int -> String
forall b a. (Show a, IsString b) => a -> b
show Either () Int
result
              Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Either () Int
result Either () Int -> Either () Int -> Bool
forall a. Eq a => a -> a -> Bool
== Either () Int
expected

    String -> (Positive Int -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"uses at most ceil(log2 n) + 1 evaluations" ((Positive Int -> Property) -> Spec)
-> (Positive Int -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
      \(Positive Int
maxChunk) ->
        -- (,) (Sum Int) is a Monad via the base Monoid-writer instance; each
        -- tryTx call contributes Sum 1 so the fst accumulates the total.
        let (Sum Int
count, Either () Int
_) =
              (Int -> (Sum Int, Maybe Int)) -> Int -> (Sum Int, Either () Int)
forall (m :: * -> *) tx.
Monad m =>
(Int -> m (Maybe tx)) -> Int -> m (Either () tx)
findLargestFitting
                (\Int
n -> (Int -> Sum Int
forall a. a -> Sum a
Sum Int
1, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n))
                Int
maxChunk
            bound :: Int
bound = (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxChunk :: Double) :: Double) :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
         in String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"maxChunk=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
maxChunk String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", evaluations=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
count String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", bound=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
bound) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
              Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
bound

    String -> (Positive Int -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"propagates exceptions thrown by tryTx" ((Positive Int -> Property) -> Spec)
-> (Positive Int -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
      \(Positive Int
maxChunk) -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
        let tryTx :: Int -> IO (Maybe Int)
            tryTx :: Int -> IO (Maybe Int)
tryTx Int
_ = IOError -> IO (Maybe Int)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError -> IO (Maybe Int)) -> IOError -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"structural failure"
        (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ 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
"maxChunk=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
maxChunk
        Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
          (Int -> IO (Maybe Int)) -> Int -> IO (Either () Int)
forall (m :: * -> *) tx.
Monad m =>
(Int -> m (Maybe tx)) -> Int -> m (Either () tx)
findLargestFitting Int -> IO (Maybe Int)
tryTx Int
maxChunk
            IO (Either () Int) -> Selector IOError -> Expectation
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \IOError
e -> IOError -> String
ioeGetErrorString IOError
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"structural failure"

    String -> (UTxO -> NonNegative Int -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"take and drop split preserves all entries and sizes" ((UTxO -> NonNegative Int -> Property) -> Spec)
-> (UTxO -> NonNegative Int -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
      \(UTxO
utxo :: UTxO) (NonNegative Int
n) ->
        let pairs :: [(TxIn, TxOut CtxUTxO Era)]
pairs = UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
utxo
            (UTxO
first', UTxO
rest) = ([(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
take Int
n [(TxIn, TxOut CtxUTxO Era)]
pairs), [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
drop Int
n [(TxIn, TxOut CtxUTxO Era)]
pairs))
            expectedFirst :: Int
expectedFirst = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
utxo)
            utxoSize :: Int
utxoSize = UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
utxo
         in String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"n=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", utxoSize=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
utxoSize) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
              Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
20 (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
utxoSize Bool -> Bool -> Bool
&& Int
utxoSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) String
"normal split" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
20 (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
utxoSize Bool -> Bool -> Bool
&& Int
utxoSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) String
"n exceeds UTxO size" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                  Double -> Bool -> String -> Bool -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 (Int
utxoSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) String
"empty UTxO" (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
                    UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
first' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
expectedFirst
                      Bool -> Bool -> Bool
&& UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
rest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
utxoSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
expectedFirst
                      Bool -> Bool -> Bool
&& UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList (UTxO
first' UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
rest) [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)] -> Bool
forall a. Eq a => a -> a -> Bool
== UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList (UTxO
utxo :: UTxO)

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"findFittingFanoutTx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"throws StalePartialFanoutTx when on-chain accumulator doesn't match remaining UTxO" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
genClosedStateForFanout Int
3) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
cctx, ClosedState{TxIn
seedTxIn :: TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlot, UTxO
_u0) ->
          PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
            -- A freshly generated UTxO won't match the commitment in the closed-head
            -- datum → partialFanout returns Left StaleChainState → StalePartialFanoutTx
            UTxO
mismatchedUTxO <- IO UTxO -> PropertyM IO UTxO
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO UTxO -> PropertyM IO UTxO) -> IO UTxO -> PropertyM IO UTxO
forall a b. (a -> b) -> a -> b
$ Gen UTxO -> IO UTxO
forall a. Gen a -> IO a
generate (Gen UTxO -> IO UTxO) -> Gen UTxO -> IO UTxO
forall a b. (a -> b) -> a -> b
$ Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
5
            let wallet :: TinyWallet IO
wallet =
                  TinyWallet
                    { $sel:getUTxO:TinyWallet :: STM IO (Map TxIn TxOut)
getUTxO = Map TxIn (BabbageTxOut ConwayEra)
-> STM IO (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> STM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TxIn (BabbageTxOut ConwayEra)
forall a. Monoid a => a
mempty
                    , $sel:getSeedInput:TinyWallet :: STM IO (Maybe TxIn)
getSeedInput = Maybe TxIn -> STM IO (Maybe TxIn)
forall a. a -> STM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TxIn
forall a. Maybe a
Nothing
                    , $sel:sign:TinyWallet :: Tx -> Tx
sign = Tx -> Tx
forall a. a -> a
id
                    , $sel:coverFee:TinyWallet :: UTxO -> Tx -> IO (Either ErrCoverFee Tx)
coverFee = \UTxO
_ Tx
tx -> Either ErrCoverFee Tx -> IO (Either ErrCoverFee Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either ErrCoverFee Tx
forall a b. b -> Either a b
Right Tx
tx)
                    , $sel:evaluateScriptCosts:TinyWallet :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evaluateScriptCosts = \Tx
_ UTxO
_ -> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> IO (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
forall k a. Map k a
Map.empty
                    , $sel:isTxWithinSizeLimits:TinyWallet :: Tx -> IO Bool
isTxWithinSizeLimits = \Tx
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                    , $sel:getPParams:TinyWallet :: IO (PParams (ShelleyLedgerEra Era))
getPParams = PParams ConwayEra -> IO (PParams ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PParams (ShelleyLedgerEra Era)
PParams ConwayEra
defaultPParams
                    , $sel:reset:TinyWallet :: Expectation
reset = () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    , $sel:update:TinyWallet :: BlockHeader -> [Tx] -> Expectation
update = \BlockHeader
_ [Tx]
_ -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    }
            Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
              Tracer IO CardanoChainLog
-> TinyWallet IO
-> ChainContext
-> UTxO
-> TxIn
-> Maybe Tx
-> UTxO
-> UTxO
-> Int
-> SlotNo
-> IO Tx
forall (m :: * -> *).
MonadThrow m =>
Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO
-> TxIn
-> Maybe Tx
-> UTxO
-> UTxO
-> Int
-> SlotNo
-> m Tx
findFittingFanoutTx Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer TinyWallet IO
wallet ChainContext
cctx UTxO
spendableUTxO TxIn
seedTxIn Maybe Tx
forall a. Maybe a
Nothing UTxO
mismatchedUTxO UTxO
mismatchedUTxO (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
mismatchedUTxO Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SlotNo
deadlineSlot
                IO Tx -> Selector (PostTxError Tx) -> Expectation
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \(PostTxError Tx
e :: PostTxError Tx) -> PostTxError Tx
e PostTxError Tx -> Selector (PostTxError Tx)
forall a. Eq a => a -> a -> Bool
== PostTxError Tx
forall tx. PostTxError tx
StalePartialFanoutTx

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"throws FailedToConstructPartialFanoutTx on non-stale structural failure" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen UTxO -> (UTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
3) ((UTxO -> Property) -> Property) -> (UTxO -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO
fullUTxO -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
        ChainContext
ctx <- IO ChainContext -> PropertyM IO ChainContext
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO ChainContext -> PropertyM IO ChainContext)
-> IO ChainContext -> PropertyM IO ChainContext
forall a b. (a -> b) -> a -> b
$ Gen ChainContext -> IO ChainContext
forall a. Gen a -> IO a
generate Gen ChainContext
forall a. Arbitrary a => Gen a
arbitrary
        TxIn
seedTxIn <- IO TxIn -> PropertyM IO TxIn
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO TxIn -> PropertyM IO TxIn) -> IO TxIn -> PropertyM IO TxIn
forall a b. (a -> b) -> a -> b
$ Gen TxIn -> IO TxIn
forall a. Gen a -> IO a
generate Gen TxIn
genTxIn
        -- Empty spendableUTxO → CannotFindHeadOutput on every chunk size, which is
        -- a structural error (not a race condition) → FailedToConstructPartialFanoutTx
        let wallet :: TinyWallet IO
wallet =
              TinyWallet
                { $sel:getUTxO:TinyWallet :: STM IO (Map TxIn TxOut)
getUTxO = Map TxIn (BabbageTxOut ConwayEra)
-> STM IO (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> STM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TxIn (BabbageTxOut ConwayEra)
forall a. Monoid a => a
mempty
                , $sel:getSeedInput:TinyWallet :: STM IO (Maybe TxIn)
getSeedInput = Maybe TxIn -> STM IO (Maybe TxIn)
forall a. a -> STM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TxIn
forall a. Maybe a
Nothing
                , $sel:sign:TinyWallet :: Tx -> Tx
sign = Tx -> Tx
forall a. a -> a
id
                , $sel:coverFee:TinyWallet :: UTxO -> Tx -> IO (Either ErrCoverFee Tx)
coverFee = \UTxO
_ Tx
tx -> Either ErrCoverFee Tx -> IO (Either ErrCoverFee Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either ErrCoverFee Tx
forall a b. b -> Either a b
Right Tx
tx)
                , $sel:evaluateScriptCosts:TinyWallet :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evaluateScriptCosts = \Tx
_ UTxO
_ -> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> IO (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
forall k a. Map k a
Map.empty
                , $sel:isTxWithinSizeLimits:TinyWallet :: Tx -> IO Bool
isTxWithinSizeLimits = \Tx
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                , $sel:getPParams:TinyWallet :: IO (PParams (ShelleyLedgerEra Era))
getPParams = PParams ConwayEra -> IO (PParams ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PParams (ShelleyLedgerEra Era)
PParams ConwayEra
defaultPParams
                , $sel:reset:TinyWallet :: Expectation
reset = () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                , $sel:update:TinyWallet :: BlockHeader -> [Tx] -> Expectation
update = \BlockHeader
_ [Tx]
_ -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                }
        Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
          Tracer IO CardanoChainLog
-> TinyWallet IO
-> ChainContext
-> UTxO
-> TxIn
-> Maybe Tx
-> UTxO
-> UTxO
-> Int
-> SlotNo
-> IO Tx
forall (m :: * -> *).
MonadThrow m =>
Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO
-> TxIn
-> Maybe Tx
-> UTxO
-> UTxO
-> Int
-> SlotNo
-> m Tx
findFittingFanoutTx Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer TinyWallet IO
wallet ChainContext
ctx UTxO
forall a. Monoid a => a
mempty TxIn
seedTxIn Maybe Tx
forall a. Maybe a
Nothing UTxO
fullUTxO UTxO
fullUTxO (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
fullUTxO Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SlotNo
1
            IO Tx -> Selector (PostTxError Tx) -> Expectation
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \(PostTxError Tx
e :: PostTxError Tx) -> PostTxError Tx
e PostTxError Tx -> Selector (PostTxError Tx)
forall a. Eq a => a -> a -> Bool
== PostTxError Tx
forall tx. PostTxError tx
FailedToConstructPartialFanoutTx

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"throws FailedToConstructPartialFanoutTx when no chunk fits within budget" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
genClosedStateForFanout Int
3) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
cctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlot, UTxO
u0) ->
          PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
            -- Wallet always rejects on size → fits always returns False for every chunk
            -- → findLargestFitting returns Nothing → FailedToConstructPartialFanoutTx
            let wallet :: TinyWallet IO
wallet =
                  TinyWallet
                    { $sel:getUTxO:TinyWallet :: STM IO (Map TxIn TxOut)
getUTxO = Map TxIn (BabbageTxOut ConwayEra)
-> STM IO (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> STM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TxIn (BabbageTxOut ConwayEra)
forall a. Monoid a => a
mempty
                    , $sel:getSeedInput:TinyWallet :: STM IO (Maybe TxIn)
getSeedInput = Maybe TxIn -> STM IO (Maybe TxIn)
forall a. a -> STM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TxIn
forall a. Maybe a
Nothing
                    , $sel:sign:TinyWallet :: Tx -> Tx
sign = Tx -> Tx
forall a. a -> a
id
                    , $sel:coverFee:TinyWallet :: UTxO -> Tx -> IO (Either ErrCoverFee Tx)
coverFee = \UTxO
_ Tx
tx -> Either ErrCoverFee Tx -> IO (Either ErrCoverFee Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either ErrCoverFee Tx
forall a b. b -> Either a b
Right Tx
tx)
                    , $sel:evaluateScriptCosts:TinyWallet :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evaluateScriptCosts = \Tx
_ UTxO
_ -> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> IO (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
forall k a. Map k a
Map.empty
                    , $sel:isTxWithinSizeLimits:TinyWallet :: Tx -> IO Bool
isTxWithinSizeLimits = \Tx
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                    , $sel:getPParams:TinyWallet :: IO (PParams (ShelleyLedgerEra Era))
getPParams = PParams ConwayEra -> IO (PParams ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PParams (ShelleyLedgerEra Era)
PParams ConwayEra
defaultPParams
                    , $sel:reset:TinyWallet :: Expectation
reset = () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    , $sel:update:TinyWallet :: BlockHeader -> [Tx] -> Expectation
update = \BlockHeader
_ [Tx]
_ -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    }
            Expectation -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (Expectation -> PropertyM IO ()) -> Expectation -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
              Tracer IO CardanoChainLog
-> TinyWallet IO
-> ChainContext
-> UTxO
-> TxIn
-> Maybe Tx
-> UTxO
-> UTxO
-> Int
-> SlotNo
-> IO Tx
forall (m :: * -> *).
MonadThrow m =>
Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO
-> TxIn
-> Maybe Tx
-> UTxO
-> UTxO
-> Int
-> SlotNo
-> m Tx
findFittingFanoutTx Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer TinyWallet IO
wallet ChainContext
cctx UTxO
spendableUTxO TxIn
seedTxIn Maybe Tx
forall a. Maybe a
Nothing UTxO
u0 UTxO
u0 (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
u0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SlotNo
deadlineSlot
                IO Tx -> Selector (PostTxError Tx) -> Expectation
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \(PostTxError Tx
e :: PostTxError Tx) -> PostTxError Tx
e PostTxError Tx -> Selector (PostTxError Tx)
forall a. Eq a => a -> a -> Bool
== PostTxError Tx
forall tx. PostTxError tx
FailedToConstructPartialFanoutTx

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"falls back to partial fanout when preferred tx doesn't fit" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
genClosedStateForFanout Int
3) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
cctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlot, UTxO
u0) ->
          PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
            Tx
dummyTx <- IO Tx -> PropertyM IO Tx
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO Tx -> PropertyM IO Tx) -> IO Tx -> PropertyM IO Tx
forall a b. (a -> b) -> a -> b
$ Gen Tx -> IO Tx
forall a. Gen a -> IO a
generate Gen Tx
forall a. Arbitrary a => Gen a
arbitrary
            -- First isTxWithinSizeLimits call (for the preferred tx) returns False;
            -- all subsequent calls (for binary-search partial-fanout candidates) return True.
            IORef Bool
isFirst <- IO (IORef Bool) -> PropertyM IO (IORef Bool)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (IORef Bool) -> PropertyM IO (IORef Bool))
-> IO (IORef Bool) -> PropertyM IO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Bool
True
            let wallet :: TinyWallet IO
wallet =
                  TinyWallet
                    { $sel:getUTxO:TinyWallet :: STM IO (Map TxIn TxOut)
getUTxO = Map TxIn (BabbageTxOut ConwayEra)
-> STM (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TxIn (BabbageTxOut ConwayEra)
forall a. Monoid a => a
mempty
                    , $sel:getSeedInput:TinyWallet :: STM IO (Maybe TxIn)
getSeedInput = Maybe TxIn -> STM (Maybe TxIn)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TxIn
forall a. Maybe a
Nothing
                    , $sel:sign:TinyWallet :: Tx -> Tx
sign = Tx -> Tx
forall a. a -> a
id
                    , $sel:coverFee:TinyWallet :: UTxO -> Tx -> IO (Either ErrCoverFee Tx)
coverFee = \UTxO
_ Tx
tx -> Either ErrCoverFee Tx -> IO (Either ErrCoverFee Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either ErrCoverFee Tx
forall a b. b -> Either a b
Right Tx
tx)
                    , $sel:evaluateScriptCosts:TinyWallet :: Tx -> UTxO -> IO (Either EvaluationError EvaluationReport)
evaluateScriptCosts = \Tx
_ UTxO
_ -> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> IO (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> IO (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
forall k a. Map k a
Map.empty
                    , $sel:isTxWithinSizeLimits:TinyWallet :: Tx -> IO Bool
isTxWithinSizeLimits = \Tx
_ -> do
                        Bool
first' <- IORef Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Bool
isFirst
                        IORef Bool -> Bool -> Expectation
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef Bool
isFirst Bool
False
                        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Bool
not Bool
first')
                    , $sel:getPParams:TinyWallet :: IO (PParams (ShelleyLedgerEra Era))
getPParams = PParams ConwayEra -> IO (PParams ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PParams (ShelleyLedgerEra Era)
PParams ConwayEra
defaultPParams
                    , $sel:reset:TinyWallet :: Expectation
reset = () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    , $sel:update:TinyWallet :: BlockHeader -> [Tx] -> Expectation
update = \BlockHeader
_ [Tx]
_ -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    }
            -- Any exception thrown here will fail the test automatically.
            Tx
_ <- IO Tx -> PropertyM IO Tx
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO Tx -> PropertyM IO Tx) -> IO Tx -> PropertyM IO Tx
forall a b. (a -> b) -> a -> b
$ Tracer IO CardanoChainLog
-> TinyWallet IO
-> ChainContext
-> UTxO
-> TxIn
-> Maybe Tx
-> UTxO
-> UTxO
-> Int
-> SlotNo
-> IO Tx
forall (m :: * -> *).
MonadThrow m =>
Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO
-> TxIn
-> Maybe Tx
-> UTxO
-> UTxO
-> Int
-> SlotNo
-> m Tx
findFittingFanoutTx Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer TinyWallet IO
wallet ChainContext
cctx UTxO
spendableUTxO TxIn
seedTxIn (Tx -> Maybe Tx
forall a. a -> Maybe a
Just Tx
dummyTx) UTxO
u0 UTxO
u0 (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
u0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SlotNo
deadlineSlot
            Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert Bool
True

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"rejectOversizedDeposit" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"rejects deposit whose merged head value exceeds max value size" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      -- 130 outputs, each with a token under a distinct policy id, accumulate
      -- to a merged head-output value of well over 5 kB serialized — beyond
      -- mainnet's 5000 byte maxValSize — so the increment transaction claiming
      -- the deposit would fail the ledger's OutputTooBigUTxO check.
      Gen (HydraContext, OpenState, UTxO, Tx)
-> ((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen UTxO -> Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genDepositTxWith (Int -> Gen UTxO
genUTxOWithUniquePolicyTokensOfSize Int
130) Int
3) (((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property)
-> ((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
        \(HydraContext
ctx, st :: OpenState
st@OpenState{HeadId
headId :: HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId}, UTxO
_, Tx
txDeposit) ->
          Gen ChainContext -> (ChainContext -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx) ((ChainContext -> Property) -> Property)
-> (ChainContext -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainContext
cctx ->
            case PParams (ShelleyLedgerEra Era)
-> ChainContext
-> UTxO
-> HeadId
-> ConfirmedSnapshot Tx
-> Tx
-> SlotNo
-> Either (PostTxError Tx) ()
rejectOversizedDeposit PParams (ShelleyLedgerEra Era)
pparamsWithMainnetValueLimit ChainContext
cctx (OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st) HeadId
headId InitialSnapshot{HeadId
headId :: HeadId
$sel:headId:InitialSnapshot :: HeadId
headId} Tx
txDeposit (Word64 -> SlotNo
SlotNo Word64
100) of
              Left DepositTooLarge{Natural
estimatedValueSize :: Natural
$sel:estimatedValueSize:NoSeedInput :: forall tx. PostTxError tx -> Natural
estimatedValueSize, Natural
maximumValueSize :: Natural
$sel:maximumValueSize:NoSeedInput :: forall tx. PostTxError tx -> Natural
maximumValueSize} ->
                Bool -> Property
forall prop. Testable prop => prop -> Property
property (Natural
estimatedValueSize Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
maximumValueSize)
              Either (PostTxError Tx) ()
other ->
                String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"expected DepositTooLarge, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either (PostTxError Tx) () -> String
forall b a. (Show a, IsString b) => a -> b
show Either (PostTxError Tx) ()
other) (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"rejects deposit whose increment tx would exceed max tx size" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      -- With mainnet parameters this limit is unreachable: a worst-case
      -- increment is ~10.5 kB (deposit script 1615 B + parties-scaled datum
      -- and signatures ~3 kB + merged value bounded by maxValSize at 5 kB +
      -- skeleton), well below 16384 B. An artificially low max tx size
      -- exercises the guard for networks with smaller limits.
      Gen (HydraContext, OpenState, UTxO, Tx)
-> ((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genDepositTx Int
3) (((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property)
-> ((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
        \(HydraContext
ctx, st :: OpenState
st@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}, UTxO
_, Tx
txDeposit) ->
          Gen ChainContext -> (ChainContext -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx) ((ChainContext -> Property) -> Property)
-> (ChainContext -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainContext
cctx ->
            case PParams (ShelleyLedgerEra Era)
-> ChainContext
-> UTxO
-> HeadId
-> ConfirmedSnapshot Tx
-> Tx
-> SlotNo
-> Either (PostTxError Tx) ()
rejectOversizedDeposit (PParams (ShelleyLedgerEra Era)
PParams ConwayEra
pparamsWithMainnetValueLimit PParams ConwayEra
-> (PParams ConwayEra -> PParams ConwayEra) -> PParams ConwayEra
forall a b. a -> (a -> b) -> b
& (Word32 -> Identity Word32)
-> PParams ConwayEra -> Identity (PParams ConwayEra)
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams ConwayEra) Word32
ppMaxTxSizeL ((Word32 -> Identity Word32)
 -> PParams ConwayEra -> Identity (PParams ConwayEra))
-> Word32 -> PParams ConwayEra -> PParams ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
1000) ChainContext
cctx (OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st) HeadId
headId InitialSnapshot{HeadId
$sel:headId:InitialSnapshot :: HeadId
headId :: HeadId
headId} Tx
txDeposit (Word64 -> SlotNo
SlotNo Word64
100) of
              Left DepositTooLarge{Natural
estimatedTxSize :: Natural
$sel:estimatedTxSize:NoSeedInput :: forall tx. PostTxError tx -> Natural
estimatedTxSize, Natural
maximumTxSize :: Natural
$sel:maximumTxSize:NoSeedInput :: forall tx. PostTxError tx -> Natural
maximumTxSize} ->
                Bool -> Property
forall prop. Testable prop => prop -> Property
property (Natural
estimatedTxSize Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
maximumTxSize)
              Either (PostTxError Tx) ()
other ->
                String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"expected DepositTooLarge, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either (PostTxError Tx) () -> String
forall b a. (Show a, IsString b) => a -> b
show Either (PostTxError Tx) ()
other) (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"accepts deposit whose increment tx fits within layer 1 limits" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (HydraContext, OpenState, UTxO, Tx)
-> ((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen UTxO -> Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genDepositTxWith (Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
5) Int
3) (((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property)
-> ((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
        \(HydraContext
ctx, st :: OpenState
st@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}, UTxO
_, Tx
txDeposit) ->
          Gen ChainContext -> (ChainContext -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx) ((ChainContext -> Property) -> Property)
-> (ChainContext -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainContext
cctx ->
            PParams (ShelleyLedgerEra Era)
-> ChainContext
-> UTxO
-> HeadId
-> ConfirmedSnapshot Tx
-> Tx
-> SlotNo
-> Either (PostTxError Tx) ()
rejectOversizedDeposit PParams (ShelleyLedgerEra Era)
pparamsWithMainnetValueLimit ChainContext
cctx (OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st) HeadId
headId InitialSnapshot{HeadId
$sel:headId:InitialSnapshot :: HeadId
headId :: HeadId
headId} Tx
txDeposit (Word64 -> SlotNo
SlotNo Word64
100) Either (PostTxError Tx) ()
-> Either (PostTxError Tx) () -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== () -> Either (PostTxError Tx) ()
forall a b. b -> Either a b
Right ()

-- | Generate a byte-count limit that straddles the real serialised size of
-- @tx@, giving roughly equal probability of the size check passing or failing.
sizeLimit :: Tx -> Gen Int
sizeLimit :: Tx -> Gen Int
sizeLimit Tx
tx = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
tx) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)

-- | Generate an 'EvaluationReport' that contains at least one script failure
-- at an arbitrary witness index, optionally mixed with passing entries.
genFailingReport :: Gen EvaluationReport
genFailingReport :: Gen EvaluationReport
genFailingReport = do
  ScriptWitnessIndex
failIdx <- Word32 -> ScriptWitnessIndex
ScriptWitnessIndexTxIn (Word32 -> ScriptWitnessIndex)
-> Gen Word32 -> Gen ScriptWitnessIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
  [ScriptWitnessIndex]
passingIdxs <- Gen ScriptWitnessIndex -> Gen [ScriptWitnessIndex]
forall a. Gen a -> Gen [a]
listOf (Word32 -> ScriptWitnessIndex
ScriptWitnessIndexTxIn (Word32 -> ScriptWitnessIndex)
-> Gen Word32 -> Gen ScriptWitnessIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary)
  let passing :: EvaluationReport
passing = [(ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)]
-> EvaluationReport
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ScriptWitnessIndex
i, ExecutionUnits -> Either ScriptExecutionError ExecutionUnits
forall a b. b -> Either a b
Right (Natural -> Natural -> ExecutionUnits
ExecutionUnits Natural
100 Natural
100)) | ScriptWitnessIndex
i <- [ScriptWitnessIndex]
passingIdxs]
  EvaluationReport -> Gen EvaluationReport
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvaluationReport -> Gen EvaluationReport)
-> EvaluationReport -> Gen EvaluationReport
forall a b. (a -> b) -> a -> b
$ ScriptWitnessIndex
-> Either ScriptExecutionError ExecutionUnits
-> EvaluationReport
-> EvaluationReport
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScriptWitnessIndex
failIdx (ScriptExecutionError -> Either ScriptExecutionError ExecutionUnits
forall a b. a -> Either a b
Left ScriptExecutionError
ScriptErrorExecutionUnitsOverflow) EvaluationReport
passing

-- | Create a chain sync handler which records events as they are called back.
recordEventsHandler :: ChainContext -> ChainStateAt -> (SlotNo -> GetTimeHandle IO) -> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
recordEventsHandler :: ChainContext
-> ChainStateAt
-> (SlotNo -> GetTimeHandle IO)
-> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
recordEventsHandler ChainContext
ctx ChainStateAt
cs SlotNo -> GetTimeHandle IO
getTimeHandle = do
  TVar [ChainEvent Tx]
eventsVar <- String -> [ChainEvent Tx] -> IO (TVar IO [ChainEvent Tx])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"events-recorded" []
  LocalChainState IO Tx
localChainState <- ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
ChainStateAt
cs)
  let handler :: ChainSyncHandler IO
handler = Tracer IO CardanoChainLog
-> (ChainEvent Tx -> Expectation)
-> (SlotNo -> GetTimeHandle IO)
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler Tracer IO CardanoChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer (TVar IO [ChainEvent Tx] -> ChainEvent Tx -> Expectation
recordEvents TVar [ChainEvent Tx]
TVar IO [ChainEvent Tx]
eventsVar) SlotNo -> GetTimeHandle IO
getTimeHandle ChainContext
ctx LocalChainState IO Tx
localChainState
  (ChainSyncHandler IO, IO [ChainEvent Tx])
-> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainSyncHandler IO
handler, TVar IO [ChainEvent Tx] -> IO [ChainEvent Tx]
getEvents TVar [ChainEvent Tx]
TVar IO [ChainEvent Tx]
eventsVar)
 where
  getEvents :: TVar IO [ChainEvent Tx] -> IO [ChainEvent Tx]
  getEvents :: TVar IO [ChainEvent Tx] -> IO [ChainEvent Tx]
getEvents = TVar IO [ChainEvent Tx] -> IO [ChainEvent Tx]
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO

  recordEvents :: TVar IO [ChainEvent Tx] -> ChainEvent Tx -> IO ()
  recordEvents :: TVar IO [ChainEvent Tx] -> ChainEvent Tx -> Expectation
recordEvents TVar IO [ChainEvent Tx]
var ChainEvent Tx
event = do
    STM IO () -> Expectation
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> Expectation) -> STM IO () -> Expectation
forall a b. (a -> b) -> a -> b
$ TVar IO [ChainEvent Tx]
-> ([ChainEvent Tx] -> [ChainEvent Tx]) -> STM IO ()
forall a. TVar IO a -> (a -> a) -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar TVar IO [ChainEvent Tx]
var (ChainEvent Tx
event :)

-- | A block used for testing. This is a simpler version of the cardano-api
-- 'Block' and can be de-/constructed easily.
data TestBlock = TestBlock BlockHeader [Tx]

-- | Thin wrapper which generates a 'TestBlock' at some specific slot.
genBlockAt :: SlotNo -> [Tx] -> Gen TestBlock
genBlockAt :: SlotNo -> [Tx] -> Gen TestBlock
genBlockAt SlotNo
sl [Tx]
txs = do
  BlockHeader
header <- BlockHeader -> BlockHeader
adjustSlot (BlockHeader -> BlockHeader) -> Gen BlockHeader -> Gen BlockHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen BlockHeader -> Gen BlockHeader
forall a. Gen a -> Gen a
hedgehog Gen BlockHeader
genBlockHeader
  TestBlock -> Gen TestBlock
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestBlock -> Gen TestBlock) -> TestBlock -> Gen TestBlock
forall a b. (a -> b) -> a -> b
$ BlockHeader -> [Tx] -> TestBlock
TestBlock BlockHeader
header [Tx]
txs
 where
  adjustSlot :: BlockHeader -> BlockHeader
adjustSlot (BlockHeader SlotNo
_ Hash BlockHeader
hash BlockNo
blockNo) =
    SlotNo -> Hash BlockHeader -> BlockNo -> BlockHeader
BlockHeader SlotNo
sl Hash BlockHeader
hash BlockNo
blockNo

-- | Pick a block point in a list of blocks.
genRollbackPoint :: [TestBlock] -> Gen ChainPoint
genRollbackPoint :: [TestBlock] -> Gen ChainPoint
genRollbackPoint [TestBlock]
blocks =
  [Gen ChainPoint] -> Gen ChainPoint
forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [ Gen ChainPoint
pickFromBlocks
    , ChainPoint -> Gen ChainPoint
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainPoint
ChainPointAtGenesis
    ]
 where
  pickFromBlocks :: Gen ChainPoint
pickFromBlocks = do
    TestBlock BlockHeader
header [Tx]
_ <- [TestBlock] -> Gen TestBlock
forall a. HasCallStack => [a] -> Gen a
elements [TestBlock]
blocks
    ChainPoint -> Gen ChainPoint
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainPoint -> Gen ChainPoint) -> ChainPoint -> Gen ChainPoint
forall a b. (a -> b) -> a -> b
$ BlockHeader -> ChainPoint
getChainPoint BlockHeader
header

-- | Pick a rollback point from a list of blocks and also yield the tail of
-- blocks to be replayed.
genRollbackBlocks :: [TestBlock] -> Gen (ChainPoint, [TestBlock])
genRollbackBlocks :: [TestBlock] -> Gen (ChainPoint, [TestBlock])
genRollbackBlocks [TestBlock]
blocks =
  [Gen (ChainPoint, [TestBlock])] -> Gen (ChainPoint, [TestBlock])
forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [ Gen (ChainPoint, [TestBlock])
pickFromBlocks
    , Gen (ChainPoint, [TestBlock])
rollbackFromGenesis
    ]
 where
  rollbackFromGenesis :: Gen (ChainPoint, [TestBlock])
rollbackFromGenesis =
    (ChainPoint, [TestBlock]) -> Gen (ChainPoint, [TestBlock])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainPoint
ChainPointAtGenesis, [TestBlock]
blocks)

  pickFromBlocks :: Gen (ChainPoint, [TestBlock])
pickFromBlocks = do
    [TestBlock]
toReplay <- [[TestBlock]] -> Gen [TestBlock]
forall a. HasCallStack => [a] -> Gen a
elements ([[TestBlock]] -> Gen [TestBlock])
-> [[TestBlock]] -> Gen [TestBlock]
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> [[TestBlock]]
forall a. [a] -> [[a]]
tails [TestBlock]
blocks
    case [TestBlock]
toReplay of
      [] -> Gen (ChainPoint, [TestBlock])
rollbackFromGenesis
      ((TestBlock BlockHeader
header [Tx]
_) : [TestBlock]
blocksAfter) ->
        (ChainPoint, [TestBlock]) -> Gen (ChainPoint, [TestBlock])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockHeader -> ChainPoint
getChainPoint BlockHeader
header, [TestBlock]
blocksAfter)

-- | Generate a non-sparse sequence of blocks each containing an observable
-- transaction, starting from the returned on-chain head state.
--
-- Note that this does not generate the entire spectrum of observable
-- transactions in Hydra, but only init and deposits, which is already sufficient
-- to observe at least one state transition and different levels of rollback.
genSequenceOfObservableBlocks :: Gen (ChainContext, ChainStateAt, [TestBlock])
genSequenceOfObservableBlocks :: Gen (ChainContext, ChainStateAt, [TestBlock])
genSequenceOfObservableBlocks = do
  HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maximumNumberOfParties
  let networkId :: NetworkId
networkId = HydraContext -> NetworkId
ctxNetworkId HydraContext
ctx
  -- NOTE: deposits must be generated from each participant POV, and thus, we
  -- need all their respective ChainContext to move on.
  -- XXX: This is not as important anymore with deposits
  [ChainContext]
allContexts <- HydraContext -> Gen [ChainContext]
deriveChainContexts HydraContext
ctx
  -- Pick a peer context which will perform the init
  ChainContext
cctx <- [ChainContext] -> Gen ChainContext
forall a. HasCallStack => [a] -> Gen a
elements [ChainContext]
allContexts
  [TestBlock]
blks <- (StateT [TestBlock] Gen () -> [TestBlock] -> Gen [TestBlock])
-> [TestBlock] -> StateT [TestBlock] Gen () -> Gen [TestBlock]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [TestBlock] Gen () -> [TestBlock] -> Gen [TestBlock]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT [] (StateT [TestBlock] Gen () -> Gen [TestBlock])
-> StateT [TestBlock] Gen () -> Gen [TestBlock]
forall a b. (a -> b) -> a -> b
$ do
    Tx
txInit <- ChainContext
-> [OnChainId] -> HeadParameters -> StateT [TestBlock] Gen Tx
stepInit ChainContext
cctx (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
    let InitObservation{HeadId
headId :: HeadId
$sel:headId:InitObservation :: InitObservation -> HeadId
headId} = (NotAnInitReason -> InitObservation)
-> (InitObservation -> InitObservation)
-> Either NotAnInitReason InitObservation
-> InitObservation
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> InitObservation
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> InitObservation)
-> (NotAnInitReason -> Text) -> NotAnInitReason -> InitObservation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotAnInitReason -> Text
forall b a. (Show a, IsString b) => a -> b
show) InitObservation -> InitObservation
forall a. a -> a
id (Either NotAnInitReason InitObservation -> InitObservation)
-> Either NotAnInitReason InitObservation -> InitObservation
forall a b. (a -> b) -> a -> b
$ Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
txInit
    Int -> StateT [TestBlock] Gen () -> StateT [TestBlock] Gen ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ ([ChainContext] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ChainContext]
allContexts) (StateT [TestBlock] Gen () -> StateT [TestBlock] Gen ())
-> StateT [TestBlock] Gen () -> StateT [TestBlock] Gen ()
forall a b. (a -> b) -> a -> b
$
      NetworkId -> HeadId -> StateT [TestBlock] Gen ()
stepDeposit NetworkId
networkId HeadId
headId
  (ChainContext, ChainStateAt, [TestBlock])
-> Gen (ChainContext, ChainStateAt, [TestBlock])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, ChainStateType Tx
ChainStateAt
initialChainState, [TestBlock] -> [TestBlock]
forall a. [a] -> [a]
reverse [TestBlock]
blks)
 where
  nextSlot :: StateT [TestBlock] Gen SlotNo
nextSlot = do
    StateT [TestBlock] Gen [TestBlock]
forall s (m :: * -> *). MonadState s m => m s
get StateT [TestBlock] Gen [TestBlock]
-> ([TestBlock] -> SlotNo) -> StateT [TestBlock] Gen SlotNo
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      [] -> SlotNo
1
      TestBlock
block : [TestBlock]
_ -> SlotNo
1 SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ TestBlock -> SlotNo
blockSlotNo TestBlock
block

  blockSlotNo :: TestBlock -> SlotNo
blockSlotNo (TestBlock (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
_) [Tx]
_) = SlotNo
slotNo

  putNextBlock :: Tx -> StateT [TestBlock] Gen ()
putNextBlock Tx
tx = do
    SlotNo
sl <- StateT [TestBlock] Gen SlotNo
nextSlot
    TestBlock
blk <- Gen TestBlock -> StateT [TestBlock] Gen TestBlock
forall (m :: * -> *) a. Monad m => m a -> StateT [TestBlock] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen TestBlock -> StateT [TestBlock] Gen TestBlock)
-> Gen TestBlock -> StateT [TestBlock] Gen TestBlock
forall a b. (a -> b) -> a -> b
$ SlotNo -> [Tx] -> Gen TestBlock
genBlockAt SlotNo
sl [Tx
tx]
    ([TestBlock] -> [TestBlock]) -> StateT [TestBlock] Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (TestBlock
blk :)

  stepInit :: ChainContext
-> [OnChainId] -> HeadParameters -> StateT [TestBlock] Gen Tx
stepInit ChainContext
ctx [OnChainId]
participants HeadParameters
params = do
    TxIn
seedTxIn <- Gen TxIn -> StateT [TestBlock] Gen TxIn
forall (m :: * -> *) a. Monad m => m a -> StateT [TestBlock] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen TxIn
genTxIn
    let tx :: Tx
tx = ChainContext
-> PParams (ShelleyLedgerEra Era)
-> TxIn
-> [OnChainId]
-> HeadParameters
-> Tx
initialize ChainContext
ctx PParams (ShelleyLedgerEra Era)
defaultPParams TxIn
seedTxIn [OnChainId]
participants HeadParameters
params
    Tx
tx Tx -> StateT [TestBlock] Gen () -> StateT [TestBlock] Gen Tx
forall a b.
a -> StateT [TestBlock] Gen b -> StateT [TestBlock] Gen a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tx -> StateT [TestBlock] Gen ()
putNextBlock Tx
tx

  stepDeposit :: NetworkId -> HeadId -> StateT [TestBlock] Gen ()
stepDeposit NetworkId
networkId HeadId
headId = do
    UTxO
utxoToDeposit <- Gen UTxO -> StateT [TestBlock] Gen UTxO
forall (m :: * -> *) a. Monad m => m a -> StateT [TestBlock] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen UTxO -> StateT [TestBlock] Gen UTxO)
-> Gen UTxO -> StateT [TestBlock] Gen UTxO
forall a b. (a -> b) -> a -> b
$ Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
1 Gen UTxO -> (UTxO -> Bool) -> Gen UTxO
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
not (Bool -> Bool) -> (UTxO -> Bool) -> UTxO -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> Bool
forall era. UTxO era -> Bool
UTxO.null)
    SlotNo
slot <- StateT [TestBlock] Gen SlotNo
nextSlot
    SlotNo
slotsUntilDeadline <- Gen SlotNo -> StateT [TestBlock] Gen SlotNo
forall (m :: * -> *) a. Monad m => m a -> StateT [TestBlock] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen SlotNo -> StateT [TestBlock] Gen SlotNo)
-> Gen SlotNo -> StateT [TestBlock] Gen SlotNo
forall a b. (a -> b) -> a -> b
$ (SlotNo, SlotNo) -> Gen SlotNo
forall a. Enum a => (a, a) -> Gen a
chooseEnum (SlotNo
0, SlotNo
86400)
    let deadline :: UTCTime
deadline =
          SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime
            SystemStart
Fixture.systemStart
            SlotLength
Fixture.slotLength
            (SlotNo
slot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
slotsUntilDeadline)
    let tx :: Tx
tx =
          HasCallStack =>
NetworkId
-> PParams (ShelleyLedgerEra Era)
-> HeadId
-> CommitBlueprintTx Tx
-> SlotNo
-> UTCTime
-> Maybe AddressInEra
-> Tx
NetworkId
-> PParams (ShelleyLedgerEra Era)
-> HeadId
-> CommitBlueprintTx Tx
-> SlotNo
-> UTCTime
-> Maybe AddressInEra
-> Tx
depositTx
            NetworkId
networkId
            PParams (ShelleyLedgerEra Era)
Fixture.pparams
            HeadId
headId
            (UTxOType Tx -> CommitBlueprintTx Tx
forall tx. IsTx tx => UTxOType tx -> CommitBlueprintTx tx
mkSimpleBlueprintTx UTxOType Tx
UTxO
utxoToDeposit)
            SlotNo
slot
            UTCTime
deadline
            Maybe AddressInEra
forall a. Maybe a
Nothing
    Tx -> StateT [TestBlock] Gen ()
putNextBlock Tx
tx