{-# 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
  , configSecurityParam
  )
import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..))
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 Test.Ouroboros.Storage.ChainDB.Model (Model)
import qualified Test.Ouroboros.Storage.ChainDB.Model as Model
import Test.Ouroboros.Storage.ChainDB.StateMachine
  ( AllComponents
  , ChainDBEnv (..)
  , ChainDBState (..)
  , ShouldGarbageCollect (..)
  , TestConstraints
  , allComponents
  , 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]
        ]
    ]

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

-- | 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 DoNotGarbageCollect
  -- 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 -> TestBody
TestBody Word
0 Bool
True

-- | 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 DoNotGarbageCollect

  targetBlock :: TestBlock
targetBlock = SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
0 TestBody
fork0
  fork0 :: TestBody
fork0 = Word -> Bool -> TestBody
TestBody Word
0 Bool
True

-- | 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 DoNotGarbageCollect
  -- 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 -> TestBody
TestBody Word
0 Bool
True

-- | 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 DoNotGarbageCollect
  -- 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 -> TestBody
TestBody Word
0 Bool
True

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

  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)

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

  -- the implementation is intentionally left trivial
  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

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)

  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