{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

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


import           Cardano.Slotting.Slot (WithOrigin (..))
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
                     (pointToWithOriginRealPoint)
import           Ouroboros.Consensus.Config (TopLevelConfig,
                     configSecurityParam)
import           Ouroboros.Consensus.Ledger.Basics
import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState)
import           Ouroboros.Consensus.Ledger.SupportsProtocol
                     (LedgerSupportsProtocol)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as API
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment 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)
import qualified Ouroboros.Network.Mock.Chain as Mock
import qualified Test.Ouroboros.Storage.ChainDB.Model as Model
import           Test.Ouroboros.Storage.ChainDB.Model (Model)
import qualified Test.Ouroboros.Storage.ChainDB.StateMachine as SM
import           Test.Ouroboros.Storage.ChainDB.StateMachine (AllComponents,
                     ChainDBEnv (..), ChainDBState (..),
                     ShouldGarbageCollect (..), TestConstraints, allComponents,
                     close, mkTestCfg, open)
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
    ]
  ]


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 -> TestBody
TestBody Word
i Bool
True
  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 -> TestBody
TestBody Word
i Bool
True
  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 DoNotGarbageCollect
    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
    persistBlks GarbageCollect

    -- 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 = [
            -- The dead fork has been garbage-collected.
            [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 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 -> TestBody
TestBody Word
i Bool
True

    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
    -- Do not call this function with `Genesis`
    blockRealPoint :: blk -> RealPoint blk
blockRealPoint blk
blk = case Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint (Point blk -> WithOrigin (RealPoint blk))
-> Point blk -> WithOrigin (RealPoint blk)
forall a b. (a -> b) -> a -> b
$ blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
blk of
      At RealPoint blk
realPoint -> RealPoint blk
realPoint
      WithOrigin (RealPoint blk)
_            -> String -> RealPoint blk
forall a. HasCallStack => String -> a
error String
"Should not happen"


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
    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 = ChunkInfo -> TopLevelConfig TestBlock
mkTestCfg 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
    topLevelConfig :: TopLevelConfig TestBlock
topLevelConfig = ChunkInfo -> TopLevelConfig TestBlock
mkTestCfg 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 :: ShouldGarbageCollect -> 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)))


{-------------------------------------------------------------------------------
  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)


withModelContext :: (Model blk -> TopLevelConfig blk -> (a, Model blk)) -> ModelM blk a
withModelContext :: forall blk a.
(Model blk -> TopLevelConfig blk -> (a, Model blk)) -> ModelM blk a
withModelContext Model blk -> TopLevelConfig blk -> (a, Model blk)
f = do
  model <- ModelM blk (Model blk)
forall s (m :: * -> *). MonadState s m => m s
get
  topLevelConfig <- ask
  let (a, model') = f model topLevelConfig
  put model'
  pure a


instance (Model.ModelSupportsBlock blk, LedgerSupportsProtocol 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 = (Model blk
 -> TopLevelConfig blk -> (FollowerId (ModelM blk), Model blk))
-> ModelM blk (FollowerId (ModelM blk))
forall blk a.
(Model blk -> TopLevelConfig blk -> (a, Model blk)) -> ModelM blk a
withModelContext ((Model blk
  -> TopLevelConfig blk -> (FollowerId (ModelM blk), Model blk))
 -> ModelM blk (FollowerId (ModelM blk)))
-> (Model blk
    -> TopLevelConfig blk -> (FollowerId (ModelM blk), Model blk))
-> ModelM blk (FollowerId (ModelM blk))
forall a b. (a -> b) -> a -> b
$ \Model blk
model TopLevelConfig blk
_ ->
    Model blk -> (Int, Model blk)
forall blk. HasHeader blk => Model blk -> (Int, Model blk)
Model.newFollower Model blk
model

  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 = (Model blk
 -> TopLevelConfig blk
 -> (Either
       (ChainDbError (Block (ModelM blk)))
       (Maybe
          (ChainUpdate
             (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))),
     Model blk))
-> ModelM
     blk
     (Either
        (ChainDbError (Block (ModelM blk)))
        (Maybe
           (ChainUpdate
              (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))))
forall blk a.
(Model blk -> TopLevelConfig blk -> (a, Model blk)) -> ModelM blk a
withModelContext ((Model blk
  -> TopLevelConfig blk
  -> (Either
        (ChainDbError (Block (ModelM blk)))
        (Maybe
           (ChainUpdate
              (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))),
      Model blk))
 -> ModelM
      blk
      (Either
         (ChainDbError (Block (ModelM blk)))
         (Maybe
            (ChainUpdate
               (Block (ModelM blk)) (AllComponents (Block (ModelM blk)))))))
-> (Model blk
    -> TopLevelConfig blk
    -> (Either
          (ChainDbError (Block (ModelM blk)))
          (Maybe
             (ChainUpdate
                (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))),
        Model blk))
-> ModelM
     blk
     (Either
        (ChainDbError (Block (ModelM blk)))
        (Maybe
           (ChainUpdate
              (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))))
forall a b. (a -> b) -> a -> b
$ \Model blk
model TopLevelConfig blk
_ ->
    case Int
-> BlockComponent
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> Model blk
-> Either
     (ChainDbError blk)
     (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)),
      Model blk)
