{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Ouroboros.Storage.ChainDB.Unit (tests) where

import Cardano.Ledger.BaseTypes (knownNonZeroBounded)
import Control.Monad (replicateM, unless, void)
import Control.Monad.Except
  ( Except
  , ExceptT (..)
  , MonadError
  , runExcept
  , runExceptT
  , throwError
  )
import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
import Control.Monad.State (MonadState, StateT, evalStateT, get, put)
import Control.Monad.Trans.Class (lift)
import Control.ResourceRegistry (closeRegistry, unsafeNewRegistry)
import Data.Maybe (isJust)
import Ouroboros.Consensus.Block.RealPoint
  ( RealPoint (..)
  , blockRealPoint
  )
import Ouroboros.Consensus.Config
  ( TopLevelConfig
  )
import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..))
import Ouroboros.Consensus.Ledger.Basics
import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as API
import Ouroboros.Consensus.Storage.ChainDB.Impl (TraceEvent)
import Ouroboros.Consensus.Storage.ChainDB.Impl.Args
import Ouroboros.Consensus.Storage.Common
  ( StreamFrom (..)
  , StreamTo (..)
  )
import Ouroboros.Consensus.Storage.ImmutableDB.Chunks as ImmutableDB
import Ouroboros.Consensus.Util.IOLike
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (ChainUpdate (..), Point, blockPoint, genesisPoint)
import qualified Ouroboros.Network.Mock.Chain as Mock
import Test.Ouroboros.Storage.ChainDB.Model (Model)
import qualified Test.Ouroboros.Storage.ChainDB.Model as Model
import Test.Ouroboros.Storage.ChainDB.StateMachine
  ( AllComponents
  , ChainDBEnv (..)
  , ChainDBState (..)
  , TestConstraints
  , close
  , mkTestCfg
  , open
  )
import qualified Test.Ouroboros.Storage.ChainDB.StateMachine as SM
import Test.Ouroboros.Storage.TestBlock
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, assertFailure, testCase)
import Test.Util.ChainDB
  ( MinimalChainDbArgs (..)
  , emptyNodeDBs
  , fromMinimalChainDbArgs
  , nodeDBsVol
  )
import Test.Util.Tracer (recordingTracerTVar)

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Unit tests"
    [ String -> [TestTree] -> TestTree
testGroup
        String
"First follower instruction isJust on empty ChainDB"
        [ String -> Assertion -> TestTree
testCase String
"model" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ LoE () -> ModelM TestBlock () -> Assertion
forall a. LoE () -> ModelM TestBlock a -> Assertion
runModelIO LoE ()
forall a. LoE a
API.LoEDisabled ModelM TestBlock ()
forall (m :: * -> *).
(SupportsUnitTest m, MonadError TestFailure m) =>
m ()
followerInstructionOnEmptyChain
        , String -> Assertion -> TestTree
testCase String
"system" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ SystemM TestBlock IO () -> Assertion
forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO ()
forall (m :: * -> *).
(SupportsUnitTest m, MonadError TestFailure m) =>
m ()
followerInstructionOnEmptyChain
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"Follower switches to new chain"
        [ String -> Assertion -> TestTree
testCase String
"model" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ LoE () -> ModelM TestBlock () -> Assertion
forall a. LoE () -> ModelM TestBlock a -> Assertion
runModelIO LoE ()
forall a. LoE a
API.LoEDisabled ModelM TestBlock ()
forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
followerSwitchesToNewChain
        , String -> Assertion -> TestTree
testCase String
"system" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ SystemM TestBlock IO () -> Assertion
forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO ()
forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
followerSwitchesToNewChain
        ]
    , String -> [TestTree] -> TestTree
testGroup
        (Int -> String
ouroborosNetworkIssue Int
4183)
        [ String -> Assertion -> TestTree
testCase String
"model" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ LoE () -> ModelM TestBlock () -> Assertion
forall a. LoE () -> ModelM TestBlock a -> Assertion
runModelIO LoE ()
forall a. LoE a
API.LoEDisabled ModelM TestBlock ()
forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
ouroboros_network_4183
        , String -> Assertion -> TestTree
testCase String
"system" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ SystemM TestBlock IO () -> Assertion
forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO ()
forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
ouroboros_network_4183
        ]
    , String -> [TestTree] -> TestTree
testGroup
        (Int -> String
ouroborosNetworkIssue Int
3999)
        [ String -> Assertion -> TestTree
testCase String
"model" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ LoE () -> ModelM TestBlock () -> Assertion
forall a. LoE () -> ModelM TestBlock a -> Assertion
runModelIO LoE ()
forall a. LoE a
API.LoEDisabled ModelM TestBlock ()
forall (m :: * -> *).
(HasHeader (Block m), Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
ouroboros_network_3999
        , String -> Assertion -> TestTree
testCase String
"system" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ SystemM TestBlock IO () -> Assertion
forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO ()
forall (m :: * -> *).
(HasHeader (Block m), Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
ouroboros_network_3999
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"ChainDB.waitForImmutableBlock"
        [ String -> [TestTree] -> TestTree
testGroup
            String
"Existing block, returns same"
            [String -> Assertion -> TestTree
testCase String
"system" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ SystemM TestBlock IO () -> Assertion
forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO ()
forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
waitForImmutableBlock_existingBlock]
        , String -> [TestTree] -> TestTree
testGroup
            String
"Existing block, returns same, call 'wait' concurrently with adding blocks"
            [String -> Assertion -> TestTree
testCase String
"system" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ SystemM TestBlock IO () -> Assertion
forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO ()
forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m,
 MonadFork m) =>
m ()
waitForImmutableBlock_existingBlockConcurrent]
        , String -> [TestTree] -> TestTree
testGroup
            String
"Wrong hash, returns the actual block at slot"
            [String -> Assertion -> TestTree
testCase String
"system" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ SystemM TestBlock IO () -> Assertion
forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO ()
forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
waitForImmutableBlock_wrongHash]
        , String -> [TestTree] -> TestTree
testGroup
            String
"Empty slot, returns block at next filled slot"
            [String -> Assertion -> TestTree
testCase String
"system" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ SystemM TestBlock IO () -> Assertion
forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO ()
forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
waitForImmutableBlock_emptySlot]
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"Interaction of ImmutableDB, wiping the VolatileDB and ledger state snapshots"
        [ String -> [TestTree] -> TestTree
testGroup
            String
"Chain not long enough to take a snapshot, so blocks are not persisted into ImmutableDB and are lost."
            [String -> Assertion -> TestTree
testCase String
"system" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ SystemM TestBlock IO () -> Assertion
forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO ()
forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
updateLedgerSnapshots_WipeVolatileDB_withoutSnapshot]
        ]
    ]

followerInstructionOnEmptyChain :: (SupportsUnitTest m, MonadError TestFailure m) => m ()
followerInstructionOnEmptyChain :: forall (m :: * -> *).
(SupportsUnitTest m, MonadError TestFailure m) =>
m ()
followerInstructionOnEmptyChain = do
  f <- m (FollowerId m)
forall (m :: * -> *). SupportsUnitTest m => m (FollowerId m)
newFollower
  followerInstruction f >>= \case
    Right Maybe
  (ChainUpdate
     (Block m)
     (Block m, Block m, Header (Block m), ByteString, ByteString,
      HeaderHash (Block m), SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) (Block m)))
instr -> Maybe
  (ChainUpdate
     (Block m)
     (Block m, Block m, Header (Block m), ByteString, ByteString,
      HeaderHash (Block m), SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) (Block m)))
-> Bool
forall a. Maybe a -> Bool
isJust Maybe
  (ChainUpdate
     (Block m)
     (Block m, Block m, Header (Block m), ByteString, ByteString,
      HeaderHash (Block m), SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) (Block m)))
instr Bool -> String -> m ()
forall (m :: * -> *).
MonadError TestFailure m =>
Bool -> String -> m ()
`orFailWith` String
"Expecting a follower instruction"
    Left ChainDbError (Block m)
_ -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"ChainDbError"

-- | Test that a follower starts following the newly selected fork.
-- The chain constructed in this example looks like:
--
--     G --- b1 --- b2
--            \
--             \--- b3 -- b4
followerSwitchesToNewChain ::
  (Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m) => m ()
followerSwitchesToNewChain :: forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
followerSwitchesToNewChain =
  let fork :: Word -> TestBody
fork Word
i = Word -> Bool -> Maybe PerasRoundNo -> TestBody
TestBody Word
i Bool
True Maybe PerasRoundNo
forall a. Maybe a
Nothing
   in do
        b1 <- Block m -> m (Block m)
forall (m :: * -> *). SupportsUnitTest m => Block m -> m (Block m)
addBlock (Block m -> m (Block m)) -> Block m -> m (Block m)
forall a b. (a -> b) -> a -> b
$ SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
0 (TestBody -> TestBlock) -> TestBody -> TestBlock
forall a b. (a -> b) -> a -> b
$ Word -> TestBody
fork Word
0 -- b1 on top of G
        b2 <- addBlock $ mkNextBlock b1 1 $ fork 0 -- b2 on top of b1
        f <- newFollower
        followerForward f [blockPoint b2] >>= \case
          Right (Just Point TestBlock
pt) -> Point TestBlock -> Point TestBlock -> String -> m ()
forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b2) Point TestBlock
pt String
"Expected to be at b2"
          Either (ChainDbError TestBlock) (Maybe (Point TestBlock))
_ -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith String
"Expecting a success"
        b3 <- addBlock $ mkNextBlock b1 2 $ fork 1 -- b3 on top of b1
        b4 <- addBlock $ mkNextBlock b3 3 $ fork 1 -- b4 on top of b3
        followerInstruction f >>= \case
          Right (Just (RollBack Point TestBlock
actual)) ->
            -- Expect to rollback to the intersection point between [b1, b2] and
            -- [b1, b3, b4]
            Point TestBlock -> Point TestBlock -> String -> m ()
forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b1) Point TestBlock
actual String
"Rollback to wrong point"
          Either
  (ChainDbError TestBlock)
  (Maybe
     (ChainUpdate
        TestBlock
        (TestBlock, TestBlock, Header TestBlock, ByteString, ByteString,
         TestHeaderHash, SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) TestBlock)))
_ -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith String
"Expecting a rollback"
        followerInstruction f >>= \case
          Right (Just (AddBlock (TestBlock, TestBlock, Header TestBlock, ByteString, ByteString,
 TestHeaderHash, SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) TestBlock)
actual)) ->
            TestBlock -> TestBlock -> String -> m ()
forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual TestBlock
b3 (AllComponents TestBlock -> TestBlock
forall blk. AllComponents blk -> blk
extractBlock AllComponents TestBlock
(TestBlock, TestBlock, Header TestBlock, ByteString, ByteString,
 TestHeaderHash, SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) TestBlock)
actual) String
"Instructed to add wrong block"
          Either
  (ChainDbError TestBlock)
  (Maybe
     (ChainUpdate
        TestBlock
        (TestBlock, TestBlock, Header TestBlock, ByteString, ByteString,
         TestHeaderHash, SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) TestBlock)))
_ -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith String
"Expecting instruction to add a block"
        followerInstruction f >>= \case
          Right (Just (AddBlock (TestBlock, TestBlock, Header TestBlock, ByteString, ByteString,
 TestHeaderHash, SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) TestBlock)
actual)) ->
            TestBlock -> TestBlock -> String -> m ()
forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual TestBlock
b4 (AllComponents TestBlock -> TestBlock
forall blk. AllComponents blk -> blk
extractBlock AllComponents TestBlock
(TestBlock, TestBlock, Header TestBlock, ByteString, ByteString,
 TestHeaderHash, SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) TestBlock)
actual) String
"Instructed to add wrong block"
          Either
  (ChainDbError TestBlock)
  (Maybe
     (ChainUpdate
        TestBlock
        (TestBlock, TestBlock, Header TestBlock, ByteString, ByteString,
         TestHeaderHash, SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) TestBlock)))
_ -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith String
"Expecting instruction to add a block"

ouroborosNetworkIssue :: Int -> String
ouroborosNetworkIssue :: Int -> String
ouroborosNetworkIssue Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> String
forall a. HasCallStack => String -> a
error String
"Issue number should be positive"
  | Bool
