{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.Chain.Direct.HandlersSpec where

import Hydra.Prelude hiding (label)

import Control.Concurrent.Class.MonadSTM (MonadSTM (..), newTVarIO)
import Control.Tracer (nullTracer)
import Data.Maybe (fromJust)
import Hydra.Cardano.Api (
  BlockHeader (..),
  ChainPoint (ChainPointAtGenesis),
  PaymentKey,
  SlotNo (..),
  Tx,
  VerificationKey,
  genTxIn,
  getChainPoint,
 )

import Hydra.Chain (ChainEvent (..), OnChainTx (..), currentState, initHistory, maximumNumberOfParties)
import Hydra.Chain.ChainState (ChainSlot (..), chainStateSlot)
import Hydra.Chain.Direct.Handlers (
  ChainSyncHandler (..),
  GetTimeHandle,
  TimeConversionException (..),
  chainSyncHandler,
  getLatest,
  history,
  newLocalChainState,
 )
import Hydra.Chain.Direct.State (
  ChainContext (..),
  ChainStateAt (..),
  HydraContext,
  InitialState (..),
  chainSlotFromPoint,
  ctxHeadParameters,
  ctxParticipants,
  ctxVerificationKeys,
  deriveChainContexts,
  genChainStateWithTx,
  genCommit,
  genHydraContext,
  getKnownUTxO,
  initialChainState,
  initialize,
  observeCommit,
  unsafeCommit,
  unsafeObserveInit,
 )
import Hydra.Chain.Direct.State qualified as Transition
import Hydra.Chain.Direct.TimeHandle (TimeHandle (slotToUTCTime), TimeHandleParams (..), genTimeParams, mkTimeHandle)
import Hydra.Tx.HeadParameters (HeadParameters)
import Hydra.Tx.OnChainId (OnChainId)
import Test.Hydra.Prelude
import Test.QuickCheck (
  counterexample,
  elements,
  label,
  oneof,
  (===),
 )
import Test.QuickCheck.Monadic (
  PropertyM,
  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 = HasCallStack => SlotNo -> SystemStart -> EraHistory -> 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 = HasCallStack => SlotNo -> SystemStart -> EraHistory -> 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
-> GetTimeHandle IO
-> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
recordEventsHandler ChainContext
chainContext ChainStateAt
chainState (TimeHandle -> GetTimeHandle IO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeHandle
timeHandle)

        IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> BlockHeader -> [Tx] -> IO ()
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
        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 -> ChainSlot -> ChainEvent Tx
forall tx. UTCTime -> ChainSlot -> ChainEvent tx
Tick UTCTime
expectedUTCTime (Natural -> ChainSlot
ChainSlot (Natural -> ChainSlot)
-> (Word64 -> Natural) -> Word64 -> ChainSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> ChainSlot) -> Word64 -> ChainSlot
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]

    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.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory Tx
chainState
        let chainSyncCallback :: b -> IO a
chainSyncCallback = IO a -> b -> IO a
forall a b. a -> b -> a
const (IO a -> b -> IO a) -> IO a -> b -> IO a
forall a b. (a -> b) -> a -> b
$ String -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Unexpected callback"
            handler :: ChainSyncHandler IO
handler =
              Tracer IO DirectChainLog
-> ChainCallback Tx IO
-> GetTimeHandle IO
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
                Tracer IO DirectChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                ChainCallback Tx IO
forall {b} {a}. b -> IO a
chainSyncCallback
                (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
        IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
          ChainSyncHandler IO -> BlockHeader -> [Tx] -> IO ()
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler IO
handler BlockHeader
header [Tx]
txs
            IO () -> Selector TimeConversionException -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`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
"observes 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.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall 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 :: ChainCallback Tx IO
callback = \case
            Rollback{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"rolled back but expected roll forward."
            PostTxError{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Unxpected PostTxError event"
            Tick{} -> () -> IO ()
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
              let observedTransition :: ChainTransition
observedTransition =
                    case OnChainTx Tx
observedTx of
                      OnInitTx{} -> ChainTransition
Transition.Init
                      OnCommitTx{} -> ChainTransition
Transition.Commit
                      OnAbortTx{} -> ChainTransition
Transition.Abort
                      OnCollectComTx{} -> ChainTransition
Transition.Collect
                      OnDecrementTx{} -> ChainTransition
Transition.Decrement
                      OnIncrementTx{} -> ChainTransition
Transition.Increment
                      OnCloseTx{} -> ChainTransition
Transition.Close
                      OnContestTx{} -> ChainTransition
Transition.Contest
                      OnFanoutTx{} -> ChainTransition
Transition.Fanout
                      OnDepositTx{} -> Text -> ChainTransition
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"OnDepositTx not expected"
                      OnRecoverTx{} -> Text -> ChainTransition
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"OnRecoverTx not expected"
              ChainTransition
observedTransition ChainTransition -> ChainTransition -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` ChainTransition
transition

      let handler :: ChainSyncHandler IO
handler =
            Tracer IO DirectChainLog
-> ChainCallback Tx IO
-> GetTimeHandle IO
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
              Tracer IO DirectChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              ChainCallback Tx IO
callback
              (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
      IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> BlockHeader -> [Tx] -> IO ()
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))
IO (TMVar IO (ChainStateHistory Tx))
forall a. IO (TMVar IO a)
forall (m :: * -> *) a. MonadSTM m => m (TMVar m a)
newEmptyTMVarIO
      let callback :: ChainCallback Tx IO
callback = \case
            Rollback{ChainStateType Tx
rolledBackChainState :: ChainStateType Tx
$sel:rolledBackChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
rolledBackChainState} ->
              STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
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. ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
rolledBackChainState)
            ChainEvent Tx