forall blk b.
ModelSupportsBlock blk =>
Int
-> BlockComponent blk b
-> Model blk
-> Either (ChainDbError blk) (Maybe (ChainUpdate blk b), Model blk)
Model.followerInstruction Int
FollowerId (ModelM blk)
followerId BlockComponent
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
forall blk. BlockComponent blk (AllComponents blk)
allComponents Model blk
model of
      Left ChainDbError blk
err                     -> (ChainDbError 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 -> Either a b
Left ChainDbError blk
err, Model blk
model)
      Right (Maybe
  (ChainUpdate
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
mChainUpdate, Model blk
model') -> (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))
mChainUpdate, Model blk
model')

  addBlock :: Block (ModelM blk) -> ModelM blk (Block (ModelM blk))
addBlock Block (ModelM blk)
blk = do
    -- Ensure that blocks are not characterized as invalid because they are
    -- from the future.
    (Model blk -> TopLevelConfig blk -> ((), Model blk))
-> ModelM blk ()
forall blk a.
(Model blk -> TopLevelConfig blk -> (a, Model blk)) -> ModelM blk a
withModelContext ((Model blk -> TopLevelConfig blk -> ((), Model blk))
 -> ModelM blk ())
-> (Model blk -> TopLevelConfig blk -> ((), Model blk))
-> ModelM blk ()
forall a b. (a -> b) -> a -> b
$ \Model blk
model TopLevelConfig blk
cfg -> ((), TopLevelConfig blk -> blk -> Model blk -> Model blk
forall blk.
(LedgerSupportsProtocol blk,
 LedgerTablesAreTrivial (ExtLedgerState blk)) =>
TopLevelConfig blk -> blk -> Model blk -> Model blk
Model.addBlock TopLevelConfig blk
cfg blk
Block (ModelM blk)
blk Model blk
model)
    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 = (Model blk
 -> TopLevelConfig blk
 -> (Either
       (ChainDbError (Block (ModelM blk)))
       (Maybe (Point (Block (ModelM blk)))),
     Model blk))
-> ModelM
     blk
     (Either
        (ChainDbError (Block (ModelM blk)))
        (Maybe (Point (Block (ModelM blk)))))
forall blk a.
(Model blk -> TopLevelConfig blk -> (a, Model blk)) -> ModelM blk a
withModelContext ((Model blk
  -> TopLevelConfig blk
  -> (Either
        (ChainDbError (Block (ModelM blk)))
        (Maybe (Point (Block (ModelM blk)))),
      Model blk))
 -> ModelM
      blk
      (Either
         (ChainDbError (Block (ModelM blk)))
         (Maybe (Point (Block (ModelM blk))))))
-> (Model blk
    -> TopLevelConfig blk
    -> (Either
          (ChainDbError (Block (ModelM blk)))
          (Maybe (Point (Block (ModelM blk)))),
        Model blk))
-> ModelM
     blk
     (Either
        (ChainDbError (Block (ModelM blk)))
        (Maybe (Point (Block (ModelM blk)))))
forall a b. (a -> b) -> a -> b
$ \Model blk
model TopLevelConfig blk
_ ->
    case Int
-> [Point blk]
-> Model blk
-> Either (ChainDbError blk) (Maybe (Point blk), Model blk)
forall blk.
HasHeader blk =>
Int
-> [Point blk]
-> Model blk
-> Either (ChainDbError blk) (Maybe (Point blk), Model blk)
Model.followerForward Int
FollowerId (ModelM blk)
followerId [Point blk]
[Point (Block (ModelM blk))]
points Model blk
model of
      Left ChainDbError blk
err                     -> (ChainDbError blk -> Either (ChainDbError blk) (Maybe (Point blk))
forall a b. a -> Either a b
Left ChainDbError blk
err, Model blk
model)
      Right (Maybe (Point blk)
mChainUpdate, Model blk
model') -> (Maybe (Point blk) -> Either (ChainDbError blk) (Maybe (Point blk))
forall a b. b -> Either a b
Right Maybe (Point blk)
mChainUpdate, Model blk
model')

  persistBlks :: ShouldGarbageCollect -> ModelM blk ()
persistBlks ShouldGarbageCollect
shouldGarbageCollect = (Model blk -> TopLevelConfig blk -> ((), Model blk))
-> ModelM blk ()
forall blk a.
(Model blk -> TopLevelConfig blk -> (a, Model blk)) -> ModelM blk a
withModelContext ((Model blk -> TopLevelConfig blk -> ((), Model blk))
 -> ModelM blk ())
-> (Model blk -> TopLevelConfig blk -> ((), Model blk))
-> ModelM blk ()
forall a b. (a -> b) -> a -> b
$ \Model blk
model TopLevelConfig blk
cfg ->
    do
      let k :: SecurityParam
k = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg
      Model blk -> ((), Model blk)
forall a. a -> ((), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Model blk -> ((), Model blk)) -> Model blk -> ((), Model blk)
forall a b. (a -> b) -> a -> b
$ SecurityParam -> ShouldGarbageCollect -> Model blk -> Model blk
forall blk.
HasHeader blk =>
SecurityParam -> ShouldGarbageCollect -> Model blk -> Model blk
Model.copyToImmutableDB SecurityParam
k ShouldGarbageCollect
shouldGarbageCollect Model blk
model

  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 = (Model blk
 -> TopLevelConfig blk
 -> (Either
       (ChainDbError (Block (ModelM blk)))
       (Either
          (UnknownRange (Block (ModelM blk))) (IteratorId (ModelM blk))),
     Model blk))
-> ModelM
     blk
     (Either
        (ChainDbError (Block (ModelM blk)))
        (Either
           (UnknownRange (Block (ModelM blk))) (IteratorId (ModelM blk))))
forall blk a.
(Model blk -> TopLevelConfig blk -> (a, Model blk)) -> ModelM blk a
withModelContext ((Model blk
  -> TopLevelConfig blk
  -> (Either
        (ChainDbError (Block (ModelM blk)))
        (Either
           (UnknownRange (Block (ModelM blk))) (IteratorId (ModelM blk))),
      Model blk))
 -> ModelM
      blk
      (Either
         (ChainDbError (Block (ModelM blk)))
         (Either
            (UnknownRange (Block (ModelM blk))) (IteratorId (ModelM blk)))))
-> (Model blk
    -> TopLevelConfig blk
    -> (Either
          (ChainDbError (Block (ModelM blk)))
          (Either
             (UnknownRange (Block (ModelM blk))) (IteratorId (ModelM blk))),
        Model blk))
-> ModelM
     blk
     (Either
        (ChainDbError (Block (ModelM blk)))
        (Either
           (UnknownRange (Block (ModelM blk))) (IteratorId (ModelM blk))))
forall a b. (a -> b) -> a -> b
$ \Model blk
model TopLevelConfig blk
cfg ->
    do
      let k :: SecurityParam
k = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg
      case SecurityParam
-> StreamFrom blk
-> StreamTo blk
-> Model blk
-> Either
     (ChainDbError blk) (Either (UnknownRange blk) Int, Model blk)
forall blk.
GetPrevHash blk =>
SecurityParam
-> StreamFrom blk
-> StreamTo blk
-> Model blk
-> Either
     (ChainDbError blk) (Either (UnknownRange blk) Int, Model blk)
Model.stream SecurityParam
k StreamFrom blk
StreamFrom (Block (ModelM blk))
from StreamTo blk
StreamTo (Block (ModelM blk))
to Model blk
model of
        Left ChainDbError blk
err               -> (ChainDbError blk
-> Either (ChainDbError blk) (Either (UnknownRange blk) Int)
forall a b. a -> Either a b
Left ChainDbError blk
err, Model blk
model)
        Right (Either (UnknownRange blk) Int
result, Model blk
model') -> (Either (UnknownRange blk) Int
-> Either (ChainDbError blk) (Either (UnknownRange blk) Int)
forall a b. b -> Either a b
Right Either (UnknownRange blk) Int
result, Model blk
model')

  iteratorNext :: IteratorId (ModelM blk)
-> ModelM
     blk
     (IteratorResult
        (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))
iteratorNext IteratorId (ModelM blk)
iteratorId = (Model blk
 -> TopLevelConfig blk
 -> (IteratorResult
       (Block (ModelM blk)) (AllComponents (Block (ModelM blk))),
     Model blk))
-> ModelM
     blk
     (IteratorResult
        (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))
forall blk a.
(Model blk -> TopLevelConfig blk -> (a, Model blk)) -> ModelM blk a
withModelContext ((Model blk
  -> TopLevelConfig blk
  -> (IteratorResult
        (Block (ModelM blk)) (AllComponents (Block (ModelM blk))),
      Model blk))
 -> ModelM
      blk
      (IteratorResult
         (Block (ModelM blk)) (AllComponents (Block (ModelM blk)))))
-> (Model blk
    -> TopLevelConfig blk
    -> (IteratorResult
          (Block (ModelM blk)) (AllComponents (Block (ModelM blk))),
        Model blk))
-> ModelM
     blk
     (IteratorResult
        (Block (ModelM blk)) (AllComponents (Block (ModelM blk))))
forall a b. (a -> b) -> a -> b
$ \Model blk
model TopLevelConfig blk
_ ->
    Int
-> BlockComponent
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> Model blk
-> (IteratorResult
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk),
    Model blk)
forall blk b.
ModelSupportsBlock blk =>
Int
-> BlockComponent blk b
-> Model blk
-> (IteratorResult blk b, Model blk)
Model.iteratorNext Int
IteratorId (ModelM blk)
iteratorId BlockComponent
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
forall blk. BlockComponent blk (AllComponents blk)
allComponents Model blk
model

{-------------------------------------------------------------------------------
  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)


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
      varCurSlot <- uncheckedNewTVarM 0
      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 SlotNo
varCurSlot :: StrictTVar m SlotNo
varCurSlot :: StrictTVar m SlotNo
varCurSlot
            , 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.
(MonadThrow m, MonadSTM m, ConsensusProtocol (BlockProtocol blk),
 PrimMonad m) =>
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

instance IOLike m => SupportsUnitTest (SystemM blk m) where

  type IteratorId (SystemM blk m) = API.Iterator m blk (AllComponents blk)
  type FollowerId (SystemM blk m) = API.Follower m blk (AllComponents 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
    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)
      void $ API.addBlock api API.noPunishment blk
      pure blk

  persistBlks :: ShouldGarbageCollect -> SystemM blk m ()
persistBlks ShouldGarbageCollect
shouldGarbageCollect = do
    env <- SystemM blk m (ChainDBEnv m blk)
forall r (m :: * -> *). MonadReader r m => m r
ask
    SystemM $ lift $ lift $ do
      internal <- internal <$> readTVarIO (varDB env)
      SM.persistBlks shouldGarbageCollect internal

  newFollower :: SystemM blk m (FollowerId (SystemM blk m))
newFollower = 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.newFollower api (registry env) API.SelectedChain allComponents

  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 = ReaderT
  (ChainDBEnv m blk)
  (ExceptT TestFailure m)
  (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 blk (m :: * -> *) a.
ReaderT (ChainDBEnv m blk) (ExceptT TestFailure m) a
-> SystemM blk m a
SystemM (ReaderT
   (ChainDBEnv m blk)
   (ExceptT TestFailure m)
   (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)))))
-> (m (Maybe
         (ChainUpdate
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
    -> ReaderT
         (ChainDBEnv m blk)
         (ExceptT TestFailure m)
         (Either
            (ChainDbError blk)
            (Maybe
               (ChainUpdate
                  blk
                  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                   SlotNo, IsEBB, SizeInBytes, Word16,
                   SomeSecond (NestedCtxt Header) blk)))))
-> m (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 b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT
  TestFailure
  m
  (Either
     (ChainDbError blk)
     (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> ReaderT
     (ChainDBEnv m blk)
     (ExceptT TestFailure m)
     (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.
Monad m =>
m a -> ReaderT (ChainDBEnv m blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT
   TestFailure
   m
   (Either
      (ChainDbError blk)
      (Maybe
         (ChainUpdate
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> ReaderT
      (ChainDBEnv m blk)
      (ExceptT TestFailure m)
      (Either
         (ChainDbError blk)
         (Maybe
            (ChainUpdate
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk)))))
-> (m (Maybe
         (ChainUpdate
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
    -> ExceptT
         TestFailure
         m
         (Either
            (ChainDbError blk)
            (Maybe
               (ChainUpdate
                  blk
                  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                   SlotNo, IsEBB, SizeInBytes, Word16,
                   SomeSecond (NestedCtxt Header) blk)))))
-> m (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
-> ReaderT
     (ChainDBEnv m blk)
     (ExceptT TestFailure m)
     (Either
        (ChainDbError blk)
        (Maybe
           (ChainUpdate
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either
     (ChainDbError blk)
     (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> ExceptT
     TestFailure
     m
     (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. Monad m => m a -> ExceptT TestFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either
      (ChainDbError blk)
      (Maybe
         (ChainUpdate
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> ExceptT
      TestFailure
      m
      (Either
         (ChainDbError blk)
         (Maybe
            (ChainUpdate
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk)))))
-> (m (Maybe
         (ChainUpdate
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
    -> m (Either
            (ChainDbError blk)
            (Maybe
               (ChainUpdate
                  blk
                  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                   SlotNo, IsEBB, SizeInBytes, Word16,
                   SomeSecond (NestedCtxt Header) blk)))))
-> m (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
-> ExceptT
     TestFailure
     m
     (Either
        (ChainDbError blk)
        (Maybe
           (ChainUpdate
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))))
-> m (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) 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 b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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
    (m (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)))))
-> (Follower
      m
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk)
    -> m (Maybe
            (ChainUpdate
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
-> Follower
     m
     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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Follower
  m
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> m (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall (m :: * -> *) blk a.
Follower m blk a -> m (Maybe (ChainUpdate blk a))
API.followerInstruction

  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)
follower [Point (Block (SystemM blk m))]
points = ReaderT
  (ChainDBEnv m blk)
  (ExceptT TestFailure m)
  (Either
     (ChainDbError (Block (SystemM blk m)))
     (Maybe (Point (Block (SystemM blk m)))))
-> SystemM
     blk
     m
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
forall blk (m :: * -> *) a.
ReaderT (ChainDBEnv m blk) (ExceptT TestFailure m) a
-> SystemM blk m a
SystemM (ReaderT
   (ChainDBEnv m blk)
   (ExceptT TestFailure m)
   (Either
      (ChainDbError (Block (SystemM blk m)))
      (Maybe (Point (Block (SystemM blk m)))))
 -> SystemM
      blk
      m
      (Either
         (ChainDbError (Block (SystemM blk m)))
         (Maybe (Point (Block (SystemM blk m))))))
-> ReaderT
     (ChainDBEnv m blk)
     (ExceptT TestFailure m)
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
-> SystemM
     blk
     m
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
forall a b. (a -> b) -> a -> b
$ ExceptT
  TestFailure
  m
  (Either
     (ChainDbError (Block (SystemM blk m)))
     (Maybe (Point (Block (SystemM blk m)))))
-> ReaderT
     (ChainDBEnv m blk)
     (ExceptT TestFailure m)
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (ChainDBEnv m blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT
   TestFailure
   m
   (Either
      (ChainDbError (Block (SystemM blk m)))
      (Maybe (Point (Block (SystemM blk m)))))
 -> ReaderT
      (ChainDBEnv m blk)
      (ExceptT TestFailure m)
      (Either
         (ChainDbError (Block (SystemM blk m)))
         (Maybe (Point (Block (SystemM blk m))))))
-> ExceptT
     TestFailure
     m
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
-> ReaderT
     (ChainDBEnv m blk)
     (ExceptT TestFailure m)
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
forall a b. (a -> b) -> a -> b
$ m (Either
     (ChainDbError (Block (SystemM blk m)))
     (Maybe (Point (Block (SystemM blk m)))))
-> ExceptT
     TestFailure
     m
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
forall (m :: * -> *) a. Monad m => m a -> ExceptT TestFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either
      (ChainDbError (Block (SystemM blk m)))
      (Maybe (Point (Block (SystemM blk m)))))
 -> ExceptT
      TestFailure
      m
      (Either
         (ChainDbError (Block (SystemM blk m)))
         (Maybe (Point (Block (SystemM blk m))))))
-> m (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
-> ExceptT
     TestFailure
     m
     (Either
        (ChainDbError (Block (SystemM blk m)))
        (Maybe (Point (Block (SystemM blk m)))))
forall a b. (a -> b) -> a -> b
$ Maybe (Point blk) -> Either (ChainDbError blk) (Maybe (Point blk))
forall a b. b -> Either a b
Right
    (Maybe (Point blk)
 -> Either (ChainDbError blk) (Maybe (Point blk)))
-> m (Maybe (Point blk))
-> m (Either (ChainDbError blk) (Maybe (Point blk)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Follower
  m
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> [Point blk] -> m (Maybe (Point blk))
forall (m :: * -> *) blk a.
Follower m blk a -> [Point blk] -> m (Maybe (Point blk))
API.followerForward Follower
  m
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
FollowerId (SystemM blk m)
follower [Point blk]
[Point (Block (SystemM blk m))]
points

  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
    env <- SystemM blk m (ChainDBEnv m blk)
forall r (m :: * -> *). MonadReader r m => m r
ask
    SystemM $ lift $ lift $ fmap Right $ do
      api <- chainDB <$> readTVarIO (varDB env)
      API.stream api (registry env) allComponents from to

  iteratorNext :: IteratorId (SystemM blk m)
-> SystemM
     blk
     m
     (IteratorResult
        (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
iteratorNext IteratorId (SystemM blk m)
iterator = ReaderT
  (ChainDBEnv m blk)
  (ExceptT TestFailure m)
  (IteratorResult
     (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
-> SystemM
     blk
     m
     (IteratorResult
        (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
forall blk (m :: * -> *) a.
ReaderT (ChainDBEnv m blk) (ExceptT TestFailure m) a
-> SystemM blk m a
SystemM (ReaderT
   (ChainDBEnv m blk)
   (ExceptT TestFailure m)
   (IteratorResult
      (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
 -> SystemM
      blk
      m
      (IteratorResult
         (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m)))))
-> ReaderT
     (ChainDBEnv m blk)
     (ExceptT TestFailure m)
     (IteratorResult
        (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
-> SystemM
     blk
     m
     (IteratorResult
        (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
forall a b. (a -> b) -> a -> b
$ ExceptT
  TestFailure
  m
  (IteratorResult
     (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
-> ReaderT
     (ChainDBEnv m blk)
     (ExceptT TestFailure m)
     (IteratorResult
        (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (ChainDBEnv m blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT
   TestFailure
   m
   (IteratorResult
      (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
 -> ReaderT
      (ChainDBEnv m blk)
      (ExceptT TestFailure m)
      (IteratorResult
         (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m)))))
-> ExceptT
     TestFailure
     m
     (IteratorResult
        (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
-> ReaderT
     (ChainDBEnv m blk)
     (ExceptT TestFailure m)
     (IteratorResult
        (Block (SystemM blk m)) (AllComponents (Block (SystemM blk m))))
forall a b. (a -> b) -> a -> b
$ m (IteratorResult
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> ExceptT
     TestFailure
     m
     (IteratorResult
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall (m :: * -> *) a. Monad m => m a -> ExceptT TestFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Iterator
  m
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> m (IteratorResult
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall (m :: * -> *) blk b.
Iterator m blk b -> m (IteratorResult blk b)
API.iteratorNext Iterator
  m
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
IteratorId (SystemM blk m)
iterator)