otherwise = String
"https://github.com/IntersectMBO/ouroboros-network/issues/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n

ouroboros_network_4183 ::
  ( Block m ~ TestBlock
  , SupportsUnitTest m
  , MonadError TestFailure m
  ) =>
  m ()
ouroboros_network_4183 :: forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
ouroboros_network_4183 =
  let fork :: Word -> TestBody
fork Word
i = Word -> Bool -> Maybe PerasRoundNo -> TestBody
TestBody Word
i Bool
True Maybe PerasRoundNo
forall a. Maybe a
Nothing
   in do
        b1 <- Block m -> m (Block m)
forall (m :: * -> *). SupportsUnitTest m => Block m -> m (Block m)
addBlock (Block m -> m (Block m)) -> Block m -> m (Block m)
forall a b. (a -> b) -> a -> b
$ (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB (Bool -> SlotNo -> Bool
forall a b. a -> b -> a
const Bool
True) (TestBody -> TestBlock) -> TestBody -> TestBlock
forall a b. (a -> b) -> a -> b
$ Word -> TestBody
fork Word
0
        b2 <- addBlock $ mkNextBlock b1 0 $ fork 0
        b3 <- addBlock $ mkNextBlock b2 1 $ fork 1
        b4 <- addBlock $ mkNextBlock b2 1 $ fork 0
        f <- newFollower
        void $ followerForward f [blockPoint b1]
        void $ addBlock $ mkNextBlock b4 4 $ fork 0
        persistBlks
        void $ addBlock $ mkNextBlock b3 3 $ fork 1
        followerInstruction f >>= \case
          Right (Just (RollBack Point TestBlock
actual)) ->
            Point TestBlock -> Point TestBlock -> String -> m ()
forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b1) Point TestBlock
actual String
"Rollback to wrong point"
          Either
  (ChainDbError TestBlock)
  (Maybe
     (ChainUpdate
        TestBlock
        (TestBlock, TestBlock, Header TestBlock, ByteString, ByteString,
         TestHeaderHash, SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) TestBlock)))
_ -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith String
"Expecting a rollback"

-- | Test that iterators over dead forks that may have been garbage-collected
-- either stream the blocks in the dead fork normally, report that the blocks
-- have been garbage-collected, or return that the iterator is exhausted,
-- depending on when garbage collection happened. The result is
-- non-deterministic, since garbage collection happens in the background, and
-- hence, may not yet have happened when the next item in the iterator is
-- requested.
ouroboros_network_3999 ::
  ( Mock.HasHeader (Block m)
  , Block m ~ TestBlock
  , SupportsUnitTest m
  , MonadError TestFailure m
  ) =>
  m ()
ouroboros_network_3999 :: forall (m :: * -> *).
(HasHeader (Block m), Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
ouroboros_network_3999 = do
  b1 <- Block m -> m (Block m)
forall (m :: * -> *). SupportsUnitTest m => Block m -> m (Block m)
addBlock (Block m -> m (Block m)) -> Block m -> m (Block m)
forall a b. (a -> b) -> a -> b
$ SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
0 (TestBody -> TestBlock) -> TestBody -> TestBlock
forall a b. (a -> b) -> a -> b
$ Word -> TestBody
fork Word
1
  b2 <- addBlock $ mkNextBlock b1 1 $ fork 1
  b3 <- addBlock $ mkNextBlock b2 2 $ fork 1
  i <- streamAssertSuccess (inclusiveFrom b1) (inclusiveTo b3)
  b4 <- addBlock $ mkNextBlock b1 3 $ fork 2
  b5 <- addBlock $ mkNextBlock b4 4 $ fork 2
  b6 <- addBlock $ mkNextBlock b5 5 $ fork 2
  void $ addBlock $ mkNextBlock b6 6 $ fork 2
  persistBlksThenGC

  -- The block b1 is part of the current chain, so should always be returned.
  result <- iteratorNextBlock i
  assertEqual (API.IteratorResult b1) result "Streaming first block"

  -- The remainder of the elements in the iterator are part of the dead fork,
  -- and may have been garbage-collected.
  let options =
        [ -- If the dead fork has been garbage-collected, the SUT, *given that
          -- the minimal chaindb args set the max blocks per file to 4* will
          -- close the iterator, as the block will really be GCed.
          [RealPoint TestBlock -> IteratorResult TestBlock TestBlock
forall blk b. RealPoint blk -> IteratorResult blk b
API.IteratorBlockGCed (RealPoint TestBlock -> IteratorResult TestBlock TestBlock)
-> RealPoint TestBlock -> IteratorResult TestBlock TestBlock
forall a b. (a -> b) -> a -> b
$ TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b2, IteratorResult TestBlock TestBlock
forall blk b. IteratorResult blk b
API.IteratorExhausted]
        , -- The model will always think that the block has been garbage
          -- collected, and will keep returning the same thing. This way we
          -- abstract away from how the implementation internally works
          -- (deleting whole files).
          [RealPoint TestBlock -> IteratorResult TestBlock TestBlock
forall blk b. RealPoint blk -> IteratorResult blk b
API.IteratorBlockGCed (RealPoint TestBlock -> IteratorResult TestBlock TestBlock)
-> RealPoint TestBlock -> IteratorResult TestBlock TestBlock
forall a b. (a -> b) -> a -> b
$ TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b2, RealPoint TestBlock -> IteratorResult TestBlock TestBlock
forall blk b. RealPoint blk -> IteratorResult blk b
API.IteratorBlockGCed (RealPoint TestBlock -> IteratorResult TestBlock TestBlock)
-> RealPoint TestBlock -> IteratorResult TestBlock TestBlock
forall a b. (a -> b) -> a -> b
$ TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b2]
        , -- The dead fork has not been garbage-collected yet.
          [TestBlock -> IteratorResult TestBlock TestBlock
forall blk b. b -> IteratorResult blk b
API.IteratorResult TestBlock
b2, TestBlock -> IteratorResult TestBlock TestBlock
forall blk b. b -> IteratorResult blk b
API.IteratorResult TestBlock
b3]
        ]

  actual <- replicateM 2 (iteratorNextBlock i)
  assertOneOf options actual "Streaming over dead fork"
 where
  fork :: Word -> TestBody
fork Word
i = Word -> Bool -> Maybe PerasRoundNo -> TestBody
TestBody Word
i Bool
True Maybe PerasRoundNo
forall a. Maybe a
Nothing

  iteratorNextBlock :: IteratorId f -> f (IteratorResult (Block f) (Block f))
iteratorNextBlock IteratorId f
it = ((Block f, Block f, Header (Block f), ByteString, ByteString,
  HeaderHash (Block f), SlotNo, IsEBB, SizeInBytes, Word16,
  SomeSecond (NestedCtxt Header) (Block f))
 -> Block f)
-> IteratorResult
     (Block f)
     (Block f, Block f, Header (Block f), ByteString, ByteString,
      HeaderHash (Block f), SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) (Block f))
-> IteratorResult (Block f) (Block f)
forall a b.
(a -> b)
-> IteratorResult (Block f) a -> IteratorResult (Block f) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Block f, Block f, Header (Block f), ByteString, ByteString,
 HeaderHash (Block f), SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) (Block f))
-> Block f
forall blk. AllComponents blk -> blk
extractBlock (IteratorResult
   (Block f)
   (Block f, Block f, Header (Block f), ByteString, ByteString,
    HeaderHash (Block f), SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) (Block f))
 -> IteratorResult (Block f) (Block f))
-> f (IteratorResult
        (Block f)
        (Block f, Block f, Header (Block f), ByteString, ByteString,
         HeaderHash (Block f), SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) (Block f)))
-> f (IteratorResult (Block f) (Block f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IteratorId f
-> f (IteratorResult
        (Block f)
        (Block f, Block f, Header (Block f), ByteString, ByteString,
         HeaderHash (Block f), SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) (Block f)))
forall (m :: * -> *).
SupportsUnitTest m =>
IteratorId m
-> m (IteratorResult (Block m) (AllComponents (Block m)))
iteratorNext IteratorId f
it

  inclusiveFrom :: TestBlock -> StreamFrom TestBlock
inclusiveFrom = RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (RealPoint TestBlock -> StreamFrom TestBlock)
-> (TestBlock -> RealPoint TestBlock)
-> TestBlock
-> StreamFrom TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint
  inclusiveTo :: TestBlock -> StreamTo TestBlock
inclusiveTo = RealPoint TestBlock -> StreamTo TestBlock
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (RealPoint TestBlock -> StreamTo TestBlock)
-> (TestBlock -> RealPoint TestBlock)
-> TestBlock
-> StreamTo TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint

-- | Tests that given an existing block, we get that same block back
waitForImmutableBlock_existingBlock ::
  forall m. (Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m) => m ()
waitForImmutableBlock_existingBlock :: forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
waitForImmutableBlock_existingBlock = do
  -- add three blocks, as @k@ is set to 2 in these test
  b1 <- Block m -> m (Block m)
forall (m :: * -> *). SupportsUnitTest m => Block m -> m (Block m)
addBlock (Block m -> m (Block m)) -> Block m -> m (Block m)
forall a b. (a -> b) -> a -> b
$ SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
0 (TestBody -> TestBlock) -> TestBody -> TestBlock
forall a b. (a -> b) -> a -> b
$ TestBody
fork0
  b2 <- addBlock $ mkNextBlock b1 1 $ fork0
  _b3 <- addBlock $ mkNextBlock b2 2 $ fork0
  -- copy the blocks older than @k@ into ImmutableDB,
  -- should copy only b1
  persistBlks
  -- request the immutable block
  waitForImmutableBlock (blockRealPoint b1) >>= \case
    Left SeekBlockError
e -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (SeekBlockError -> String
forall a. Show a => a -> String
show SeekBlockError
e)
    Right RealPoint TestBlock
result -> RealPoint TestBlock -> RealPoint TestBlock -> String -> m ()
forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual RealPoint TestBlock
result (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b1) String
""
 where
  fork0 :: TestBody
fork0 = Word -> Bool -> Maybe PerasRoundNo -> TestBody
TestBody Word
0 Bool
True Maybe PerasRoundNo
forall a. Maybe a
Nothing

-- | Tests that given an existing block, we get that same block back,
--   but we wait first and then add the blocks to test the waiting behaviour
waitForImmutableBlock_existingBlockConcurrent ::
  forall m. (Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m, MonadFork m) => m ()
waitForImmutableBlock_existingBlockConcurrent :: forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m,
 MonadFork m) =>
m ()
waitForImmutableBlock_existingBlockConcurrent = do
  _ <- m () -> m (ThreadId m)
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO m ()
addBlocksConcurrently
  waitForImmutableBlock (blockRealPoint targetBlock) >>= \case
    Left SeekBlockError
e -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (SeekBlockError -> String
forall a. Show a => a -> String
show SeekBlockError
e)
    Right RealPoint TestBlock
result -> RealPoint TestBlock -> RealPoint TestBlock -> String -> m ()
forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual RealPoint TestBlock
result (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
targetBlock) String
""
 where
  addBlocksConcurrently :: m ()
  addBlocksConcurrently :: m ()
addBlocksConcurrently = do
    -- add three blocks, as @k@ is set to 2 in these test
    b1 <- Block m -> m (Block m)
forall (m :: * -> *). SupportsUnitTest m => Block m -> m (Block m)
addBlock (Block m -> m (Block m)) -> Block m -> m (Block m)
forall a b. (a -> b) -> a -> b
$ SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
0 (TestBody -> TestBlock) -> TestBody -> TestBlock
forall a b. (a -> b) -> a -> b
$ TestBody
fork0
    b2 <- addBlock $ mkNextBlock b1 1 $ fork0
    _b3 <- addBlock $ mkNextBlock b2 2 $ fork0
    -- copy the blocks older than @k@ into ImmutableDB,
    -- should copy only b1
    persistBlks

  targetBlock :: TestBlock
targetBlock = SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
0 TestBody
fork0
  fork0 :: TestBody
fork0 = Word -> Bool -> Maybe PerasRoundNo -> TestBody
TestBody Word
0 Bool
True Maybe PerasRoundNo
forall a. Maybe a
Nothing

-- | Tests that given a block at a filled slot but with a wrong hash,
--   we get the actual block at that slot
waitForImmutableBlock_wrongHash ::
  forall m. (Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m) => m ()