_ -> () -> IO ()
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.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall tx. ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
ChainStateAt
chainStateAt)
      let handler :: ChainSyncHandler IO
handler =
            Tracer IO DirectChainLog
-> ChainCallback Tx IO
-> GetTimeHandle IO
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
              Tracer IO DirectChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              ChainCallback Tx IO
callback
              (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
      IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> (TestBlock -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestBlock]
blocks ((TestBlock -> IO ()) -> IO ()) -> (TestBlock -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(TestBlock BlockHeader
header [Tx]
txs) -> ChainSyncHandler IO -> BlockHeader -> [Tx] -> IO ()
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 (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> ChainPoint -> IO ()
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.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall tx. ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
ChainStateAt
chainStateAt)
      let handler :: ChainSyncHandler IO
handler =
            Tracer IO DirectChainLog
-> ChainCallback Tx IO
-> GetTimeHandle IO
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
              Tracer IO DirectChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              (\ChainEvent Tx
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              (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
      IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> (TestBlock -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestBlock]
blocks ((TestBlock -> IO ()) -> IO ()) -> (TestBlock -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(TestBlock BlockHeader
header [Tx]
txs) -> ChainSyncHandler IO -> BlockHeader -> [Tx] -> IO ()
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.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory Tx
prevAdvancedChainState
      let resumedHandler :: ChainSyncHandler IO
resumedHandler =
            Tracer IO DirectChainLog
-> ChainCallback Tx IO
-> GetTimeHandle IO
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
              Tracer IO DirectChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              (\ChainEvent Tx
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              (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"

      IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ ChainSyncHandler IO -> ChainPoint -> IO ()
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
      IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ [TestBlock] -> (TestBlock -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestBlock]
blocksAfter ((TestBlock -> IO ()) -> IO ()) -> (TestBlock -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(TestBlock BlockHeader
header [Tx]
txs) -> ChainSyncHandler IO -> BlockHeader -> [Tx] -> IO ()
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

-- | Create a chain sync handler which records events as they are called back.
recordEventsHandler :: ChainContext -> ChainStateAt -> GetTimeHandle IO -> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
recordEventsHandler :: ChainContext
-> ChainStateAt
-> GetTimeHandle IO
-> IO (ChainSyncHandler IO, IO [ChainEvent Tx])
recordEventsHandler ChainContext
ctx ChainStateAt
cs GetTimeHandle IO
getTimeHandle = do
  TVar [ChainEvent Tx]
eventsVar <- [ChainEvent Tx] -> IO (TVar IO [ChainEvent Tx])
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
  LocalChainState IO Tx
localChainState <- ChainStateHistory Tx -> IO (LocalChainState IO Tx)
forall (m :: * -> *) tx.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall tx. ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
ChainStateAt
cs)
  let handler :: ChainSyncHandler IO
handler = Tracer IO DirectChainLog
-> ChainCallback Tx IO
-> GetTimeHandle IO
-> ChainContext
-> LocalChainState IO Tx
-> ChainSyncHandler IO
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler Tracer IO DirectChainLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer (TVar IO [ChainEvent Tx] -> ChainCallback Tx IO
forall {m :: * -> *} {a}. MonadSTM m => TVar m [a] -> a -> m ()
recordEvents TVar [ChainEvent Tx]
TVar IO [ChainEvent Tx]
eventsVar) 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]
forall {a}. TVar IO a -> IO a
getEvents TVar [ChainEvent Tx]
TVar IO [ChainEvent Tx]
eventsVar)
 where
  getEvents :: TVar IO a -> IO a
getEvents = TVar IO a -> IO a
forall {a}. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO

  recordEvents :: TVar m [a] -> a -> m ()
recordEvents TVar m [a]
var a
event = do
    STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m [a] -> ([a] -> [a]) -> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar TVar m [a]
var (a
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]

withCounterExample :: [TestBlock] -> TVar IO ChainStateAt -> IO a -> PropertyM IO a
withCounterExample :: forall a.
[TestBlock] -> TVar IO ChainStateAt -> IO a -> PropertyM IO a
withCounterExample [TestBlock]
blocks TVar IO ChainStateAt
headState IO a
step = do
  ChainStateAt
stBefore <- IO ChainStateAt -> PropertyM IO ChainStateAt
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO ChainStateAt -> PropertyM IO ChainStateAt)
-> IO ChainStateAt -> PropertyM IO ChainStateAt
forall a b. (a -> b) -> a -> b
$ TVar IO ChainStateAt -> IO ChainStateAt
forall {a}. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar IO ChainStateAt
headState
  a
a <- IO a -> PropertyM IO a
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run IO a
step
  ChainStateAt
stAfter <- IO ChainStateAt -> PropertyM IO ChainStateAt
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO ChainStateAt -> PropertyM IO ChainStateAt)
-> IO ChainStateAt -> PropertyM IO ChainStateAt
forall a b. (a -> b) -> a -> b
$ TVar IO ChainStateAt -> IO ChainStateAt
forall {a}. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar IO ChainStateAt
headState
  a
a a -> PropertyM IO () -> PropertyM IO a
forall a b. a -> PropertyM IO b -> PropertyM IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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
$
        Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
            [ Text
"Chain state at (before rollback): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainStateAt -> Text
forall b a. (Show a, IsString b) => a -> b
show ChainStateAt
stBefore
            , Text
"Chain state at (after rollback):  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainStateAt -> Text
forall b a. (Show a, IsString b) => a -> b
show ChainStateAt
stAfter
            , Text
"Block sequence: \n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
                  ( (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                      (Text
"    " <>)
                      [ChainPoint -> Text
forall b a. (Show a, IsString b) => a -> b
show (BlockHeader -> ChainPoint
getChainPoint BlockHeader
header) | TestBlock BlockHeader
header [Tx]
_ <- [TestBlock]
blocks]
                  )
            ]

-- | 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
forall a. Arbitrary a => Gen a
arbitrary
  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 commits, 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
  -- NOTE: commits must be generated from each participant POV, and thus, we
  -- need all their respective ChainContext to move on.
  [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
initTx <- ChainContext
-> [OnChainId] -> HeadParameters -> StateT [TestBlock] Gen Tx
stepInit ChainContext
cctx (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
    -- Commit using all contexts
    StateT [TestBlock] Gen [InitialState] -> StateT [TestBlock] Gen ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT [TestBlock] Gen [InitialState]
 -> StateT [TestBlock] Gen ())
-> StateT [TestBlock] Gen [InitialState]
-> StateT [TestBlock] Gen ()
forall a b. (a -> b) -> a -> b
$ HydraContext
-> Tx -> [ChainContext] -> StateT [TestBlock] Gen [InitialState]
stepCommits HydraContext
ctx Tx
initTx [ChainContext]
allContexts
  (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 :: Monad m => StateT [TestBlock] m SlotNo
  nextSlot :: forall (m :: * -> *). Monad m => StateT [TestBlock] m SlotNo
nextSlot = do
    StateT [TestBlock] m [TestBlock]
forall s (m :: * -> *). MonadState s m => m s
get StateT [TestBlock] m [TestBlock]
-> ([TestBlock] -> SlotNo) -> StateT [TestBlock] m 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 -> StateT [TestBlock] Gen ()
putNextBlock Tx
tx = do
    SlotNo
sl <- StateT [TestBlock] Gen SlotNo
forall (m :: * -> *). Monad m => StateT [TestBlock] m 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
-> [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 initTx :: Tx
initTx = ChainContext -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
ctx TxIn
seedTxIn [OnChainId]
participants HeadParameters
params
    Tx
initTx 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
initTx

  stepCommits ::
    HydraContext ->
    Tx ->
    [ChainContext] ->
    StateT [TestBlock] Gen [InitialState]
  stepCommits :: HydraContext
-> Tx -> [ChainContext] -> StateT [TestBlock] Gen [InitialState]
stepCommits HydraContext
hydraCtx Tx
initTx = \case
    [] ->
      [InitialState] -> StateT [TestBlock] Gen [InitialState]
forall a. a -> StateT [TestBlock] Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    ChainContext
ctx : [ChainContext]
rest -> do
      InitialState
stInitialized <- ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> StateT [TestBlock] Gen InitialState
stepCommit ChainContext
ctx (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
hydraCtx) Tx
initTx
      (InitialState
stInitialized :) ([InitialState] -> [InitialState])
-> StateT [TestBlock] Gen [InitialState]
-> StateT [TestBlock] Gen [InitialState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HydraContext
-> Tx -> [ChainContext] -> StateT [TestBlock] Gen [InitialState]
stepCommits HydraContext
hydraCtx Tx
initTx [ChainContext]
rest

  stepCommit ::
    ChainContext ->
    [VerificationKey PaymentKey] ->
    Tx ->
    StateT [TestBlock] Gen InitialState
  stepCommit :: ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> StateT [TestBlock] Gen InitialState
stepCommit ChainContext
ctx [VerificationKey PaymentKey]
allVerificationKeys Tx
initTx = do
    let stInitial :: InitialState
stInitial@InitialState{HeadId
headId :: HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId} = HasCallStack =>
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
unsafeObserveInit ChainContext
ctx [VerificationKey PaymentKey]
allVerificationKeys Tx
initTx
    UTxO
utxo <- 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
genCommit
    let commitTx :: Tx
commitTx = HasCallStack => ChainContext -> HeadId -> UTxO -> UTxO -> Tx
ChainContext -> HeadId -> UTxO -> UTxO -> Tx
unsafeCommit ChainContext
ctx HeadId
headId (InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitial) UTxO
utxo
    Tx -> StateT [TestBlock] Gen ()
putNextBlock Tx
commitTx
    InitialState -> StateT [TestBlock] Gen InitialState
forall a. a -> StateT [TestBlock] Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InitialState -> StateT [TestBlock] Gen InitialState)
-> InitialState -> StateT [TestBlock] Gen InitialState
forall a b. (a -> b) -> a -> b
$ (OnChainTx Tx, InitialState) -> InitialState
forall a b. (a, b) -> b
snd ((OnChainTx Tx, InitialState) -> InitialState)
-> (OnChainTx Tx, InitialState) -> InitialState
forall a b. (a -> b) -> a -> b
$ Maybe (OnChainTx Tx, InitialState) -> (OnChainTx Tx, InitialState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (OnChainTx Tx, InitialState)
 -> (OnChainTx Tx, InitialState))
-> Maybe (OnChainTx Tx, InitialState)
-> (OnChainTx Tx, InitialState)
forall a b. (a -> b) -> a -> b
$ ChainContext
-> InitialState -> Tx -> Maybe (OnChainTx Tx, InitialState)
observeCommit ChainContext
ctx InitialState
stInitial Tx
commitTx

showRollbackInfo :: (Word, ChainPoint) -> String
showRollbackInfo :: (Word, ChainPoint) -> String
showRollbackInfo (Word
rollbackDepth, ChainPoint
rollbackPoint) =
  Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
      [ Text
"Rollback depth: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word -> Text
forall b a. (Show a, IsString b) => a -> b
show Word
rollbackDepth
      , Text
"Rollback point: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainPoint -> Text
forall b a. (Show a, IsString b) => a -> b
show ChainPoint
rollbackPoint
      ]