waitForImmutableBlock_wrongHash :: forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
waitForImmutableBlock_wrongHash = do
  -- add four blocks, as @k@ is set to 2 in these test
  b1 <- Block m -> m (Block m)
forall (m :: * -> *). SupportsUnitTest m => Block m -> m (Block m)
addBlock (Block m -> m (Block m)) -> Block m -> m (Block m)
forall a b. (a -> b) -> a -> b
$ SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
0 (TestBody -> TestBlock) -> TestBody -> TestBlock
forall a b. (a -> b) -> a -> b
$ TestBody
fork0
  b2 <- addBlock $ mkNextBlock b1 1 $ fork0
  b3 <- addBlock $ mkNextBlock b2 2 $ fork0
  _b4 <- addBlock $ mkNextBlock b3 3 $ fork0
  -- copy the blocks older than @k@ into ImmutableDB,
  -- should copy only b1 and b2
  persistBlks
  -- request a block at a filled slot, but give the wrong hash
  let targetPoint = SlotNo -> HeaderHash TestBlock -> RealPoint TestBlock
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
0 (Int -> TestHeaderHash
TestHeaderHash Int
0)
  -- expect to get the block at slot 0 and the correct hash
  let expectedPoint = TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b1
  waitForImmutableBlock targetPoint >>= \case
    Left SeekBlockError
e -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (SeekBlockError -> String
forall a. Show a => a -> String
show SeekBlockError
e)
    Right RealPoint TestBlock
result -> RealPoint TestBlock -> RealPoint TestBlock -> String -> m ()
forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual RealPoint TestBlock
result RealPoint TestBlock
expectedPoint String
""
 where
  fork0 :: TestBody
fork0 = Word -> Bool -> Maybe PerasRoundNo -> TestBody
TestBody Word
0 Bool
True Maybe PerasRoundNo
forall a. Maybe a
Nothing

-- | Tests that given an empty slot, we get a block
--   at the next filled slot
waitForImmutableBlock_emptySlot ::
  forall m. (Block m ~ TestBlock, SupportsUnitTest m, MonadError TestFailure m) => m ()
waitForImmutableBlock_emptySlot :: forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
waitForImmutableBlock_emptySlot = do
  -- add four blocks, as @k@ is set to 2 in these test
  b1 <- Block m -> m (Block m)
forall (m :: * -> *). SupportsUnitTest m => Block m -> m (Block m)
addBlock (Block m -> m (Block m)) -> Block m -> m (Block m)
forall a b. (a -> b) -> a -> b
$ SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
1 (TestBody -> TestBlock) -> TestBody -> TestBlock
forall a b. (a -> b) -> a -> b
$ TestBody
fork0
  b2 <- addBlock $ mkNextBlock b1 2 $ fork0
  b3 <- addBlock $ mkNextBlock b2 3 $ fork0
  _b4 <- addBlock $ mkNextBlock b3 4 $ fork0
  -- copy the blocks older than @k@ into ImmutableDB,
  -- should copy only b1
  persistBlks
  -- request a block at an empty slot, the hash doesn't matter
  let targetPoint = SlotNo -> HeaderHash TestBlock -> RealPoint TestBlock
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
0 (Int -> TestHeaderHash
TestHeaderHash Int
0)
  -- expect to get the block at slot 1 and the correct hash
  let expectedPoint = TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b1
  waitForImmutableBlock targetPoint >>= \case
    Left SeekBlockError
e -> String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (SeekBlockError -> String
forall a. Show a => a -> String
show SeekBlockError
e)
    Right RealPoint TestBlock
result -> RealPoint TestBlock -> RealPoint TestBlock -> String -> m ()
forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual RealPoint TestBlock
result RealPoint TestBlock
expectedPoint String
""
 where
  fork0 :: TestBody
fork0 = Word -> Bool -> Maybe PerasRoundNo -> TestBody
TestBody Word
0 Bool
True Maybe PerasRoundNo
forall a. Maybe a
Nothing

-- | Taking a ledger state snapshot should only copy blocks to the
-- ImmutableDB when the snapshot policy selects slots for snapshotting. When the
-- immutable chain is too short, no blocks should be flushed, and WipeVolatileDB
-- should recover to the tip of the (empty) ImmutableDB.
updateLedgerSnapshots_WipeVolatileDB_withoutSnapshot ::
  forall m.
  ( Block m ~ TestBlock
  , SupportsUnitTest m
  , MonadError TestFailure m
  ) =>
  m ()
updateLedgerSnapshots_WipeVolatileDB_withoutSnapshot :: forall (m :: * -> *).
(Block m ~ TestBlock, SupportsUnitTest m,
 MonadError TestFailure m) =>
m ()
updateLedgerSnapshots_WipeVolatileDB_withoutSnapshot = do
  b1 <- Block m -> m (Block m)
forall (m :: * -> *). SupportsUnitTest m => Block m -> m (Block m)
addBlock (Block m -> m (Block m)) -> Block m -> m (Block m)
forall a b. (a -> b) -> a -> b
$ SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
1 (TestBody -> TestBlock) -> TestBody -> TestBlock
forall a b. (a -> b) -> a -> b
$ TestBody
fork0
  b2 <- addBlock $ mkNextBlock b1 3 $ fork0
  _b3 <- addBlock $ mkNextBlock b2 5 $ fork0

  -- With k=2, 3 blocks are not enough to trigger a snapshot,
  updateLedgerSnapshots

  tip <- wipeVolatileDB
  tip
    == genesisPoint
      `orFailWith` ("Expected ChainDB tip after wiping VolatileDB to be at Genesis, but got: " <> show tip)
 where
  fork0 :: TestBody
fork0 = Word -> Bool -> Maybe PerasRoundNo -> TestBody
TestBody Word
1 Bool
True Maybe PerasRoundNo
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Helpers and testing infrastructure
-------------------------------------------------------------------------------}

streamAssertSuccess ::
  (MonadError TestFailure m, SupportsUnitTest m, Mock.HasHeader (Block m)) =>
  StreamFrom (Block m) -> StreamTo (Block m) -> m (IteratorId m)
streamAssertSuccess :: forall (m :: * -> *).
(MonadError TestFailure m, SupportsUnitTest m,
 HasHeader (Block m)) =>
StreamFrom (Block m) -> StreamTo (Block m) -> m (IteratorId m)
streamAssertSuccess StreamFrom (Block m)
from StreamTo (Block m)
to =
  StreamFrom (Block m)
-> StreamTo (Block m)
-> m (Either
        (ChainDbError (Block m))
        (Either (UnknownRange (Block m)) (IteratorId m)))
forall (m :: * -> *).
SupportsUnitTest m =>
StreamFrom (Block m)
-> StreamTo (Block m)
-> m (Either
        (ChainDbError (Block m))
        (Either (UnknownRange (Block m)) (IteratorId m)))
stream StreamFrom (Block m)
from StreamTo (Block m)
to m (Either
     (ChainDbError (Block m))
     (Either (UnknownRange (Block m)) (IteratorId m)))
-> (Either
      (ChainDbError (Block m))
      (Either (UnknownRange (Block m)) (IteratorId m))
    -> m (IteratorId m))
-> m (IteratorId m)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ChainDbError (Block m)
err -> String -> m (IteratorId m)
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (String -> m (IteratorId m)) -> String -> m (IteratorId m)
forall a b. (a -> b) -> a -> b
$ String
"Should be able to create iterator: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ChainDbError (Block m) -> String
forall a. Show a => a -> String
show ChainDbError (Block m)
err
    Right (Left UnknownRange (Block m)
err) -> String -> m (IteratorId m)
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (String -> m (IteratorId m)) -> String -> m (IteratorId m)
forall a b. (a -> b) -> a -> b
$ String
"Range should be valid: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnknownRange (Block m) -> String
forall a. Show a => a -> String
show UnknownRange (Block m)
err
    Right (Right IteratorId m
iteratorId) -> IteratorId m -> m (IteratorId m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IteratorId m
iteratorId

extractBlock :: AllComponents blk -> blk
extractBlock :: forall blk. AllComponents blk -> blk
extractBlock (blk
blk, blk
_, Header blk
_, ByteString
_, ByteString
_, HeaderHash blk
_, SlotNo
_, IsEBB
_, SizeInBytes
_, Word16
_, SomeSecond (NestedCtxt Header) blk
_) = blk
blk

-- | Helper function to run the test against the model and translate to something
-- that HUnit likes.
runModelIO :: API.LoE () -> ModelM TestBlock a -> IO ()
runModelIO :: forall a. LoE () -> ModelM TestBlock a -> Assertion
runModelIO LoE ()
loe ModelM TestBlock a
expr = Either TestFailure a -> Assertion
forall a. Either TestFailure a -> Assertion
toAssertion (Model TestBlock
-> TopLevelConfig TestBlock
-> ModelM TestBlock a
-> Either TestFailure a
forall blk b.
Model blk
-> TopLevelConfig blk -> ModelM blk b -> Either TestFailure b
runModel Model TestBlock
newModel TopLevelConfig TestBlock
topLevelConfig ModelM TestBlock a
expr)
 where
  chunkInfo :: ChunkInfo
chunkInfo = EpochSize -> ChunkInfo
ImmutableDB.simpleChunkInfo EpochSize
100
  k :: SecurityParam
k = NonZero Word64 -> SecurityParam
SecurityParam (forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @2)
  newModel :: Model TestBlock
newModel = LoE () -> ExtLedgerState TestBlock EmptyMK -> Model TestBlock
forall blk.
HasHeader blk =>
LoE () -> ExtLedgerState blk EmptyMK -> Model blk
Model.empty LoE ()
loe ExtLedgerState TestBlock EmptyMK
testInitExtLedger
  topLevelConfig :: TopLevelConfig TestBlock
topLevelConfig = SecurityParam -> ChunkInfo -> TopLevelConfig TestBlock
mkTestCfg SecurityParam
k ChunkInfo
chunkInfo

-- | Helper function to run the test against the actual chain database and
-- translate to something that HUnit likes.
runSystemIO :: SystemM TestBlock IO a -> IO ()
runSystemIO :: forall a. SystemM TestBlock IO a -> Assertion
runSystemIO SystemM TestBlock IO a
expr = (forall a.
 (ChainDBEnv IO TestBlock -> IO [TraceEvent TestBlock] -> IO a)
 -> IO a)
-> SystemM TestBlock IO a -> IO (Either TestFailure a)
forall (m :: * -> *) blk b.
(forall a. (ChainDBEnv m blk -> m [TraceEvent blk] -> m a) -> m a)
-> SystemM blk m b -> m (Either TestFailure b)
runSystem (ChainDBEnv IO TestBlock -> IO [TraceEvent TestBlock] -> IO a)
-> IO a
forall a.
(ChainDBEnv IO TestBlock -> IO [TraceEvent TestBlock] -> IO a)
-> IO a
withChainDbEnv SystemM TestBlock IO a
expr IO (Either TestFailure a)
-> (Either TestFailure a -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either TestFailure a -> Assertion
forall a. Either TestFailure a -> Assertion
toAssertion
 where
  chunkInfo :: ChunkInfo
chunkInfo = EpochSize -> ChunkInfo
ImmutableDB.simpleChunkInfo EpochSize
100
  k :: SecurityParam
k = NonZero Word64 -> SecurityParam
SecurityParam (forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @2)
  topLevelConfig :: TopLevelConfig TestBlock
topLevelConfig = SecurityParam -> ChunkInfo -> TopLevelConfig TestBlock
mkTestCfg SecurityParam
k ChunkInfo
chunkInfo
  withChainDbEnv :: (ChainDBEnv IO TestBlock -> IO [TraceEvent TestBlock] -> IO a)
-> IO a
withChainDbEnv = TopLevelConfig TestBlock
-> ChunkInfo
-> ExtLedgerState TestBlock ValuesMK
-> (ChainDBEnv IO TestBlock -> IO [TraceEvent TestBlock] -> IO a)
-> IO a
forall (m :: * -> *) blk a.
(IOLike m, TestConstraints blk) =>
TopLevelConfig blk
-> ChunkInfo
-> ExtLedgerState blk ValuesMK
-> (ChainDBEnv m blk -> m [TraceEvent blk] -> m a)
-> m a
withTestChainDbEnv TopLevelConfig TestBlock
topLevelConfig ChunkInfo
chunkInfo (ExtLedgerState TestBlock ValuesMK
 -> (ChainDBEnv IO TestBlock -> IO [TraceEvent TestBlock] -> IO a)
 -> IO a)
-> ExtLedgerState TestBlock ValuesMK
-> (ChainDBEnv IO TestBlock -> IO [TraceEvent TestBlock] -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ ExtLedgerState TestBlock EmptyMK
-> ExtLedgerState TestBlock ValuesMK
forall (mk :: MapKind) (mk' :: MapKind).
ExtLedgerState TestBlock mk -> ExtLedgerState TestBlock mk'
forall (l :: LedgerStateKind) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind ExtLedgerState TestBlock EmptyMK
testInitExtLedger

newtype TestFailure = TestFailure String deriving Int -> TestFailure -> String -> String
[TestFailure] -> String -> String
TestFailure -> String
(Int -> TestFailure -> String -> String)
-> (TestFailure -> String)
-> ([TestFailure] -> String -> String)
-> Show TestFailure
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestFailure -> String -> String
showsPrec :: Int -> TestFailure -> String -> String
$cshow :: TestFailure -> String
show :: TestFailure -> String
$cshowList :: [TestFailure] -> String -> String
showList :: [TestFailure] -> String -> String
Show

toAssertion :: Either TestFailure a -> Assertion
toAssertion :: forall a. Either TestFailure a -> Assertion
toAssertion (Left (TestFailure String
t)) = String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure String
t
toAssertion (Right a
_) = () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

orFailWith :: MonadError TestFailure m => Bool -> String -> m ()
orFailWith :: forall (m :: * -> *).
MonadError TestFailure m =>
Bool -> String -> m ()
orFailWith Bool
b String
msg = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith String
msg
infixl 1 `orFailWith`

failWith :: MonadError TestFailure m => String -> m a
failWith :: forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith String
msg = TestFailure -> m a
forall a. TestFailure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> TestFailure
TestFailure String
msg)

assertEqual ::
  (MonadError TestFailure m, Eq a, Show a) =>
  a -> a -> String -> m ()
assertEqual :: forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
a -> a -> String -> m ()
assertEqual a
expected a
actual String
description = a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual Bool -> String -> m ()
forall (m :: * -> *).
MonadError TestFailure m =>
Bool -> String -> m ()
`orFailWith` String
msg
 where
  msg :: String
msg =
    String
description
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\t Expected: "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
expected
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\t Actual: "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
actual

assertOneOf ::
  (MonadError TestFailure m, Eq a, Show a) =>
  [a] -> a -> String -> m ()
assertOneOf :: forall (m :: * -> *) a.
(MonadError TestFailure m, Eq a, Show a) =>
[a] -> a -> String -> m ()
assertOneOf [a]
options a
actual String
description = a
actual a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
options Bool -> String -> m ()
forall (m :: * -> *).
MonadError TestFailure m =>
Bool -> String -> m ()
`orFailWith` String
msg
 where
  msg :: String
msg =
    String
description
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\t Options: "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall a. Show a => a -> String
show [a]
options
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\t Actual: "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
actual

-- | SupportsUnitTests for the test expression need to instantiate this class.
class SupportsUnitTest m where
  type FollowerId m
  type IteratorId m
  type Block m

  addBlock ::
    Block m -> m (Block m)

  newFollower ::
    m (FollowerId m)

  followerInstruction ::
    FollowerId m ->
    m
      ( Either
          (API.ChainDbError (Block m))
          (Maybe (ChainUpdate (Block m) (AllComponents (Block m))))
      )

  followerForward ::
    FollowerId m ->
    [Point (Block m)] ->
    m
      ( Either
          (API.ChainDbError (Block m))
          (Maybe (Point (Block m)))
      )

  persistBlks :: m ()

  persistBlksThenGC :: m ()

  stream ::
    StreamFrom (Block m) ->
    StreamTo (Block m) ->
    m
      ( Either
          (API.ChainDbError (Block m))
          (Either (API.UnknownRange (Block m)) (IteratorId m))
      )

  iteratorNext ::
    IteratorId m ->
    m (API.IteratorResult (Block m) (AllComponents (Block m)))

  updateLedgerSnapshots :: m ()

  wipeVolatileDB :: m (Point (Block m))

  waitForImmutableBlock ::
    RealPoint (Block m) -> m (Either API.SeekBlockError (RealPoint (Block m)))

{-------------------------------------------------------------------------------
  Model
-------------------------------------------------------------------------------}

-- | Tests against the model run in this monad.
newtype ModelM blk a = ModelM
  { forall blk a.
ModelM blk a
-> StateT
     (Model blk) (ReaderT (TopLevelConfig blk) (Except TestFailure)) a
runModelM :: StateT (Model blk) (ReaderT (TopLevelConfig blk) (Except TestFailure)) a
  }
  deriving newtype
    ( (forall a b. (a -> b) -> ModelM blk a -> ModelM blk b)
-> (forall a b. a -> ModelM blk b -> ModelM blk a)
-> Functor (ModelM blk)
forall a b. a -> ModelM blk b -> ModelM blk a
forall a b. (a -> b) -> ModelM blk a -> ModelM blk b
forall blk a b. a -> ModelM blk b -> ModelM blk a
forall blk a b. (a -> b) -> ModelM blk a -> ModelM blk b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall blk a b. (a -> b) -> ModelM blk a -> ModelM blk b
fmap :: forall a b. (a -> b) -> ModelM blk a -> ModelM blk b
$c<$ :: forall blk a b. a -> ModelM blk b -> ModelM blk a
<$ :: forall a b. a -> ModelM blk b -> ModelM blk a
Functor
    , Functor (ModelM blk)
Functor (ModelM blk) =>
(forall a. a -> ModelM blk a)
-> (forall a b.
    ModelM blk (a -> b) -> ModelM blk a -> ModelM blk b)
-> (forall a b c.
    (a -> b -> c) -> ModelM blk a -> ModelM blk b -> ModelM blk c)
-> (forall a b. ModelM blk a -> ModelM blk b -> ModelM blk b)
-> (forall a b. ModelM blk a -> ModelM blk b -> ModelM blk a)
-> Applicative (ModelM blk)
forall blk. Functor (ModelM blk)
forall a. a -> ModelM blk a
forall blk a. a -> ModelM blk a
forall a b. ModelM blk a -> ModelM blk b -> ModelM blk a
forall a b. ModelM blk a -> ModelM blk b -> ModelM blk b
forall a b. ModelM blk (a -> b) -> ModelM blk a -> ModelM blk b
forall blk a b. ModelM blk a -> ModelM blk b -> ModelM blk a
forall blk a b. ModelM blk a -> ModelM blk b -> ModelM blk b
forall blk a b. ModelM blk (a -> b) -> ModelM blk a -> ModelM blk b
forall a b c.
(a -> b -> c) -> ModelM blk a -> ModelM blk b -> ModelM blk c
forall blk a b c.
(a -> b -> c) -> ModelM blk a -> ModelM blk b -> ModelM blk c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall blk a. a -> ModelM blk a
pure :: forall a. a -> ModelM blk a
$c<*> :: forall blk a b. ModelM blk (a -> b) -> ModelM blk a -> ModelM blk b
<*> :: forall a b. ModelM blk (a -> b) -> ModelM blk a -> ModelM blk b
$cliftA2 :: forall blk a b c.
(a -> b -> c) -> ModelM blk a -> ModelM blk b -> ModelM blk c
liftA2 :: forall a b c.
(a -> b -> c) -> ModelM blk a -> ModelM blk b -> ModelM blk c
$c*> :: forall blk a b. ModelM blk a -> ModelM blk b -> ModelM blk b
*> :: forall a b. ModelM blk a -> ModelM blk b -> ModelM blk b
$c<* :: forall blk a b. ModelM blk a -> ModelM blk b -> ModelM blk a
<* :: forall a b. ModelM blk a -> ModelM blk b -> ModelM blk a
Applicative
    , Applicative (ModelM blk)
Applicative (ModelM blk) =>
(forall a b. ModelM blk a -> (a -> ModelM blk b) -> ModelM blk b)
-> (forall a b. ModelM blk a -> ModelM blk b -> ModelM blk b)
-> (forall a. a -> ModelM blk a)
-> Monad (ModelM blk)
forall blk. Applicative (ModelM blk)
forall a. a -> ModelM blk a
forall blk a. a -> ModelM blk a
forall a b. ModelM blk a -> ModelM blk b -> ModelM blk b
forall a b. ModelM blk a -> (a -> ModelM blk b) -> ModelM blk b
forall blk a b. ModelM blk a -> ModelM blk b -> ModelM blk b
forall blk a b. ModelM blk a -> (a -> ModelM blk b) -> ModelM blk b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall blk a b. ModelM blk a -> (a -> ModelM blk b) -> ModelM blk b
>>= :: forall a b. ModelM blk a -> (a -> ModelM blk b) -> ModelM blk b
$c>> :: forall blk a b. ModelM blk a -> ModelM blk b -> ModelM blk b
>> :: forall a b. ModelM blk a -> ModelM blk b -> ModelM blk b
$creturn :: forall blk a. a -> ModelM blk a
return :: forall a. a -> ModelM blk a
Monad
    , MonadReader (TopLevelConfig blk)
    , MonadState (Model blk)
    , MonadError TestFailure
    )

runModel ::
  Model blk ->
  TopLevelConfig blk ->
  ModelM blk b ->
  Either TestFailure b
runModel :: forall blk b.
Model blk
-> TopLevelConfig blk -> ModelM blk b -> Either TestFailure b
runModel Model blk
model TopLevelConfig blk
topLevelConfig ModelM blk b
expr =
  Except TestFailure b -> Either TestFailure b
forall e a. Except e a -> Either e a
runExcept (ReaderT (TopLevelConfig blk) (Except TestFailure) b
-> TopLevelConfig blk -> Except TestFailure b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT
  (Model blk) (ReaderT (TopLevelConfig blk) (Except TestFailure)) b
-> Model blk -> ReaderT (TopLevelConfig blk) (Except TestFailure) b
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ModelM blk b
-> StateT
     (Model blk) (ReaderT (TopLevelConfig blk) (Except TestFailure)) b
forall blk a.
ModelM blk a
-> StateT
     (Model blk) (ReaderT (TopLevelConfig blk) (Except TestFailure)) a
runModelM ModelM blk b
expr) Model blk
model) TopLevelConfig blk
topLevelConfig)

-- | Run a 'Cmd' against the model via 'SM.runPure'.
runModelCmd ::
  TestConstraints blk =>
  SM.Cmd blk Model.IteratorId Model.FollowerId ->
  ModelM blk (SM.Success blk Model.IteratorId Model.FollowerId)
runModelCmd :: forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd Cmd blk Int Int
cmd = do
  model <- ModelM blk (DBModel blk)
forall s (m :: * -> *). MonadState s m => m s
get
  cfg <- ask
  let (SM.Resp resp, model') = SM.runPure cfg cmd model
  put model'
  case resp of
    Left ChainDbError blk
err -> String -> ModelM blk (Success blk Int Int)
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (String -> ModelM blk (Success blk Int Int))
-> String -> ModelM blk (Success blk Int Int)
forall a b. (a -> b) -> a -> b
$ String
"runModelCmd: ChainDbError: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ChainDbError blk -> String
forall a. Show a => a -> String
show ChainDbError blk
err
    Right Success blk Int Int
success -> Success blk Int Int -> ModelM blk (Success blk Int Int)
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Success blk Int Int
success

instance
  (TestConstraints blk, LedgerTablesAreTrivial (LedgerState blk)) =>
  SupportsUnitTest (ModelM blk)
  where
  type FollowerId (ModelM blk) = Model.FollowerId
  type IteratorId (ModelM blk) = Model.IteratorId
  type Block (ModelM blk) = blk

  newFollower :: ModelM blk (FollowerId (ModelM blk))
newFollower = do
    result <- Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd (ChainType -> Cmd blk Int Int
forall blk it flr. ChainType -> Cmd blk it flr
SM.NewFollower ChainType
API.SelectedChain)
    case result of
      SM.Flr Int
fid -> Int -> ModelM blk Int
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
fid
      Success blk Int Int
_ -> String -> ModelM blk Int
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (String -> ModelM blk Int) -> String -> ModelM blk Int
forall a b. (a -> b) -> a -> b
$ String
"newFollower: unexpected result " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Success blk Int Int -> String
forall a. Show a => a -> String
show Success blk Int Int
result

  followerInstruction :: FollowerId (ModelM blk)
-> ModelM
     blk
     (Either
        (ChainDbError (Block (ModelM blk)))
        (Maybe
           (ChainUpdate
              (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))))
followerInstruction FollowerId (ModelM blk)
followerId = do
    result <- Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd (Int -> Cmd blk Int Int
forall blk it flr. flr -> Cmd blk it flr
SM.FollowerInstruction Int
FollowerId (ModelM blk)
followerId)
    case result of
      SM.MbChainUpdate Maybe
  (ChainUpdate
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
mcu -> Either
  (ChainDbError blk)
  (Maybe
     (ChainUpdate
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> ModelM
     blk
     (Either
        (ChainDbError blk)
        (Maybe
           (ChainUpdate
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
  (ChainUpdate
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> Either
     (ChainDbError blk)
     (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall a b. b -> Either a b
Right Maybe
  (ChainUpdate
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
mcu)
      Success blk Int Int
_ -> String
-> ModelM
     blk
     (Either
        (ChainDbError blk)
        (Maybe
           (ChainUpdate
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (String
 -> ModelM
      blk
      (Either
         (ChainDbError blk)
         (Maybe
            (ChainUpdate
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk)))))
-> String
-> ModelM
     blk
     (Either
        (ChainDbError blk)
        (Maybe
           (ChainUpdate
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall a b. (a -> b) -> a -> b
$ String
"followerInstruction: unexpected result" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Success blk Int Int -> String
forall a. Show a => a -> String
show Success blk Int Int
result

  addBlock :: Block (ModelM blk) -> ModelM blk (Block (ModelM blk))
addBlock Block (ModelM blk)
blk = do
    ModelM blk (Success blk Int Int) -> ModelM blk ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ModelM blk (Success blk Int Int) -> ModelM blk ())
-> ModelM blk (Success blk Int Int) -> ModelM blk ()
forall a b. (a -> b) -> a -> b
$ Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd (blk -> Persistent [blk] -> Cmd blk Int Int
forall blk it flr. blk -> Persistent [blk] -> Cmd blk it flr
SM.AddBlock blk
Block (ModelM blk)
blk ([blk] -> Persistent [blk]
forall a. a -> Persistent a
SM.Persistent []))
    blk -> ModelM blk blk
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure blk
Block (ModelM blk)
blk

  followerForward :: FollowerId (ModelM blk)
-> [Point (Block (ModelM blk))]
-> ModelM
     blk
     (Either
        (ChainDbError (Block (ModelM blk)))
        (Maybe (Point (Block (ModelM blk)))))
followerForward FollowerId (ModelM blk)
followerId [Point (Block (ModelM blk))]
points = do
    result <- Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd (Int -> [Point blk] -> Cmd blk Int Int
forall blk it flr. flr -> [Point blk] -> Cmd blk it flr
SM.FollowerForward Int
FollowerId (ModelM blk)
followerId [Point blk]
[Point (Block (ModelM blk))]
points)
    case result of
      SM.MbPoint Maybe (Point blk)
mp -> Either (ChainDbError blk) (Maybe (Point blk))
-> ModelM blk (Either (ChainDbError blk) (Maybe (Point blk)))
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Point blk) -> Either (ChainDbError blk) (Maybe (Point blk))
forall a b. b -> Either a b
Right Maybe (Point blk)
mp)
      Success blk Int Int
_ -> String
-> ModelM blk (Either (ChainDbError blk) (Maybe (Point blk)))
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (String
 -> ModelM blk (Either (ChainDbError blk) (Maybe (Point blk))))
-> String
-> ModelM blk (Either (ChainDbError blk) (Maybe (Point blk)))
forall a b. (a -> b) -> a -> b
$ String
"followerForward: unexpected result" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Success blk Int Int -> String
forall a. Show a => a -> String
show Success blk Int Int
result

  persistBlks :: ModelM blk ()
persistBlks =
    ModelM blk (Success blk Int Int) -> ModelM blk ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ModelM blk (Success blk Int Int) -> ModelM blk ())
-> ModelM blk (Success blk Int Int) -> ModelM blk ()
forall a b. (a -> b) -> a -> b
$ Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd Cmd blk Int Int
forall blk it flr. Cmd blk it flr
SM.PersistBlks

  persistBlksThenGC :: ModelM blk ()
persistBlksThenGC =
    ModelM blk (Success blk Int Int) -> ModelM blk ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ModelM blk (Success blk Int Int) -> ModelM blk ())
-> ModelM blk (Success blk Int Int) -> ModelM blk ()
forall a b. (a -> b) -> a -> b
$ Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd Cmd blk Int Int
forall blk it flr. Cmd blk it flr
SM.PersistBlksThenGC

  updateLedgerSnapshots :: ModelM blk ()
updateLedgerSnapshots =
    ModelM blk (Success blk Int Int) -> ModelM blk ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ModelM blk (Success blk Int Int) -> ModelM blk ())
-> ModelM blk (Success blk Int Int) -> ModelM blk ()
forall a b. (a -> b) -> a -> b
$ Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd Cmd blk Int Int
forall blk it flr. Cmd blk it flr
SM.UpdateLedgerSnapshots

  wipeVolatileDB :: ModelM blk (Point (Block (ModelM blk)))
wipeVolatileDB = do
    result <- Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd Cmd blk Int Int
forall blk it flr. Cmd blk it flr
SM.WipeVolatileDB
    case result of
      SM.Point Point blk
p -> Point blk -> ModelM blk (Point blk)
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Point blk
p
      Success blk Int Int
_ -> String -> ModelM blk (Point blk)
forall a. HasCallStack => String -> a
error (String -> ModelM blk (Point blk))
-> String -> ModelM blk (Point blk)
forall a b. (a -> b) -> a -> b
$ String
"wipeVolatileDB: unexpected result" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Success blk Int Int -> String
forall a. Show a => a -> String
show Success blk Int Int
result

  stream :: StreamFrom (Block (ModelM blk))
-> StreamTo (Block (ModelM blk))
-> ModelM
     blk
     (Either
        (ChainDbError (Block (ModelM blk)))
        (Either
           (UnknownRange (Block (ModelM blk))) (IteratorId (ModelM blk))))
stream StreamFrom (Block (ModelM blk))
from StreamTo (Block (ModelM blk))
to = do
    result <- Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd (StreamFrom blk -> StreamTo blk -> Cmd blk Int Int
forall blk it flr. StreamFrom blk -> StreamTo blk -> Cmd blk it flr
SM.Stream StreamFrom blk
StreamFrom (Block (ModelM blk))
from StreamTo blk
StreamTo (Block (ModelM blk))
to)
    case result of
      SM.Iter Int
iid -> Either (ChainDbError blk) (Either (UnknownRange blk) Int)
-> ModelM
     blk (Either (ChainDbError blk) (Either (UnknownRange blk) Int))
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (UnknownRange blk) Int
-> Either (ChainDbError blk) (Either (UnknownRange blk) Int)
forall a b. b -> Either a b
Right (Int -> Either (UnknownRange blk) Int
forall a b. b -> Either a b
Right Int
iid))
      SM.UnknownRange UnknownRange blk
ur -> Either (ChainDbError blk) (Either (UnknownRange blk) Int)
-> ModelM
     blk (Either (ChainDbError blk) (Either (UnknownRange blk) Int))
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (UnknownRange blk) Int
-> Either (ChainDbError blk) (Either (UnknownRange blk) Int)
forall a b. b -> Either a b
Right (UnknownRange blk -> Either (UnknownRange blk) Int
forall a b. a -> Either a b
Left UnknownRange blk
ur))
      Success blk Int Int
_ -> String
-> ModelM
     blk (Either (ChainDbError blk) (Either (UnknownRange blk) Int))
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (String
 -> ModelM
      blk (Either (ChainDbError blk) (Either (UnknownRange blk) Int)))
-> String
-> ModelM
     blk (Either (ChainDbError blk) (Either (UnknownRange blk) Int))
forall a b. (a -> b) -> a -> b
$ String
"stream: unexpected result" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Success blk Int Int -> String
forall a. Show a => a -> String
show Success blk Int Int
result

  iteratorNext :: IteratorId (ModelM blk)
-> ModelM
     blk
     (IteratorResult
        (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))
iteratorNext IteratorId (ModelM blk)
iteratorId = do
    result <- Cmd blk Int Int -> ModelM blk (Success blk Int Int)
forall blk.
TestConstraints blk =>
Cmd blk Int Int -> ModelM blk (Success blk Int Int)
runModelCmd (Int -> Cmd blk Int Int
forall blk it flr. it -> Cmd blk it flr
SM.IteratorNext Int
IteratorId (ModelM blk)
iteratorId)
    case result of
      SM.IterResult IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
ir -> IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> ModelM
     blk
     (IteratorResult
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
ir
      Success blk Int Int
_ -> String
-> ModelM
     blk
     (IteratorResult
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall (m :: * -> *) a. MonadError TestFailure m => String -> m a
failWith (String
 -> ModelM
      blk
      (IteratorResult
         blk
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)))
-> String
-> ModelM
     blk
     (IteratorResult
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall a b. (a -> b) -> a -> b
$ String
"iteratorNext: unexpected result" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Success blk Int Int -> String
forall a. Show a => a -> String
show Success blk Int Int
result

  -- the implementation is intentionally left trivial
  -- cannot be implemented in terms of `runCmdModel`
  waitForImmutableBlock :: RealPoint (Block (ModelM blk))
-> ModelM
     blk (Either SeekBlockError (RealPoint (Block (ModelM blk))))
waitForImmutableBlock RealPoint (Block (ModelM blk))
_ = Either SeekBlockError (RealPoint blk)
-> ModelM blk (Either SeekBlockError (RealPoint blk))
Either SeekBlockError (RealPoint blk)
-> ModelM
     blk (Either SeekBlockError (RealPoint (Block (ModelM blk))))
forall a. a -> ModelM blk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SeekBlockError (RealPoint blk)
 -> ModelM
      blk (Either SeekBlockError (RealPoint (Block (ModelM blk)))))
-> (SeekBlockError -> Either SeekBlockError (RealPoint blk))
-> SeekBlockError
-> ModelM
     blk (Either SeekBlockError (RealPoint (Block (ModelM blk))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeekBlockError -> Either SeekBlockError (RealPoint blk)
forall a b. a -> Either a b
Left (SeekBlockError
 -> ModelM
      blk (Either SeekBlockError (RealPoint (Block (ModelM blk)))))
-> SeekBlockError
-> ModelM
     blk (Either SeekBlockError (RealPoint (Block (ModelM blk))))
forall a b. (a -> b) -> a -> b
$ SeekBlockError
API.TargetNewerThanTip

{-------------------------------------------------------------------------------
  System
-------------------------------------------------------------------------------}

-- | Tests against the actual chain database run in this monad.
newtype SystemM blk m a = SystemM
  { forall blk (m :: * -> *) a.
SystemM blk m a
-> ReaderT (ChainDBEnv m blk) (ExceptT TestFailure m) a
runSystemM :: ReaderT (ChainDBEnv m blk) (ExceptT TestFailure m) a
  }
  deriving newtype
    ( (forall a b. (a -> b) -> SystemM blk m a -> SystemM blk m b)
-> (forall a b. a -> SystemM blk m b -> SystemM blk m a)
-> Functor (SystemM blk m)
forall a b. a -> SystemM blk m b -> SystemM blk m a
forall a b. (a -> b) -> SystemM blk m a -> SystemM blk m b
forall blk (m :: * -> *) a b.
Functor m =>
a -> SystemM blk m b -> SystemM blk m a
forall blk (m :: * -> *) a b.
Functor m =>
(a -> b) -> SystemM blk m a -> SystemM blk m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall blk (m :: * -> *) a b.
Functor m =>
(a -> b) -> SystemM blk m a -> SystemM blk m b
fmap :: forall a b. (a -> b) -> SystemM blk m a -> SystemM blk m b
$c<$ :: forall blk (m :: * -> *) a b.
Functor m =>
a -> SystemM blk m b -> SystemM blk m a
<$ :: forall a b. a -> SystemM blk m b -> SystemM blk m a
Functor
    , Functor (SystemM blk m)
Functor (SystemM blk m) =>
(forall a. a -> SystemM blk m a)
-> (forall a b.
    SystemM blk m (a -> b) -> SystemM blk m a -> SystemM blk m b)
-> (forall a b c.
    (a -> b -> c)
    -> SystemM blk m a -> SystemM blk m b -> SystemM blk m c)
-> (forall a b.
    SystemM blk m a -> SystemM blk m b -> SystemM blk m b)
-> (forall a b.
    SystemM blk m a -> SystemM blk m b -> SystemM blk m a)
-> Applicative (SystemM blk m)
forall a. a -> SystemM blk m a
forall a b. SystemM blk m a -> SystemM blk m b -> SystemM blk m a
forall a b. SystemM blk m a -> SystemM blk m b -> SystemM blk m b
forall a b.
SystemM blk m (a -> b) -> SystemM blk m a -> SystemM blk m b
forall a b c.
(a -> b -> c)
-> SystemM blk m a -> SystemM blk m b -> SystemM blk m c
forall blk (m :: * -> *). Monad m => Functor (SystemM blk m)
forall blk (m :: * -> *) a. Monad m => a -> SystemM blk m a
forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m a -> SystemM blk m b -> SystemM blk m a
forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m a -> SystemM blk m b -> SystemM blk m b
forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m (a -> b) -> SystemM blk m a -> SystemM blk m b
forall blk (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> SystemM blk m a -> SystemM blk m b -> SystemM blk m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall blk (m :: * -> *) a. Monad m => a -> SystemM blk m a
pure :: forall a. a -> SystemM blk m a
$c<*> :: forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m (a -> b) -> SystemM blk m a -> SystemM blk m b
<*> :: forall a b.
SystemM blk m (a -> b) -> SystemM blk m a -> SystemM blk m b
$cliftA2 :: forall blk (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> SystemM blk m a -> SystemM blk m b -> SystemM blk m c
liftA2 :: forall a b c.
(a -> b -> c)
-> SystemM blk m a -> SystemM blk m b -> SystemM blk m c
$c*> :: forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m a -> SystemM blk m b -> SystemM blk m b
*> :: forall a b. SystemM blk m a -> SystemM blk m b -> SystemM blk m b
$c<* :: forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m a -> SystemM blk m b -> SystemM blk m a
<* :: forall a b. SystemM blk m a -> SystemM blk m b -> SystemM blk m a
Applicative
    , Applicative (SystemM blk m)
Applicative (SystemM blk m) =>
(forall a b.
 SystemM blk m a -> (a -> SystemM blk m b) -> SystemM blk m b)
-> (forall a b.
    SystemM blk m a -> SystemM blk m b -> SystemM blk m b)
-> (forall a. a -> SystemM blk m a)
-> Monad (SystemM blk m)
forall a. a -> SystemM blk m a
forall a b. SystemM blk m a -> SystemM blk m b -> SystemM blk m b
forall a b.
SystemM blk m a -> (a -> SystemM blk m b) -> SystemM blk m b
forall blk (m :: * -> *). Monad m => Applicative (SystemM blk m)
forall blk (m :: * -> *) a. Monad m => a -> SystemM blk m a
forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m a -> SystemM blk m b -> SystemM blk m b
forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m a -> (a -> SystemM blk m b) -> SystemM blk m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m a -> (a -> SystemM blk m b) -> SystemM blk m b
>>= :: forall a b.
SystemM blk m a -> (a -> SystemM blk m b) -> SystemM blk m b
$c>> :: forall blk (m :: * -> *) a b.
Monad m =>
SystemM blk m a -> SystemM blk m b -> SystemM blk m b
>> :: forall a b. SystemM blk m a -> SystemM blk m b -> SystemM blk m b
$creturn :: forall blk (m :: * -> *) a. Monad m => a -> SystemM blk m a
return :: forall a. a -> SystemM blk m a
Monad
    , MonadReader (ChainDBEnv m blk)
    , MonadError TestFailure
    , Eq (ThreadId (SystemM blk m))
Monad (SystemM blk m)
Ord (ThreadId (SystemM blk m))
Show (ThreadId (SystemM blk m))
SystemM blk m (ThreadId (SystemM blk m))
(Monad (SystemM blk m), Eq (ThreadId (SystemM blk m)),
 Ord (ThreadId (SystemM blk m)), Show (ThreadId (SystemM blk m))) =>
SystemM blk m (ThreadId (SystemM blk m))
-> (ThreadId (SystemM blk m) -> String -> SystemM blk m ())
-> (ThreadId (SystemM blk m) -> SystemM blk m (Maybe String))
-> MonadThread (SystemM blk m)
ThreadId (SystemM blk m) -> SystemM blk m (Maybe String)
ThreadId (SystemM blk m) -> String -> SystemM blk m ()
forall blk (m :: * -> *).
MonadThread m =>
Eq (ThreadId (SystemM blk m))
forall blk (m :: * -> *). MonadThread m => Monad (SystemM blk m)
forall blk (m :: * -> *).
MonadThread m =>
Ord (ThreadId (SystemM blk m))
forall blk (m :: * -> *).
MonadThread m =>
Show (ThreadId (SystemM blk m))
forall blk (m :: * -> *).
MonadThread m =>
SystemM blk m (ThreadId (SystemM blk m))
forall blk (m :: * -> *).
MonadThread m =>
ThreadId (SystemM blk m) -> SystemM blk m (Maybe String)
forall blk (m :: * -> *).
MonadThread m =>
ThreadId (SystemM blk m) -> String -> SystemM blk m ()
forall (m :: * -> *).
(Monad m, Eq (ThreadId m), Ord (ThreadId m), Show (ThreadId m)) =>
m (ThreadId m)
-> (ThreadId m -> String -> m ())
-> (ThreadId m -> m (Maybe String))
-> MonadThread m
$cmyThreadId :: forall blk (m :: * -> *).
MonadThread m =>
SystemM blk m (ThreadId (SystemM blk m))
myThreadId :: SystemM blk m (ThreadId (SystemM blk m))
$clabelThread :: forall blk (m :: * -> *).
MonadThread m =>
ThreadId (SystemM blk m) -> String -> SystemM blk m ()
labelThread :: ThreadId (SystemM blk m) -> String -> SystemM blk m ()
$cthreadLabel :: forall blk (m :: * -> *).
MonadThread m =>
ThreadId (SystemM blk m) -> SystemM blk m (Maybe String)
threadLabel :: ThreadId (SystemM blk m) -> SystemM blk m (Maybe String)
MonadThread
    , MonadThread (SystemM blk m)
SystemM blk m Int
SystemM blk m ()
Int -> SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m))
MonadThread (SystemM blk m) =>
(SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m)))
-> (Int
    -> SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m)))
-> (((forall a. SystemM blk m a -> SystemM blk m a)
     -> SystemM blk m ())
    -> SystemM blk m (ThreadId (SystemM blk m)))
-> (forall a.
    SystemM blk m a
    -> (Either SomeException a -> SystemM blk m ())
    -> SystemM blk m (ThreadId (SystemM blk m)))
-> (forall e.
    Exception e =>
    ThreadId (SystemM blk m) -> e -> SystemM blk m ())
-> (ThreadId (SystemM blk m) -> SystemM blk m ())
-> SystemM blk m ()
-> SystemM blk m Int
-> MonadFork (SystemM blk m)
ThreadId (SystemM blk m) -> SystemM blk m ()
SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m))
((forall a. SystemM blk m a -> SystemM blk m a)
 -> SystemM blk m ())
-> SystemM blk m (ThreadId (SystemM blk m))
forall e.
Exception e =>
ThreadId (SystemM blk m) -> e -> SystemM blk m ()
forall a.
SystemM blk m a
-> (Either SomeException a -> SystemM blk m ())
-> SystemM blk m (ThreadId (SystemM blk m))
forall blk (m :: * -> *).
MonadFork m =>
MonadThread (SystemM blk m)
forall blk (m :: * -> *). MonadFork m => SystemM blk m Int
forall blk (m :: * -> *). MonadFork m => SystemM blk m ()
forall blk (m :: * -> *).
MonadFork m =>
Int -> SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m))
forall blk (m :: * -> *).
MonadFork m =>
ThreadId (SystemM blk m) -> SystemM blk m ()
forall blk (m :: * -> *).
MonadFork m =>
SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m))
forall blk (m :: * -> *).
MonadFork m =>
((forall a. SystemM blk m a -> SystemM blk m a)
 -> SystemM blk m ())
-> SystemM blk m (ThreadId (SystemM blk m))
forall blk (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId (SystemM blk m) -> e -> SystemM blk m ()
forall blk (m :: * -> *) a.
MonadFork m =>
SystemM blk m a
-> (Either SomeException a -> SystemM blk m ())
-> SystemM blk m (ThreadId (SystemM blk m))
forall (m :: * -> *).
MonadThread m =>
(m () -> m (ThreadId m))
-> (Int -> m () -> m (ThreadId m))
-> (((forall a. m a -> m a) -> m ()) -> m (ThreadId m))
-> (forall a.
    m a -> (Either SomeException a -> m ()) -> m (ThreadId m))
-> (forall e. Exception e => ThreadId m -> e -> m ())
-> (ThreadId m -> m ())
-> m ()
-> m Int
-> MonadFork m
$cforkIO :: forall blk (m :: * -> *).
MonadFork m =>
SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m))
forkIO :: SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m))
$cforkOn :: forall blk (m :: * -> *).
MonadFork m =>
Int -> SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m))
forkOn :: Int -> SystemM blk m () -> SystemM blk m (ThreadId (SystemM blk m))
$cforkIOWithUnmask :: forall blk (m :: * -> *).
MonadFork m =>
((forall a. SystemM blk m a -> SystemM blk m a)
 -> SystemM blk m ())
-> SystemM blk m (ThreadId (SystemM blk m))
forkIOWithUnmask :: ((forall a. SystemM blk m a -> SystemM blk m a)
 -> SystemM blk m ())
-> SystemM blk m (ThreadId (SystemM blk m))
$cforkFinally :: forall blk (m :: * -> *) a.
MonadFork m =>
SystemM blk m a
-> (Either SomeException a -> SystemM blk m ())
-> SystemM blk m (ThreadId (SystemM blk m))
forkFinally :: forall a.
SystemM blk m a
-> (Either SomeException a -> SystemM blk m ())
-> SystemM blk m (ThreadId (SystemM blk m))
$cthrowTo :: forall blk (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId (SystemM blk m) -> e -> SystemM blk m ()
throwTo :: forall e.
Exception e =>
ThreadId (SystemM blk m) -> e -> SystemM blk m ()
$ckillThread :: forall blk (m :: * -> *).
MonadFork m =>
ThreadId (SystemM blk m) -> SystemM blk m ()
killThread :: ThreadId (SystemM blk m) -> SystemM blk m ()
$cyield :: forall blk (m :: * -> *). MonadFork m => SystemM blk m ()
yield :: SystemM blk m ()
$cgetNumCapabilities :: forall blk (m :: * -> *). MonadFork m => SystemM blk m Int
getNumCapabilities :: SystemM blk m Int
MonadFork
    )

-- this instance is needed for the concurrent tests of 'waitForImmutableBlock'
instance MonadThread m => MonadThread (ExceptT e m) where
  type ThreadId (ExceptT e m) = ThreadId m
  myThreadId :: ExceptT e m (ThreadId (ExceptT e m))
myThreadId = m (ThreadId m) -> ExceptT e m (ThreadId m)
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (ThreadId m)
forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
  labelThread :: ThreadId (ExceptT e m) -> String -> ExceptT e m ()
labelThread ThreadId (ExceptT e m)
t String
l = m () -> ExceptT e m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ThreadId m -> String -> m ()
forall (m :: * -> *). MonadThread m => ThreadId m -> String -> m ()
labelThread ThreadId m
ThreadId (ExceptT e m)
t String
l)
  threadLabel :: ThreadId (ExceptT e m) -> ExceptT e m (Maybe String)
threadLabel ThreadId (ExceptT e m)
t = m (Maybe String) -> ExceptT e m (Maybe String)
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ThreadId m -> m (Maybe String)
forall (m :: * -> *).
MonadThread m =>
ThreadId m -> m (Maybe String)
threadLabel ThreadId m
ThreadId (ExceptT e m)
t)

-- this instance is needed for the concurrent tests of 'waitForImmutableBlock',
-- but we only need 'forkIO'
instance MonadFork m => MonadFork (ExceptT e m) where
  forkIO :: ExceptT e m () -> ExceptT e m (ThreadId (ExceptT e m))
forkIO (ExceptT m (Either e ())
action) = m (ThreadId (ExceptT e m)) -> ExceptT e m (ThreadId (ExceptT e m))
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ThreadId (ExceptT e m))
 -> ExceptT e m (ThreadId (ExceptT e m)))
-> m (ThreadId (ExceptT e m))
-> ExceptT e m (ThreadId (ExceptT e m))
forall a b. (a -> b) -> a -> b
$ m () -> m (ThreadId m)
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO (m (Either e ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m (Either e ())
action)
  forkIOWithUnmask :: ((forall a. ExceptT e m a -> ExceptT e m a) -> ExceptT e m ())
-> ExceptT e m (ThreadId (ExceptT e m))
forkIOWithUnmask (forall a. ExceptT e m a -> ExceptT e m a) -> ExceptT e m ()
_ = String -> ExceptT e m (ThreadId m)
forall a. HasCallStack => String -> a
error String
"Intentionally left unimplemented"
  forkOn :: Int -> ExceptT e m () -> ExceptT e m (ThreadId (ExceptT e m))
forkOn = String -> Int -> ExceptT e m () -> ExceptT e m (ThreadId m)
forall a. HasCallStack => String -> a
error String
"Intentionally left unimplemented"
  forkFinally :: forall a.
ExceptT e m a
-> (Either SomeException a -> ExceptT e m ())
-> ExceptT e m (ThreadId (ExceptT e m))
forkFinally = String
-> ExceptT e m a
-> (Either SomeException a -> ExceptT e m ())
-> ExceptT e m (ThreadId m)
forall a. HasCallStack => String -> a
error String
"Intentionally left unimplemented"
  throwTo :: forall e.
Exception e =>
ThreadId (ExceptT e m) -> e -> ExceptT e m ()
throwTo = String -> ThreadId m -> e -> ExceptT e m ()
forall a. HasCallStack => String -> a
error String
"Intentionally left unimplemented"
  yield :: ExceptT e m ()
yield = String -> ExceptT e m ()
forall a. HasCallStack => String -> a
error String
"Intentionally left unimplemented"
  getNumCapabilities :: ExceptT e m Int
getNumCapabilities = String -> ExceptT e m Int
forall a. HasCallStack => String -> a
error String
"Intentionally left unimplemented"

runSystem ::
  (forall a. (ChainDBEnv m blk -> m [TraceEvent blk] -> m a) -> m a) ->
  SystemM blk m b ->
  m (Either TestFailure b)
runSystem :: forall (m :: * -> *) blk b.
(forall a. (ChainDBEnv m blk -> m [TraceEvent blk] -> m a) -> m a)
-> SystemM blk m b -> m (Either TestFailure b)
runSystem forall a. (ChainDBEnv m blk -> m [TraceEvent blk] -> m a) -> m a
withChainDbEnv SystemM blk m b
expr =
  (ChainDBEnv m blk
 -> m [TraceEvent blk] -> m (Either TestFailure b))
-> m (Either TestFailure b)
forall a. (ChainDBEnv m blk -> m [TraceEvent blk] -> m a) -> m a
withChainDbEnv ((ChainDBEnv m blk
  -> m [TraceEvent blk] -> m (Either TestFailure b))
 -> m (Either TestFailure b))
-> (ChainDBEnv m blk
    -> m [TraceEvent blk] -> m (Either TestFailure b))
-> m (Either TestFailure b)
forall a b. (a -> b) -> a -> b
$ \ChainDBEnv m blk
env m [TraceEvent blk]
_getTrace ->
    ExceptT TestFailure m b -> m (Either TestFailure b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TestFailure m b -> m (Either TestFailure b))
-> ExceptT TestFailure m b -> m (Either TestFailure b)
forall a b. (a -> b) -> a -> b
$ ReaderT (ChainDBEnv m blk) (ExceptT TestFailure m) b
-> ChainDBEnv m blk -> ExceptT TestFailure m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SystemM blk m b
-> ReaderT (ChainDBEnv m blk) (ExceptT TestFailure m) b
forall blk (m :: * -> *) a.
SystemM blk m a
-> ReaderT (ChainDBEnv m blk) (ExceptT TestFailure m) a
runSystemM SystemM blk m b
expr) ChainDBEnv m blk
env

-- | Provide a standard ChainDbEnv for testing.
withTestChainDbEnv ::
  (IOLike m, TestConstraints blk) =>
  TopLevelConfig blk ->
  ImmutableDB.ChunkInfo ->
  ExtLedgerState blk ValuesMK ->
  (ChainDBEnv m blk -> m [TraceEvent blk] -> m a) ->
  m a
withTestChainDbEnv :: forall (m :: * -> *) blk a.
(IOLike m, TestConstraints blk) =>
TopLevelConfig blk
-> ChunkInfo
-> ExtLedgerState blk ValuesMK
-> (ChainDBEnv m blk -> m [TraceEvent blk] -> m a)
-> m a
withTestChainDbEnv TopLevelConfig blk
topLevelConfig ChunkInfo
chunkInfo ExtLedgerState blk ValuesMK
extLedgerState ChainDBEnv m blk -> m [TraceEvent blk] -> m a
cont =
  m (ChainDBEnv m blk, m [TraceEvent blk])
-> ((ChainDBEnv m blk, m [TraceEvent blk]) -> m ())
-> ((ChainDBEnv m blk, m [TraceEvent blk]) -> m a)
-> m a
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m (ChainDBEnv m blk, m [TraceEvent blk])
openChainDbEnv (ChainDBEnv m blk, m [TraceEvent blk]) -> m ()
forall {m :: * -> *} {blk} {b}.
IOLike m =>
(ChainDBEnv m blk, b) -> m ()
closeChainDbEnv ((ChainDBEnv m blk -> m [TraceEvent blk] -> m a)
-> (ChainDBEnv m blk, m [TraceEvent blk]) -> m a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ChainDBEnv m blk -> m [TraceEvent blk] -> m a
cont)
 where
  openChainDbEnv :: m (ChainDBEnv m blk, m [TraceEvent blk])
openChainDbEnv = do
    threadRegistry <- m (ResourceRegistry m)
forall (m :: * -> *).
(MonadSTM m, MonadThread m, HasCallStack) =>
m (ResourceRegistry m)
unsafeNewRegistry
    iteratorRegistry <- unsafeNewRegistry
    varNextId <- uncheckedNewTVarM 0
    varLoEFragment <- newTVarIO $ AF.Empty AF.AnchorGenesis
    nodeDbs <- emptyNodeDBs
    (tracer, getTrace) <- recordingTracerTVar
    let args = ResourceRegistry m
-> NodeDBs (StrictTMVar m MockFS)
-> Tracer m (TraceEvent blk)
-> ChainDbArgs Identity m blk
chainDbArgs ResourceRegistry m
threadRegistry NodeDBs (StrictTMVar m MockFS)
nodeDbs Tracer m (TraceEvent blk)
tracer
    varDB <- open args >>= newTVarIO
    let env =
          ChainDBEnv
            { StrictTVar m (ChainDBState m blk)
varDB :: StrictTVar m (ChainDBState m blk)
varDB :: StrictTVar m (ChainDBState m blk)
varDB
            , registry :: ResourceRegistry m
registry = ResourceRegistry m
iteratorRegistry
            , StrictTVar m Id
varNextId :: StrictTVar m Id
varNextId :: StrictTVar m Id
varNextId
            , varVolatileDbFs :: StrictTMVar m MockFS
varVolatileDbFs = NodeDBs (StrictTMVar m MockFS) -> StrictTMVar m MockFS
forall db. NodeDBs db -> db
nodeDBsVol NodeDBs (StrictTMVar m MockFS)
nodeDbs
            , ChainDbArgs Identity m blk
args :: ChainDbArgs Identity m blk
args :: ChainDbArgs Identity m blk
args
            , StrictTVar
  m
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk))
varLoEFragment :: StrictTVar
  m
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk))
varLoEFragment :: StrictTVar
  m
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk))
varLoEFragment
            }
    pure (env, getTrace)

  closeChainDbEnv :: (ChainDBEnv m blk, b) -> m ()
closeChainDbEnv (ChainDBEnv m blk
env, b
_) = do
    StrictTVar m (ChainDBState m blk) -> m (ChainDBState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ChainDBEnv m blk -> StrictTVar m (ChainDBState m blk)
forall (m :: * -> *) blk.
ChainDBEnv m blk -> StrictTVar m (ChainDBState m blk)
varDB ChainDBEnv m blk
env) m (ChainDBState m blk) -> (ChainDBState m blk -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChainDBState m blk -> m ()
forall (m :: * -> *) blk. IOLike m => ChainDBState m blk -> m ()
close
    ResourceRegistry m -> m ()
forall (m :: * -> *).
(MonadMask m, MonadThread m, MonadSTM m, HasCallStack) =>
ResourceRegistry m -> m ()
closeRegistry (ChainDBEnv m blk -> ResourceRegistry m
forall (m :: * -> *) blk. ChainDBEnv m blk -> ResourceRegistry m
registry ChainDBEnv m blk
env)
    ResourceRegistry m -> m ()
forall (m :: * -> *).
(MonadMask m, MonadThread m, MonadSTM m, HasCallStack) =>
ResourceRegistry m -> m ()
closeRegistry (ChainDbSpecificArgs Identity m blk
-> HKD Identity (ResourceRegistry m)
ChainDbSpecificArgs Identity m blk -> ResourceRegistry m
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> HKD f (ResourceRegistry m)
cdbsRegistry (ChainDbSpecificArgs Identity m blk -> ResourceRegistry m)
-> (ChainDbArgs Identity m blk
    -> ChainDbSpecificArgs Identity m blk)
-> ChainDbArgs Identity m blk
-> ResourceRegistry m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDbArgs Identity m blk -> ChainDbSpecificArgs Identity m blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbSpecificArgs f m blk
cdbsArgs (ChainDbArgs Identity m blk -> ResourceRegistry m)
-> ChainDbArgs Identity m blk -> ResourceRegistry m
forall a b. (a -> b) -> a -> b
$ ChainDBEnv m blk -> ChainDbArgs Identity m blk
forall (m :: * -> *) blk.
ChainDBEnv m blk -> ChainDbArgs Identity m blk
args ChainDBEnv m blk
env)

  chainDbArgs :: ResourceRegistry m
-> NodeDBs (StrictTMVar m MockFS)
-> Tracer m (TraceEvent blk)
-> ChainDbArgs Identity m blk
chainDbArgs ResourceRegistry m
registry NodeDBs (StrictTMVar m MockFS)
nodeDbs Tracer m (TraceEvent blk)
tracer =
    let args :: ChainDbArgs Identity m blk
args =
          MinimalChainDbArgs m blk -> ChainDbArgs Identity m blk
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 LedgerSupportsLedgerDB blk) =>
MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk
fromMinimalChainDbArgs
            MinimalChainDbArgs
              { mcdbTopLevelConfig :: TopLevelConfig blk
mcdbTopLevelConfig = TopLevelConfig blk
topLevelConfig
              , mcdbChunkInfo :: ChunkInfo
mcdbChunkInfo = ChunkInfo
chunkInfo
              , mcdbInitLedger :: ExtLedgerState blk ValuesMK
mcdbInitLedger = ExtLedgerState blk ValuesMK
extLedgerState
              , mcdbRegistry :: ResourceRegistry m
mcdbRegistry = ResourceRegistry m
registry
              , mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs = NodeDBs (StrictTMVar m MockFS)
nodeDbs
              }
     in Tracer m (TraceEvent blk)
-> ChainDbArgs Identity m blk -> ChainDbArgs Identity m blk
forall (m :: * -> *) blk (f :: * -> *).
Tracer m (TraceEvent blk)
-> ChainDbArgs f m blk -> ChainDbArgs f m blk
updateTracer Tracer m (TraceEvent blk)
tracer ChainDbArgs Identity m blk
args

-- | Run a 'Cmd' against the real ChainDB via 'SM.run'.
runCmd ::
  (IOLike m, TestConstraints blk) =>
  SM.Cmd blk (SM.TestIterator m blk) (SM.TestFollower m blk) ->
  SystemM blk m (SM.Success blk (SM.TestIterator m blk) (SM.TestFollower m blk))
runCmd :: forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd Cmd blk (TestIterator m blk) (TestFollower m blk)
cmd = do
  env <- SystemM blk m (ChainDBEnv m blk)
forall r (m :: * -> *). MonadReader r m => m r
ask
  let cfg = ChainDbSpecificArgs Identity m blk
-> HKD Identity (TopLevelConfig blk)
ChainDbSpecificArgs Identity m blk -> TopLevelConfig blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> HKD f (TopLevelConfig blk)
cdbsTopLevelConfig (ChainDbSpecificArgs Identity m blk -> TopLevelConfig blk)
-> (ChainDbArgs Identity m blk
    -> ChainDbSpecificArgs Identity m blk)
-> ChainDbArgs Identity m blk
-> TopLevelConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDbArgs Identity m blk -> ChainDbSpecificArgs Identity m blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbSpecificArgs f m blk
cdbsArgs (ChainDbArgs Identity m blk -> TopLevelConfig blk)
-> ChainDbArgs Identity m blk -> TopLevelConfig blk
forall a b. (a -> b) -> a -> b
$ ChainDBEnv m blk -> ChainDbArgs Identity m blk
forall (m :: * -> *) blk.
ChainDBEnv m blk -> ChainDbArgs Identity m blk
args ChainDBEnv m blk
env
  SystemM $ lift $ lift $ SM.run cfg env cmd

instance (IOLike m, TestConstraints blk) => SupportsUnitTest (SystemM blk m) where
  type IteratorId (SystemM blk m) = SM.TestIterator m blk
  type FollowerId (SystemM blk m) = SM.TestFollower m blk
  type Block (SystemM blk m) = blk

  addBlock :: Block (SystemM blk m) -> SystemM blk m (Block (SystemM blk m))
addBlock Block (SystemM blk m)
blk = do
    SystemM
  blk
  m
  (Success
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> SystemM blk m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (SystemM
   blk
   m
   (Success
      blk
      (WithEq
         (Iterator
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
      (WithEq
         (Follower
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> SystemM blk m ())
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
-> SystemM blk m ()
forall a b. (a -> b) -> a -> b
$ Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd (blk
-> Persistent [blk]
-> Cmd
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. blk -> Persistent [blk] -> Cmd blk it flr
SM.AddBlock blk
Block (SystemM blk m)
blk ([blk] -> Persistent [blk]
forall a. a -> Persistent a
SM.Persistent []))
    blk -> SystemM blk m blk
forall a. a -> SystemM blk m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure blk
Block (SystemM blk m)
blk

  persistBlks :: SystemM blk m ()
persistBlks =
    SystemM
  blk
  m
  (Success
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> SystemM blk m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (SystemM
   blk
   m
   (Success
      blk
      (WithEq
         (Iterator
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
      (WithEq
         (Follower
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> SystemM blk m ())
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
-> SystemM blk m ()
forall a b. (a -> b) -> a -> b
$ Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. Cmd blk it flr
SM.PersistBlks

  persistBlksThenGC :: SystemM blk m ()
persistBlksThenGC =
    SystemM
  blk
  m
  (Success
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> SystemM blk m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (SystemM
   blk
   m
   (Success
      blk
      (WithEq
         (Iterator
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
      (WithEq
         (Follower
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> SystemM blk m ())
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
-> SystemM blk m ()
forall a b. (a -> b) -> a -> b
$ Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. Cmd blk it flr
SM.PersistBlksThenGC

  updateLedgerSnapshots :: SystemM blk m ()
updateLedgerSnapshots = do
    SystemM
  blk
  m
  (Success
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> SystemM blk m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (SystemM
   blk
   m
   (Success
      blk
      (WithEq
         (Iterator
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
      (WithEq
         (Follower
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> SystemM blk m ())
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
-> SystemM blk m ()
forall a b. (a -> b) -> a -> b
$ Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. Cmd blk it flr
SM.UpdateLedgerSnapshots

  wipeVolatileDB :: SystemM blk m (Point (Block (SystemM blk m)))
wipeVolatileDB = do
    result <- Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. Cmd blk it flr
SM.WipeVolatileDB
    case result of
      SM.Point Point blk
p -> Point blk -> SystemM blk m (Point blk)
forall a. a -> SystemM blk m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Point blk
p
      Success
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
_ -> String -> SystemM blk m (Point blk)
forall a. HasCallStack => String -> a
error (String -> SystemM blk m (Point blk))
-> String -> SystemM blk m (Point blk)
forall a b. (a -> b) -> a -> b
$ String
"wipeVolatileDB: unexpected result"

  newFollower :: SystemM blk m (FollowerId (SystemM blk m))
newFollower = do
    result <- Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd (ChainType
-> Cmd
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. ChainType -> Cmd blk it flr
SM.NewFollower ChainType
API.SelectedChain)
    case result of
      SM.Flr WithEq
  (Follower
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
fid -> WithEq
  (Follower
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> SystemM
     blk
     m
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall a. a -> SystemM blk m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithEq
  (Follower
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
fid
      Success
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
_ -> String
-> SystemM
     blk
     m
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall a. HasCallStack => String -> a
error String
"newFollower: unexpected result"

  followerInstruction :: FollowerId (SystemM blk m)
-> SystemM
     blk
     m
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe
           (ChainUpdate
              (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))))
followerInstruction FollowerId (SystemM blk m)
followerId = do
    result <- Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd (WithEq
  (Follower
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> Cmd
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. flr -> Cmd blk it flr
SM.FollowerInstruction WithEq
  (Follower
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
FollowerId (SystemM blk m)
followerId)
    case result of
      SM.MbChainUpdate Maybe
  (ChainUpdate
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
mcu -> Either
  (ChainDbError blk)
  (Maybe
     (ChainUpdate
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Either
        (ChainDbError blk)
        (Maybe
           (ChainUpdate
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall a. a -> SystemM blk m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
  (ChainUpdate
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> Either
     (ChainDbError blk)
     (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall a b. b -> Either a b
Right Maybe
  (ChainUpdate
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
mcu)
      Success
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
_ -> String
-> SystemM
     blk
     m
     (Either
        (ChainDbError blk)
        (Maybe
           (ChainUpdate
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall a. HasCallStack => String -> a
error String
"followerInstruction: unexpected result"

  followerForward :: FollowerId (SystemM blk m)
-> [Point (Block (SystemM blk m))]
-> SystemM
     blk
     m
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
followerForward FollowerId (SystemM blk m)
followerId [Point (Block (SystemM blk m))]
points = do
    result <- Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd (WithEq
  (Follower
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> [Point blk]
-> Cmd
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. flr -> [Point blk] -> Cmd blk it flr
SM.FollowerForward WithEq
  (Follower
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
FollowerId (SystemM blk m)
followerId [Point blk]
[Point (Block (SystemM blk m))]
points)
    case result of
      SM.MbPoint Maybe (Point blk)
mp -> Either (ChainDbError blk) (Maybe (Point blk))
-> SystemM blk m (Either (ChainDbError blk) (Maybe (Point blk)))
forall a. a -> SystemM blk m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Point blk) -> Either (ChainDbError blk) (Maybe (Point blk))
forall a b. b -> Either a b
Right Maybe (Point blk)
mp)
      Success
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
_ -> String
-> SystemM blk m (Either (ChainDbError blk) (Maybe (Point blk)))
forall a. HasCallStack => String -> a
error String
"followerForward: unexpected result"

  stream :: StreamFrom (Block (SystemM blk m))
-> StreamTo (Block (SystemM blk m))
-> SystemM
     blk
     m
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Either
           (UnknownRange (Block (SystemM blk m)))
           (IteratorId (SystemM blk m))))
stream StreamFrom (Block (SystemM blk m))
from StreamTo (Block (SystemM blk m))
to = do
    result <- Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd (StreamFrom blk
-> StreamTo blk
-> Cmd
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. StreamFrom blk -> StreamTo blk -> Cmd blk it flr
SM.Stream StreamFrom blk
StreamFrom (Block (SystemM blk m))
from StreamTo blk
StreamTo (Block (SystemM blk m))
to)
    case result of
      SM.Iter WithEq
  (Iterator
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
iid -> Either
  (ChainDbError blk)
  (Either
     (UnknownRange blk)
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> SystemM
     blk
     m
     (Either
        (ChainDbError blk)
        (Either
           (UnknownRange blk)
           (WithEq
              (Iterator
                 m
                 blk
                 (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                  SlotNo, IsEBB, SizeInBytes, Word16,
                  SomeSecond (NestedCtxt Header) blk)))))
forall a. a -> SystemM blk m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
  (UnknownRange blk)
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> Either
     (ChainDbError blk)
     (Either
        (UnknownRange blk)
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall a b. b -> Either a b
Right (WithEq
  (Iterator
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> Either
     (UnknownRange blk)
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall a b. b -> Either a b
Right WithEq
  (Iterator
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
iid))
      SM.UnknownRange UnknownRange blk
ur -> Either
  (ChainDbError blk)
  (Either
     (UnknownRange blk)
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> SystemM
     blk
     m
     (Either
        (ChainDbError blk)
        (Either
           (UnknownRange blk)
           (WithEq
              (Iterator
                 m
                 blk
                 (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                  SlotNo, IsEBB, SizeInBytes, Word16,
                  SomeSecond (NestedCtxt Header) blk)))))
forall a. a -> SystemM blk m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
  (UnknownRange blk)
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> Either
     (ChainDbError blk)
     (Either
        (UnknownRange blk)
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall a b. b -> Either a b
Right (UnknownRange blk
-> Either
     (UnknownRange blk)
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall a b. a -> Either a b
Left UnknownRange blk
ur))
      Success
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
_ -> String
-> SystemM
     blk
     m
     (Either
        (ChainDbError blk)
        (Either
           (UnknownRange blk)
           (WithEq
              (Iterator
                 m
                 blk
                 (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                  SlotNo, IsEBB, SizeInBytes, Word16,
                  SomeSecond (NestedCtxt Header) blk)))))
forall a. HasCallStack => String -> a
error String
"stream: unexpected result"

  iteratorNext :: IteratorId (SystemM blk m)
-> SystemM
     blk
     m
     (IteratorResult
        (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
iteratorNext IteratorId (SystemM blk m)
iteratorId = do
    result <- Cmd
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> SystemM
     blk
     m
     (Success
        blk
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
Cmd blk (TestIterator m blk) (TestFollower m blk)
-> SystemM
     blk m (Success blk (TestIterator m blk) (TestFollower m blk))
runCmd (WithEq
  (Iterator
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> Cmd
     blk
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall blk it flr. it -> Cmd blk it flr
SM.IteratorNext WithEq
  (Iterator
     m
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
IteratorId (SystemM blk m)
iteratorId)
    case result of
      SM.IterResult IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
ir -> IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> SystemM
     blk
     m
     (IteratorResult
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall a. a -> SystemM blk m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
ir
      Success
  blk
  (WithEq
     (Iterator
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
  (WithEq
     (Follower
        m
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
_ -> String
-> SystemM
     blk
     m
     (IteratorResult
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall a. HasCallStack => String -> a
error String
"iteratorNext: unexpected result"

  -- cannot be implemented in terms of `runCmd`
  waitForImmutableBlock :: RealPoint (Block (SystemM blk m))
-> SystemM
     blk m (Either SeekBlockError (RealPoint (Block (SystemM blk m))))
waitForImmutableBlock RealPoint (Block (SystemM blk m))
targetPoint = do
    env <- SystemM blk m (ChainDBEnv m blk)
forall r (m :: * -> *). MonadReader r m => m r
ask
    SystemM $ lift $ lift $ do
      api <- chainDB <$> readTVarIO (varDB env)
      API.waitForImmutableBlock api targetPoint