{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Main tests for the chain DB.
--
-- These are the main tests for the chain DB. Commands include
--
-- * Add a block
-- * Add a block with a @SlotNo@ that is ahead of the wall-clock.
-- * Get the current chain and/or ledger state
-- * Create a new iterator and use it to stream blocks
-- * Create a new follower and use it to follow the chain
-- * (Limited) disk corruption (the chain DB relies on the immutable DB and
--   volatile DB for the storage proper and /they/ have extensive disk corruption
--   tests, so we don't need to repeat that here).
--
module Test.Ouroboros.Storage.ChainDB.StateMachine (
    -- * Commands
    At (..)
  , Cmd (..)
  , FollowerRef
  , IterRef
  , IteratorResult (..)
  , IteratorResultGCed (..)
    -- * Responses
  , Resp (..)
  , Success (..)
    -- * Model
  , Model
  , ShouldGarbageCollect (..)
    -- * Running the model
  , runCmdsLockstep
    -- * System under test
  , ChainDBEnv (..)
  , ChainDBState (..)
  , close
  , mkTestCfg
  , open
  , persistBlks
    -- * Specifying block components
  , AllComponents
  , allComponents
    -- * Constraints
  , TestConstraints
    -- * Tracing
  , traceEventName
    -- * Entry point to the tests
  , tests
  ) where

import           Cardano.Ledger.BaseTypes (knownNonZeroBounded)
import           Codec.Serialise (Serialise)
import           Control.Monad (replicateM, void)
import           Control.ResourceRegistry
import           Control.Tracer as CT
import           Data.Bifoldable
import           Data.Bifunctor
import qualified Data.Bifunctor.TH as TH
import           Data.Bitraversable
import           Data.ByteString.Lazy (ByteString)
import           Data.Function (on)
import           Data.Functor (($>))
import           Data.Functor.Classes (Eq1, Show1)
import           Data.Functor.Identity (Identity)
import           Data.List (sortOn)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe)
import           Data.Ord (Down (..))
import           Data.Proxy
import           Data.TreeDiff
import           Data.Typeable
import           Data.Void (Void)
import           Data.Word (Word16)
import qualified Generics.SOP as SOP
import           GHC.Generics (Generic)
import           NoThunks.Class (AllowThunk (..))
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HardFork.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.Abstract
                     (ImmutableEraParams)
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Inspect
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Ledger.Tables.Utils
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Storage.ChainDB hiding
                     (TraceFollowerEvent (..))
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import           Ouroboros.Consensus.Storage.Common (SizeInBytes)
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal
                     (unsafeChunkNoToEpochNo)
import           Ouroboros.Consensus.Storage.LedgerDB (LedgerSupportsLedgerDB)
import qualified Ouroboros.Consensus.Storage.LedgerDB.TraceEvent as LedgerDB
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbChangelog
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
import           Ouroboros.Consensus.Util (split)
import           Ouroboros.Consensus.Util.CallStack
import           Ouroboros.Consensus.Util.Condense (condense)
import           Ouroboros.Consensus.Util.Enclose
import           Ouroboros.Consensus.Util.IOLike hiding (invariant)
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (ChainUpdate, MaxSlotNo)
import qualified Ouroboros.Network.Mock.Chain as Chain
import qualified System.FS.Sim.MockFS as Mock
import           System.FS.Sim.MockFS (MockFS)
import qualified Test.Ouroboros.Storage.ChainDB.Model as Model
import           Test.Ouroboros.Storage.ChainDB.Model (FollowerId, IteratorId,
                     ModelSupportsBlock,
                     ShouldGarbageCollect (DoNotGarbageCollect, GarbageCollect))
import           Test.Ouroboros.Storage.Orphans ()
import           Test.Ouroboros.Storage.TestBlock
import           Test.QuickCheck hiding (forAll)
import qualified Test.QuickCheck.Monadic as QC
import           Test.StateMachine
import qualified Test.StateMachine.Labelling as C
import qualified Test.StateMachine.Sequential as QSM
import qualified Test.StateMachine.Types as QSM
import qualified Test.StateMachine.Types.Rank2 as Rank2
import           Test.Tasty (TestTree, testGroup)
import           Test.Tasty.QuickCheck (testProperty)
import           Test.Util.ChainDB
import           Test.Util.ChunkInfo
import           Test.Util.Header (attachSlotTimeToFragment)
import           Test.Util.Orphans.Arbitrary ()
import           Test.Util.Orphans.ToExpr ()
import           Test.Util.QuickCheck
import qualified Test.Util.RefEnv as RE
import           Test.Util.RefEnv (RefEnv)
import           Test.Util.SOP
import           Test.Util.TestEnv (adjustQuickCheckTests)
import           Test.Util.ToExpr ()
import           Test.Util.Tracer (recordingTracerIORef)
import           Test.Util.WithEq

{-------------------------------------------------------------------------------
  Abstract model
-------------------------------------------------------------------------------}

-- | Commands
data Cmd blk it flr
  = AddBlock       blk
    -- ^ Advance the current slot to the block's slot (unless smaller than the
    -- current slot), add the block and run chain selection.
  | GetCurrentChain
  | GetTipBlock
  | GetTipHeader
  | GetTipPoint
  | GetBlockComponent     (RealPoint blk)
  | GetGCedBlockComponent (RealPoint blk)
    -- ^ Only for blocks that may have been garbage collected.
  | GetMaxSlotNo
  | GetIsValid            (RealPoint blk)
  | Stream                (StreamFrom blk) (StreamTo blk)
  | UpdateLoE             (AnchoredFragment blk)
    -- ^ Update the LoE fragment and run chain selection.
  | IteratorNext          it
  | IteratorNextGCed      it
    -- ^ Only for blocks that may have been garbage collected.
  | IteratorClose         it
  | NewFollower           ChainType
  | FollowerInstruction   flr
    -- ^ 'followerInstructionBlocking' is excluded, as it requires multiple
    -- threads. Its code path is pretty much the same as 'followerInstruction'
    -- anyway.
  | FollowerForward       flr [Point blk]
  | FollowerClose         flr
  | Close
  | Reopen

    -- Internal
  | PersistBlks
    -- ^ Copy the blocks older than @k@ from the Volatile DB to the Immutable
    -- DB.
  | PersistBlksThenGC
    -- ^ Copy the blocks older than @k@ from the Volatile DB to the Immutable
    -- DB __and then__ perform garbage colllection.
    --
    -- The garbage collection procedure of the Chain DB (our system under test)
    -- removes the blocks from the volatile DB __without__ caring about whether
    -- the removed blocks were persisted. Therefore, this part of the Chain DB
    -- logic assumes that copy to the immutable DB took place __before__
    -- garbage collection. The model uses this assumption as well. As a result,
    -- we cannot perform garbage collection in isolation, since this will break
    -- the model's 'invariant'.
  | UpdateLedgerSnapshots
    -- ^ Write a new 'LedgerDB' snapshot to disk and remove the oldest ones.

    -- Corruption
  | WipeVolatileDB
  deriving ((forall x. Cmd blk it flr -> Rep (Cmd blk it flr) x)
-> (forall x. Rep (Cmd blk it flr) x -> Cmd blk it flr)
-> Generic (Cmd blk it flr)
forall x. Rep (Cmd blk it flr) x -> Cmd blk it flr
forall x. Cmd blk it flr -> Rep (Cmd blk it flr) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk it flr x. Rep (Cmd blk it flr) x -> Cmd blk it flr
forall blk it flr x. Cmd blk it flr -> Rep (Cmd blk it flr) x
$cfrom :: forall blk it flr x. Cmd blk it flr -> Rep (Cmd blk it flr) x
from :: forall x. Cmd blk it flr -> Rep (Cmd blk it flr) x
$cto :: forall blk it flr x. Rep (Cmd blk it flr) x -> Cmd blk it flr
to :: forall x. Rep (Cmd blk it flr) x -> Cmd blk it flr
Generic, Int -> Cmd blk it flr -> ShowS
[Cmd blk it flr] -> ShowS
Cmd blk it flr -> String
(Int -> Cmd blk it flr -> ShowS)
-> (Cmd blk it flr -> String)
-> ([Cmd blk it flr] -> ShowS)
-> Show (Cmd blk it flr)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall blk it flr.
(StandardHash blk, Show blk, Show it, Show flr) =>
Int -> Cmd blk it flr -> ShowS
forall blk it flr.
(StandardHash blk, Show blk, Show it, Show flr) =>
[Cmd blk it flr] -> ShowS
forall blk it flr.
(StandardHash blk, Show blk, Show it, Show flr) =>
Cmd blk it flr -> String
$cshowsPrec :: forall blk it flr.
(StandardHash blk, Show blk, Show it, Show flr) =>
Int -> Cmd blk it flr -> ShowS
showsPrec :: Int -> Cmd blk it flr -> ShowS
$cshow :: forall blk it flr.
(StandardHash blk, Show blk, Show it, Show flr) =>
Cmd blk it flr -> String
show :: Cmd blk it flr -> String
$cshowList :: forall blk it flr.
(StandardHash blk, Show blk, Show it, Show flr) =>
[Cmd blk it flr] -> ShowS
showList :: [Cmd blk it flr] -> ShowS
Show, (forall a b. (a -> b) -> Cmd blk it a -> Cmd blk it b)
-> (forall a b. a -> Cmd blk it b -> Cmd blk it a)
-> Functor (Cmd blk it)
forall a b. a -> Cmd blk it b -> Cmd blk it a
forall a b. (a -> b) -> Cmd blk it a -> Cmd blk it b
forall blk it a b. a -> Cmd blk it b -> Cmd blk it a
forall blk it a b. (a -> b) -> Cmd blk it a -> Cmd blk it 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 it a b. (a -> b) -> Cmd blk it a -> Cmd blk it b
fmap :: forall a b. (a -> b) -> Cmd blk it a -> Cmd blk it b
$c<$ :: forall blk it a b. a -> Cmd blk it b -> Cmd blk it a
<$ :: forall a b. a -> Cmd blk it b -> Cmd blk it a
Functor, (forall m. Monoid m => Cmd blk it m -> m)
-> (forall m a. Monoid m => (a -> m) -> Cmd blk it a -> m)
-> (forall m a. Monoid m => (a -> m) -> Cmd blk it a -> m)
-> (forall a b. (a -> b -> b) -> b -> Cmd blk it a -> b)
-> (forall a b. (a -> b -> b) -> b -> Cmd blk it a -> b)
-> (forall b a. (b -> a -> b) -> b -> Cmd blk it a -> b)
-> (forall b a. (b -> a -> b) -> b -> Cmd blk it a -> b)
-> (forall a. (a -> a -> a) -> Cmd blk it a -> a)
-> (forall a. (a -> a -> a) -> Cmd blk it a -> a)
-> (forall a. Cmd blk it a -> [a])
-> (forall a. Cmd blk it a -> Bool)
-> (forall a. Cmd blk it a -> Int)
-> (forall a. Eq a => a -> Cmd blk it a -> Bool)
-> (forall a. Ord a => Cmd blk it a -> a)
-> (forall a. Ord a => Cmd blk it a -> a)
-> (forall a. Num a => Cmd blk it a -> a)
-> (forall a. Num a => Cmd blk it a -> a)
-> Foldable (Cmd blk it)
forall a. Eq a => a -> Cmd blk it a -> Bool
forall a. Num a => Cmd blk it a -> a
forall a. Ord a => Cmd blk it a -> a
forall m. Monoid m => Cmd blk it m -> m
forall a. Cmd blk it a -> Bool
forall a. Cmd blk it a -> Int
forall a. Cmd blk it a -> [a]
forall a. (a -> a -> a) -> Cmd blk it a -> a
forall m a. Monoid m => (a -> m) -> Cmd blk it a -> m
forall b a. (b -> a -> b) -> b -> Cmd blk it a -> b
forall a b. (a -> b -> b) -> b -> Cmd blk it a -> b
forall blk it a. Eq a => a -> Cmd blk it a -> Bool
forall blk it a. Num a => Cmd blk it a -> a
forall blk it a. Ord a => Cmd blk it a -> a
forall blk it m. Monoid m => Cmd blk it m -> m
forall blk it a. Cmd blk it a -> Bool
forall blk it a. Cmd blk it a -> Int
forall blk it a. Cmd blk it a -> [a]
forall blk it a. (a -> a -> a) -> Cmd blk it a -> a
forall blk it m a. Monoid m => (a -> m) -> Cmd blk it a -> m
forall blk it b a. (b -> a -> b) -> b -> Cmd blk it a -> b
forall blk it a b. (a -> b -> b) -> b -> Cmd blk it a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall blk it m. Monoid m => Cmd blk it m -> m
fold :: forall m. Monoid m => Cmd blk it m -> m
$cfoldMap :: forall blk it m a. Monoid m => (a -> m) -> Cmd blk it a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Cmd blk it a -> m
$cfoldMap' :: forall blk it m a. Monoid m => (a -> m) -> Cmd blk it a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Cmd blk it a -> m
$cfoldr :: forall blk it a b. (a -> b -> b) -> b -> Cmd blk it a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Cmd blk it a -> b
$cfoldr' :: forall blk it a b. (a -> b -> b) -> b -> Cmd blk it a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Cmd blk it a -> b
$cfoldl :: forall blk it b a. (b -> a -> b) -> b -> Cmd blk it a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Cmd blk it a -> b
$cfoldl' :: forall blk it b a. (b -> a -> b) -> b -> Cmd blk it a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Cmd blk it a -> b
$cfoldr1 :: forall blk it a. (a -> a -> a) -> Cmd blk it a -> a
foldr1 :: forall a. (a -> a -> a) -> Cmd blk it a -> a
$cfoldl1 :: forall blk it a. (a -> a -> a) -> Cmd blk it a -> a
foldl1 :: forall a. (a -> a -> a) -> Cmd blk it a -> a
$ctoList :: forall blk it a. Cmd blk it a -> [a]
toList :: forall a. Cmd blk it a -> [a]
$cnull :: forall blk it a. Cmd blk it a -> Bool
null :: forall a. Cmd blk it a -> Bool
$clength :: forall blk it a. Cmd blk it a -> Int
length :: forall a. Cmd blk it a -> Int
$celem :: forall blk it a. Eq a => a -> Cmd blk it a -> Bool
elem :: forall a. Eq a => a -> Cmd blk it a -> Bool
$cmaximum :: forall blk it a. Ord a => Cmd blk it a -> a
maximum :: forall a. Ord a => Cmd blk it a -> a
$cminimum :: forall blk it a. Ord a => Cmd blk it a -> a
minimum :: forall a. Ord a => Cmd blk it a -> a
$csum :: forall blk it a. Num a => Cmd blk it a -> a
sum :: forall a. Num a => Cmd blk it a -> a
$cproduct :: forall blk it a. Num a => Cmd blk it a -> a
product :: forall a. Num a => Cmd blk it a -> a
Foldable, Functor (Cmd blk it)
Foldable (Cmd blk it)
(Functor (Cmd blk it), Foldable (Cmd blk it)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Cmd blk it a -> f (Cmd blk it b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Cmd blk it (f a) -> f (Cmd blk it a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Cmd blk it a -> m (Cmd blk it b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Cmd blk it (m a) -> m (Cmd blk it a))
-> Traversable (Cmd blk it)
forall blk it. Functor (Cmd blk it)
forall blk it. Foldable (Cmd blk it)
forall blk it (m :: * -> *) a.
Monad m =>
Cmd blk it (m a) -> m (Cmd blk it a)
forall blk it (f :: * -> *) a.
Applicative f =>
Cmd blk it (f a) -> f (Cmd blk it a)
forall blk it (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cmd blk it a -> m (Cmd blk it b)
forall blk it (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cmd blk it a -> f (Cmd blk it b)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Cmd blk it (m a) -> m (Cmd blk it a)
forall (f :: * -> *) a.
Applicative f =>
Cmd blk it (f a) -> f (Cmd blk it a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cmd blk it a -> m (Cmd blk it b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cmd blk it a -> f (Cmd blk it b)
$ctraverse :: forall blk it (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cmd blk it a -> f (Cmd blk it b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cmd blk it a -> f (Cmd blk it b)
$csequenceA :: forall blk it (f :: * -> *) a.
Applicative f =>
Cmd blk it (f a) -> f (Cmd blk it a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Cmd blk it (f a) -> f (Cmd blk it a)
$cmapM :: forall blk it (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cmd blk it a -> m (Cmd blk it b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cmd blk it a -> m (Cmd blk it b)
$csequence :: forall blk it (m :: * -> *) a.
Monad m =>
Cmd blk it (m a) -> m (Cmd blk it a)
sequence :: forall (m :: * -> *) a.
Monad m =>
Cmd blk it (m a) -> m (Cmd blk it a)
Traversable)

-- = Invalid blocks
--
-- We don't test 'getIsInvalidBlock' because the simple chain selection in the
-- model and the incremental chain selection in the real implementation differ
-- non-trivially.
--
-- In the real chain selection, if a block is invalid, no chains containing
-- that block will be validated again. So if a successor of the block is added
-- afterwards, it will never be validated, as any chain it would be part of
-- would also contain the block we know to be invalid. So if the successor is
-- also invalid, we would never discover and record it (as there is no need
-- from the point of chain selection, as we'll never use it in a candidate
-- chain anyway). In the model implementation of chain selection, all possible
-- chains are (re)validated each time, including previously invalid chains, so
-- new invalid blocks that are successors of known invalid blocks /are/ being
-- validated and recorded as invalid blocks.
--
-- Further complicating this is the fact that the recorded invalid blocks are
-- also garbage-collected. We can work around this, just like for 'getBlock'.
--
-- While it is certainly possible to overcome the issues described above,
-- e.g., we could change the model to closer match the real implementation
-- (but at the cost of more complexity), it is not worth the effort. The whole
-- point of recording invalid blocks is to avoid constructing candidates
-- containing known invalid blocks and needlessly validating them, which is
-- something we are testing in 'prop_trace', see
-- 'invalidBlockNeverValidatedAgain'.

deriving instance SOP.Generic         (Cmd blk it flr)
deriving instance SOP.HasDatatypeInfo (Cmd blk it flr)

-- | Return type for successful database operations.
data Success blk it flr
  = Unit                ()
  | Chain               (AnchoredFragment (Header blk))
  | LedgerDB            (DbChangelog.DbChangelog' blk)
  | MbBlock             (Maybe blk)
  | MbAllComponents     (Maybe (AllComponents blk))
  | MbGCedAllComponents (MaybeGCedBlock (AllComponents blk))
  | MbHeader            (Maybe (Header blk))
  | Point               (Point blk)
  | IsValid             IsValidResult
  | UnknownRange        (UnknownRange blk)
  | Iter                it
  | IterResult          (IteratorResult blk (AllComponents blk))
  | IterResultGCed      (IteratorResultGCed blk)
  | Flr                 flr
  | MbChainUpdate       (Maybe (ChainUpdate blk (AllComponents blk)))
  | MbPoint             (Maybe (Point blk))
  | MaxSlot             MaxSlotNo
  deriving ((forall a b. (a -> b) -> Success blk it a -> Success blk it b)
-> (forall a b. a -> Success blk it b -> Success blk it a)
-> Functor (Success blk it)
forall a b. a -> Success blk it b -> Success blk it a
forall a b. (a -> b) -> Success blk it a -> Success blk it b
forall blk it a b. a -> Success blk it b -> Success blk it a
forall blk it a b. (a -> b) -> Success blk it a -> Success blk it 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 it a b. (a -> b) -> Success blk it a -> Success blk it b
fmap :: forall a b. (a -> b) -> Success blk it a -> Success blk it b
$c<$ :: forall blk it a b. a -> Success blk it b -> Success blk it a
<$ :: forall a b. a -> Success blk it b -> Success blk it a
Functor, (forall m. Monoid m => Success blk it m -> m)
-> (forall m a. Monoid m => (a -> m) -> Success blk it a -> m)
-> (forall m a. Monoid m => (a -> m) -> Success blk it a -> m)
-> (forall a b. (a -> b -> b) -> b -> Success blk it a -> b)
-> (forall a b. (a -> b -> b) -> b -> Success blk it a -> b)
-> (forall b a. (b -> a -> b) -> b -> Success blk it a -> b)
-> (forall b a. (b -> a -> b) -> b -> Success blk it a -> b)
-> (forall a. (a -> a -> a) -> Success blk it a -> a)
-> (forall a. (a -> a -> a) -> Success blk it a -> a)
-> (forall a. Success blk it a -> [a])
-> (forall a. Success blk it a -> Bool)
-> (forall a. Success blk it a -> Int)
-> (forall a. Eq a => a -> Success blk it a -> Bool)
-> (forall a. Ord a => Success blk it a -> a)
-> (forall a. Ord a => Success blk it a -> a)
-> (forall a. Num a => Success blk it a -> a)
-> (forall a. Num a => Success blk it a -> a)
-> Foldable (Success blk it)
forall a. Eq a => a -> Success blk it a -> Bool
forall a. Num a => Success blk it a -> a
forall a. Ord a => Success blk it a -> a
forall m. Monoid m => Success blk it m -> m
forall a. Success blk it a -> Bool
forall a. Success blk it a -> Int
forall a. Success blk it a -> [a]
forall a. (a -> a -> a) -> Success blk it a -> a
forall m a. Monoid m => (a -> m) -> Success blk it a -> m
forall b a. (b -> a -> b) -> b -> Success blk it a -> b
forall a b. (a -> b -> b) -> b -> Success blk it a -> b
forall blk it a. Eq a => a -> Success blk it a -> Bool
forall blk it a. Num a => Success blk it a -> a
forall blk it a. Ord a => Success blk it a -> a
forall blk it m. Monoid m => Success blk it m -> m
forall blk it a. Success blk it a -> Bool
forall blk it a. Success blk it a -> Int
forall blk it a. Success blk it a -> [a]
forall blk it a. (a -> a -> a) -> Success blk it a -> a
forall blk it m a. Monoid m => (a -> m) -> Success blk it a -> m
forall blk it b a. (b -> a -> b) -> b -> Success blk it a -> b
forall blk it a b. (a -> b -> b) -> b -> Success blk it a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall blk it m. Monoid m => Success blk it m -> m
fold :: forall m. Monoid m => Success blk it m -> m
$cfoldMap :: forall blk it m a. Monoid m => (a -> m) -> Success blk it a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Success blk it a -> m
$cfoldMap' :: forall blk it m a. Monoid m => (a -> m) -> Success blk it a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Success blk it a -> m
$cfoldr :: forall blk it a b. (a -> b -> b) -> b -> Success blk it a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Success blk it a -> b
$cfoldr' :: forall blk it a b. (a -> b -> b) -> b -> Success blk it a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Success blk it a -> b
$cfoldl :: forall blk it b a. (b -> a -> b) -> b -> Success blk it a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Success blk it a -> b
$cfoldl' :: forall blk it b a. (b -> a -> b) -> b -> Success blk it a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Success blk it a -> b
$cfoldr1 :: forall blk it a. (a -> a -> a) -> Success blk it a -> a
foldr1 :: forall a. (a -> a -> a) -> Success blk it a -> a
$cfoldl1 :: forall blk it a. (a -> a -> a) -> Success blk it a -> a
foldl1 :: forall a. (a -> a -> a) -> Success blk it a -> a
$ctoList :: forall blk it a. Success blk it a -> [a]
toList :: forall a. Success blk it a -> [a]
$cnull :: forall blk it a. Success blk it a -> Bool
null :: forall a. Success blk it a -> Bool
$clength :: forall blk it a. Success blk it a -> Int
length :: forall a. Success blk it a -> Int
$celem :: forall blk it a. Eq a => a -> Success blk it a -> Bool
elem :: forall a. Eq a => a -> Success blk it a -> Bool
$cmaximum :: forall blk it a. Ord a => Success blk it a -> a
maximum :: forall a. Ord a => Success blk it a -> a
$cminimum :: forall blk it a. Ord a => Success blk it a -> a
minimum :: forall a. Ord a => Success blk it a -> a
$csum :: forall blk it a. Num a => Success blk it a -> a
sum :: forall a. Num a => Success blk it a -> a
$cproduct :: forall blk it a. Num a => Success blk it a -> a
product :: forall a. Num a => Success blk it a -> a
Foldable, Functor (Success blk it)
Foldable (Success blk it)
(Functor (Success blk it), Foldable (Success blk it)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Success blk it a -> f (Success blk it b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Success blk it (f a) -> f (Success blk it a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Success blk it a -> m (Success blk it b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Success blk it (m a) -> m (Success blk it a))
-> Traversable (Success blk it)
forall blk it. Functor (Success blk it)
forall blk it. Foldable (Success blk it)
forall blk it (m :: * -> *) a.
Monad m =>
Success blk it (m a) -> m (Success blk it a)
forall blk it (f :: * -> *) a.
Applicative f =>
Success blk it (f a) -> f (Success blk it a)
forall blk it (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Success blk it a -> m (Success blk it b)
forall blk it (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Success blk it a -> f (Success blk it b)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Success blk it (m a) -> m (Success blk it a)
forall (f :: * -> *) a.
Applicative f =>
Success blk it (f a) -> f (Success blk it a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Success blk it a -> m (Success blk it b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Success blk it a -> f (Success blk it b)
$ctraverse :: forall blk it (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Success blk it a -> f (Success blk it b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Success blk it a -> f (Success blk it b)
$csequenceA :: forall blk it (f :: * -> *) a.
Applicative f =>
Success blk it (f a) -> f (Success blk it a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Success blk it (f a) -> f (Success blk it a)
$cmapM :: forall blk it (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Success blk it a -> m (Success blk it b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Success blk it a -> m (Success blk it b)
$csequence :: forall blk it (m :: * -> *) a.
Monad m =>
Success blk it (m a) -> m (Success blk it a)
sequence :: forall (m :: * -> *) a.
Monad m =>
Success blk it (m a) -> m (Success blk it a)
Traversable)

-- | Product of all 'BlockComponent's. As this is a GADT, generating random
-- values of it (and combinations!) is not so simple. Therefore, we just
-- always request all block components.
allComponents :: BlockComponent blk (AllComponents blk)
allComponents :: forall blk. BlockComponent blk (AllComponents blk)
allComponents = (,,,,,,,,,,)
    (blk
 -> blk
 -> Header blk
 -> ByteString
 -> ByteString
 -> HeaderHash blk
 -> SlotNo
 -> IsEBB
 -> SizeInBytes
 -> Word16
 -> SomeSecond (NestedCtxt Header) blk
 -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
     SlotNo, IsEBB, SizeInBytes, Word16,
     SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk blk
-> BlockComponent
     blk
     (blk
      -> Header blk
      -> ByteString
      -> ByteString
      -> HeaderHash blk
      -> SlotNo
      -> IsEBB
      -> SizeInBytes
      -> Word16
      -> SomeSecond (NestedCtxt Header) 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
<$> BlockComponent blk blk
forall blk. BlockComponent blk blk
GetVerifiedBlock
    BlockComponent
  blk
  (blk
   -> Header blk
   -> ByteString
   -> ByteString
   -> HeaderHash blk
   -> SlotNo
   -> IsEBB
   -> SizeInBytes
   -> Word16
   -> SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk blk
-> BlockComponent
     blk
     (Header blk
      -> ByteString
      -> ByteString
      -> HeaderHash blk
      -> SlotNo
      -> IsEBB
      -> SizeInBytes
      -> Word16
      -> SomeSecond (NestedCtxt Header) blk
      -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock
    BlockComponent
  blk
  (Header blk
   -> ByteString
   -> ByteString
   -> HeaderHash blk
   -> SlotNo
   -> IsEBB
   -> SizeInBytes
   -> Word16
   -> SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk (Header blk)
-> BlockComponent
     blk
     (ByteString
      -> ByteString
      -> HeaderHash blk
      -> SlotNo
      -> IsEBB
      -> SizeInBytes
      -> Word16
      -> SomeSecond (NestedCtxt Header) blk
      -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk (Header blk)
forall blk. BlockComponent blk (Header blk)
GetHeader
    BlockComponent
  blk
  (ByteString
   -> ByteString
   -> HeaderHash blk
   -> SlotNo
   -> IsEBB
   -> SizeInBytes
   -> Word16
   -> SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk ByteString
-> BlockComponent
     blk
     (ByteString
      -> HeaderHash blk
      -> SlotNo
      -> IsEBB
      -> SizeInBytes
      -> Word16
      -> SomeSecond (NestedCtxt Header) blk
      -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk ByteString
forall blk. BlockComponent blk ByteString
GetRawBlock
    BlockComponent
  blk
  (ByteString
   -> HeaderHash blk
   -> SlotNo
   -> IsEBB
   -> SizeInBytes
   -> Word16
   -> SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk ByteString
-> BlockComponent
     blk
     (HeaderHash blk
      -> SlotNo
      -> IsEBB
      -> SizeInBytes
      -> Word16
      -> SomeSecond (NestedCtxt Header) blk
      -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk ByteString
forall blk. BlockComponent blk ByteString
GetRawHeader
    BlockComponent
  blk
  (HeaderHash blk
   -> SlotNo
   -> IsEBB
   -> SizeInBytes
   -> Word16
   -> SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk (HeaderHash blk)
-> BlockComponent
     blk
     (SlotNo
      -> IsEBB
      -> SizeInBytes
      -> Word16
      -> SomeSecond (NestedCtxt Header) blk
      -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk (HeaderHash blk)
forall blk. BlockComponent blk (HeaderHash blk)
GetHash
    BlockComponent
  blk
  (SlotNo
   -> IsEBB
   -> SizeInBytes
   -> Word16
   -> SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk SlotNo
-> BlockComponent
     blk
     (IsEBB
      -> SizeInBytes
      -> Word16
      -> SomeSecond (NestedCtxt Header) blk
      -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk SlotNo
forall blk. BlockComponent blk SlotNo
GetSlot
    BlockComponent
  blk
  (IsEBB
   -> SizeInBytes
   -> Word16
   -> SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk IsEBB
-> BlockComponent
     blk
     (SizeInBytes
      -> Word16
      -> SomeSecond (NestedCtxt Header) blk
      -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk IsEBB
forall blk. BlockComponent blk IsEBB
GetIsEBB
    BlockComponent
  blk
  (SizeInBytes
   -> Word16
   -> SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk SizeInBytes
-> BlockComponent
     blk
     (Word16
      -> SomeSecond (NestedCtxt Header) blk
      -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk SizeInBytes
forall blk. BlockComponent blk SizeInBytes
GetBlockSize
    BlockComponent
  blk
  (Word16
   -> SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk Word16
-> BlockComponent
     blk
     (SomeSecond (NestedCtxt Header) blk
      -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk Word16
forall blk. BlockComponent blk Word16
GetHeaderSize
    BlockComponent
  blk
  (SomeSecond (NestedCtxt Header) blk
   -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
-> BlockComponent blk (SomeSecond (NestedCtxt Header) blk)
-> BlockComponent
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk (SomeSecond (NestedCtxt Header) blk)
forall blk. BlockComponent blk (SomeSecond (NestedCtxt Header) blk)
GetNestedCtxt

-- | A list of all the 'BlockComponent' indices (@b@) we are interested in.
type AllComponents blk =
  ( blk
  , blk
  , Header blk
  , ByteString
  , ByteString
  , HeaderHash blk
  , SlotNo
  , IsEBB
  , SizeInBytes
  , Word16
  , SomeSecond (NestedCtxt Header) blk
  )

type TestConstraints blk =
  ( ConsensusProtocol    (BlockProtocol blk)
  , LedgerSupportsProtocol              blk
  , BlockSupportsDiffusionPipelining    blk
  , InspectLedger                       blk
  , Eq (ChainDepState    (BlockProtocol blk))
  , Eq (LedgerState                     blk EmptyMK)
  , Eq                                  blk
  , Show                                blk
  , HasHeader                           blk
  , StandardHash                        blk
  , Serialise                           blk
  , ModelSupportsBlock                  blk
  , Eq                         (Header  blk)
  , Show                       (Header  blk)
  , ConvertRawHash                      blk
  , HasHardForkHistory                  blk
  , SerialiseDiskConstraints            blk
  , Show (LedgerState                   blk EmptyMK)
  , LedgerTablesAreTrivial (LedgerState blk)
  , LedgerSupportsLedgerDB              blk
  , ImmutableEraParams                  blk
  )

deriving instance (TestConstraints blk, Eq   it, Eq   flr)
               => Eq   (Success blk it flr)
deriving instance (TestConstraints blk, Show it, Show flr)
               => Show (Success blk it flr)

-- | Short-hand
type TestIterator m blk = WithEq (Iterator m blk (AllComponents blk))
-- | Short-hand
type TestFollower m blk = WithEq (Follower m blk (AllComponents blk))

-- | The current ChainDB instance and things related to it.
--
-- When closing and reopening the ChainDB, this record will be replaced in the
-- 'varDB' field of 'ChainDBEnv' with a new one.
data ChainDBState m blk = ChainDBState
    { forall (m :: * -> *) blk. ChainDBState m blk -> ChainDB m blk
chainDB       :: ChainDB m blk
    , forall (m :: * -> *) blk. ChainDBState m blk -> Internal m blk
internal      :: ChainDB.Internal m blk
    , forall (m :: * -> *) blk. ChainDBState m blk -> Async m Void
addBlockAsync :: Async m Void
      -- ^ Background thread that adds blocks to the ChainDB
    }
  deriving Context -> ChainDBState m blk -> IO (Maybe ThunkInfo)
Proxy (ChainDBState m blk) -> String
(Context -> ChainDBState m blk -> IO (Maybe ThunkInfo))
-> (Context -> ChainDBState m blk -> IO (Maybe ThunkInfo))
-> (Proxy (ChainDBState m blk) -> String)
-> NoThunks (ChainDBState m blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) blk.
Context -> ChainDBState m blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) blk. Proxy (ChainDBState m blk) -> String
$cnoThunks :: forall (m :: * -> *) blk.
Context -> ChainDBState m blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> ChainDBState m blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk.
Context -> ChainDBState m blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ChainDBState m blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) blk. Proxy (ChainDBState m blk) -> String
showTypeOf :: Proxy (ChainDBState m blk) -> String
NoThunks via AllowThunk (ChainDBState m blk)

-- | Environment to run commands against the real ChainDB implementation.
data ChainDBEnv m blk = ChainDBEnv {
    forall (m :: * -> *) blk.
ChainDBEnv m blk -> StrictTVar m (ChainDBState m blk)
varDB           :: StrictTVar m (ChainDBState m blk)
  , forall (m :: * -> *) blk. ChainDBEnv m blk -> ResourceRegistry m
registry        :: ResourceRegistry m
  , forall (m :: * -> *) blk. ChainDBEnv m blk -> StrictTVar m SlotNo
varCurSlot      :: StrictTVar m SlotNo
  , forall (m :: * -> *) blk. ChainDBEnv m blk -> StrictTVar m Id
varNextId       :: StrictTVar m Id
  , forall (m :: * -> *) blk. ChainDBEnv m blk -> StrictTMVar m MockFS
varVolatileDbFs :: StrictTMVar m MockFS
  , forall (m :: * -> *) blk.
ChainDBEnv m blk -> ChainDbArgs Identity m blk
args            :: ChainDbArgs Identity m blk
    -- ^ Needed to reopen a ChainDB, i.e., open a new one.
  , forall (m :: * -> *) blk.
ChainDBEnv m blk
-> StrictTVar m (AnchoredFragment (HeaderWithTime blk))
varLoEFragment  :: StrictTVar m (AnchoredFragment (HeaderWithTime blk))
  }

open ::
     (IOLike m, TestConstraints blk)
  => ChainDbArgs Identity m blk -> m (ChainDBState m blk)
open :: forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
ChainDbArgs Identity m blk -> m (ChainDBState m blk)
open ChainDbArgs Identity m blk
args = do
    (chainDB, internal) <- ChainDbArgs Identity m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk, HasCallStack,
 LedgerSupportsLedgerDB blk) =>
Complete ChainDbArgs m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
openDBInternal ChainDbArgs Identity m blk
args Bool
False
    addBlockAsync       <- async (intAddBlockRunner internal)
    link addBlockAsync
    return ChainDBState { chainDB, internal, addBlockAsync }

-- PRECONDITION: the ChainDB is closed
reopen ::
     (IOLike m, TestConstraints blk)
  => ChainDBEnv m blk -> m ()
reopen :: forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
ChainDBEnv m blk -> m ()
reopen ChainDBEnv { StrictTVar m (ChainDBState m blk)
varDB :: forall (m :: * -> *) blk.
ChainDBEnv m blk -> StrictTVar m (ChainDBState m blk)
varDB :: StrictTVar m (ChainDBState m blk)
varDB, ChainDbArgs Identity m blk
args :: forall (m :: * -> *) blk.
ChainDBEnv m blk -> ChainDbArgs Identity m blk
args :: ChainDbArgs Identity m blk
args } = do
    chainDBState <- ChainDbArgs Identity m blk -> m (ChainDBState m blk)
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
ChainDbArgs Identity m blk -> m (ChainDBState m blk)
open ChainDbArgs Identity m blk
args
    void $ atomically $ swapTVar varDB chainDBState

close :: IOLike m => ChainDBState m blk -> m ()
close :: forall (m :: * -> *) blk. IOLike m => ChainDBState m blk -> m ()
close ChainDBState { ChainDB m blk
chainDB :: forall (m :: * -> *) blk. ChainDBState m blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB, Async m Void
addBlockAsync :: forall (m :: * -> *) blk. ChainDBState m blk -> Async m Void
addBlockAsync :: Async m Void
addBlockAsync } = do
    Async m Void -> m ()
forall a. Async m a -> m ()
forall (m :: * -> *) a. MonadAsync m => Async m a -> m ()
cancel Async m Void
addBlockAsync
    ChainDB m blk -> m ()
forall (m :: * -> *) blk. ChainDB m blk -> m ()
closeDB ChainDB m blk
chainDB

run :: forall m blk.
       (IOLike m, TestConstraints blk)
    => TopLevelConfig blk
    -> ChainDBEnv m   blk
    ->    Cmd         blk (TestIterator m blk) (TestFollower m blk)
    -> m (Success     blk (TestIterator m blk) (TestFollower m blk))
run :: forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
TopLevelConfig blk
-> ChainDBEnv m blk
-> Cmd blk (TestIterator m blk) (TestFollower m blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
run TopLevelConfig blk
cfg env :: ChainDBEnv m blk
env@ChainDBEnv { StrictTVar m (ChainDBState m blk)
varDB :: forall (m :: * -> *) blk.
ChainDBEnv m blk -> StrictTVar m (ChainDBState m blk)
varDB :: StrictTVar m (ChainDBState m blk)
varDB, StrictTVar m SlotNo
StrictTVar m (AnchoredFragment (HeaderWithTime blk))
StrictTVar m Id
StrictTMVar m MockFS
ChainDbArgs Identity m blk
ResourceRegistry m
registry :: forall (m :: * -> *) blk. ChainDBEnv m blk -> ResourceRegistry m
varCurSlot :: forall (m :: * -> *) blk. ChainDBEnv m blk -> StrictTVar m SlotNo
varNextId :: forall (m :: * -> *) blk. ChainDBEnv m blk -> StrictTVar m Id
varVolatileDbFs :: forall (m :: * -> *) blk. ChainDBEnv m blk -> StrictTMVar m MockFS
args :: forall (m :: * -> *) blk.
ChainDBEnv m blk -> ChainDbArgs Identity m blk
varLoEFragment :: forall (m :: * -> *) blk.
ChainDBEnv m blk
-> StrictTVar m (AnchoredFragment (HeaderWithTime blk))
registry :: ResourceRegistry m
varCurSlot :: StrictTVar m SlotNo
varNextId :: StrictTVar m Id
varVolatileDbFs :: StrictTMVar m MockFS
args :: ChainDbArgs Identity m blk
varLoEFragment :: StrictTVar m (AnchoredFragment (HeaderWithTime blk))
.. } Cmd blk (TestIterator m blk) (TestFollower m blk)
cmd =
    StrictTVar m (ChainDBState m blk) -> m (ChainDBState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (ChainDBState m blk)
varDB m (ChainDBState m blk)
-> (ChainDBState m blk
    -> m (Success blk (TestIterator m blk) (TestFollower m blk)))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \st :: ChainDBState m blk
st@ChainDBState { chainDB :: forall (m :: * -> *) blk. ChainDBState m blk -> ChainDB m blk
chainDB = ChainDB{m (Maybe blk)
m (Maybe (Header blk))
m (Maybe Statistics)
m ()
m (ChainSelectionPromise m)
STM m Bool
STM m (Point blk)
STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
STM m (ExtLedgerState blk EmptyMK)
STM m (HeaderStateHistory blk)
STM m (AnchoredFragment (Header blk))
STM m (AnchoredFragment (HeaderWithTime blk))
STM m MaxSlotNo
STM m ChainSelStarvation
STM m (Point blk -> Bool)
STM m (RealPoint blk -> Maybe Bool)
Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
Point blk
-> LedgerTables (ExtLedgerState blk) KeysMK
-> m (Maybe (LedgerTables (ExtLedgerState blk) ValuesMK))
InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (ReadOnlyForker' m blk))
forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b)
forall b.
ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk b))
forall b.
ResourceRegistry m
-> ChainType -> BlockComponent blk b -> m (Follower m blk b)
closeDB :: forall (m :: * -> *) blk. ChainDB m blk -> m ()
addBlockAsync :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
chainSelAsync :: m (ChainSelectionPromise m)
getCurrentChain :: STM m (AnchoredFragment (Header blk))
getCurrentChainWithTime :: STM m (AnchoredFragment (HeaderWithTime blk))
getCurrentLedger :: STM m (ExtLedgerState blk EmptyMK)
getImmutableLedger :: STM m (ExtLedgerState blk EmptyMK)
getPastLedger :: Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
getHeaderStateHistory :: STM m (HeaderStateHistory blk)
getReadOnlyForkerAtPoint :: ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (ReadOnlyForker' m blk))
getTipBlock :: m (Maybe blk)
getTipHeader :: m (Maybe (Header blk))
getTipPoint :: STM m (Point blk)
getBlockComponent :: forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b)
getIsFetched :: STM m (Point blk -> Bool)
getIsValid :: STM m (RealPoint blk -> Maybe Bool)
getMaxSlotNo :: STM m MaxSlotNo
stream :: forall b.
ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk b))
newFollower :: forall b.
ResourceRegistry m
-> ChainType -> BlockComponent blk b -> m (Follower m blk b)
getIsInvalidBlock :: STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getChainSelStarvation :: STM m ChainSelStarvation
getLedgerTablesAtFor :: Point blk
-> LedgerTables (ExtLedgerState blk) KeysMK
-> m (Maybe (LedgerTables (ExtLedgerState blk) ValuesMK))
getStatistics :: m (Maybe Statistics)
closeDB :: m ()
isOpen :: STM m Bool
isOpen :: forall (m :: * -> *) blk. ChainDB m blk -> STM m Bool
getStatistics :: forall (m :: * -> *) blk. ChainDB m blk -> m (Maybe Statistics)
getLedgerTablesAtFor :: forall (m :: * -> *) blk.
ChainDB m blk
-> Point blk
-> LedgerTables (ExtLedgerState blk) KeysMK
-> m (Maybe (LedgerTables (ExtLedgerState blk) ValuesMK))
getChainSelStarvation :: forall (m :: * -> *) blk. ChainDB m blk -> STM m ChainSelStarvation
getIsInvalidBlock :: forall (m :: * -> *) blk.
ChainDB m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
newFollower :: forall (m :: * -> *) blk.
ChainDB m blk
-> forall b.
   ResourceRegistry m
   -> ChainType -> BlockComponent blk b -> m (Follower m blk b)
stream :: forall (m :: * -> *) blk.
ChainDB m blk
-> forall b.
   ResourceRegistry m
   -> BlockComponent blk b
   -> StreamFrom blk
   -> StreamTo blk
   -> m (Either (UnknownRange blk) (Iterator m blk b))
getMaxSlotNo :: forall (m :: * -> *) blk. ChainDB m blk -> STM m MaxSlotNo
getIsValid :: forall (m :: * -> *) blk.
ChainDB m blk -> STM m (RealPoint blk -> Maybe Bool)
getIsFetched :: forall (m :: * -> *) blk.
ChainDB m blk -> STM m (Point blk -> Bool)
getBlockComponent :: forall (m :: * -> *) blk.
ChainDB m blk
-> forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b)
getTipPoint :: forall (m :: * -> *) blk. ChainDB m blk -> STM m (Point blk)
getTipHeader :: forall (m :: * -> *) blk. ChainDB m blk -> m (Maybe (Header blk))
getTipBlock :: forall (m :: * -> *) blk. ChainDB m blk -> m (Maybe blk)
getReadOnlyForkerAtPoint :: forall (m :: * -> *) blk.
ChainDB m blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (ReadOnlyForker' m blk))
getHeaderStateHistory :: forall (m :: * -> *) blk.
ChainDB m blk -> STM m (HeaderStateHistory blk)
getPastLedger :: forall (m :: * -> *) blk.
ChainDB m blk
-> Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
getImmutableLedger :: forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
getCurrentLedger :: forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
getCurrentChainWithTime :: forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (HeaderWithTime blk))
getCurrentChain :: forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
chainSelAsync :: forall (m :: * -> *) blk.
ChainDB m blk -> m (ChainSelectionPromise m)
addBlockAsync :: forall (m :: * -> *) blk.
ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
..}, Internal m blk
internal :: forall (m :: * -> *) blk. ChainDBState m blk -> Internal m blk
internal :: Internal m blk
internal } -> case Cmd blk (TestIterator m blk) (TestFollower m blk)
cmd of
      AddBlock blk
blk             -> Point blk -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. Point blk -> Success blk it flr
Point               (Point blk
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Point blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ChainDBState m blk -> SlotNo -> blk -> m (Point blk)
advanceAndAdd ChainDBState m blk
st (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk) blk
blk)
      Cmd blk (TestIterator m blk) (TestFollower m blk)
GetCurrentChain          -> AnchoredFragment (Header blk)
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr.
AnchoredFragment (Header blk) -> Success blk it flr
Chain               (AnchoredFragment (Header blk)
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (AnchoredFragment (Header blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (AnchoredFragment (Header blk))
-> m (AnchoredFragment (Header blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (AnchoredFragment (Header blk))
getCurrentChain
      Cmd blk (TestIterator m blk) (TestFollower m blk)
GetTipBlock              -> Maybe blk -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. Maybe blk -> Success blk it flr
MbBlock             (Maybe blk
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Maybe blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe blk)
getTipBlock
      Cmd blk (TestIterator m blk) (TestFollower m blk)
GetTipHeader             -> Maybe (Header blk)
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. Maybe (Header blk) -> Success blk it flr
MbHeader            (Maybe (Header blk)
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Maybe (Header blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe (Header blk))
getTipHeader
      Cmd blk (TestIterator m blk) (TestFollower m blk)
GetTipPoint              -> Point blk -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. Point blk -> Success blk it flr
Point               (Point blk
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Point blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Point blk) -> m (Point blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (Point blk)
getTipPoint
      GetBlockComponent RealPoint blk
pt     -> Maybe (AllComponents blk)
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. Maybe (AllComponents blk) -> Success blk it flr
MbAllComponents     (Maybe (AllComponents blk)
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Maybe (AllComponents blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockComponent blk (AllComponents blk)
-> RealPoint blk -> m (Maybe (AllComponents blk))
forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b)
getBlockComponent BlockComponent blk (AllComponents blk)
forall blk. BlockComponent blk (AllComponents blk)
allComponents RealPoint blk
pt
      GetGCedBlockComponent RealPoint blk
pt -> Maybe (AllComponents blk)
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. Maybe (AllComponents blk) -> Success blk it flr
mbGCedAllComponents (Maybe (AllComponents blk)
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Maybe (AllComponents blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockComponent blk (AllComponents blk)
-> RealPoint blk -> m (Maybe (AllComponents blk))
forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b)
getBlockComponent BlockComponent blk (AllComponents blk)
forall blk. BlockComponent blk (AllComponents blk)
allComponents RealPoint blk
pt
      GetIsValid RealPoint blk
pt            -> Maybe Bool -> Success blk (TestIterator m blk) (TestFollower m blk)
forall {blk} {it} {flr}. Maybe Bool -> Success blk it flr
isValidResult       (Maybe Bool
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> ((RealPoint blk -> Maybe Bool) -> Maybe Bool)
-> (RealPoint blk -> Maybe Bool)
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((RealPoint blk -> Maybe Bool) -> RealPoint blk -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ RealPoint blk
pt) ((RealPoint blk -> Maybe Bool)
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (RealPoint blk -> Maybe Bool)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (RealPoint blk -> Maybe Bool)
-> m (RealPoint blk -> Maybe Bool)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (RealPoint blk -> Maybe Bool)
getIsValid
      Cmd blk (TestIterator m blk) (TestFollower m blk)
GetMaxSlotNo             -> MaxSlotNo -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. MaxSlotNo -> Success blk it flr
MaxSlot             (MaxSlotNo
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m MaxSlotNo
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m MaxSlotNo -> m MaxSlotNo
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m MaxSlotNo
getMaxSlotNo
      UpdateLoE AnchoredFragment blk
frag           -> Point blk -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. Point blk -> Success blk it flr
Point               (Point blk
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Point blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDBState m blk -> AnchoredFragment blk -> m (Point blk)
updateLoE ChainDBState m blk
st AnchoredFragment blk
frag
      Stream StreamFrom blk
from StreamTo blk
to           -> Either (UnknownRange blk) (Iterator m blk (AllComponents blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
iter                (Either (UnknownRange blk) (Iterator m blk (AllComponents blk))
 -> m (Success blk (TestIterator m blk) (TestFollower m blk)))
-> m (Either
        (UnknownRange blk) (Iterator m blk (AllComponents blk)))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ResourceRegistry m
-> BlockComponent blk (AllComponents blk)
-> StreamFrom blk
-> StreamTo blk
-> m (Either
        (UnknownRange blk) (Iterator m blk (AllComponents blk)))
forall b.
ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk b))
stream ResourceRegistry m
registry BlockComponent blk (AllComponents blk)
forall blk. BlockComponent blk (AllComponents blk)
allComponents StreamFrom blk
from StreamTo blk
to
      IteratorNext  TestIterator m blk
it         -> IteratorResult blk (AllComponents blk)
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr.
IteratorResult blk (AllComponents blk) -> Success blk it flr
IterResult          (IteratorResult blk (AllComponents blk)
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (IteratorResult blk (AllComponents blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Iterator m blk (AllComponents blk)
-> m (IteratorResult blk (AllComponents blk))
forall (m :: * -> *) blk b.
Iterator m blk b -> m (IteratorResult blk b)
iteratorNext (TestIterator m blk -> Iterator m blk (AllComponents blk)
forall a. WithEq a -> a
unWithEq TestIterator m blk
it)
      IteratorNextGCed  TestIterator m blk
it     -> IteratorResult blk (AllComponents blk)
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr.
IteratorResult blk (AllComponents blk) -> Success blk it flr
iterResultGCed      (IteratorResult blk (AllComponents blk)
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (IteratorResult blk (AllComponents blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Iterator m blk (AllComponents blk)
-> m (IteratorResult blk (AllComponents blk))
forall (m :: * -> *) blk b.
Iterator m blk b -> m (IteratorResult blk b)
iteratorNext (TestIterator m blk -> Iterator m blk (AllComponents blk)
forall a. WithEq a -> a
unWithEq TestIterator m blk
it)
      IteratorClose TestIterator m blk
it         -> () -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. () -> Success blk it flr
Unit                (() -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m ()
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Iterator m blk (AllComponents blk) -> m ()
forall (m :: * -> *) blk b. Iterator m blk b -> m ()
iteratorClose (TestIterator m blk -> Iterator m blk (AllComponents blk)
forall a. WithEq a -> a
unWithEq TestIterator m blk
it)
      NewFollower ChainType
ct           -> Follower m blk (AllComponents blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
follower            (Follower m blk (AllComponents blk)
 -> m (Success blk (TestIterator m blk) (TestFollower m blk)))
-> m (Follower m blk (AllComponents blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ResourceRegistry m
-> ChainType
-> BlockComponent blk (AllComponents blk)
-> m (Follower m blk (AllComponents blk))
forall b.
ResourceRegistry m
-> ChainType -> BlockComponent blk b -> m (Follower m blk b)
newFollower ResourceRegistry m
registry ChainType
ct BlockComponent blk (AllComponents blk)
forall blk. BlockComponent blk (AllComponents blk)
allComponents
      FollowerInstruction TestFollower m blk
flr  -> Maybe (ChainUpdate blk (AllComponents blk))
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr.
Maybe (ChainUpdate blk (AllComponents blk)) -> Success blk it flr
MbChainUpdate       (Maybe (ChainUpdate blk (AllComponents blk))
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Maybe (ChainUpdate blk (AllComponents blk)))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Follower m blk (AllComponents blk)
-> m (Maybe (ChainUpdate blk (AllComponents blk)))
forall (m :: * -> *) blk a.
Follower m blk a -> m (Maybe (ChainUpdate blk a))
followerInstruction (TestFollower m blk -> Follower m blk (AllComponents blk)
forall a. WithEq a -> a
unWithEq TestFollower m blk
flr)
      FollowerForward TestFollower m blk
flr [Point blk]
pts  -> Maybe (Point blk)
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. Maybe (Point blk) -> Success blk it flr
MbPoint             (Maybe (Point blk)
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Maybe (Point blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Follower m blk (AllComponents blk)
-> [Point blk] -> m (Maybe (Point blk))
forall (m :: * -> *) blk a.
Follower m blk a -> [Point blk] -> m (Maybe (Point blk))
followerForward (TestFollower m blk -> Follower m blk (AllComponents blk)
forall a. WithEq a -> a
unWithEq TestFollower m blk
flr) [Point blk]
pts
      FollowerClose TestFollower m blk
flr        -> () -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. () -> Success blk it flr
Unit                (() -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m ()
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Follower m blk (AllComponents blk) -> m ()
forall (m :: * -> *) blk a. Follower m blk a -> m ()
followerClose (TestFollower m blk -> Follower m blk (AllComponents blk)
forall a. WithEq a -> a
unWithEq TestFollower m blk
flr)
      Cmd blk (TestIterator m blk) (TestFollower m blk)
Close                    -> () -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. () -> Success blk it flr
Unit                (() -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m ()
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDBState m blk -> m ()
forall (m :: * -> *) blk. IOLike m => ChainDBState m blk -> m ()
close ChainDBState m blk
st
      Cmd blk (TestIterator m blk) (TestFollower m blk)
Reopen                   -> () -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. () -> Success blk it flr
Unit                (() -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m ()
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDBEnv m blk -> m ()
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
ChainDBEnv m blk -> m ()
reopen ChainDBEnv m blk
env
      Cmd blk (TestIterator m blk) (TestFollower m blk)
PersistBlks              -> () -> Success blk (TestIterator m blk) (TestFollower m blk)
forall {p} {blk} {it} {flr}. p -> Success blk it flr
ignore              (() -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m ()
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShouldGarbageCollect -> Internal m blk -> m ()
forall (m :: * -> *) blk.
IOLike m =>
ShouldGarbageCollect -> Internal m blk -> m ()
persistBlks ShouldGarbageCollect
DoNotGarbageCollect Internal m blk
internal
      Cmd blk (TestIterator m blk) (TestFollower m blk)
PersistBlksThenGC        -> () -> Success blk (TestIterator m blk) (TestFollower m blk)
forall {p} {blk} {it} {flr}. p -> Success blk it flr
ignore              (() -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m ()
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShouldGarbageCollect -> Internal m blk -> m ()
forall (m :: * -> *) blk.
IOLike m =>
ShouldGarbageCollect -> Internal m blk -> m ()
persistBlks ShouldGarbageCollect
GarbageCollect Internal m blk
internal
      Cmd blk (TestIterator m blk) (TestFollower m blk)
UpdateLedgerSnapshots    -> () -> Success blk (TestIterator m blk) (TestFollower m blk)
forall {p} {blk} {it} {flr}. p -> Success blk it flr
ignore              (() -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m ()
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Internal m blk -> m ()
forall (m :: * -> *) blk. Internal m blk -> m ()
intTryTakeSnapshot Internal m blk
internal
      Cmd blk (TestIterator m blk) (TestFollower m blk)
WipeVolatileDB           -> Point blk -> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. Point blk -> Success blk it flr
Point               (Point blk
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (Point blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDBState m blk -> m (Point blk)
wipeVolatileDB ChainDBState m blk
st
  where
    mbGCedAllComponents :: Maybe
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
mbGCedAllComponents = MaybeGCedBlock
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
forall blk it flr.
MaybeGCedBlock (AllComponents blk) -> Success blk it flr
MbGCedAllComponents (MaybeGCedBlock
   (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
    SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) blk)
 -> Success blk it flr)
-> (Maybe
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk)
    -> MaybeGCedBlock
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
-> Maybe
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Maybe
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> MaybeGCedBlock
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
forall blk. Bool -> Maybe blk -> MaybeGCedBlock blk
MaybeGCedBlock Bool
True
    isValidResult :: Maybe Bool -> Success blk it flr
isValidResult = IsValidResult -> Success blk it flr
forall blk it flr. IsValidResult -> Success blk it flr
IsValid (IsValidResult -> Success blk it flr)
-> (Maybe Bool -> IsValidResult)
-> Maybe Bool
-> Success blk it flr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe Bool -> IsValidResult
IsValidResult Bool
True
    iterResultGCed :: IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
iterResultGCed = IteratorResultGCed blk -> Success blk it flr
forall blk it flr. IteratorResultGCed blk -> Success blk it flr
IterResultGCed (IteratorResultGCed blk -> Success blk it flr)
-> (IteratorResult
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk)
    -> IteratorResultGCed blk)
-> IteratorResult
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> IteratorResult
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> IteratorResultGCed blk
forall blk.
Bool
-> IteratorResult blk (AllComponents blk) -> IteratorResultGCed blk
IteratorResultGCed Bool
True
    iter :: Either (UnknownRange blk) (Iterator m blk (AllComponents blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
iter = (UnknownRange blk
 -> m (Success blk (TestIterator m blk) (TestFollower m blk)))
-> (Iterator m blk (AllComponents blk)
    -> m (Success blk (TestIterator m blk) (TestFollower m blk)))
-> Either (UnknownRange blk) (Iterator m blk (AllComponents blk))
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Success blk (TestIterator m blk) (TestFollower m blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Success blk (TestIterator m blk) (TestFollower m blk)
 -> m (Success blk (TestIterator m blk) (TestFollower m blk)))
-> (UnknownRange blk
    -> Success blk (TestIterator m blk) (TestFollower m blk))
-> UnknownRange blk
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnknownRange blk
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. UnknownRange blk -> Success blk it flr
UnknownRange) ((TestIterator m blk
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (TestIterator m blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestIterator m blk
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. it -> Success blk it flr
Iter (m (TestIterator m blk)
 -> m (Success blk (TestIterator m blk) (TestFollower m blk)))
-> (Iterator m blk (AllComponents blk) -> m (TestIterator m blk))
-> Iterator m blk (AllComponents blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iterator m blk (AllComponents blk) -> m (TestIterator m blk)
forall a. a -> m (WithEq a)
giveWithEq)
    follower :: Follower m blk (AllComponents blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
follower = (TestFollower m blk
 -> Success blk (TestIterator m blk) (TestFollower m blk))
-> m (TestFollower m blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestFollower m blk
-> Success blk (TestIterator m blk) (TestFollower m blk)
forall blk it flr. flr -> Success blk it flr
Flr (m (TestFollower m blk)
 -> m (Success blk (TestIterator m blk) (TestFollower m blk)))
-> (Follower m blk (AllComponents blk) -> m (TestFollower m blk))
-> Follower m blk (AllComponents blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Follower m blk (AllComponents blk) -> m (TestFollower m blk)
forall a. a -> m (WithEq a)
giveWithEq
    ignore :: p -> Success blk it flr
ignore p
_ = () -> Success blk it flr
forall blk it flr. () -> Success blk it flr
Unit ()

    advanceAndAdd :: ChainDBState m blk -> SlotNo -> blk -> m (Point blk)
    advanceAndAdd :: ChainDBState m blk -> SlotNo -> blk -> m (Point blk)
advanceAndAdd ChainDBState { ChainDB m blk
chainDB :: forall (m :: * -> *) blk. ChainDBState m blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB } SlotNo
newCurSlot blk
blk = do
      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m SlotNo -> (SlotNo -> SlotNo) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m SlotNo
varCurSlot (SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
max SlotNo
newCurSlot)
      -- `blockProcessed` always returns 'Just'
      res <- ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockResult blk)
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockResult blk)
addBlock ChainDB m blk
chainDB InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment blk
blk
      ChainDB.triggerChainSelection chainDB
      return $ case res of
        FailedToAddBlock String
f       -> String -> Point blk
forall a. HasCallStack => String -> a
error (String -> Point blk) -> String -> Point blk
forall a b. (a -> b) -> a -> b
$ String
"advanceAndAdd: block not added - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f
        SuccesfullyAddedBlock Point blk
pt -> Point blk
pt

    updateLoE :: ChainDBState m blk -> AnchoredFragment blk -> m (Point blk)
    updateLoE :: ChainDBState m blk -> AnchoredFragment blk -> m (Point blk)
updateLoE ChainDBState { ChainDB m blk
chainDB :: forall (m :: * -> *) blk. ChainDBState m blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB } AnchoredFragment blk
frag = do
      let headersFrag :: AnchoredFragment (Header blk)
headersFrag = (blk -> Header blk)
-> AnchoredFragment blk -> AnchoredFragment (Header blk)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader AnchoredFragment blk
frag
      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (AnchoredFragment (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (AnchoredFragment (HeaderWithTime blk))
varLoEFragment (AnchoredFragment (HeaderWithTime blk) -> STM m ())
-> AnchoredFragment (HeaderWithTime blk) -> STM m ()
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (HeaderWithTime blk)
forall blk.
(HasHeader (Header blk), Typeable blk, ImmutableEraParams blk) =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (HeaderWithTime blk)
attachSlotTimeToFragment TopLevelConfig blk
cfg AnchoredFragment (Header blk)
headersFrag
      ChainDB m blk -> m ()
forall (m :: * -> *) blk. IOLike m => ChainDB m blk -> m ()
ChainDB.triggerChainSelection ChainDB m blk
chainDB
      STM m (Point blk) -> m (Point blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Point blk) -> m (Point blk))
-> STM m (Point blk) -> m (Point blk)
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> STM m (Point blk)
forall (m :: * -> *) blk. ChainDB m blk -> STM m (Point blk)
getTipPoint ChainDB m blk
chainDB

    wipeVolatileDB :: ChainDBState m blk -> m (Point blk)
    wipeVolatileDB :: ChainDBState m blk -> m (Point blk)
wipeVolatileDB ChainDBState m blk
st = do
      ChainDBState m blk -> m ()
forall (m :: * -> *) blk. IOLike m => ChainDBState m blk -> m ()
close ChainDBState m blk
st
      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        StrictTMVar m MockFS -> MockFS -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
writeTMVar StrictTMVar m MockFS
varVolatileDbFs MockFS
Mock.empty
        -- The LoE fragment must be anchored in an immutable point. Wiping the
        -- VolDB can invalidate this when some immutable blocks have not yet
        -- been persisted.
        StrictTVar m (AnchoredFragment (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (AnchoredFragment (HeaderWithTime blk))
varLoEFragment (AnchoredFragment (HeaderWithTime blk) -> STM m ())
-> AnchoredFragment (HeaderWithTime blk) -> STM m ()
forall a b. (a -> b) -> a -> b
$ Anchor (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (HeaderWithTime blk)
forall block. Anchor block
AF.AnchorGenesis
      ChainDBEnv m blk -> m ()
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
ChainDBEnv m blk -> m ()
reopen ChainDBEnv m blk
env
      ChainDB { getTipPoint } <- ChainDBState m blk -> ChainDB m blk
forall (m :: * -> *) blk. ChainDBState m blk -> ChainDB m blk
chainDB (ChainDBState m blk -> ChainDB m blk)
-> m (ChainDBState m blk) -> m (ChainDB m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (ChainDBState m blk) -> m (ChainDBState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (ChainDBState m blk)
varDB
      atomically getTipPoint

    giveWithEq :: a -> m (WithEq a)
    giveWithEq :: forall a. a -> m (WithEq a)
giveWithEq a
a =
      (Id -> WithEq a) -> m Id -> m (WithEq a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Id -> a -> WithEq a
forall a. Id -> a -> WithEq a
`WithEq` a
a) (m Id -> m (WithEq a)) -> m Id -> m (WithEq a)
forall a b. (a -> b) -> a -> b
$ STM m Id -> m Id
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Id -> m Id) -> STM m Id -> m Id
forall a b. (a -> b) -> a -> b
$ StrictTVar m Id -> (Id -> (Id, Id)) -> STM m Id
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m Id
varNextId ((Id -> (Id, Id)) -> STM m Id) -> (Id -> (Id, Id)) -> STM m Id
forall a b. (a -> b) -> a -> b
$ \Id
i -> (Id
i, Id -> Id
forall a. Enum a => a -> a
succ Id
i)

persistBlks :: IOLike m => ShouldGarbageCollect -> ChainDB.Internal m blk -> m ()
persistBlks :: forall (m :: * -> *) blk.
IOLike m =>
ShouldGarbageCollect -> Internal m blk -> m ()
persistBlks ShouldGarbageCollect
collectGarbage ChainDB.Internal{m Void
m ()
m (WithOrigin SlotNo)
StrictTVar m (m ())
SlotNo -> m ()
intAddBlockRunner :: forall (m :: * -> *) blk. Internal m blk -> m Void
intTryTakeSnapshot :: forall (m :: * -> *) blk. Internal m blk -> m ()
intCopyToImmutableDB :: m (WithOrigin SlotNo)
intGarbageCollect :: SlotNo -> m ()
intTryTakeSnapshot :: m ()
intAddBlockRunner :: m Void
intKillBgThreads :: StrictTVar m (m ())
intKillBgThreads :: forall (m :: * -> *) blk. Internal m blk -> StrictTVar m (m ())
intGarbageCollect :: forall (m :: * -> *) blk. Internal m blk -> SlotNo -> m ()
intCopyToImmutableDB :: forall (m :: * -> *) blk. Internal m blk -> m (WithOrigin SlotNo)
..} = do
    mSlotNo <- m (WithOrigin SlotNo)
intCopyToImmutableDB
    case (collectGarbage, mSlotNo) of
      (ShouldGarbageCollect
DoNotGarbageCollect, WithOrigin SlotNo
_               ) -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (ShouldGarbageCollect
GarbageCollect     , WithOrigin SlotNo
Origin          ) -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (ShouldGarbageCollect
GarbageCollect     , NotOrigin SlotNo
slotNo) -> SlotNo -> m ()
intGarbageCollect SlotNo
slotNo

-- | Result type for 'getBlock'. Note that the real implementation of
-- 'getBlock' is non-deterministic: if the requested block is older than @k@
-- and not part of the current chain, it might have been garbage collected.
--
-- The first source of non-determinism is whether or not the background thread
-- that performs garbage collection has been run yet. We disable this thread in
-- the state machine tests and instead generate the 'PersistBlksThenGC'
-- command that triggers the garbage collection explicitly, after persisting
-- the blocks older than @k@ from the current chain's tip. So this source of
-- non-determinism is not a problem in the tests.
--
-- However, there is a second source of non-determinism: if a garbage
-- collection has been performed and the block was eligible for collection, it
-- might still not have been removed because it was part of a file that
-- contained other blocks that cannot be garbage collected yet. So the block
-- is still left in the VolatileDB. We do not try to imitate this behaviour,
-- which would couple the test too tightly to the actual implementation.
-- Instead, we accept this source of non-determinism and are more lenient when
-- comparing the results of 'getBlock' when the block may have been garbage
-- collected.
--
-- Equality of two 'MaybeGCedBlock' is determined as follows:
-- * If both are produced by a model implementation, then the @Maybe blk@s must
--   be equal, as the these results are deterministic.
-- * If at least one of them is produced by a real implementation, then:
--   * If either is 'Nothing', which means the block might have been
--     garbage-collected, then they are equal (even if the other is 'Just',
--     which means it was not yet garbage-collected).
--   * If both are 'Just's, then the blocks must be equal.
--
-- In practice, this equality is used when comparing the result of the real
-- implementation with the result of the model implementation.
data MaybeGCedBlock blk = MaybeGCedBlock
  { forall blk. MaybeGCedBlock blk -> Bool
real    :: Bool
    -- ^ 'True':  result of calling 'getBlock' on the real implementation
    -- ^ 'False': result of calling 'getBlock' on the model implementation
  , forall blk. MaybeGCedBlock blk -> Maybe blk
mbBlock :: Maybe blk
    -- ^ A value of 'Nothing' in this field indicates that the block might have
    -- been garbage collected.
  } deriving (Int -> MaybeGCedBlock blk -> ShowS
[MaybeGCedBlock blk] -> ShowS
MaybeGCedBlock blk -> String
(Int -> MaybeGCedBlock blk -> ShowS)
-> (MaybeGCedBlock blk -> String)
-> ([MaybeGCedBlock blk] -> ShowS)
-> Show (MaybeGCedBlock blk)
forall blk. Show blk => Int -> MaybeGCedBlock blk -> ShowS
forall blk. Show blk => [MaybeGCedBlock blk] -> ShowS
forall blk. Show blk => MaybeGCedBlock blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. Show blk => Int -> MaybeGCedBlock blk -> ShowS
showsPrec :: Int -> MaybeGCedBlock blk -> ShowS
$cshow :: forall blk. Show blk => MaybeGCedBlock blk -> String
show :: MaybeGCedBlock blk -> String
$cshowList :: forall blk. Show blk => [MaybeGCedBlock blk] -> ShowS
showList :: [MaybeGCedBlock blk] -> ShowS
Show)

instance Eq blk => Eq (MaybeGCedBlock blk) where
  MaybeGCedBlock Bool
real1 Maybe blk
mbBlock1 == :: MaybeGCedBlock blk -> MaybeGCedBlock blk -> Bool
== MaybeGCedBlock Bool
real2 Maybe blk
mbBlock2 =
    -- Two @MaybeGCedBlock@s are equal iff either:
    --
    -- - they are both produced by the model and contain the same result, or
    -- - at least one of them was garbage collected, or
    -- - none of them were garbage collected and they contain the same block.
    --
    -- See the comments on 'MaybeGCedBlock' for a justification on why we
    -- implemented this form of lenient equality.
      case (Bool
real1, Bool
real2) of
        (Bool
False, Bool
False) -> Maybe blk
mbBlock1 Maybe blk -> Maybe blk -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe blk
mbBlock2
        (Bool
True,  Bool
_)     -> Bool
eqIfJust
        (Bool
_,     Bool
True)  -> Bool
eqIfJust
    where
      eqIfJust :: Bool
eqIfJust = case (Maybe blk
mbBlock1, Maybe blk
mbBlock2) of
        (Just blk
b1, Just blk
b2) -> blk
b1 blk -> blk -> Bool
forall a. Eq a => a -> a -> Bool
== blk
b2
        (Maybe blk, Maybe blk)
_                  -> Bool
True

-- | Similar to 'MaybeGCedBlock', but for the block returned by
-- 'iteratorNext'. A garbage-collected block could result in
-- 'IteratorBlockGCed' instead of 'IteratorResult'.
data IteratorResultGCed blk = IteratorResultGCed
  { forall blk. IteratorResultGCed blk -> Bool
real       :: Bool
    -- ^ 'True':  result of calling 'getBlock' on the real implementation
    -- ^ 'False': result of calling 'getBlock' on the model implementation
  , forall blk.
IteratorResultGCed blk -> IteratorResult blk (AllComponents blk)
iterResult :: IteratorResult blk (AllComponents blk)
  }

deriving instance ( Show blk
                  , Show (Header blk)
                  , StandardHash blk
                  , HasNestedContent Header blk
                  ) => Show (IteratorResultGCed blk)

instance (Eq blk, Eq (Header blk), StandardHash blk, HasNestedContent Header blk)
      => Eq (IteratorResultGCed blk) where
  IteratorResultGCed Bool
real1 IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
iterResult1 == :: IteratorResultGCed blk -> IteratorResultGCed blk -> Bool
== IteratorResultGCed Bool
real2 IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
iterResult2 =
      case (Bool
real1, Bool
real2) of
        (Bool
False, Bool
False) -> IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
iterResult1 IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> IteratorResult
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> Bool
forall a. Eq a => a -> a -> Bool
== IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
iterResult2
        (Bool
True,  Bool
_)     -> Bool
eqIfNotGCed
        (Bool
_,     Bool
True)  -> Bool
eqIfNotGCed
    where
      eqIfNotGCed :: Bool
eqIfNotGCed = case (IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
iterResult1, IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
iterResult2) of
        (IteratorBlockGCed {}, IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
_)                    -> Bool
True
        (IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
_,                    IteratorBlockGCed {}) -> Bool
True
        (IteratorResult (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
 SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) blk)
b1,    IteratorResult (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
 SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) blk)
b2)    -> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
 SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) blk)
b1 (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
 SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) blk)
-> (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
    SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) blk)
-> Bool
forall a. Eq a => a -> a -> Bool
== (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
 SlotNo, IsEBB, SizeInBytes, Word16,
 SomeSecond (NestedCtxt Header) blk)
b2
        (IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
IteratorExhausted,    IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
IteratorExhausted)    -> Bool
True
        (IteratorResult
   blk
   (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
    SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) blk),
 IteratorResult
   blk
   (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
    SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) blk))
_                                            -> Bool
False

-- | The model knows about all valid blocks whereas the real implementation
-- only knows about blocks that have been validated in the VolatileDB if they
-- were part of a chain selected by chain selection.
--
-- 'Nothing' means the validity of the block is unknown.
--
-- When the real implementation returned 'Nothing', we ignore the result of
-- the model. If the model returned 'Nothing', the real implementation must
-- too. In the 'Just' case, the result of the implementation and the model
-- must match.
data IsValidResult = IsValidResult
  { IsValidResult -> Bool
real    :: Bool
    -- ^ 'True':  result of calling 'getIsValid' on the real implementation
    -- ^ 'False': result of calling 'getIsValid' on the model implementation
  , IsValidResult -> Maybe Bool
isValid :: Maybe Bool
  } deriving (Int -> IsValidResult -> ShowS
[IsValidResult] -> ShowS
IsValidResult -> String
(Int -> IsValidResult -> ShowS)
-> (IsValidResult -> String)
-> ([IsValidResult] -> ShowS)
-> Show IsValidResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IsValidResult -> ShowS
showsPrec :: Int -> IsValidResult -> ShowS
$cshow :: IsValidResult -> String
show :: IsValidResult -> String
$cshowList :: [IsValidResult] -> ShowS
showList :: [IsValidResult] -> ShowS
Show)

instance Eq IsValidResult where
  IsValidResult Bool
real1 Maybe Bool
isValid1 == :: IsValidResult -> IsValidResult -> Bool
== IsValidResult Bool
real2 Maybe Bool
isValid2 =
      case (Bool
real1, Bool
real2) of
        (Bool
False, Bool
False) -> Maybe Bool
isValid1 Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Bool
isValid2
        (Bool
True,  Bool
False) -> Maybe Bool -> Maybe Bool -> Bool
forall {a}. Eq a => Maybe a -> Maybe a -> Bool
realMatchesModel Maybe Bool
isValid1 Maybe Bool
isValid2
        (Bool
False, Bool
True)  -> Maybe Bool -> Maybe Bool -> Bool
forall {a}. Eq a => Maybe a -> Maybe a -> Bool
realMatchesModel Maybe Bool
isValid2 Maybe Bool
isValid1
        (Bool
True,  Bool
True)  -> Bool
eqIfJust
    where
      eqIfJust :: Bool
eqIfJust = case (Maybe Bool
isValid1, Maybe Bool
isValid2) of
        (Just Bool
x1, Just Bool
x2) -> Bool
x1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
x2
        (Maybe Bool, Maybe Bool)
_                  -> Bool
True

      realMatchesModel :: Maybe a -> Maybe a -> Bool
realMatchesModel Maybe a
real Maybe a
model = case (Maybe a
real, Maybe a
model) of
        (Just a
x1, Just a
x2) -> a
x1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x2
        (Maybe a
Nothing, Maybe a
Nothing) -> Bool
True
        (Maybe a
Nothing, Just a
_)  -> Bool
True
        (Just a
_,  Maybe a
Nothing) -> Bool
False

{-------------------------------------------------------------------------------
  Instantiating the semantics
-------------------------------------------------------------------------------}

-- | Responses are either successful termination or an error.
newtype Resp blk it flr = Resp
  { forall blk it flr.
Resp blk it flr -> Either (ChainDbError blk) (Success blk it flr)
getResp :: Either (ChainDbError blk) (Success blk it flr) }
  deriving ((forall a b. (a -> b) -> Resp blk it a -> Resp blk it b)
-> (forall a b. a -> Resp blk it b -> Resp blk it a)
-> Functor (Resp blk it)
forall a b. a -> Resp blk it b -> Resp blk it a
forall a b. (a -> b) -> Resp blk it a -> Resp blk it b
forall blk it a b. a -> Resp blk it b -> Resp blk it a
forall blk it a b. (a -> b) -> Resp blk it a -> Resp blk it 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 it a b. (a -> b) -> Resp blk it a -> Resp blk it b
fmap :: forall a b. (a -> b) -> Resp blk it a -> Resp blk it b
$c<$ :: forall blk it a b. a -> Resp blk it b -> Resp blk it a
<$ :: forall a b. a -> Resp blk it b -> Resp blk it a
Functor, (forall m. Monoid m => Resp blk it m -> m)
-> (forall m a. Monoid m => (a -> m) -> Resp blk it a -> m)
-> (forall m a. Monoid m => (a -> m) -> Resp blk it a -> m)
-> (forall a b. (a -> b -> b) -> b -> Resp blk it a -> b)
-> (forall a b. (a -> b -> b) -> b -> Resp blk it a -> b)
-> (forall b a. (b -> a -> b) -> b -> Resp blk it a -> b)
-> (forall b a. (b -> a -> b) -> b -> Resp blk it a -> b)
-> (forall a. (a -> a -> a) -> Resp blk it a -> a)
-> (forall a. (a -> a -> a) -> Resp blk it a -> a)
-> (forall a. Resp blk it a -> [a])
-> (forall a. Resp blk it a -> Bool)
-> (forall a. Resp blk it a -> Int)
-> (forall a. Eq a => a -> Resp blk it a -> Bool)
-> (forall a. Ord a => Resp blk it a -> a)
-> (forall a. Ord a => Resp blk it a -> a)
-> (forall a. Num a => Resp blk it a -> a)
-> (forall a. Num a => Resp blk it a -> a)
-> Foldable (Resp blk it)
forall a. Eq a => a -> Resp blk it a -> Bool
forall a. Num a => Resp blk it a -> a
forall a. Ord a => Resp blk it a -> a
forall m. Monoid m => Resp blk it m -> m
forall a. Resp blk it a -> Bool
forall a. Resp blk it a -> Int
forall a. Resp blk it a -> [a]
forall a. (a -> a -> a) -> Resp blk it a -> a
forall m a. Monoid m => (a -> m) -> Resp blk it a -> m
forall b a. (b -> a -> b) -> b -> Resp blk it a -> b
forall a b. (a -> b -> b) -> b -> Resp blk it a -> b
forall blk it a. Eq a => a -> Resp blk it a -> Bool
forall blk it a. Num a => Resp blk it a -> a
forall blk it a. Ord a => Resp blk it a -> a
forall blk it m. Monoid m => Resp blk it m -> m
forall blk it a. Resp blk it a -> Bool
forall blk it a. Resp blk it a -> Int
forall blk it a. Resp blk it a -> [a]
forall blk it a. (a -> a -> a) -> Resp blk it a -> a
forall blk it m a. Monoid m => (a -> m) -> Resp blk it a -> m
forall blk it b a. (b -> a -> b) -> b -> Resp blk it a -> b
forall blk it a b. (a -> b -> b) -> b -> Resp blk it a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall blk it m. Monoid m => Resp blk it m -> m
fold :: forall m. Monoid m => Resp blk it m -> m
$cfoldMap :: forall blk it m a. Monoid m => (a -> m) -> Resp blk it a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Resp blk it a -> m
$cfoldMap' :: forall blk it m a. Monoid m => (a -> m) -> Resp blk it a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Resp blk it a -> m
$cfoldr :: forall blk it a b. (a -> b -> b) -> b -> Resp blk it a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Resp blk it a -> b
$cfoldr' :: forall blk it a b. (a -> b -> b) -> b -> Resp blk it a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Resp blk it a -> b
$cfoldl :: forall blk it b a. (b -> a -> b) -> b -> Resp blk it a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Resp blk it a -> b
$cfoldl' :: forall blk it b a. (b -> a -> b) -> b -> Resp blk it a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Resp blk it a -> b
$cfoldr1 :: forall blk it a. (a -> a -> a) -> Resp blk it a -> a
foldr1 :: forall a. (a -> a -> a) -> Resp blk it a -> a
$cfoldl1 :: forall blk it a. (a -> a -> a) -> Resp blk it a -> a
foldl1 :: forall a. (a -> a -> a) -> Resp blk it a -> a
$ctoList :: forall blk it a. Resp blk it a -> [a]
toList :: forall a. Resp blk it a -> [a]
$cnull :: forall blk it a. Resp blk it a -> Bool
null :: forall a. Resp blk it a -> Bool
$clength :: forall blk it a. Resp blk it a -> Int
length :: forall a. Resp blk it a -> Int
$celem :: forall blk it a. Eq a => a -> Resp blk it a -> Bool
elem :: forall a. Eq a => a -> Resp blk it a -> Bool
$cmaximum :: forall blk it a. Ord a => Resp blk it a -> a
maximum :: forall a. Ord a => Resp blk it a -> a
$cminimum :: forall blk it a. Ord a => Resp blk it a -> a
minimum :: forall a. Ord a => Resp blk it a -> a
$csum :: forall blk it a. Num a => Resp blk it a -> a
sum :: forall a. Num a => Resp blk it a -> a
$cproduct :: forall blk it a. Num a => Resp blk it a -> a
product :: forall a. Num a => Resp blk it a -> a
Foldable, Functor (Resp blk it)
Foldable (Resp blk it)
(Functor (Resp blk it), Foldable (Resp blk it)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Resp blk it a -> f (Resp blk it b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Resp blk it (f a) -> f (Resp blk it a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Resp blk it a -> m (Resp blk it b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Resp blk it (m a) -> m (Resp blk it a))
-> Traversable (Resp blk it)
forall blk it. Functor (Resp blk it)
forall blk it. Foldable (Resp blk it)
forall blk it (m :: * -> *) a.
Monad m =>
Resp blk it (m a) -> m (Resp blk it a)
forall blk it (f :: * -> *) a.
Applicative f =>
Resp blk it (f a) -> f (Resp blk it a)
forall blk it (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Resp blk it a -> m (Resp blk it b)
forall blk it (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Resp blk it a -> f (Resp blk it b)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Resp blk it (m a) -> m (Resp blk it a)
forall (f :: * -> *) a.
Applicative f =>
Resp blk it (f a) -> f (Resp blk it a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Resp blk it a -> m (Resp blk it b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Resp blk it a -> f (Resp blk it b)
$ctraverse :: forall blk it (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Resp blk it a -> f (Resp blk it b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Resp blk it a -> f (Resp blk it b)
$csequenceA :: forall blk it (f :: * -> *) a.
Applicative f =>
Resp blk it (f a) -> f (Resp blk it a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Resp blk it (f a) -> f (Resp blk it a)
$cmapM :: forall blk it (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Resp blk it a -> m (Resp blk it b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Resp blk it a -> m (Resp blk it b)
$csequence :: forall blk it (m :: * -> *) a.
Monad m =>
Resp blk it (m a) -> m (Resp blk it a)
sequence :: forall (m :: * -> *) a.
Monad m =>
Resp blk it (m a) -> m (Resp blk it a)
Traversable)

deriving instance (TestConstraints blk, Show it, Show flr)
               => Show (Resp blk it flr)

instance (TestConstraints blk, Eq it, Eq flr) => Eq (Resp blk it flr) where
  Resp (Left  ChainDbError blk
e) == :: Resp blk it flr -> Resp blk it flr -> Bool
== Resp (Left  ChainDbError blk
e') = ChainDbError blk
e ChainDbError blk -> ChainDbError blk -> Bool
forall a. Eq a => a -> a -> Bool
== ChainDbError blk
e'
  Resp (Right Success blk it flr
a) == Resp (Right Success blk it flr
a') = Success blk it flr
a Success blk it flr -> Success blk it flr -> Bool
forall a. Eq a => a -> a -> Bool
== Success blk it flr
a'
  Resp blk it flr
_              == Resp blk it flr
_               = Bool
False


type DBModel blk = Model.Model blk

-- We can't reuse 'run' because the 'ChainDB' API uses 'STM'. Instead, we call
-- the model directly.
runPure :: forall blk.
           TestConstraints blk
        => TopLevelConfig  blk
        -> Cmd             blk IteratorId FollowerId
        -> DBModel         blk
        -> (Resp           blk IteratorId FollowerId, DBModel blk)
runPure :: forall blk.
TestConstraints blk =>
TopLevelConfig blk
-> Cmd blk Int Int
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
runPure TopLevelConfig blk
cfg = \case
    AddBlock blk
blk             -> (Point blk -> Success blk Int Int)
-> (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  Point blk -> Success blk Int Int
forall blk it flr. Point blk -> Success blk it flr
Point               ((DBModel blk -> (Point blk, DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk -> (Point blk, DBModel blk)
forall {t} {t}. (t -> t) -> t -> t
update  (blk -> DBModel blk -> (Point blk, DBModel blk)
add blk
blk)
    Cmd blk Int Int
GetCurrentChain          -> (AnchoredFragment (Header blk) -> Success blk Int Int)
-> (DBModel blk -> (AnchoredFragment (Header blk), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  AnchoredFragment (Header blk) -> Success blk Int Int
forall blk it flr.
AnchoredFragment (Header blk) -> Success blk it flr
Chain               ((DBModel blk -> (AnchoredFragment (Header blk), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (AnchoredFragment (Header blk), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> AnchoredFragment (Header blk))
-> DBModel blk -> (AnchoredFragment (Header blk), DBModel blk)
forall {b} {a}. (b -> a) -> b -> (a, b)
query   (SecurityParam
-> (blk -> Header blk)
-> DBModel blk
-> AnchoredFragment (Header blk)
forall a blk.
(HasHeader a, HasHeader blk) =>
SecurityParam -> (blk -> a) -> Model blk -> AnchoredFragment a
Model.volatileChain SecurityParam
k blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader)
    Cmd blk Int Int
GetTipBlock              -> (Maybe blk -> Success blk Int Int)
-> (DBModel blk -> (Maybe blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  Maybe blk -> Success blk Int Int
forall blk it flr. Maybe blk -> Success blk it flr
MbBlock             ((DBModel blk -> (Maybe blk, DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (Maybe blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> Maybe blk)
-> DBModel blk -> (Maybe blk, DBModel blk)
forall {b} {a}. (b -> a) -> b -> (a, b)
query    DBModel blk -> Maybe blk
forall blk. Model blk -> Maybe blk
Model.tipBlock
    Cmd blk Int Int
GetTipHeader             -> (Maybe (Header blk) -> Success blk Int Int)
-> (DBModel blk -> (Maybe (Header blk), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  Maybe (Header blk) -> Success blk Int Int
forall blk it flr. Maybe (Header blk) -> Success blk it flr
MbHeader            ((DBModel blk -> (Maybe (Header blk), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (Maybe (Header blk), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> Maybe (Header blk))
-> DBModel blk -> (Maybe (Header blk), DBModel blk)
forall {b} {a}. (b -> a) -> b -> (a, b)
query   ((blk -> Header blk) -> Maybe blk -> Maybe (Header blk)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader (Maybe blk -> Maybe (Header blk))
-> (DBModel blk -> Maybe blk) -> DBModel blk -> Maybe (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBModel blk -> Maybe blk
forall blk. Model blk -> Maybe blk
Model.tipBlock)
    Cmd blk Int Int
GetTipPoint              -> (Point blk -> Success blk Int Int)
-> (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  Point blk -> Success blk Int Int
forall blk it flr. Point blk -> Success blk it flr
Point               ((DBModel blk -> (Point blk, DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> Point blk)
-> DBModel blk -> (Point blk, DBModel blk)
forall {b} {a}. (b -> a) -> b -> (a, b)
query    DBModel blk -> Point blk
forall blk. HasHeader blk => Model blk -> Point blk
Model.tipPoint
    GetBlockComponent RealPoint blk
pt     -> (Maybe
   (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
    SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) blk)
 -> Success blk Int Int)
-> (DBModel blk
    -> (Either
          (ChainDbError blk)
          (Maybe
             (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
              SlotNo, IsEBB, SizeInBytes, Word16,
              SomeSecond (NestedCtxt Header) blk)),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (Either (ChainDbError blk) a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
err Maybe
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk Int Int
forall blk it flr. Maybe (AllComponents blk) -> Success blk it flr
MbAllComponents     ((DBModel blk
  -> (Either
        (ChainDbError blk)
        (Maybe
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)),
      DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk
    -> (Either
          (ChainDbError blk)
          (Maybe
             (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
              SlotNo, IsEBB, SizeInBytes, Word16,
              SomeSecond (NestedCtxt Header) blk)),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk
 -> Either
      (ChainDbError blk)
      (Maybe
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)))
-> DBModel blk
-> (Either
      (ChainDbError blk)
      (Maybe
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)),
    DBModel blk)
forall {b} {a}. (b -> a) -> b -> (a, b)
query   (BlockComponent
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> RealPoint blk
-> DBModel blk
-> Either
     (ChainDbError blk)
     (Maybe
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall blk b.
ModelSupportsBlock blk =>
BlockComponent blk b
-> RealPoint blk
-> Model blk
-> Either (ChainDbError blk) (Maybe b)
Model.getBlockComponentByPoint 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 RealPoint blk
pt)
    GetGCedBlockComponent RealPoint blk
pt -> (Maybe
   (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
    SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) blk)
 -> Success blk Int Int)
-> (DBModel blk
    -> (Either
          (ChainDbError blk)
          (Maybe
             (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
              SlotNo, IsEBB, SizeInBytes, Word16,
              SomeSecond (NestedCtxt Header) blk)),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (Either (ChainDbError blk) a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
err Maybe
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk Int Int
forall blk it flr. Maybe (AllComponents blk) -> Success blk it flr
mbGCedAllComponents ((DBModel blk
  -> (Either
        (ChainDbError blk)
        (Maybe
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)),
      DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk
    -> (Either
          (ChainDbError blk)
          (Maybe
             (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
              SlotNo, IsEBB, SizeInBytes, Word16,
              SomeSecond (NestedCtxt Header) blk)),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk
 -> Either
      (ChainDbError blk)
      (Maybe
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)))
-> DBModel blk
-> (Either
      (ChainDbError blk)
      (Maybe
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)),
    DBModel blk)
forall {b} {a}. (b -> a) -> b -> (a, b)
query   (BlockComponent
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> RealPoint blk
-> DBModel blk
-> Either
     (ChainDbError blk)
     (Maybe
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall blk b.
ModelSupportsBlock blk =>
BlockComponent blk b
-> RealPoint blk
-> Model blk
-> Either (ChainDbError blk) (Maybe b)
Model.getBlockComponentByPoint 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 RealPoint blk
pt)
    Cmd blk Int Int
GetMaxSlotNo             -> (MaxSlotNo -> Success blk Int Int)
-> (DBModel blk -> (MaxSlotNo, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  MaxSlotNo -> Success blk Int Int
forall blk it flr. MaxSlotNo -> Success blk it flr
MaxSlot             ((DBModel blk -> (MaxSlotNo, DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (MaxSlotNo, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> MaxSlotNo)
-> DBModel blk -> (MaxSlotNo, DBModel blk)
forall {b} {a}. (b -> a) -> b -> (a, b)
query    DBModel blk -> MaxSlotNo
forall blk. HasHeader blk => Model blk -> MaxSlotNo
Model.getMaxSlotNo
    GetIsValid RealPoint blk
pt            -> (Maybe Bool -> Success blk Int Int)
-> (DBModel blk -> (Maybe Bool, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  Maybe Bool -> Success blk Int Int
forall {blk} {it} {flr}. Maybe Bool -> Success blk it flr
isValidResult       ((DBModel blk -> (Maybe Bool, DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (Maybe Bool, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> Maybe Bool)
-> DBModel blk -> (Maybe Bool, DBModel blk)
forall {b} {a}. (b -> a) -> b -> (a, b)
query   (RealPoint blk -> DBModel blk -> Maybe Bool
forall blk.
LedgerSupportsProtocol blk =>
RealPoint blk -> Model blk -> Maybe Bool
Model.isValid RealPoint blk
pt)
    UpdateLoE AnchoredFragment blk
frag           -> (Point blk -> Success blk Int Int)
-> (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  Point blk -> Success blk Int Int
forall blk it flr. Point blk -> Success blk it flr
Point               ((DBModel blk -> (Point blk, DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk -> (Point blk, DBModel blk)
forall {t} {t}. (t -> t) -> t -> t
update  (TopLevelConfig blk
-> AnchoredFragment blk -> DBModel blk -> (Point blk, DBModel blk)
forall blk.
(LedgerTablesAreTrivial (ExtLedgerState blk),
 LedgerSupportsProtocol blk) =>
TopLevelConfig blk
-> AnchoredFragment blk -> Model blk -> (Point blk, Model blk)
Model.updateLoE TopLevelConfig blk
cfg AnchoredFragment blk
frag)
    Stream StreamFrom blk
from StreamTo blk
to           -> (Either (UnknownRange blk) Int -> Success blk Int Int)
-> (DBModel blk
    -> (Either (ChainDbError blk) (Either (UnknownRange blk) Int),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (Either (ChainDbError blk) a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
err Either (UnknownRange blk) Int -> Success blk Int Int
forall {blk} {it} {flr}.
Either (UnknownRange blk) it -> Success blk it flr
iter                ((DBModel blk
  -> (Either (ChainDbError blk) (Either (UnknownRange blk) Int),
      DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk
    -> (Either (ChainDbError blk) (Either (UnknownRange blk) Int),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk
 -> Either
      (ChainDbError blk) (Either (UnknownRange blk) Int, DBModel blk))
-> DBModel blk
-> (Either (ChainDbError blk) (Either (UnknownRange blk) Int),
    DBModel blk)
forall {b} {a} {b}. (b -> Either a (b, b)) -> b -> (Either a b, b)
updateE (SecurityParam
-> StreamFrom blk
-> StreamTo blk
-> DBModel blk
-> Either
     (ChainDbError blk) (Either (UnknownRange blk) Int, DBModel 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
from StreamTo blk
to)
    IteratorNext  Int
it         -> (IteratorResult
   blk
   (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
    SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) blk)
 -> Success blk Int Int)
-> (DBModel blk
    -> (IteratorResult
          blk
          (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
           SlotNo, IsEBB, SizeInBytes, Word16,
           SomeSecond (NestedCtxt Header) blk),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk Int Int
forall blk it flr.
IteratorResult blk (AllComponents blk) -> Success blk it flr
IterResult          ((DBModel blk
  -> (IteratorResult
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk),
      DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk
    -> (IteratorResult
          blk
          (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
           SlotNo, IsEBB, SizeInBytes, Word16,
           SomeSecond (NestedCtxt Header) blk),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk
 -> (IteratorResult
       blk
       (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
        SlotNo, IsEBB, SizeInBytes, Word16,
        SomeSecond (NestedCtxt Header) blk),
     DBModel blk))
-> DBModel blk
-> (IteratorResult
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk),
    DBModel blk)
forall {t} {t}. (t -> t) -> t -> t
update  (Int
-> BlockComponent
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> DBModel blk
-> (IteratorResult
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk),
    DBModel blk)
forall blk b.
ModelSupportsBlock blk =>
Int
-> BlockComponent blk b
-> Model blk
-> (IteratorResult blk b, Model blk)
Model.iteratorNext Int
it 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)
    IteratorNextGCed Int
it      -> (IteratorResult
   blk
   (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
    SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) blk)
 -> Success blk Int Int)
-> (DBModel blk
    -> (IteratorResult
          blk
          (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
           SlotNo, IsEBB, SizeInBytes, Word16,
           SomeSecond (NestedCtxt Header) blk),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk Int Int
forall blk it flr.
IteratorResult blk (AllComponents blk) -> Success blk it flr
iterResultGCed      ((DBModel blk
  -> (IteratorResult
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk),
      DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk
    -> (IteratorResult
          blk
          (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
           SlotNo, IsEBB, SizeInBytes, Word16,
           SomeSecond (NestedCtxt Header) blk),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk
 -> (IteratorResult
       blk
       (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
        SlotNo, IsEBB, SizeInBytes, Word16,
        SomeSecond (NestedCtxt Header) blk),
     DBModel blk))
-> DBModel blk
-> (IteratorResult
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk),
    DBModel blk)
forall {t} {t}. (t -> t) -> t -> t
update  (Int
-> BlockComponent
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> DBModel blk
-> (IteratorResult
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk),
    DBModel blk)
forall blk b.
ModelSupportsBlock blk =>
Int
-> BlockComponent blk b
-> Model blk
-> (IteratorResult blk b, Model blk)
Model.iteratorNext Int
it 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)
    IteratorClose Int
it         -> (() -> Success blk Int Int)
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  () -> Success blk Int Int
forall blk it flr. () -> Success blk it flr
Unit                ((DBModel blk -> ((), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> DBModel blk) -> DBModel blk -> ((), DBModel blk)
forall {t} {b}. (t -> b) -> t -> ((), b)
update_ (Int -> DBModel blk -> DBModel blk
forall blk. Int -> Model blk -> Model blk
Model.iteratorClose Int
it)
    -- As tentative followers differ from normal followers only during chain
    -- selection, this test can not distinguish between them due to its
    -- sequential nature. Hence, we don't add a pure model for tentative
    -- followers.
    NewFollower ChainType
_            -> (Int -> Success blk Int Int)
-> (DBModel blk -> (Int, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  Int -> Success blk Int Int
forall blk it flr. flr -> Success blk it flr
Flr                 ((DBModel blk -> (Int, DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (Int, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> (Int, DBModel blk))
-> DBModel blk -> (Int, DBModel blk)
forall {t} {t}. (t -> t) -> t -> t
update   DBModel blk -> (Int, DBModel blk)
forall blk. HasHeader blk => Model blk -> (Int, Model blk)
Model.newFollower
    FollowerInstruction Int
flr  -> (Maybe
   (ChainUpdate
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
 -> Success blk Int Int)
-> (DBModel blk
    -> (Either
          (ChainDbError blk)
          (Maybe
             (ChainUpdate
                blk
                (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                 SlotNo, IsEBB, SizeInBytes, Word16,
                 SomeSecond (NestedCtxt Header) blk))),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (Either (ChainDbError blk) a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
err Maybe
  (ChainUpdate
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> Success blk Int Int
forall blk it flr.
Maybe (ChainUpdate blk (AllComponents blk)) -> Success blk it flr
MbChainUpdate       ((DBModel blk
  -> (Either
        (ChainDbError blk)
        (Maybe
           (ChainUpdate
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))),
      DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk
    -> (Either
          (ChainDbError blk)
          (Maybe
             (ChainUpdate
                blk
                (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                 SlotNo, IsEBB, SizeInBytes, Word16,
                 SomeSecond (NestedCtxt Header) blk))),
        DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk
 -> Either
      (ChainDbError blk)
      (Maybe
         (ChainUpdate
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)),
       DBModel blk))
-> DBModel blk
-> (Either
      (ChainDbError blk)
      (Maybe
         (ChainUpdate
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))),
    DBModel blk)
forall {b} {a} {b}. (b -> Either a (b, b)) -> b -> (Either a b, b)
updateE (Int
-> BlockComponent
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> DBModel blk
-> Either
     (ChainDbError blk)
     (Maybe
        (ChainUpdate
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)),
      DBModel blk)
forall blk b.
ModelSupportsBlock blk =>
Int
-> BlockComponent blk b
-> Model blk
-> Either (ChainDbError blk) (Maybe (ChainUpdate blk b), Model blk)
Model.followerInstruction Int
flr 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)
    FollowerForward Int
flr [Point blk]
pts  -> (Maybe (Point blk) -> Success blk Int Int)
-> (DBModel blk
    -> (Either (ChainDbError blk) (Maybe (Point blk)), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (Either (ChainDbError blk) a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
err Maybe (Point blk) -> Success blk Int Int
forall blk it flr. Maybe (Point blk) -> Success blk it flr
MbPoint             ((DBModel blk
  -> (Either (ChainDbError blk) (Maybe (Point blk)), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk
    -> (Either (ChainDbError blk) (Maybe (Point blk)), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk
 -> Either (ChainDbError blk) (Maybe (Point blk), DBModel blk))
-> DBModel blk
-> (Either (ChainDbError blk) (Maybe (Point blk)), DBModel blk)
forall {b} {a} {b}. (b -> Either a (b, b)) -> b -> (Either a b, b)
updateE (Int
-> [Point blk]
-> DBModel blk
-> Either (ChainDbError blk) (Maybe (Point blk), DBModel blk)
forall blk.
HasHeader blk =>
Int
-> [Point blk]
-> Model blk
-> Either (ChainDbError blk) (Maybe (Point blk), Model blk)
Model.followerForward Int
flr [Point blk]
pts)
    FollowerClose Int
flr        -> (() -> Success blk Int Int)
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  () -> Success blk Int Int
forall blk it flr. () -> Success blk it flr
Unit                ((DBModel blk -> ((), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> DBModel blk) -> DBModel blk -> ((), DBModel blk)
forall {t} {b}. (t -> b) -> t -> ((), b)
update_ (Int -> DBModel blk -> DBModel blk
forall blk. Int -> Model blk -> Model blk
Model.followerClose Int
flr)
    Cmd blk Int Int
PersistBlks              -> (() -> Success blk Int Int)
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  () -> Success blk Int Int
forall blk it flr. () -> Success blk it flr
Unit                ((DBModel blk -> ((), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> DBModel blk) -> DBModel blk -> ((), DBModel blk)
forall {t} {b}. (t -> b) -> t -> ((), b)
update_ (SecurityParam -> ShouldGarbageCollect -> DBModel blk -> DBModel blk
forall blk.
HasHeader blk =>
SecurityParam -> ShouldGarbageCollect -> Model blk -> Model blk
Model.copyToImmutableDB SecurityParam
k ShouldGarbageCollect
DoNotGarbageCollect)
    Cmd blk Int Int
PersistBlksThenGC        -> (() -> Success blk Int Int)
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  () -> Success blk Int Int
forall blk it flr. () -> Success blk it flr
Unit                ((DBModel blk -> ((), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> DBModel blk) -> DBModel blk -> ((), DBModel blk)
forall {t} {b}. (t -> b) -> t -> ((), b)
update_ (SecurityParam -> ShouldGarbageCollect -> DBModel blk -> DBModel blk
forall blk.
HasHeader blk =>
SecurityParam -> ShouldGarbageCollect -> Model blk -> Model blk
Model.copyToImmutableDB SecurityParam
k ShouldGarbageCollect
GarbageCollect)
    -- TODO: The model does not capture the notion of ledger snapshots,
    -- therefore we ignore this command here. This introduces an assymetry in
    -- the way the 'UpdateLedgerSnapshots' command is handled in the model and
    -- in the system under test. It would be better if we modelled the
    -- snapshots so that this aspect of the system would be explicitly
    -- specified. See https://github.com/IntersectMBO/ouroboros-network/issues/3375
    --
    Cmd blk Int Int
UpdateLedgerSnapshots    -> (() -> Success blk Int Int)
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  () -> Success blk Int Int
forall blk it flr. () -> Success blk it flr
Unit                ((DBModel blk -> ((), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ ((), )
    Cmd blk Int Int
Close                    -> (DBModel blk -> ((), DBModel blk))
-> DBModel blk -> (Resp blk Int Int, DBModel blk)
forall {p :: MapKind} {a} {c} {blk} {it} {flr}.
Bifunctor p =>
(a -> p () c) -> a -> p (Resp blk it flr) c
openOrClosed            ((DBModel blk -> ((), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> DBModel blk) -> DBModel blk -> ((), DBModel blk)
forall {t} {b}. (t -> b) -> t -> ((), b)
update_  DBModel blk -> DBModel blk
forall blk. Model blk -> Model blk
Model.closeDB
    Cmd blk Int Int
Reopen                   -> (DBModel blk -> ((), DBModel blk))
-> DBModel blk -> (Resp blk Int Int, DBModel blk)
forall {p :: MapKind} {a} {c} {blk} {it} {flr}.
Bifunctor p =>
(a -> p () c) -> a -> p (Resp blk it flr) c
openOrClosed            ((DBModel blk -> ((), DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> ((), DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> DBModel blk) -> DBModel blk -> ((), DBModel blk)
forall {t} {b}. (t -> b) -> t -> ((), b)
update_  DBModel blk -> DBModel blk
forall blk. Model blk -> Model blk
Model.reopen
    Cmd blk Int Int
WipeVolatileDB           -> (Point blk -> Success blk Int Int)
-> (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok  Point blk -> Success blk Int Int
forall blk it flr. Point blk -> Success blk it flr
Point               ((DBModel blk -> (Point blk, DBModel blk))
 -> DBModel blk -> (Resp blk Int Int, DBModel blk))
-> (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall a b. (a -> b) -> a -> b
$ (DBModel blk -> (Point blk, DBModel blk))
-> DBModel blk -> (Point blk, DBModel blk)
forall {t} {t}. (t -> t) -> t -> t
update  (TopLevelConfig blk -> DBModel blk -> (Point blk, DBModel blk)
forall blk.
(LedgerSupportsProtocol blk,
 LedgerTablesAreTrivial (ExtLedgerState blk)) =>
TopLevelConfig blk -> Model blk -> (Point blk, Model blk)
Model.wipeVolatileDB TopLevelConfig blk
cfg)
  where
    k :: SecurityParam
k = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg

    add :: blk -> DBModel blk -> (Point blk, DBModel blk)
add blk
blk DBModel blk
m = (DBModel blk -> Point blk
forall blk. HasHeader blk => Model blk -> Point blk
Model.tipPoint DBModel blk
m', DBModel blk
m')
      where
        m' :: DBModel blk
m' = TopLevelConfig blk -> blk -> DBModel blk -> DBModel blk
forall blk.
(LedgerSupportsProtocol blk,
 LedgerTablesAreTrivial (ExtLedgerState blk)) =>
TopLevelConfig blk -> blk -> Model blk -> Model blk
Model.addBlock TopLevelConfig blk
cfg blk
blk DBModel blk
m

    iter :: Either (UnknownRange blk) it -> Success blk it flr
iter = (UnknownRange blk -> Success blk it flr)
-> (it -> Success blk it flr)
-> Either (UnknownRange blk) it
-> Success blk it flr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either UnknownRange blk -> Success blk it flr
forall blk it flr. UnknownRange blk -> Success blk it flr
UnknownRange it -> Success blk it flr
forall blk it flr. it -> Success blk it flr
Iter
    mbGCedAllComponents :: Maybe
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
mbGCedAllComponents = MaybeGCedBlock
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
forall blk it flr.
MaybeGCedBlock (AllComponents blk) -> Success blk it flr
MbGCedAllComponents (MaybeGCedBlock
   (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
    SlotNo, IsEBB, SizeInBytes, Word16,
    SomeSecond (NestedCtxt Header) blk)
 -> Success blk it flr)
-> (Maybe
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk)
    -> MaybeGCedBlock
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
-> Maybe
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Maybe
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> MaybeGCedBlock
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
forall blk. Bool -> Maybe blk -> MaybeGCedBlock blk
MaybeGCedBlock Bool
False
    iterResultGCed :: IteratorResult
  blk
  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
   SlotNo, IsEBB, SizeInBytes, Word16,
   SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
iterResultGCed = IteratorResultGCed blk -> Success blk it flr
forall blk it flr. IteratorResultGCed blk -> Success blk it flr
IterResultGCed (IteratorResultGCed blk -> Success blk it flr)
-> (IteratorResult
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk)
    -> IteratorResultGCed blk)
-> IteratorResult
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> Success blk it flr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> IteratorResult
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk)
-> IteratorResultGCed blk
forall blk.
Bool
-> IteratorResult blk (AllComponents blk) -> IteratorResultGCed blk
IteratorResultGCed Bool
False
    isValidResult :: Maybe Bool -> Success blk it flr
isValidResult = IsValidResult -> Success blk it flr
forall blk it flr. IsValidResult -> Success blk it flr
IsValid (IsValidResult -> Success blk it flr)
-> (Maybe Bool -> IsValidResult)
-> Maybe Bool
-> Success blk it flr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe Bool -> IsValidResult
IsValidResult Bool
False

    query :: (b -> a) -> b -> (a, b)
query   b -> a
f b
m = (b -> a
f b
m, b
m)

    update :: (t -> t) -> t -> t
update  t -> t
f t
m = t -> t
f t
m
    update_ :: (t -> b) -> t -> ((), b)
update_ t -> b
f t
m = ((), t -> b
f t
m)
    updateE :: (b -> Either a (b, b)) -> b -> (Either a b, b)
updateE b -> Either a (b, b)
f b
m = case b -> Either a (b, b)
f b
m of
      Left  a
e       -> (a -> Either a b
forall a b. a -> Either a b
Left a
e, b
m)
      Right (b
a, b
m') -> (b -> Either a b
forall a b. b -> Either a b
Right b
a, b
m')

    -- Only executed when the ChainDB is open, otherwise a 'ClosedDBError' is
    -- returned.
    ok :: (a -> Success blk it flr)
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
ok a -> Success blk it flr
toSuccess Model blk -> (a, Model blk)
f = (a -> Success blk it flr)
-> (Model blk -> (Either (ChainDbError blk) a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
forall {a} {blk} {it} {flr} {blk}.
(a -> Success blk it flr)
-> (Model blk -> (Either (ChainDbError blk) a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
err a -> Success blk it flr
toSuccess ((a -> Either (ChainDbError blk) a)
-> (a, Model blk) -> (Either (ChainDbError blk) a, Model blk)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: MapKind) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> Either (ChainDbError blk) a
forall a b. b -> Either a b
Right ((a, Model blk) -> (Either (ChainDbError blk) a, Model blk))
-> (Model blk -> (a, Model blk))
-> Model blk
-> (Either (ChainDbError blk) a, Model blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> (a, Model blk)
f)
    err :: (a -> Success blk it flr)
-> (Model blk -> (Either (ChainDbError blk) a, Model blk))
-> Model blk
-> (Resp blk it flr, Model blk)
err a -> Success blk it flr
toSuccess Model blk -> (Either (ChainDbError blk) a, Model blk)
f Model blk
m
      | Model blk -> Bool
forall blk. Model blk -> Bool
Model.isOpen Model blk
m
      = (Either (ChainDbError blk) a -> Resp blk it flr)
-> (Either (ChainDbError blk) a, Model blk)
-> (Resp blk it flr, Model blk)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: MapKind) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Either (ChainDbError blk) (Success blk it flr) -> Resp blk it flr
forall blk it flr.
Either (ChainDbError blk) (Success blk it flr) -> Resp blk it flr
Resp (Either (ChainDbError blk) (Success blk it flr) -> Resp blk it flr)
-> (Either (ChainDbError blk) a
    -> Either (ChainDbError blk) (Success blk it flr))
-> Either (ChainDbError blk) a
-> Resp blk it flr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Success blk it flr)
-> Either (ChainDbError blk) a
-> Either (ChainDbError blk) (Success blk it flr)
forall a b.
(a -> b)
-> Either (ChainDbError blk) a -> Either (ChainDbError blk) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Success blk it flr
toSuccess) (Model blk -> (Either (ChainDbError blk) a, Model blk)
f Model blk
m)
      | Bool
otherwise
      = (Either (ChainDbError blk) (Success blk it flr) -> Resp blk it flr
forall blk it flr.
Either (ChainDbError blk) (Success blk it flr) -> Resp blk it flr
Resp (ChainDbError blk -> Either (ChainDbError blk) (Success blk it flr)
forall a b. a -> Either a b
Left (PrettyCallStack -> ChainDbError blk
forall blk. PrettyCallStack -> ChainDbError blk
ClosedDBError PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack)), Model blk
m)

    -- Executed whether the ChainDB is open or closed.
    openOrClosed :: (a -> p () c) -> a -> p (Resp blk it flr) c
openOrClosed a -> p () c
f = (() -> Resp blk it flr) -> p () c -> p (Resp blk it flr) c
forall a b c. (a -> b) -> p a c -> p b c
forall (p :: MapKind) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Either (ChainDbError blk) (Success blk it flr) -> Resp blk it flr
forall blk it flr.
Either (ChainDbError blk) (Success blk it flr) -> Resp blk it flr
Resp (Either (ChainDbError blk) (Success blk it flr) -> Resp blk it flr)
-> (() -> Either (ChainDbError blk) (Success blk it flr))
-> ()
-> Resp blk it flr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Success blk it flr
-> Either (ChainDbError blk) (Success blk it flr)
forall a b. b -> Either a b
Right (Success blk it flr
 -> Either (ChainDbError blk) (Success blk it flr))
-> (() -> Success blk it flr)
-> ()
-> Either (ChainDbError blk) (Success blk it flr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Success blk it flr
forall blk it flr. () -> Success blk it flr
Unit) (p () c -> p (Resp blk it flr) c)
-> (a -> p () c) -> a -> p (Resp blk it flr) c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> p () c
f

runIO :: TestConstraints blk
      => TopLevelConfig blk
      -> ChainDBEnv IO blk
      -> Cmd blk (TestIterator IO blk) (TestFollower IO blk)
      -> IO (Resp blk (TestIterator IO blk) (TestFollower IO blk))
runIO :: forall blk.
TestConstraints blk =>
TopLevelConfig blk
-> ChainDBEnv IO blk
-> Cmd blk (TestIterator IO blk) (TestFollower IO blk)
-> IO (Resp blk (TestIterator IO blk) (TestFollower IO blk))
runIO TopLevelConfig blk
cfg ChainDBEnv IO blk
env Cmd blk (TestIterator IO blk) (TestFollower IO blk)
cmd = Either
  (ChainDbError blk)
  (Success blk (TestIterator IO blk) (TestFollower IO blk))
-> Resp blk (TestIterator IO blk) (TestFollower IO blk)
forall blk it flr.
Either (ChainDbError blk) (Success blk it flr) -> Resp blk it flr
Resp (Either
   (ChainDbError blk)
   (Success blk (TestIterator IO blk) (TestFollower IO blk))
 -> Resp blk (TestIterator IO blk) (TestFollower IO blk))
-> IO
     (Either
        (ChainDbError blk)
        (Success blk (TestIterator IO blk) (TestFollower IO blk)))
-> IO (Resp blk (TestIterator IO blk) (TestFollower IO blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Success blk (TestIterator IO blk) (TestFollower IO blk))
-> IO
     (Either
        (ChainDbError blk)
        (Success blk (TestIterator IO blk) (TestFollower IO blk)))
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (TopLevelConfig blk
-> ChainDBEnv IO blk
-> Cmd blk (TestIterator IO blk) (TestFollower IO blk)
-> IO (Success blk (TestIterator IO blk) (TestFollower IO blk))
forall (m :: * -> *) blk.
(IOLike m, TestConstraints blk) =>
TopLevelConfig blk
-> ChainDBEnv m blk
-> Cmd blk (TestIterator m blk) (TestFollower m blk)
-> m (Success blk (TestIterator m blk) (TestFollower m blk))
run TopLevelConfig blk
cfg ChainDBEnv IO blk
env Cmd blk (TestIterator IO blk) (TestFollower IO blk)
cmd)

{-------------------------------------------------------------------------------
  Collect arguments
-------------------------------------------------------------------------------}

-- | Collect all iterators created.
iters :: Bitraversable t => t it flr -> [it]
iters :: forall (t :: MapKind) it flr. Bitraversable t => t it flr -> [it]
iters = (it -> [it]) -> (flr -> [it]) -> t it flr -> [it]
forall m a b. Monoid m => (a -> m) -> (b -> m) -> t a b -> m
forall (p :: MapKind) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap (it -> [it] -> [it]
forall a. a -> [a] -> [a]
:[]) ([it] -> flr -> [it]
forall a b. a -> b -> a
const [])

-- | Collect all followers created.
flrs :: Bitraversable t => t it flr -> [flr]
flrs :: forall (t :: MapKind) it flr. Bitraversable t => t it flr -> [flr]
flrs = (it -> [flr]) -> (flr -> [flr]) -> t it flr -> [flr]
forall m a b. Monoid m => (a -> m) -> (b -> m) -> t a b -> m
forall (p :: MapKind) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap ([flr] -> it -> [flr]
forall a b. a -> b -> a
const []) (flr -> [flr] -> [flr]
forall a. a -> [a] -> [a]
:[])

{-------------------------------------------------------------------------------
  Bitraversable instances
-------------------------------------------------------------------------------}

TH.deriveBifunctor     ''Cmd
TH.deriveBifoldable    ''Cmd
TH.deriveBitraversable ''Cmd

TH.deriveBifunctor     ''Success
TH.deriveBifoldable    ''Success
TH.deriveBitraversable ''Success

TH.deriveBifunctor     ''Resp
TH.deriveBifoldable    ''Resp
TH.deriveBitraversable ''Resp

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

-- | Concrete or symbolic references to a real iterator
type IterRef blk m r = Reference (Opaque (TestIterator m blk)) r

-- | Mapping between iterator references and mocked iterators
type KnownIters blk m r = RefEnv (Opaque (TestIterator m blk)) IteratorId r

-- | Concrete or symbolic references to a real follower
type FollowerRef blk m r = Reference (Opaque (TestFollower m blk)) r

-- | Mapping between iterator references and mocked followers
type KnownFollowers blk m r = RefEnv (Opaque (TestFollower m blk)) FollowerId r

-- | Execution model
data Model blk m r = Model
  { forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
dbModel        :: DBModel                blk
  , forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownIters blk m r
knownIters     :: KnownIters             blk m r
  , forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownFollowers blk m r
knownFollowers :: KnownFollowers         blk m r
  , forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> Opaque (TopLevelConfig blk)
modelConfig    :: Opaque (TopLevelConfig blk)
  } deriving ((forall x. Model blk m r -> Rep (Model blk m r) x)
-> (forall x. Rep (Model blk m r) x -> Model blk m r)
-> Generic (Model blk m r)
forall x. Rep (Model blk m r) x -> Model blk m r
forall x. Model blk m r -> Rep (Model blk m r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk (m :: * -> *) (r :: * -> *) x.
Rep (Model blk m r) x -> Model blk m r
forall blk (m :: * -> *) (r :: * -> *) x.
Model blk m r -> Rep (Model blk m r) x
$cfrom :: forall blk (m :: * -> *) (r :: * -> *) x.
Model blk m r -> Rep (Model blk m r) x
from :: forall x. Model blk m r -> Rep (Model blk m r) x
$cto :: forall blk (m :: * -> *) (r :: * -> *) x.
Rep (Model blk m r) x -> Model blk m r
to :: forall x. Rep (Model blk m r) x -> Model blk m r
Generic)

deriving instance (TestConstraints blk, Show1 r) => Show (Model blk m r)

-- | Initial model
initModel :: HasHeader blk
          => LoE ()
          -> TopLevelConfig blk
          -> ExtLedgerState blk EmptyMK
          -> Model blk m r
initModel :: forall blk (m :: * -> *) (r :: * -> *).
HasHeader blk =>
LoE ()
-> TopLevelConfig blk
-> ExtLedgerState blk EmptyMK
-> Model blk m r
initModel LoE ()
loe TopLevelConfig blk
cfg ExtLedgerState blk EmptyMK
initLedger = Model
  { dbModel :: DBModel blk
dbModel        = LoE () -> ExtLedgerState blk EmptyMK -> DBModel blk
forall blk.
HasHeader blk =>
LoE () -> ExtLedgerState blk EmptyMK -> Model blk
Model.empty LoE ()
loe ExtLedgerState blk EmptyMK
initLedger
  , knownIters :: KnownIters blk m r
knownIters     = KnownIters blk m r
forall k a (r :: * -> *). RefEnv k a r
RE.empty
  , knownFollowers :: KnownFollowers blk m r
knownFollowers = KnownFollowers blk m r
forall k a (r :: * -> *). RefEnv k a r
RE.empty
  , modelConfig :: Opaque (TopLevelConfig blk)
modelConfig    = TopLevelConfig blk -> Opaque (TopLevelConfig blk)
forall a. a -> Opaque a
QSM.Opaque TopLevelConfig blk
cfg
  }

-- | Key property of the model is that we can go from real to mock responses
toMock :: (Bifunctor (t blk), Eq1 r)
       => Model blk m r -> At t blk m r -> t blk IteratorId FollowerId
toMock :: forall (t :: * -> MapKind) blk (r :: * -> *) (m :: * -> *).
(Bifunctor (t blk), Eq1 r) =>
Model blk m r -> At t blk m r -> t blk Int Int
toMock Model {KnownFollowers blk m r
KnownIters blk m r
Opaque (TopLevelConfig blk)
DBModel blk
dbModel :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
knownIters :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownIters blk m r
knownFollowers :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownFollowers blk m r
modelConfig :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> Opaque (TopLevelConfig blk)
dbModel :: DBModel blk
knownIters :: KnownIters blk m r
knownFollowers :: KnownFollowers blk m r
modelConfig :: Opaque (TopLevelConfig blk)
..} (At t blk (IterRef blk m r) (FollowerRef blk m r)
t) = (IterRef blk m r -> Int)
-> (FollowerRef blk m r -> Int)
-> t blk (IterRef blk m r) (FollowerRef blk m r)
-> t blk Int Int
forall a b c d. (a -> b) -> (c -> d) -> t blk a c -> t blk b d
forall (p :: MapKind) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (KnownIters blk m r
knownIters KnownIters blk m r -> IterRef blk m r -> Int
forall k (r :: * -> *) a.
(Eq k, Eq1 r) =>
RefEnv k a r -> Reference k r -> a
RE.!) (KnownFollowers blk m r
knownFollowers KnownFollowers blk m r -> FollowerRef blk m r -> Int
forall k (r :: * -> *) a.
(Eq k, Eq1 r) =>
RefEnv k a r -> Reference k r -> a
RE.!) t blk (IterRef blk m r) (FollowerRef blk m r)
t

-- | Step the mock semantics
--
-- We cannot step the whole Model here (see 'event', below)
step ::
     (TestConstraints blk, Eq1 r)
  => Model  blk m r
  -> At Cmd blk m r
  -> (Resp  blk IteratorId FollowerId, DBModel blk)
step :: forall blk (r :: * -> *) (m :: * -> *).
(TestConstraints blk, Eq1 r) =>
Model blk m r -> At Cmd blk m r -> (Resp blk Int Int, DBModel blk)
step model :: Model blk m r
model@Model { DBModel blk
dbModel :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
dbModel :: DBModel blk
dbModel, Opaque (TopLevelConfig blk)
modelConfig :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> Opaque (TopLevelConfig blk)
modelConfig :: Opaque (TopLevelConfig blk)
modelConfig } At Cmd blk m r
cmd =
    TopLevelConfig blk
-> Cmd blk Int Int
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
forall blk.
TestConstraints blk =>
TopLevelConfig blk
-> Cmd blk Int Int
-> DBModel blk
-> (Resp blk Int Int, DBModel blk)
runPure (Opaque (TopLevelConfig blk) -> TopLevelConfig blk
forall a. Opaque a -> a
QSM.unOpaque Opaque (TopLevelConfig blk)
modelConfig) (Model blk m r -> At Cmd blk m r -> Cmd blk Int Int
forall (t :: * -> MapKind) blk (r :: * -> *) (m :: * -> *).
(Bifunctor (t blk), Eq1 r) =>
Model blk m r -> At t blk m r -> t blk Int Int
toMock Model blk m r
model At Cmd blk m r
cmd) DBModel blk
dbModel

{-------------------------------------------------------------------------------
  Wrapping in quickcheck-state-machine references
-------------------------------------------------------------------------------}

-- | Instantiate functor @t blk@ to
-- @t blk ('IterRef' blk m r) ('FollowerRef' blk m r)@.
--
-- Needed because we need to (partially) apply @'At' t blk flr m@ to @r@.
newtype At t blk m r = At { forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
At t blk m r -> t blk (IterRef blk m r) (FollowerRef blk m r)
unAt :: t blk (IterRef blk m r) (FollowerRef blk m r) }
  deriving ((forall x. At t blk m r -> Rep (At t blk m r) x)
-> (forall x. Rep (At t blk m r) x -> At t blk m r)
-> Generic (At t blk m r)
forall x. Rep (At t blk m r) x -> At t blk m r
forall x. At t blk m r -> Rep (At t blk m r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *) x.
Rep (At t blk m r) x -> At t blk m r
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *) x.
At t blk m r -> Rep (At t blk m r) x
$cfrom :: forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *) x.
At t blk m r -> Rep (At t blk m r) x
from :: forall x. At t blk m r -> Rep (At t blk m r) x
$cto :: forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *) x.
Rep (At t blk m r) x -> At t blk m r
to :: forall x. Rep (At t blk m r) x -> At t blk m r
Generic)


deriving newtype instance Show (t blk (IterRef blk m r) (FollowerRef blk m r))
               => Show (At t blk m r)

deriving instance (TestConstraints blk, Eq1 r) => Eq (At Resp blk m r)

instance Bifunctor (t blk) => Rank2.Functor (At t blk m) where
  fmap :: forall (p :: * -> *) (q :: * -> *).
(forall x. p x -> q x) -> At t blk m p -> At t blk m q
fmap = \forall x. p x -> q x
f (At t blk (IterRef blk m p) (FollowerRef blk m p)
x) -> t blk (IterRef blk m q) (FollowerRef blk m q) -> At t blk m q
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
t blk (IterRef blk m r) (FollowerRef blk m r) -> At t blk m r
At ((IterRef blk m p -> IterRef blk m q)
-> (FollowerRef blk m p -> FollowerRef blk m q)
-> t blk (IterRef blk m p) (FollowerRef blk m p)
-> t blk (IterRef blk m q) (FollowerRef blk m q)
forall a b c d. (a -> b) -> (c -> d) -> t blk a c -> t blk b d
forall (p :: MapKind) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((p (Opaque
      (WithEq
         (Iterator
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> q (Opaque
         (WithEq
            (Iterator
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk)))))
-> IterRef blk m p -> IterRef blk m q
forall (r :: * -> *) x (r' :: * -> *).
(r x -> r' x) -> Reference x r -> Reference x r'
app p (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> q (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall x. p x -> q x
f) ((p (Opaque
      (WithEq
         (Follower
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> q (Opaque
         (WithEq
            (Follower
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk)))))
-> FollowerRef blk m p -> FollowerRef blk m q
forall (r :: * -> *) x (r' :: * -> *).
(r x -> r' x) -> Reference x r -> Reference x r'
app p (Opaque
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> q (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall x. p x -> q x
f) t blk (IterRef blk m p) (FollowerRef blk m p)
x)
    where
      app :: (r x -> r' x) -> QSM.Reference x r -> QSM.Reference x r'
      app :: forall (r :: * -> *) x (r' :: * -> *).
(r x -> r' x) -> Reference x r -> Reference x r'
app r x -> r' x
f (QSM.Reference r x
x) = r' x -> Reference x r'
forall a (r :: * -> *). r a -> Reference a r
QSM.Reference (r x -> r' x
f r x
x)

instance Bifoldable (t blk) => Rank2.Foldable (At t blk m) where
  foldMap :: forall m (p :: * -> *).
Monoid m =>
(forall x. p x -> m) -> At t blk m p -> m
foldMap = \forall x. p x -> m
f (At t blk (IterRef blk m p) (FollowerRef blk m p)
x) -> (IterRef blk m p -> m)
-> (FollowerRef blk m p -> m)
-> t blk (IterRef blk m p) (FollowerRef blk m p)
-> m
forall m a b. Monoid m => (a -> m) -> (b -> m) -> t blk a b -> m
forall (p :: MapKind) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap ((p (Opaque
      (WithEq
         (Iterator
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> m)
-> IterRef blk m p -> m
forall (r :: * -> *) x n. (r x -> n) -> Reference x r -> n
app p (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> m
forall x. p x -> m
f) ((p (Opaque
      (WithEq
         (Follower
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> m)
-> FollowerRef blk m p -> m
forall (r :: * -> *) x n. (r x -> n) -> Reference x r -> n
app p (Opaque
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> m
forall x. p x -> m
f) t blk (IterRef blk m p) (FollowerRef blk m p)
x
    where
      app :: (r x -> n) -> QSM.Reference x r -> n
      app :: forall (r :: * -> *) x n. (r x -> n) -> Reference x r -> n
app r x -> n
f (QSM.Reference r x
x) = r x -> n
f r x
x

instance Bitraversable (t blk) => Rank2.Traversable (At t blk m) where
  traverse :: forall (f :: * -> *) (p :: * -> *) (q :: * -> *).
Applicative f =>
(forall a. p a -> f (q a)) -> At t blk m p -> f (At t blk m q)
traverse = \forall a. p a -> f (q a)
f (At t blk (IterRef blk m p) (FollowerRef blk m p)
x) -> t blk (IterRef blk m q) (FollowerRef blk m q) -> At t blk m q
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
t blk (IterRef blk m r) (FollowerRef blk m r) -> At t blk m r
At (t blk (IterRef blk m q) (FollowerRef blk m q) -> At t blk m q)
-> f (t blk (IterRef blk m q) (FollowerRef blk m q))
-> f (At t blk m q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IterRef blk m p -> f (IterRef blk m q))
-> (FollowerRef blk m p -> f (FollowerRef blk m q))
-> t blk (IterRef blk m p) (FollowerRef blk m p)
-> f (t blk (IterRef blk m q) (FollowerRef blk m q))
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> t blk a b -> f (t blk c d)
forall (t :: MapKind) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse ((p (Opaque
      (WithEq
         (Iterator
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> f (q (Opaque
            (WithEq
               (Iterator
                  m
                  blk
                  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                   SlotNo, IsEBB, SizeInBytes, Word16,
                   SomeSecond (NestedCtxt Header) blk))))))
-> IterRef blk m p -> f (IterRef blk m q)
forall (f :: * -> *) (r :: * -> *) x (r' :: * -> *).
Functor f =>
(r x -> f (r' x)) -> Reference x r -> f (Reference x r')
app p (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> f (q (Opaque
           (WithEq
              (Iterator
                 m
                 blk
                 (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                  SlotNo, IsEBB, SizeInBytes, Word16,
                  SomeSecond (NestedCtxt Header) blk)))))
forall a. p a -> f (q a)
f) ((p (Opaque
      (WithEq
         (Follower
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
 -> f (q (Opaque
            (WithEq
               (Follower
                  m
                  blk
                  (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                   SlotNo, IsEBB, SizeInBytes, Word16,
                   SomeSecond (NestedCtxt Header) blk))))))
-> FollowerRef blk m p -> f (FollowerRef blk m q)
forall (f :: * -> *) (r :: * -> *) x (r' :: * -> *).
Functor f =>
(r x -> f (r' x)) -> Reference x r -> f (Reference x r')
app p (Opaque
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
-> f (q (Opaque
           (WithEq
              (Follower
                 m
                 blk
                 (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                  SlotNo, IsEBB, SizeInBytes, Word16,
                  SomeSecond (NestedCtxt Header) blk)))))
forall a. p a -> f (q a)
f) t blk (IterRef blk m p) (FollowerRef blk m p)
x
    where
      app :: Functor f
          => (r x -> f (r' x)) -> QSM.Reference x r -> f (QSM.Reference x r')
      app :: forall (f :: * -> *) (r :: * -> *) x (r' :: * -> *).
Functor f =>
(r x -> f (r' x)) -> Reference x r -> f (Reference x r')
app r x -> f (r' x)
f (QSM.Reference r x
x) = r' x -> Reference x r'
forall a (r :: * -> *). r a -> Reference a r
QSM.Reference (r' x -> Reference x r') -> f (r' x) -> f (Reference x r')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r x -> f (r' x)
f r x
x

{-------------------------------------------------------------------------------
  Events
-------------------------------------------------------------------------------}

-- | An event records the model before and after a command along with the
-- command itself, and a mocked version of the response.
data Event blk m r = Event
  { forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Model blk m r
eventBefore   :: Model  blk m r
  , forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> At Cmd blk m r
eventCmd      :: At Cmd blk m r
  , forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Model blk m r
eventAfter    :: Model  blk m r
  , forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Resp blk Int Int
eventMockResp :: Resp   blk     IteratorId FollowerId
  }

deriving instance (TestConstraints blk, Show1 r) => Show (Event blk m r)

-- | Construct an event
lockstep :: (TestConstraints blk, Eq1 r, Show1 r)
         => Model     blk m r
         -> At Cmd    blk m r
         -> At Resp   blk m r
         -> Event     blk m r
lockstep :: forall blk (r :: * -> *) (m :: * -> *).
(TestConstraints blk, Eq1 r, Show1 r) =>
Model blk m r -> At Cmd blk m r -> At Resp blk m r -> Event blk m r
lockstep model :: Model blk m r
model@Model {KnownFollowers blk m r
KnownIters blk m r
Opaque (TopLevelConfig blk)
DBModel blk
dbModel :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
knownIters :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownIters blk m r
knownFollowers :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownFollowers blk m r
modelConfig :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> Opaque (TopLevelConfig blk)
dbModel :: DBModel blk
knownIters :: KnownIters blk m r
knownFollowers :: KnownFollowers blk m r
modelConfig :: Opaque (TopLevelConfig blk)
..} At Cmd blk m r
cmd (At Resp blk (IterRef blk m r) (FollowerRef blk m r)
resp) = Event
    { eventBefore :: Model blk m r
eventBefore   = Model blk m r
model
    , eventCmd :: At Cmd blk m r
eventCmd      = At Cmd blk m r
cmd
    , eventAfter :: Model blk m r
eventAfter    = Model blk m r
model'
    , eventMockResp :: Resp blk Int Int
eventMockResp = Resp blk Int Int
mockResp
    }
  where
    (Resp blk Int Int
mockResp, DBModel blk
dbModel') = Model blk m r -> At Cmd blk m r -> (Resp blk Int Int, DBModel blk)
forall blk (r :: * -> *) (m :: * -> *).
(TestConstraints blk, Eq1 r) =>
Model blk m r -> At Cmd blk m r -> (Resp blk Int Int, DBModel blk)
step Model blk m r
model At Cmd blk m r
cmd
    newIters :: KnownIters blk m r
newIters   = [(IterRef blk m r, Int)] -> KnownIters blk m r
forall k a (r :: * -> *).
(Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) =>
[(Reference k r, a)] -> RefEnv k a r
RE.fromList ([(IterRef blk m r, Int)] -> KnownIters blk m r)
-> [(IterRef blk m r, Int)] -> KnownIters blk m r
forall a b. (a -> b) -> a -> b
$ [IterRef blk m r] -> [Int] -> [(IterRef blk m r, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Resp blk (IterRef blk m r) (FollowerRef blk m r)
-> [IterRef blk m r]
forall (t :: MapKind) it flr. Bitraversable t => t it flr -> [it]
iters Resp blk (IterRef blk m r) (FollowerRef blk m r)
resp) (Resp blk Int Int -> [Int]
forall (t :: MapKind) it flr. Bitraversable t => t it flr -> [it]
iters Resp blk Int Int
mockResp)
    newFollowers :: KnownFollowers blk m r
newFollowers = [(FollowerRef blk m r, Int)] -> KnownFollowers blk m r
forall k a (r :: * -> *).
(Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) =>
[(Reference k r, a)] -> RefEnv k a r
RE.fromList ([(FollowerRef blk m r, Int)] -> KnownFollowers blk m r)
-> [(FollowerRef blk m r, Int)] -> KnownFollowers blk m r
forall a b. (a -> b) -> a -> b
$ [FollowerRef blk m r] -> [Int] -> [(FollowerRef blk m r, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Resp blk (IterRef blk m r) (FollowerRef blk m r)
-> [FollowerRef blk m r]
forall (t :: MapKind) it flr. Bitraversable t => t it flr -> [flr]
flrs  Resp blk (IterRef blk m r) (FollowerRef blk m r)
resp) (Resp blk Int Int -> [Int]
forall (t :: MapKind) it flr. Bitraversable t => t it flr -> [flr]
flrs  Resp blk Int Int
mockResp)
    model' :: Model blk m r
model' = case At Cmd blk m r -> Cmd blk (IterRef blk m r) (FollowerRef blk m r)
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
At t blk m r -> t blk (IterRef blk m r) (FollowerRef blk m r)
unAt At Cmd blk m r
cmd of
      -- When closing the database, all open iterators and followers are closed
      -- too, so forget them.
      Cmd blk (IterRef blk m r) (FollowerRef blk m r)
Close -> Model blk m r
model
        { dbModel        = dbModel'
        , knownIters     = RE.empty
        , knownFollowers = RE.empty
        }
      Cmd blk (IterRef blk m r) (FollowerRef blk m r)
WipeVolatileDB -> Model blk m r
model
        { dbModel        = dbModel'
        , knownIters     = RE.empty
        , knownFollowers = RE.empty
        }
      Cmd blk (IterRef blk m r) (FollowerRef blk m r)
_ -> Model blk m r
model
        { dbModel        = dbModel'
        , knownIters     = knownIters `RE.union` newIters
        , knownFollowers = knownFollowers `RE.union` newFollowers
        }


{-------------------------------------------------------------------------------
  Generator
-------------------------------------------------------------------------------}

type BlockGen blk m = Model blk m Symbolic -> Gen blk

-- | Generate a 'Cmd'
generator ::
     forall blk m. TestConstraints blk
  => LoE ()
  -> BlockGen     blk m
  -> Model        blk m Symbolic
  -> Gen (At Cmd  blk m Symbolic)
generator :: forall blk (m :: * -> *).
TestConstraints blk =>
LoE ()
-> BlockGen blk m
-> Model blk m Symbolic
-> Gen (At Cmd blk m Symbolic)
generator LoE ()
loe BlockGen blk m
genBlock m :: Model blk m Symbolic
m@Model {KnownFollowers blk m Symbolic
KnownIters blk m Symbolic
Opaque (TopLevelConfig blk)
DBModel blk
dbModel :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
knownIters :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownIters blk m r
knownFollowers :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownFollowers blk m r
modelConfig :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> Opaque (TopLevelConfig blk)
dbModel :: DBModel blk
knownIters :: KnownIters blk m Symbolic
knownFollowers :: KnownFollowers blk m Symbolic
modelConfig :: Opaque (TopLevelConfig blk)
..} = Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> At Cmd blk m Symbolic
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
t blk (IterRef blk m r) (FollowerRef blk m r) -> At t blk m r
At (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
 -> At Cmd blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> Gen (At Cmd blk m Symbolic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int,
  Gen
    (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)))]
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
30, Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genAddBlock)
    , (if Bool
empty then Int
1 else Int
10, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
GetCurrentChain)
--    , (if empty then 1 else 10, return GetLedgerDB)
    , (if Bool
empty then Int
1 else Int
10, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
GetTipBlock)
      -- To check that we're on the right chain
    , (if Bool
empty then Int
1 else Int
10, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
GetTipPoint)
    , (Int
10, Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall it flr. Gen (Cmd blk it flr)
genGetBlockComponent)
    , (if Bool
empty then Int
1 else Int
10, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
GetMaxSlotNo)
    , (if Bool
empty then Int
1 else Int
10, Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall it flr. Gen (Cmd blk it flr)
genGetIsValid)

    , let freq :: Int
freq = case LoE ()
loe of
            LoE ()
LoEDisabled   -> Int
0
            LoEEnabled () -> if Bool
empty then Int
1 else Int
10
      in (Int
freq, AnchoredFragment blk
-> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. AnchoredFragment blk -> Cmd blk it flr
UpdateLoE (AnchoredFragment blk
 -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> Gen (AnchoredFragment blk)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (AnchoredFragment blk)
genLoEFragment)

    -- Iterators
    , (if Bool
empty then Int
1 else Int
10, (StreamFrom blk
 -> StreamTo blk
 -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> (StreamFrom blk, StreamTo blk)
-> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry StreamFrom blk
-> StreamTo blk
-> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. StreamFrom blk -> StreamTo blk -> Cmd blk it flr
Stream ((StreamFrom blk, StreamTo blk)
 -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> Gen (StreamFrom blk, StreamTo blk)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (StreamFrom blk, StreamTo blk)
genBounds)
    , (if [IterRef blk m Symbolic] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IterRef blk m Symbolic]
iterators then Int
0 else Int
20, Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genIteratorNext)
      -- Use a lower frequency for closing, so that the chance increases that
      -- we can stream multiple blocks from an iterator.
    , (if [IterRef blk m Symbolic] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IterRef blk m Symbolic]
iterators then Int
0 else Int
2, Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genIteratorClose)

    -- Followers
    , (Int
10, Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall {blk} {it} {flr}. Gen (Cmd blk it flr)
genNewFollower)
    , (if [FollowerRef blk m Symbolic] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FollowerRef blk m Symbolic]
followers then Int
0 else Int
10, Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genFollowerInstruction)
    , (if [FollowerRef blk m Symbolic] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FollowerRef blk m Symbolic]
followers then Int
0 else Int
10, Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genFollowerForward)
      -- Use a lower frequency for closing, so that the chance increases that
      -- we can read multiple blocks from a follower
    , (if [FollowerRef blk m Symbolic] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FollowerRef blk m Symbolic]
followers then Int
0 else Int
2, Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genFollowerClose)

    , (if Bool
empty then Int
1 else Int
10, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
Close)
    , (if DBModel blk -> Bool
forall blk. Model blk -> Bool
Model.isOpen DBModel blk
dbModel then
         (if Bool
empty then Int
1 else Int
10)
       else Int
0, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
Reopen)

      -- Internal
    , (if Bool
empty then Int
1 else Int
10, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
PersistBlks)
    , (if Bool
empty then Int
1 else Int
10, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
PersistBlksThenGC)
    , (if Bool
empty then Int
1 else Int
10, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
UpdateLedgerSnapshots)
    , (if Bool
empty then Int
1 else Int
10, Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. Cmd blk it flr
WipeVolatileDB)
    ]
    -- TODO adjust the frequencies after labelling
  where
    cfg :: TopLevelConfig blk
    cfg :: TopLevelConfig blk
cfg = Opaque (TopLevelConfig blk) -> TopLevelConfig blk
forall a. Opaque a -> a
unOpaque Opaque (TopLevelConfig blk)
modelConfig

    secParam :: SecurityParam
    secParam :: SecurityParam
secParam = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg

    iterators :: [Reference (Opaque (TestIterator m blk)) Symbolic]
    iterators :: [IterRef blk m Symbolic]
iterators = KnownIters blk m Symbolic -> [IterRef blk m Symbolic]
forall k a (r :: * -> *). RefEnv k a r -> [Reference k r]
RE.keys KnownIters blk m Symbolic
knownIters

    followers :: [Reference (Opaque (TestFollower m blk)) Symbolic]
    followers :: [FollowerRef blk m Symbolic]
followers = KnownFollowers blk m Symbolic -> [FollowerRef blk m Symbolic]
forall k a (r :: * -> *). RefEnv k a r -> [Reference k r]
RE.keys KnownFollowers blk m Symbolic
knownFollowers

    genRandomPoint :: Gen (RealPoint blk)
    genRandomPoint :: Gen (RealPoint blk)
genRandomPoint = blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint (blk -> RealPoint blk) -> Gen blk -> Gen (RealPoint blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockGen blk m
genBlock Model blk m Symbolic
m

    blocksInDB :: Map.Map (HeaderHash blk) blk
    blocksInDB :: Map (HeaderHash blk) blk
blocksInDB = DBModel blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
Model.blocks DBModel blk
dbModel

    pointsInDB :: [RealPoint blk]
    pointsInDB :: [RealPoint blk]
pointsInDB = blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint (blk -> RealPoint blk) -> [blk] -> [RealPoint blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (HeaderHash blk) blk -> [blk]
forall k a. Map k a -> [a]
Map.elems Map (HeaderHash blk) blk
blocksInDB

    genLoEFragment :: Gen (AnchoredFragment blk)
    genLoEFragment :: Gen (AnchoredFragment blk)
genLoEFragment = [(Int, Gen (AnchoredFragment blk))] -> Gen (AnchoredFragment blk)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
1, AnchoredFragment blk -> Gen (AnchoredFragment blk)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredFragment blk -> Gen (AnchoredFragment blk))
-> AnchoredFragment blk -> Gen (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ Anchor blk -> AnchoredFragment blk
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor blk
forall block. Anchor block
AF.AnchorGenesis)
        , (Int
20, (Gen (Maybe (AnchoredFragment blk))
 -> (Maybe (AnchoredFragment blk) -> Maybe (AnchoredFragment blk))
 -> Gen (AnchoredFragment blk))
-> (Maybe (AnchoredFragment blk) -> Maybe (AnchoredFragment blk))
-> Gen (Maybe (AnchoredFragment blk))
-> Gen (AnchoredFragment blk)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen (Maybe (AnchoredFragment blk))
-> (Maybe (AnchoredFragment blk) -> Maybe (AnchoredFragment blk))
-> Gen (AnchoredFragment blk)
forall a b. Gen a -> (a -> Maybe b) -> Gen b
suchThatMap Maybe (AnchoredFragment blk) -> Maybe (AnchoredFragment blk)
forall a. a -> a
id (Gen (Maybe (AnchoredFragment blk)) -> Gen (AnchoredFragment blk))
-> Gen (Maybe (AnchoredFragment blk)) -> Gen (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ do
            -- Generate a fragment between an anchor in the ImmutableDB and a
            -- tip corresponding to either the immutable tip, a volatile block
            -- or a block not yet in the ChainDB.
            anchor <- [Anchor blk] -> Gen (Anchor blk)
forall a. HasCallStack => [a] -> Gen a
elements ([Anchor blk] -> Gen (Anchor blk))
-> [Anchor blk] -> Gen (Anchor blk)
forall a b. (a -> b) -> a -> b
$
              Anchor blk
forall block. Anchor block
AF.AnchorGenesis Anchor blk -> [Anchor blk] -> [Anchor blk]
forall a. a -> [a] -> [a]
: (blk -> Anchor blk) -> [blk] -> [Anchor blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap blk -> Anchor blk
forall block. HasHeader block => block -> Anchor block
AF.anchorFromBlock [blk]
immutableBlocks
            blk <- genBlock m
            tip    <- frequency
              [ (1, pure $ Chain.headHash immutableChain)
              , (5, pure $ BlockHash (blockHash blk))
              , ( if null volatileBlocks then 0 else 5
                , elements $ BlockHash . blockHash <$> volatileBlocks
                )
              ]
            let blks = HeaderHash blk
-> blk -> Map (HeaderHash blk) blk -> Map (HeaderHash blk) blk
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk) blk
blk Map (HeaderHash blk) blk
blocksInDB
            pure $ Model.getFragmentBetween blks anchor tip)
        ]
      where
        immutableChain :: Chain blk
immutableChain  = SecurityParam -> DBModel blk -> Chain blk
forall blk. SecurityParam -> Model blk -> Chain blk
Model.immutableChain SecurityParam
secParam DBModel blk
dbModel
        immutableBlocks :: [blk]
immutableBlocks = Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toNewestFirst Chain blk
immutableChain
        volatileBlocks :: [blk]
volatileBlocks  = Map (HeaderHash blk) blk -> [blk]
forall k a. Map k a -> [a]
Map.elems (Map (HeaderHash blk) blk -> [blk])
-> Map (HeaderHash blk) blk -> [blk]
forall a b. (a -> b) -> a -> b
$ DBModel blk -> Map (HeaderHash blk) blk
forall blk. Model blk -> Map (HeaderHash blk) blk
Model.volatileDbBlocks DBModel blk
dbModel

    empty :: Bool
    empty :: Bool
empty = [RealPoint blk] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RealPoint blk]
pointsInDB

    genRealPoint :: Gen (RealPoint blk)
    genRealPoint :: Gen (RealPoint blk)
genRealPoint = [(Int, Gen (RealPoint blk))] -> Gen (RealPoint blk)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, Gen (RealPoint blk)
genRandomPoint)
      , (if Bool
empty then Int
0 else Int
7, [RealPoint blk] -> Gen (RealPoint blk)
forall a. HasCallStack => [a] -> Gen a
elements [RealPoint blk]
pointsInDB)
      ]

    genPoint :: Gen (Point blk)
    genPoint :: Gen (Point blk)
genPoint = [(Int, Gen (Point blk))] -> Gen (Point blk)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, Point blk -> Gen (Point blk)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Point blk
forall {k} (block :: k). Point block
GenesisPoint)
      , (Int
9, RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint (RealPoint blk -> Point blk)
-> Gen (RealPoint blk) -> Gen (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (RealPoint blk)
genRealPoint)
      ]

    genGetIsValid :: Gen (Cmd blk it flr)
    genGetIsValid :: forall it flr. Gen (Cmd blk it flr)
genGetIsValid =
      RealPoint blk -> Cmd blk it flr
forall blk it flr. RealPoint blk -> Cmd blk it flr
GetIsValid (RealPoint blk -> Cmd blk it flr)
-> Gen (RealPoint blk) -> Gen (Cmd blk it flr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (RealPoint blk)
genRealPoint
    genGetBlockComponent :: Gen (Cmd blk it flr)
    genGetBlockComponent :: forall it flr. Gen (Cmd blk it flr)
genGetBlockComponent = do
      pt <- Gen (RealPoint blk)
genRealPoint
      return $ if Model.garbageCollectablePoint secParam dbModel pt
        then GetGCedBlockComponent pt
        else GetBlockComponent     pt

    genAddBlock :: Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genAddBlock = blk
-> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. blk -> Cmd blk it flr
AddBlock (blk
 -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> Gen blk
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockGen blk m
genBlock Model blk m Symbolic
m

    genBounds :: Gen (StreamFrom blk, StreamTo blk)
    genBounds :: Gen (StreamFrom blk, StreamTo blk)
genBounds = [(Int, Gen (StreamFrom blk, StreamTo blk))]
-> Gen (StreamFrom blk, StreamTo blk)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, Gen (StreamFrom blk, StreamTo blk)
genRandomBounds)
      , (if Bool
empty then Int
0 else Int
3, Gen (StreamFrom blk, StreamTo blk)
genExistingBounds)
      ]

    genRandomBounds :: Gen (StreamFrom blk, StreamTo blk)
    genRandomBounds :: Gen (StreamFrom blk, StreamTo blk)
genRandomBounds = (,)
      (StreamFrom blk -> StreamTo blk -> (StreamFrom blk, StreamTo blk))
-> Gen (StreamFrom blk)
-> Gen (StreamTo blk -> (StreamFrom blk, StreamTo blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (do inEx <- Gen
  (Either
     (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk))
genFromInEx
              case inEx of
                Left  RealPoint blk -> StreamFrom blk
inc -> RealPoint blk -> StreamFrom blk
inc (RealPoint blk -> StreamFrom blk)
-> Gen (RealPoint blk) -> Gen (StreamFrom blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (RealPoint blk)
genRealPoint
                Right Point blk -> StreamFrom blk
exc -> Point blk -> StreamFrom blk
exc (Point blk -> StreamFrom blk)
-> Gen (Point blk) -> Gen (StreamFrom blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Point blk)
genPoint)
      Gen (StreamTo blk -> (StreamFrom blk, StreamTo blk))
-> Gen (StreamTo blk) -> Gen (StreamFrom blk, StreamTo blk)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RealPoint blk -> StreamTo blk
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (RealPoint blk -> StreamTo blk)
-> Gen (RealPoint blk) -> Gen (StreamTo blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (RealPoint blk)
genRealPoint)

    genFromInEx :: Gen (Either (RealPoint blk -> StreamFrom blk)
                               (Point     blk -> StreamFrom blk))
    genFromInEx :: Gen
  (Either
     (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk))
genFromInEx = [Either
   (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk)]
-> Gen
     (Either
        (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk))
forall a. HasCallStack => [a] -> Gen a
elements [(RealPoint blk -> StreamFrom blk)
-> Either
     (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk)
forall a b. a -> Either a b
Left RealPoint blk -> StreamFrom blk
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive, (Point blk -> StreamFrom blk)
-> Either
     (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk)
forall a b. b -> Either a b
Right Point blk -> StreamFrom blk
forall blk. Point blk -> StreamFrom blk
StreamFromExclusive]

    genFromInEx' :: Gen (RealPoint blk -> StreamFrom blk)
    genFromInEx' :: Gen (RealPoint blk -> StreamFrom blk)
genFromInEx' = ((RealPoint blk -> StreamFrom blk)
 -> RealPoint blk -> StreamFrom blk)
-> ((Point blk -> StreamFrom blk)
    -> RealPoint blk -> StreamFrom blk)
-> Either
     (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk)
-> RealPoint blk
-> StreamFrom blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (RealPoint blk -> StreamFrom blk)
-> RealPoint blk -> StreamFrom blk
forall a. a -> a
id ((Point blk -> StreamFrom blk)
-> (RealPoint blk -> Point blk) -> RealPoint blk -> StreamFrom blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint) (Either
   (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk)
 -> RealPoint blk -> StreamFrom blk)
-> Gen
     (Either
        (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk))
-> Gen (RealPoint blk -> StreamFrom blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen
  (Either
     (RealPoint blk -> StreamFrom blk) (Point blk -> StreamFrom blk))
genFromInEx

    -- Generate bounds that correspond to existing blocks in the DB. Make sure
    -- that the start bound is older than the end bound.
    -- NOTE: this does not mean that these bounds are on the same chain.
    genExistingBounds :: Gen (StreamFrom blk, StreamTo blk)
    genExistingBounds :: Gen (StreamFrom blk, StreamTo blk)
genExistingBounds = do
      start <- [RealPoint blk] -> Gen (RealPoint blk)
forall a. HasCallStack => [a] -> Gen a
elements [RealPoint blk]
pointsInDB
      end   <- elements pointsInDB `suchThat` ((>= realPointSlot start) .
                                               realPointSlot)
      (,) <$> (genFromInEx' <*> return start)
          <*> (return $ StreamToInclusive end)

    genIteratorClose :: Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genIteratorClose = IterRef blk m Symbolic
-> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. it -> Cmd blk it flr
IteratorClose (IterRef blk m Symbolic
 -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> Gen (IterRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IterRef blk m Symbolic] -> Gen (IterRef blk m Symbolic)
forall a. HasCallStack => [a] -> Gen a
elements [IterRef blk m Symbolic]
iterators
    genIteratorNext :: Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genIteratorNext  = do
      it <- [IterRef blk m Symbolic] -> Gen (IterRef blk m Symbolic)
forall a. HasCallStack => [a] -> Gen a
elements [IterRef blk m Symbolic]
iterators
      let blockCanBeGCed = SecurityParam -> DBModel blk -> Int -> Bool
forall blk.
ModelSupportsBlock blk =>
SecurityParam -> Model blk -> Int -> Bool
Model.garbageCollectableIteratorNext
            SecurityParam
secParam DBModel blk
dbModel (KnownIters blk m Symbolic
knownIters KnownIters blk m Symbolic -> IterRef blk m Symbolic -> Int
forall k (r :: * -> *) a.
(Eq k, Eq1 r) =>
RefEnv k a r -> Reference k r -> a
RE.! IterRef blk m Symbolic
it)
      return $ if blockCanBeGCed
        then IteratorNextGCed it
        else IteratorNext     it

    genNewFollower :: Gen (Cmd blk it flr)
genNewFollower = ChainType -> Cmd blk it flr
forall blk it flr. ChainType -> Cmd blk it flr
NewFollower (ChainType -> Cmd blk it flr)
-> Gen ChainType -> Gen (Cmd blk it flr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ChainType] -> Gen ChainType
forall a. HasCallStack => [a] -> Gen a
elements [ChainType
SelectedChain, ChainType
TentativeChain]

    genFollowerInstruction :: Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genFollowerInstruction = FollowerRef blk m Symbolic
-> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. flr -> Cmd blk it flr
FollowerInstruction (FollowerRef blk m Symbolic
 -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> Gen (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FollowerRef blk m Symbolic] -> Gen (FollowerRef blk m Symbolic)
forall a. HasCallStack => [a] -> Gen a
elements [FollowerRef blk m Symbolic]
followers
    genFollowerForward :: Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genFollowerForward     = FollowerRef blk m Symbolic
-> [Point blk]
-> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. flr -> [Point blk] -> Cmd blk it flr
FollowerForward     (FollowerRef blk m Symbolic
 -> [Point blk]
 -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> Gen (FollowerRef blk m Symbolic)
-> Gen
     ([Point blk]
      -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FollowerRef blk m Symbolic] -> Gen (FollowerRef blk m Symbolic)
forall a. HasCallStack => [a] -> Gen a
elements [FollowerRef blk m Symbolic]
followers
                                                 Gen
  ([Point blk]
   -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> Gen [Point blk]
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen [Point blk]
genFollowerForwardPoints

    genFollowerForwardPoints :: Gen [Point blk]
    genFollowerForwardPoints :: Gen [Point blk]
genFollowerForwardPoints = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
3) Gen Int -> (Int -> Gen [Point blk]) -> Gen [Point blk]
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
n ->
      (Point blk -> Down (WithOrigin SlotNo))
-> [Point blk] -> [Point blk]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (WithOrigin SlotNo -> Down (WithOrigin SlotNo)
forall a. a -> Down a
Down (WithOrigin SlotNo -> Down (WithOrigin SlotNo))
-> (Point blk -> WithOrigin SlotNo)
-> Point blk
-> Down (WithOrigin SlotNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot) ([Point blk] -> [Point blk]) -> Gen [Point blk] -> Gen [Point blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (Point blk) -> Gen [Point blk]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Gen (Point blk)
genFollowerForwardPoint

    genFollowerForwardPoint :: Gen (Point blk)
    genFollowerForwardPoint :: Gen (Point blk)
genFollowerForwardPoint = Gen (Point blk)
genPoint

    genFollowerClose :: Gen (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
genFollowerClose = FollowerRef blk m Symbolic
-> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
forall blk it flr. flr -> Cmd blk it flr
FollowerClose (FollowerRef blk m Symbolic
 -> Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> Gen (FollowerRef blk m Symbolic)
-> Gen
     (Cmd blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FollowerRef blk m Symbolic] -> Gen (FollowerRef blk m Symbolic)
forall a. HasCallStack => [a] -> Gen a
elements [FollowerRef blk m Symbolic]
followers

chooseSlot :: SlotNo -> SlotNo -> Gen SlotNo
chooseSlot :: SlotNo -> SlotNo -> Gen SlotNo
chooseSlot (SlotNo Word64
start) (SlotNo Word64
end) = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
start, Word64
end)

{-------------------------------------------------------------------------------
  Shrinking
-------------------------------------------------------------------------------}

-- | Shrinker
shrinker :: Model   blk m Symbolic
         ->  At Cmd blk m Symbolic
         -> [At Cmd blk m Symbolic]
shrinker :: forall blk (m :: * -> *).
Model blk m Symbolic
-> At Cmd blk m Symbolic -> [At Cmd blk m Symbolic]
shrinker Model blk m Symbolic
_ = [At Cmd blk m Symbolic]
-> At Cmd blk m Symbolic -> [At Cmd blk m Symbolic]
forall a b. a -> b -> a
const [] -- TODO: implement the shrinker. Command
                      -- 'PersistBlksThenGC' should be shrunk to
                      -- ['PersistBlks']

{-------------------------------------------------------------------------------
  The final state machine
-------------------------------------------------------------------------------}

-- | Mock a response
--
-- We do this by running the pure semantics and then generating mock
-- references for any new handles.
mock :: (TestConstraints blk, Typeable m)
     => Model            blk m Symbolic
     ->         At Cmd   blk m Symbolic
     -> GenSym (At Resp  blk m Symbolic)
mock :: forall blk (m :: * -> *).
(TestConstraints blk, Typeable m) =>
Model blk m Symbolic
-> At Cmd blk m Symbolic -> GenSym (At Resp blk m Symbolic)
mock Model blk m Symbolic
model At Cmd blk m Symbolic
cmd = Resp blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
-> At Resp blk m Symbolic
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
t blk (IterRef blk m r) (FollowerRef blk m r) -> At t blk m r
At (Resp blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic)
 -> At Resp blk m Symbolic)
-> GenSym
     (Resp blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
-> GenSym (At Resp blk m Symbolic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> GenSym (IterRef blk m Symbolic))
-> (Int -> GenSym (FollowerRef blk m Symbolic))
-> Resp blk Int Int
-> GenSym
     (Resp blk (IterRef blk m Symbolic) (FollowerRef blk m Symbolic))
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Resp blk a b -> f (Resp blk c d)
forall (t :: MapKind) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse (GenSym (IterRef blk m Symbolic)
-> Int -> GenSym (IterRef blk m Symbolic)
forall a b. a -> b -> a
const GenSym (IterRef blk m Symbolic)
forall a. Typeable a => GenSym (Reference a Symbolic)
genSym) (GenSym (FollowerRef blk m Symbolic)
-> Int -> GenSym (FollowerRef blk m Symbolic)
forall a b. a -> b -> a
const GenSym (FollowerRef blk m Symbolic)
forall a. Typeable a => GenSym (Reference a Symbolic)
genSym) Resp blk Int Int
resp
  where
    (Resp blk Int Int
resp, DBModel blk
_dbm) = Model blk m Symbolic
-> At Cmd blk m Symbolic -> (Resp blk Int Int, DBModel blk)
forall blk (r :: * -> *) (m :: * -> *).
(TestConstraints blk, Eq1 r) =>
Model blk m r -> At Cmd blk m r -> (Resp blk Int Int, DBModel blk)
step Model blk m Symbolic
model At Cmd blk m Symbolic
cmd

precondition :: forall m blk. TestConstraints blk
             => Model blk m Symbolic -> At Cmd blk m Symbolic -> Logic
precondition :: forall (m :: * -> *) blk.
TestConstraints blk =>
Model blk m Symbolic -> At Cmd blk m Symbolic -> Logic
precondition Model {KnownFollowers blk m Symbolic
KnownIters blk m Symbolic
Opaque (TopLevelConfig blk)
DBModel blk
dbModel :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
knownIters :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownIters blk m r
knownFollowers :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownFollowers blk m r
modelConfig :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> Opaque (TopLevelConfig blk)
dbModel :: DBModel blk
knownIters :: KnownIters blk m Symbolic
knownFollowers :: KnownFollowers blk m Symbolic
modelConfig :: Opaque (TopLevelConfig blk)
..} (At Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
cmd) =
   [Reference
   (Opaque
      (WithEq
         (Iterator
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
   Symbolic]
-> (Reference
      (Opaque
         (WithEq
            (Iterator
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
      Symbolic
    -> Logic)
-> Logic
forall a. Show a => [a] -> (a -> Logic) -> Logic
forAll (Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
-> [Reference
      (Opaque
         (WithEq
            (Iterator
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
      Symbolic]
forall (t :: MapKind) it flr. Bitraversable t => t it flr -> [it]
iters Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
cmd) (Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
-> [Reference
      (Opaque
         (WithEq
            (Iterator
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
      Symbolic]
-> Logic
forall (t :: * -> *) a.
(Foldable t, Eq a, Show a, Show (t a)) =>
a -> t a -> Logic
`member` KnownIters blk m Symbolic
-> [Reference
      (Opaque
         (WithEq
            (Iterator
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
      Symbolic]
forall k a (r :: * -> *). RefEnv k a r -> [Reference k r]
RE.keys KnownIters blk m Symbolic
knownIters)   Logic -> Logic -> Logic
.&&
   [Reference
   (Opaque
      (WithEq
         (Follower
            m
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk))))
   Symbolic]
-> (Reference
      (Opaque
         (WithEq
            (Follower
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
      Symbolic
    -> Logic)
-> Logic
forall a. Show a => [a] -> (a -> Logic) -> Logic
forAll (Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
-> [Reference
      (Opaque
         (WithEq
            (Follower
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
      Symbolic]
forall (t :: MapKind) it flr. Bitraversable t => t it flr -> [flr]
flrs  Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
cmd) (Reference
  (Opaque
     (WithEq
        (Follower
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
-> [Reference
      (Opaque
         (WithEq
            (Follower
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
      Symbolic]
-> Logic
forall (t :: * -> *) a.
(Foldable t, Eq a, Show a, Show (t a)) =>
a -> t a -> Logic
`member` KnownFollowers blk m Symbolic
-> [Reference
      (Opaque
         (WithEq
            (Follower
               m
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
      Symbolic]
forall k a (r :: * -> *). RefEnv k a r -> [Reference k r]
RE.keys KnownFollowers blk m Symbolic
knownFollowers) Logic -> Logic -> Logic
.&&
   case Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
cmd of
     -- Even though we ensure this in the generator, shrinking might change
     -- it.
     GetBlockComponent     RealPoint blk
pt -> Logic -> Logic
Not (Logic -> Logic) -> Logic -> Logic
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> Logic
garbageCollectable RealPoint blk
pt
     GetGCedBlockComponent RealPoint blk
pt -> RealPoint blk -> Logic
garbageCollectable RealPoint blk
pt
     IteratorNext     Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
it      -> Logic -> Logic
Not (Logic -> Logic) -> Logic -> Logic
forall a b. (a -> b) -> a -> b
$ Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
-> Logic
garbageCollectableIteratorNext Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
it
     IteratorNextGCed Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
it      -> Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
-> Logic
garbageCollectableIteratorNext Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
it

     -- TODO The real implementation allows streaming blocks from the
     -- VolatileDB that have no path to the current chain. The model
     -- implementation disallows this, as it only allows streaming from one of
     -- the possible forks, each starting at genesis. Temporarily only test
     -- with iterators that the model allows. So we only test a subset of the
     -- functionality, which does not include error paths.
     Stream StreamFrom blk
from StreamTo blk
to           -> StreamFrom blk -> StreamTo blk -> Logic
isValidIterator StreamFrom blk
from StreamTo blk
to
     Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
Reopen                   -> Logic -> Logic
Not (Logic -> Logic) -> Logic -> Logic
forall a b. (a -> b) -> a -> b
$ Bool -> Logic
Boolean (DBModel blk -> Bool
forall blk. Model blk -> Bool
Model.isOpen DBModel blk
dbModel)
     Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
WipeVolatileDB           -> Bool -> Logic
Boolean (Bool -> Logic) -> Bool -> Logic
forall a b. (a -> b) -> a -> b
$ DBModel blk -> Bool
forall blk. Model blk -> Bool
Model.isOpen DBModel blk
dbModel
     Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic)
_                        -> Logic
Top
  where
    garbageCollectable :: RealPoint blk -> Logic
    garbageCollectable :: RealPoint blk -> Logic
garbageCollectable =
      Bool -> Logic
Boolean (Bool -> Logic)
-> (RealPoint blk -> Bool) -> RealPoint blk -> Logic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> DBModel blk -> RealPoint blk -> Bool
forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> RealPoint blk -> Bool
Model.garbageCollectablePoint SecurityParam
secParam DBModel blk
dbModel

    garbageCollectableIteratorNext :: IterRef blk m Symbolic -> Logic
    garbageCollectableIteratorNext :: Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
-> Logic
garbageCollectableIteratorNext Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
it = Bool -> Logic
Boolean (Bool -> Logic) -> Bool -> Logic
forall a b. (a -> b) -> a -> b
$
      SecurityParam -> DBModel blk -> Int -> Bool
forall blk.
ModelSupportsBlock blk =>
SecurityParam -> Model blk -> Int -> Bool
Model.garbageCollectableIteratorNext SecurityParam
secParam DBModel blk
dbModel (KnownIters blk m Symbolic
knownIters KnownIters blk m Symbolic
-> Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     Symbolic
-> Int
forall k (r :: * -> *) a.
(Eq k, Eq1 r) =>
RefEnv k a r -> Reference k r -> a
RE.! Reference
  (Opaque
     (WithEq
        (Iterator
           m
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk))))
  Symbolic
it)

    cfg :: TopLevelConfig blk
    cfg :: TopLevelConfig blk
cfg = Opaque (TopLevelConfig blk) -> TopLevelConfig blk
forall a. Opaque a -> a
unOpaque Opaque (TopLevelConfig blk)
modelConfig

    secParam :: SecurityParam
    secParam :: SecurityParam
secParam = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg

    -- TODO #871
    isValidIterator :: StreamFrom blk -> StreamTo blk -> Logic
    isValidIterator :: StreamFrom blk -> StreamTo blk -> Logic
isValidIterator StreamFrom blk
from StreamTo blk
to =
        case SecurityParam
-> StreamFrom blk
-> StreamTo blk
-> DBModel blk
-> Either (UnknownRange blk) [blk]
forall blk.
GetPrevHash blk =>
SecurityParam
-> StreamFrom blk
-> StreamTo blk
-> Model blk
-> Either (UnknownRange blk) [blk]
Model.between SecurityParam
secParam StreamFrom blk
from StreamTo blk
to DBModel blk
dbModel of
          Left  UnknownRange blk
_    -> Logic
Bot
          -- All blocks must be valid
          Right [blk]
blks -> [blk] -> (blk -> Logic) -> Logic
forall a. Show a => [a] -> (a -> Logic) -> Logic
forAll [blk]
blks ((blk -> Logic) -> Logic) -> (blk -> Logic) -> Logic
forall a b. (a -> b) -> a -> b
$ \blk
blk -> Bool -> Logic
Boolean (Bool -> Logic) -> Bool -> Logic
forall a b. (a -> b) -> a -> b
$
            HeaderHash blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk) (Map (HeaderHash blk) (ExtValidationError blk, SlotNo) -> Bool)
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo) -> Bool
forall a b. (a -> b) -> a -> b
$ DBModel blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
forall blk. Model blk -> InvalidBlocks blk
Model.invalid DBModel blk
dbModel

transition :: (TestConstraints blk, Show1 r, Eq1 r)
           => Model   blk m r
           -> At Cmd  blk m r
           -> At Resp blk m r
           -> Model   blk m r
transition :: forall blk (r :: * -> *) (m :: * -> *).
(TestConstraints blk, Show1 r, Eq1 r) =>
Model blk m r -> At Cmd blk m r -> At Resp blk m r -> Model blk m r
transition Model blk m r
model At Cmd blk m r
cmd = Event blk m r -> Model blk m r
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Model blk m r
eventAfter (Event blk m r -> Model blk m r)
-> (At Resp blk m r -> Event blk m r)
-> At Resp blk m r
-> Model blk m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk m r -> At Cmd blk m r -> At Resp blk m r -> Event blk m r
forall blk (r :: * -> *) (m :: * -> *).
(TestConstraints blk, Eq1 r, Show1 r) =>
Model blk m r -> At Cmd blk m r -> At Resp blk m r -> Event blk m r
lockstep Model blk m r
model At Cmd blk m r
cmd

invariant ::
     forall m blk. TestConstraints blk
  => TopLevelConfig blk
  -> Model blk m Concrete
  -> Logic
invariant :: forall (m :: * -> *) blk.
TestConstraints blk =>
TopLevelConfig blk -> Model blk m Concrete -> Logic
invariant TopLevelConfig blk
cfg Model {KnownFollowers blk m Concrete
KnownIters blk m Concrete
Opaque (TopLevelConfig blk)
DBModel blk
dbModel :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
knownIters :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownIters blk m r
knownFollowers :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownFollowers blk m r
modelConfig :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> Opaque (TopLevelConfig blk)
dbModel :: DBModel blk
knownIters :: KnownIters blk m Concrete
knownFollowers :: KnownFollowers blk m Concrete
modelConfig :: Opaque (TopLevelConfig blk)
..} =
    [RealPoint blk] -> (RealPoint blk -> Logic) -> Logic
forall a. Show a => [a] -> (a -> Logic) -> Logic
forAll [RealPoint blk]
ptsOnCurChain (Bool -> Logic
Boolean (Bool -> Logic)
-> (RealPoint blk -> Bool) -> RealPoint blk -> Logic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool)
-> (RealPoint blk -> Maybe Bool) -> RealPoint blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBModel blk -> RealPoint blk -> Maybe Bool
forall blk.
LedgerSupportsProtocol blk =>
Model blk -> RealPoint blk -> Maybe Bool
Model.getIsValid DBModel blk
dbModel) Logic -> Logic -> Logic
.&&
    Logic
loeHasImmutableAnchor
  where
    -- | The blocks occurring on the current volatile chain fragment
    ptsOnCurChain :: [RealPoint blk]
    ptsOnCurChain :: [RealPoint blk]
ptsOnCurChain =
          (blk -> RealPoint blk) -> [blk] -> [RealPoint blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint
        ([blk] -> [RealPoint blk])
-> (DBModel blk -> [blk]) -> DBModel blk -> [RealPoint blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst
        (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> [blk])
-> (DBModel blk
    -> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> DBModel blk
-> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam
-> (blk -> blk)
-> DBModel blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall a blk.
(HasHeader a, HasHeader blk) =>
SecurityParam -> (blk -> a) -> Model blk -> AnchoredFragment a
Model.volatileChain (TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg) blk -> blk
forall a. a -> a
id
        (DBModel blk -> [RealPoint blk]) -> DBModel blk -> [RealPoint blk]
forall a b. (a -> b) -> a -> b
$ DBModel blk
dbModel

    loeHasImmutableAnchor :: Logic
    loeHasImmutableAnchor :: Logic
loeHasImmutableAnchor = case DBModel blk
-> LoE (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
forall blk. Model blk -> LoE (AnchoredFragment blk)
Model.getLoEFragment DBModel blk
dbModel of
        LoEEnabled AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
frag ->
          Bool -> Logic
Boolean (Bool -> Logic) -> Bool -> Logic
forall a b. (a -> b) -> a -> b
$ Point blk -> Chain blk -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
Chain.pointOnChain (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Point blk
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
frag) Chain blk
immChain
        LoE (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
LoEDisabled     -> Logic
Top
      where
        immChain :: Chain blk
immChain = SecurityParam -> DBModel blk -> Chain blk
forall blk. SecurityParam -> Model blk -> Chain blk
Model.immutableChain (TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg) DBModel blk
dbModel

postcondition :: TestConstraints blk
              => Model   blk m Concrete
              -> At Cmd  blk m Concrete
              -> At Resp blk m Concrete
              -> Logic
postcondition :: forall blk (m :: * -> *).
TestConstraints blk =>
Model blk m Concrete
-> At Cmd blk m Concrete -> At Resp blk m Concrete -> Logic
postcondition Model blk m Concrete
model At Cmd blk m Concrete
cmd At Resp blk m Concrete
resp =
    (Model blk m Concrete -> At Resp blk m Concrete -> Resp blk Int Int
forall (t :: * -> MapKind) blk (r :: * -> *) (m :: * -> *).
(Bifunctor (t blk), Eq1 r) =>
Model blk m r -> At t blk m r -> t blk Int Int
toMock (Event blk m Concrete -> Model blk m Concrete
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Model blk m r
eventAfter Event blk m Concrete
ev) At Resp blk m Concrete
resp Resp blk Int Int -> Resp blk Int Int -> Logic
forall a. (Eq a, Show a) => a -> a -> Logic
.== Event blk m Concrete -> Resp blk Int Int
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Resp blk Int Int
eventMockResp Event blk m Concrete
ev)
    Logic -> String -> Logic
.// String
"real response didn't match model response"
  where
    ev :: Event blk m Concrete
ev = Model blk m Concrete
-> At Cmd blk m Concrete
-> At Resp blk m Concrete
-> Event blk m Concrete
forall blk (r :: * -> *) (m :: * -> *).
(TestConstraints blk, Eq1 r, Show1 r) =>
Model blk m r -> At Cmd blk m r -> At Resp blk m r -> Event blk m r
lockstep Model blk m Concrete
model At Cmd blk m Concrete
cmd At Resp blk m Concrete
resp

semantics :: forall blk. TestConstraints blk
          => TopLevelConfig blk
          -> ChainDBEnv IO blk
          -> At Cmd blk IO Concrete
          -> IO (At Resp blk IO Concrete)
semantics :: forall blk.
TestConstraints blk =>
TopLevelConfig blk
-> ChainDBEnv IO blk
-> At Cmd blk IO Concrete
-> IO (At Resp blk IO Concrete)
semantics TopLevelConfig blk
cfg ChainDBEnv IO blk
env (At Cmd blk (IterRef blk IO Concrete) (FollowerRef blk IO Concrete)
cmd) =
    Resp blk (IterRef blk IO Concrete) (FollowerRef blk IO Concrete)
-> At Resp blk IO Concrete
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
t blk (IterRef blk m r) (FollowerRef blk m r) -> At t blk m r
At (Resp blk (IterRef blk IO Concrete) (FollowerRef blk IO Concrete)
 -> At Resp blk IO Concrete)
-> (Resp
      blk
      (WithEq
         (Iterator
            IO
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
      (WithEq
         (Follower
            IO
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
    -> Resp
         blk (IterRef blk IO Concrete) (FollowerRef blk IO Concrete))
-> Resp
     blk
     (WithEq
        (Iterator
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
-> At Resp blk IO Concrete
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((WithEq
   (Iterator
      IO
      blk
      (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
       SlotNo, IsEBB, SizeInBytes, Word16,
       SomeSecond (NestedCtxt Header) blk))
 -> IterRef blk IO Concrete)
-> (WithEq
      (Follower
         IO
         blk
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
    -> FollowerRef blk IO Concrete)
-> Resp
     blk
     (WithEq
        (Iterator
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
-> Resp blk (IterRef blk IO Concrete) (FollowerRef blk IO Concrete)
forall a b c d.
(a -> b) -> (c -> d) -> Resp blk a c -> Resp blk b d
forall (p :: MapKind) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Opaque
  (WithEq
     (Iterator
        IO
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> IterRef blk IO Concrete
forall a. Typeable a => a -> Reference a Concrete
QSM.reference (Opaque
   (WithEq
      (Iterator
         IO
         blk
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)))
 -> IterRef blk IO Concrete)
-> (WithEq
      (Iterator
         IO
         blk
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
    -> Opaque
         (WithEq
            (Iterator
               IO
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
-> WithEq
     (Iterator
        IO
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
-> IterRef blk IO Concrete
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithEq
  (Iterator
     IO
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> Opaque
     (WithEq
        (Iterator
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall a. a -> Opaque a
QSM.Opaque) (Opaque
  (WithEq
     (Follower
        IO
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk)))
-> FollowerRef blk IO Concrete
forall a. Typeable a => a -> Reference a Concrete
QSM.reference (Opaque
   (WithEq
      (Follower
         IO
         blk
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)))
 -> FollowerRef blk IO Concrete)
-> (WithEq
      (Follower
         IO
         blk
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk))
    -> Opaque
         (WithEq
            (Follower
               IO
               blk
               (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
                SlotNo, IsEBB, SizeInBytes, Word16,
                SomeSecond (NestedCtxt Header) blk))))
-> WithEq
     (Follower
        IO
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
-> FollowerRef blk IO Concrete
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithEq
  (Follower
     IO
     blk
     (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
      SlotNo, IsEBB, SizeInBytes, Word16,
      SomeSecond (NestedCtxt Header) blk))
-> Opaque
     (WithEq
        (Follower
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall a. a -> Opaque a
QSM.Opaque)) (Resp
   blk
   (WithEq
      (Iterator
         IO
         blk
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)))
   (WithEq
      (Follower
         IO
         blk
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)))
 -> At Resp blk IO Concrete)
-> IO
     (Resp
        blk
        (WithEq
           (Iterator
              IO
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              IO
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
-> IO (At Resp blk IO Concrete)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    TopLevelConfig blk
-> ChainDBEnv IO blk
-> Cmd
     blk
     (WithEq
        (Iterator
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
-> IO
     (Resp
        blk
        (WithEq
           (Iterator
              IO
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk)))
        (WithEq
           (Follower
              IO
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
forall blk.
TestConstraints blk =>
TopLevelConfig blk
-> ChainDBEnv IO blk
-> Cmd blk (TestIterator IO blk) (TestFollower IO blk)
-> IO (Resp blk (TestIterator IO blk) (TestFollower IO blk))
runIO TopLevelConfig blk
cfg ChainDBEnv IO blk
env ((IterRef blk IO Concrete
 -> WithEq
      (Iterator
         IO
         blk
         (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
          SlotNo, IsEBB, SizeInBytes, Word16,
          SomeSecond (NestedCtxt Header) blk)))
-> (FollowerRef blk IO Concrete
    -> WithEq
         (Follower
            IO
            blk
            (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
             SlotNo, IsEBB, SizeInBytes, Word16,
             SomeSecond (NestedCtxt Header) blk)))
-> Cmd blk (IterRef blk IO Concrete) (FollowerRef blk IO Concrete)
-> Cmd
     blk
     (WithEq
        (Iterator
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
     (WithEq
        (Follower
           IO
           blk
           (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
            SlotNo, IsEBB, SizeInBytes, Word16,
            SomeSecond (NestedCtxt Header) blk)))
forall a b c d. (a -> b) -> (c -> d) -> Cmd blk a c -> Cmd blk b d
forall (p :: MapKind) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap IterRef blk IO Concrete
-> WithEq
     (Iterator
        IO
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall a. Reference (Opaque a) Concrete -> a
QSM.opaque FollowerRef blk IO Concrete
-> WithEq
     (Follower
        IO
        blk
        (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
         SlotNo, IsEBB, SizeInBytes, Word16,
         SomeSecond (NestedCtxt Header) blk))
forall a. Reference (Opaque a) Concrete -> a
QSM.opaque Cmd blk (IterRef blk IO Concrete) (FollowerRef blk IO Concrete)
cmd)

-- | The state machine proper
sm :: TestConstraints blk
   => LoE ()
   -> ChainDBEnv IO blk
   -> BlockGen                  blk IO
   -> TopLevelConfig            blk
   -> ExtLedgerState            blk EmptyMK
   -> StateMachine (Model       blk IO)
                   (At Cmd      blk IO)
                                    IO
                   (At Resp     blk IO)
sm :: forall blk.
TestConstraints blk =>
LoE ()
-> ChainDBEnv IO blk
-> BlockGen blk IO
-> TopLevelConfig blk
-> ExtLedgerState blk EmptyMK
-> StateMachine (Model blk IO) (At Cmd blk IO) IO (At Resp blk IO)
sm LoE ()
loe ChainDBEnv IO blk
env BlockGen blk IO
genBlock TopLevelConfig blk
cfg ExtLedgerState blk EmptyMK
initLedger = StateMachine
  { initModel :: forall (r :: * -> *). Model blk IO r
initModel     = LoE ()
-> TopLevelConfig blk
-> ExtLedgerState blk EmptyMK
-> Model blk IO r
forall blk (m :: * -> *) (r :: * -> *).
HasHeader blk =>
LoE ()
-> TopLevelConfig blk
-> ExtLedgerState blk EmptyMK
-> Model blk m r
initModel LoE ()
loe TopLevelConfig blk
cfg ExtLedgerState blk EmptyMK
initLedger
  , transition :: forall (r :: * -> *).
(Show1 r, Ord1 r) =>
Model blk IO r
-> At Cmd blk IO r -> At Resp blk IO r -> Model blk IO r
transition    = Model blk IO r
-> At Cmd blk IO r -> At Resp blk IO r -> Model blk IO r
forall blk (r :: * -> *) (m :: * -> *).
(TestConstraints blk, Show1 r, Eq1 r) =>
Model blk m r -> At Cmd blk m r -> At Resp blk m r -> Model blk m r
forall (r :: * -> *).
(Show1 r, Ord1 r) =>
Model blk IO r
-> At Cmd blk IO r -> At Resp blk IO r -> Model blk IO r
transition
  , precondition :: Model blk IO Symbolic -> At Cmd blk IO Symbolic -> Logic
precondition  = Model blk IO Symbolic -> At Cmd blk IO Symbolic -> Logic
forall (m :: * -> *) blk.
TestConstraints blk =>
Model blk m Symbolic -> At Cmd blk m Symbolic -> Logic
precondition
  , postcondition :: Model blk IO Concrete
-> At Cmd blk IO Concrete -> At Resp blk IO Concrete -> Logic
postcondition = Model blk IO Concrete
-> At Cmd blk IO Concrete -> At Resp blk IO Concrete -> Logic
forall blk (m :: * -> *).
TestConstraints blk =>
Model blk m Concrete
-> At Cmd blk m Concrete -> At Resp blk m Concrete -> Logic
postcondition
  , generator :: Model blk IO Symbolic -> Maybe (Gen (At Cmd blk IO Symbolic))
generator     = Gen (At Cmd blk IO Symbolic)
-> Maybe (Gen (At Cmd blk IO Symbolic))
forall a. a -> Maybe a
Just (Gen (At Cmd blk IO Symbolic)
 -> Maybe (Gen (At Cmd blk IO Symbolic)))
-> (Model blk IO Symbolic -> Gen (At Cmd blk IO Symbolic))
-> Model blk IO Symbolic
-> Maybe (Gen (At Cmd blk IO Symbolic))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoE ()
-> BlockGen blk IO
-> Model blk IO Symbolic
-> Gen (At Cmd blk IO Symbolic)
forall blk (m :: * -> *).
TestConstraints blk =>
LoE ()
-> BlockGen blk m
-> Model blk m Symbolic
-> Gen (At Cmd blk m Symbolic)
generator LoE ()
loe BlockGen blk IO
genBlock
  , shrinker :: Model blk IO Symbolic
-> At Cmd blk IO Symbolic -> [At Cmd blk IO Symbolic]
shrinker      = Model blk IO Symbolic
-> At Cmd blk IO Symbolic -> [At Cmd blk IO Symbolic]
forall blk (m :: * -> *).
Model blk m Symbolic
-> At Cmd blk m Symbolic -> [At Cmd blk m Symbolic]
shrinker
  , semantics :: At Cmd blk IO Concrete -> IO (At Resp blk IO Concrete)
semantics     = TopLevelConfig blk
-> ChainDBEnv IO blk
-> At Cmd blk IO Concrete
-> IO (At Resp blk IO Concrete)
forall blk.
TestConstraints blk =>
TopLevelConfig blk
-> ChainDBEnv IO blk
-> At Cmd blk IO Concrete
-> IO (At Resp blk IO Concrete)
semantics TopLevelConfig blk
cfg ChainDBEnv IO blk
env
  , mock :: Model blk IO Symbolic
-> At Cmd blk IO Symbolic -> GenSym (At Resp blk IO Symbolic)
mock          = Model blk IO Symbolic
-> At Cmd blk IO Symbolic -> GenSym (At Resp blk IO Symbolic)
forall blk (m :: * -> *).
(TestConstraints blk, Typeable m) =>
Model blk m Symbolic
-> At Cmd blk m Symbolic -> GenSym (At Resp blk m Symbolic)
mock
  , invariant :: Maybe (Model blk IO Concrete -> Logic)
invariant     = (Model blk IO Concrete -> Logic)
-> Maybe (Model blk IO Concrete -> Logic)
forall a. a -> Maybe a
Just ((Model blk IO Concrete -> Logic)
 -> Maybe (Model blk IO Concrete -> Logic))
-> (Model blk IO Concrete -> Logic)
-> Maybe (Model blk IO Concrete -> Logic)
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk -> Model blk IO Concrete -> Logic
forall (m :: * -> *) blk.
TestConstraints blk =>
TopLevelConfig blk -> Model blk m Concrete -> Logic
invariant TopLevelConfig blk
cfg
  , cleanup :: Model blk IO Concrete -> IO ()
cleanup       = Model blk IO Concrete -> IO ()
forall (m :: * -> *) (model :: (* -> *) -> *).
Monad m =>
model Concrete -> m ()
noCleanup
  }

{-------------------------------------------------------------------------------
  Required instances

  The 'ToExpr' constraints come from "Data.TreeDiff".
-------------------------------------------------------------------------------}

instance CommandNames (At Cmd blk m) where
  cmdName :: forall (r :: * -> *). At Cmd blk m r -> String
cmdName (At Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     r)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     r)
cmd) = Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     r)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     r)
-> String
forall a. HasDatatypeInfo a => a -> String
constrName Cmd
  blk
  (Reference
     (Opaque
        (WithEq
           (Iterator
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     r)
  (Reference
     (Opaque
        (WithEq
           (Follower
              m
              blk
              (blk, blk, Header blk, ByteString, ByteString, HeaderHash blk,
               SlotNo, IsEBB, SizeInBytes, Word16,
               SomeSecond (NestedCtxt Header) blk))))
     r)
cmd
  cmdNames :: forall (r :: * -> *). Proxy (At Cmd blk m r) -> Context
cmdNames (Proxy (At Cmd blk m r)
_ :: Proxy (At Cmd blk m r)) =
    Proxy (Cmd blk () ()) -> Context
forall a (proxy :: * -> *). HasDatatypeInfo a => proxy a -> Context
constrNames (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Cmd blk () ()))

deriving instance ( ToExpr blk
                  , ToExpr (HeaderHash  blk)
                  , ToExpr (ChainDepState (BlockProtocol blk))
                  , ToExpr (TipInfo blk)
                  , ToExpr (LedgerState blk EmptyMK)
                  , ToExpr (ExtValidationError blk)
                  )
                 => ToExpr (Model blk IO Concrete)
{-------------------------------------------------------------------------------
  Labelling
-------------------------------------------------------------------------------}

deriving instance SOP.Generic         (TraceEvent blk)
deriving instance SOP.HasDatatypeInfo (TraceEvent blk)
deriving instance SOP.Generic         (TraceAddBlockEvent blk)
deriving instance SOP.HasDatatypeInfo (TraceAddBlockEvent blk)
deriving instance SOP.Generic         (ChainDB.TraceFollowerEvent blk)
deriving instance SOP.HasDatatypeInfo (ChainDB.TraceFollowerEvent blk)
deriving instance SOP.Generic         (TraceCopyToImmutableDBEvent blk)
deriving instance SOP.HasDatatypeInfo (TraceCopyToImmutableDBEvent blk)
deriving instance SOP.Generic         (TraceValidationEvent blk)
deriving instance SOP.HasDatatypeInfo (TraceValidationEvent blk)
deriving instance SOP.Generic         (TraceInitChainSelEvent blk)
deriving instance SOP.HasDatatypeInfo (TraceInitChainSelEvent blk)
deriving instance SOP.Generic         (TraceOpenEvent blk)
deriving instance SOP.HasDatatypeInfo (TraceOpenEvent blk)
deriving instance SOP.Generic         (TraceGCEvent blk)
deriving instance SOP.HasDatatypeInfo (TraceGCEvent blk)
deriving instance SOP.Generic         (TraceIteratorEvent blk)
deriving instance SOP.HasDatatypeInfo (TraceIteratorEvent blk)
deriving instance SOP.Generic         (LedgerDB.TraceEvent blk)
deriving instance SOP.HasDatatypeInfo (LedgerDB.TraceEvent blk)
deriving instance SOP.Generic         (ImmutableDB.TraceEvent blk)
deriving instance SOP.HasDatatypeInfo (ImmutableDB.TraceEvent blk)
deriving instance SOP.Generic         (VolatileDB.TraceEvent blk)
deriving instance SOP.HasDatatypeInfo (VolatileDB.TraceEvent blk)
deriving anyclass instance SOP.Generic         (TraceChainSelStarvationEvent blk)
deriving anyclass instance SOP.HasDatatypeInfo (TraceChainSelStarvationEvent blk)

data Tag =
    TagGetIsValidJust
  | TagGetIsValidNothing
  | TagChainSelReprocessChangedSelection
  | TagChainSelReprocessKeptSelection
  deriving (Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
(Int -> Tag -> ShowS)
-> (Tag -> String) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tag -> ShowS
showsPrec :: Int -> Tag -> ShowS
$cshow :: Tag -> String
show :: Tag -> String
$cshowList :: [Tag] -> ShowS
showList :: [Tag] -> ShowS
Show, Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
/= :: Tag -> Tag -> Bool
Eq)

-- | Predicate on events
type EventPred m = C.Predicate (Event Blk m Symbolic) Tag

-- | Convenience combinator for creating classifiers for successful commands
successful ::
     (    Event Blk m Symbolic
       -> Success Blk IteratorId FollowerId
       -> Either Tag (EventPred m)
     )
  -> EventPred m
successful :: forall (m :: * -> *).
(Event Blk m Symbolic
 -> Success Blk Int Int -> Either Tag (EventPred m))
-> EventPred m
successful Event Blk m Symbolic
-> Success Blk Int Int -> Either Tag (EventPred m)
f = (Event Blk m Symbolic -> Either Tag (EventPred m)) -> EventPred m
forall a b. (a -> Either b (Predicate a b)) -> Predicate a b
C.predicate ((Event Blk m Symbolic -> Either Tag (EventPred m)) -> EventPred m)
-> (Event Blk m Symbolic -> Either Tag (EventPred m))
-> EventPred m
forall a b. (a -> b) -> a -> b
$ \Event Blk m Symbolic
ev -> case Event Blk m Symbolic -> Resp Blk Int Int
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Resp blk Int Int
eventMockResp Event Blk m Symbolic
ev of
    Resp (Left  ChainDbError Blk
_ ) -> EventPred m -> Either Tag (EventPred m)
forall a b. b -> Either a b
Right (EventPred m -> Either Tag (EventPred m))
-> EventPred m -> Either Tag (EventPred m)
forall a b. (a -> b) -> a -> b
$ (Event Blk m Symbolic
 -> Success Blk Int Int -> Either Tag (EventPred m))
-> EventPred m
forall (m :: * -> *).
(Event Blk m Symbolic
 -> Success Blk Int Int -> Either Tag (EventPred m))
-> EventPred m
successful Event Blk m Symbolic
-> Success Blk Int Int -> Either Tag (EventPred m)
f
    Resp (Right Success Blk Int Int
ok) -> Event Blk m Symbolic
-> Success Blk Int Int -> Either Tag (EventPred m)
f Event Blk m Symbolic
ev Success Blk Int Int
ok

-- | Tag commands
--
-- Tagging works on symbolic events, so that we can tag without doing real IO.
tag :: forall m. [Event Blk m Symbolic] -> [Tag]
tag :: forall (m :: * -> *). [Event Blk m Symbolic] -> [Tag]
tag = [Predicate (Event Blk m Symbolic) Tag]
-> [Event Blk m Symbolic] -> [Tag]
forall a b. [Predicate a b] -> [a] -> [b]
C.classify [
      Predicate (Event Blk m Symbolic) Tag
tagGetIsValidJust
    , Predicate (Event Blk m Symbolic) Tag
tagGetIsValidNothing
    , Tag
-> (Point Blk -> Point Blk -> Bool)
-> Predicate (Event Blk m Symbolic) Tag
tagChainSelReprocess Tag
TagChainSelReprocessChangedSelection Point Blk -> Point Blk -> Bool
forall a. Eq a => a -> a -> Bool
(/=)
    , Tag
-> (Point Blk -> Point Blk -> Bool)
-> Predicate (Event Blk m Symbolic) Tag
tagChainSelReprocess Tag
TagChainSelReprocessKeptSelection    Point Blk -> Point Blk -> Bool
forall a. Eq a => a -> a -> Bool
(==)
    ]
  where
    tagGetIsValidJust :: EventPred m
    tagGetIsValidJust :: Predicate (Event Blk m Symbolic) Tag
tagGetIsValidJust = (Event Blk m Symbolic
 -> Success Blk Int Int
 -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
-> Predicate (Event Blk m Symbolic) Tag
forall (m :: * -> *).
(Event Blk m Symbolic
 -> Success Blk Int Int -> Either Tag (EventPred m))
-> EventPred m
successful ((Event Blk m Symbolic
  -> Success Blk Int Int
  -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
 -> Predicate (Event Blk m Symbolic) Tag)
-> (Event Blk m Symbolic
    -> Success Blk Int Int
    -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
-> Predicate (Event Blk m Symbolic) Tag
forall a b. (a -> b) -> a -> b
$ \Event Blk m Symbolic
ev Success Blk Int Int
r -> case Success Blk Int Int
r of
      IsValid (IsValidResult { isValid :: IsValidResult -> Maybe Bool
isValid = Just Bool
_ }) | GetIsValid {} <- At Cmd Blk m Symbolic
-> Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic)
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
At t blk m r -> t blk (IterRef blk m r) (FollowerRef blk m r)
unAt (At Cmd Blk m Symbolic
 -> Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic))
-> At Cmd Blk m Symbolic
-> Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic)
forall a b. (a -> b) -> a -> b
$ Event Blk m Symbolic -> At Cmd Blk m Symbolic
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> At Cmd blk m r
eventCmd Event Blk m Symbolic
ev ->
        Tag -> Either Tag (Predicate (Event Blk m Symbolic) Tag)
forall a b. a -> Either a b
Left Tag
TagGetIsValidJust
      Success Blk Int Int
_ -> Predicate (Event Blk m Symbolic) Tag
-> Either Tag (Predicate (Event Blk m Symbolic) Tag)
forall a b. b -> Either a b
Right Predicate (Event Blk m Symbolic) Tag
tagGetIsValidJust

    tagGetIsValidNothing :: EventPred m
    tagGetIsValidNothing :: Predicate (Event Blk m Symbolic) Tag
tagGetIsValidNothing = (Event Blk m Symbolic
 -> Success Blk Int Int
 -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
-> Predicate (Event Blk m Symbolic) Tag
forall (m :: * -> *).
(Event Blk m Symbolic
 -> Success Blk Int Int -> Either Tag (EventPred m))
-> EventPred m
successful ((Event Blk m Symbolic
  -> Success Blk Int Int
  -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
 -> Predicate (Event Blk m Symbolic) Tag)
-> (Event Blk m Symbolic
    -> Success Blk Int Int
    -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
-> Predicate (Event Blk m Symbolic) Tag
forall a b. (a -> b) -> a -> b
$ \Event Blk m Symbolic
ev Success Blk Int Int
r -> case Success Blk Int Int
r of
      IsValid (IsValidResult { isValid :: IsValidResult -> Maybe Bool
isValid = Maybe Bool
Nothing }) | GetIsValid {} <- At Cmd Blk m Symbolic
-> Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic)
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
At t blk m r -> t blk (IterRef blk m r) (FollowerRef blk m r)
unAt (At Cmd Blk m Symbolic
 -> Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic))
-> At Cmd Blk m Symbolic
-> Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic)
forall a b. (a -> b) -> a -> b
$ Event Blk m Symbolic -> At Cmd Blk m Symbolic
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> At Cmd blk m r
eventCmd Event Blk m Symbolic
ev ->
        Tag -> Either Tag (Predicate (Event Blk m Symbolic) Tag)
forall a b. a -> Either a b
Left Tag
TagGetIsValidNothing
      Success Blk Int Int
_ -> Predicate (Event Blk m Symbolic) Tag
-> Either Tag (Predicate (Event Blk m Symbolic) Tag)
forall a b. b -> Either a b
Right Predicate (Event Blk m Symbolic) Tag
tagGetIsValidNothing

    tagChainSelReprocess ::
         Tag -> (Point TestBlock -> Point TestBlock -> Bool) -> EventPred m
    tagChainSelReprocess :: Tag
-> (Point Blk -> Point Blk -> Bool)
-> Predicate (Event Blk m Symbolic) Tag
tagChainSelReprocess Tag
t Point Blk -> Point Blk -> Bool
test = (Event Blk m Symbolic
 -> Success Blk Int Int
 -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
-> Predicate (Event Blk m Symbolic) Tag
forall (m :: * -> *).
(Event Blk m Symbolic
 -> Success Blk Int Int -> Either Tag (EventPred m))
-> EventPred m
successful ((Event Blk m Symbolic
  -> Success Blk Int Int
  -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
 -> Predicate (Event Blk m Symbolic) Tag)
-> (Event Blk m Symbolic
    -> Success Blk Int Int
    -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
-> Predicate (Event Blk m Symbolic) Tag
forall a b. (a -> b) -> a -> b
$ \Event Blk m Symbolic
ev Success Blk Int Int
_r -> case At Cmd Blk m Symbolic
-> Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic)
forall (t :: * -> MapKind) blk (m :: * -> *) (r :: * -> *).
At t blk m r -> t blk (IterRef blk m r) (FollowerRef blk m r)
unAt (At Cmd Blk m Symbolic
 -> Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic))
-> At Cmd Blk m Symbolic
-> Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic)
forall a b. (a -> b) -> a -> b
$ Event Blk m Symbolic -> At Cmd Blk m Symbolic
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> At Cmd blk m r
eventCmd Event Blk m Symbolic
ev of
      UpdateLoE{}
        | (Point Blk -> Point Blk -> Bool
test (Point Blk -> Point Blk -> Bool)
-> (Model Blk m Symbolic -> Point Blk)
-> Model Blk m Symbolic
-> Model Blk m Symbolic
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Model Blk -> Point Blk
forall blk. HasHeader blk => Model blk -> Point blk
Model.tipPoint (Model Blk -> Point Blk)
-> (Model Blk m Symbolic -> Model Blk)
-> Model Blk m Symbolic
-> Point Blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model Blk m Symbolic -> Model Blk
forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
dbModel) (Event Blk m Symbolic -> Model Blk m Symbolic
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Model blk m r
eventBefore Event Blk m Symbolic
ev) (Event Blk m Symbolic -> Model Blk m Symbolic
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Model blk m r
eventAfter Event Blk m Symbolic
ev)
        -> Tag -> Either Tag (Predicate (Event Blk m Symbolic) Tag)
forall a b. a -> Either a b
Left Tag
t
      Cmd Blk (IterRef Blk m Symbolic) (FollowerRef Blk m Symbolic)
_ -> Predicate (Event Blk m Symbolic) Tag
-> Either Tag (Predicate (Event Blk m Symbolic) Tag)
forall a b. b -> Either a b
Right (Predicate (Event Blk m Symbolic) Tag
 -> Either Tag (Predicate (Event Blk m Symbolic) Tag))
-> Predicate (Event Blk m Symbolic) Tag
-> Either Tag (Predicate (Event Blk m Symbolic) Tag)
forall a b. (a -> b) -> a -> b
$ Tag
-> (Point Blk -> Point Blk -> Bool)
-> Predicate (Event Blk m Symbolic) Tag
tagChainSelReprocess Tag
t Point Blk -> Point Blk -> Bool
test

-- | Step the model using a 'QSM.Command' (i.e., a command associated with
-- an explicit set of variables)
execCmd :: Model Blk m Symbolic
        -> QSM.Command (At Cmd Blk m) (At Resp Blk m)
        -> Event Blk m Symbolic
execCmd :: forall (m :: * -> *).
Model Blk m Symbolic
-> Command (At Cmd Blk m) (At Resp Blk m) -> Event Blk m Symbolic
execCmd Model Blk m Symbolic
model (QSM.Command At Cmd Blk m Symbolic
cmdErr At Resp Blk m Symbolic
resp [Var]
_vars) = Model Blk m Symbolic
-> At Cmd Blk m Symbolic
-> At Resp Blk m Symbolic
-> Event Blk m Symbolic
forall blk (r :: * -> *) (m :: * -> *).
(TestConstraints blk, Eq1 r, Show1 r) =>
Model blk m r -> At Cmd blk m r -> At Resp blk m r -> Event blk m r
lockstep Model Blk m Symbolic
model At Cmd Blk m Symbolic
cmdErr At Resp Blk m Symbolic
resp

-- | 'execCmds' is just the repeated form of 'execCmd'
execCmds :: forall m.
            Model Blk m Symbolic
         -> QSM.Commands (At Cmd Blk m) (At Resp Blk m) -> [Event Blk m Symbolic]
execCmds :: forall (m :: * -> *).
Model Blk m Symbolic
-> Commands (At Cmd Blk m) (At Resp Blk m)
-> [Event Blk m Symbolic]
execCmds Model Blk m Symbolic
model = \(QSM.Commands [Command (At Cmd Blk m) (At Resp Blk m)]
cs) -> Model Blk m Symbolic
-> [Command (At Cmd Blk m) (At Resp Blk m)]
-> [Event Blk m Symbolic]
go Model Blk m Symbolic
model [Command (At Cmd Blk m) (At Resp Blk m)]
cs
  where
    go :: Model Blk m Symbolic -> [QSM.Command (At Cmd Blk m) (At Resp Blk m)]
       -> [Event Blk m Symbolic]
    go :: Model Blk m Symbolic
-> [Command (At Cmd Blk m) (At Resp Blk m)]
-> [Event Blk m Symbolic]
go Model Blk m Symbolic
_ []       = []
    go Model Blk m Symbolic
m (Command (At Cmd Blk m) (At Resp Blk m)
c : [Command (At Cmd Blk m) (At Resp Blk m)]
cs) = let ev :: Event Blk m Symbolic
ev = Model Blk m Symbolic
-> Command (At Cmd Blk m) (At Resp Blk m) -> Event Blk m Symbolic
forall (m :: * -> *).
Model Blk m Symbolic
-> Command (At Cmd Blk m) (At Resp Blk m) -> Event Blk m Symbolic
execCmd Model Blk m Symbolic
m Command (At Cmd Blk m) (At Resp Blk m)
c in Event Blk m Symbolic
ev Event Blk m Symbolic
-> [Event Blk m Symbolic] -> [Event Blk m Symbolic]
forall a. a -> [a] -> [a]
: Model Blk m Symbolic
-> [Command (At Cmd Blk m) (At Resp Blk m)]
-> [Event Blk m Symbolic]
go (Event Blk m Symbolic -> Model Blk m Symbolic
forall blk (m :: * -> *) (r :: * -> *).
Event blk m r -> Model blk m r
eventAfter Event Blk m Symbolic
ev) [Command (At Cmd Blk m) (At Resp Blk m)]
cs

{-------------------------------------------------------------------------------
  Generator for TestBlock
-------------------------------------------------------------------------------}

type Blk = TestBlock

-- | Note that the 'Blk = TestBlock' is general enough to be used by both the
-- ChainDB /and/ the ImmutableDB, its generators cannot. For example, in the
-- ChainDB, blocks are added /out of order/, while in the ImmutableDB, they
-- must be added /in order/. This generator can thus not be reused for the
-- ImmutableDB.
genBlk :: ImmutableDB.ChunkInfo -> BlockGen Blk m
genBlk :: forall (m :: * -> *). ChunkInfo -> BlockGen Blk m
genBlk ChunkInfo
chunkInfo Model{KnownFollowers Blk m Symbolic
KnownIters Blk m Symbolic
Opaque (TopLevelConfig Blk)
Model Blk
dbModel :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
knownIters :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownIters blk m r
knownFollowers :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> KnownFollowers blk m r
modelConfig :: forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> Opaque (TopLevelConfig blk)
dbModel :: Model Blk
knownIters :: KnownIters Blk m Symbolic
knownFollowers :: KnownFollowers Blk m Symbolic
modelConfig :: Opaque (TopLevelConfig Blk)
..} = [(Int, Gen Blk)] -> Gen Blk
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (if Bool
empty then Int
0 else Int
1, Gen Blk
genAlreadyInChain)
    , (Int
5,                      Gen Blk
genAppendToCurrentChain)
    , (Int
5,                      Gen Blk
genFitsOnSomewhere)
    , (Int
3,                      Gen Blk
genGap)
    ]
  where
    blocksInChainDB :: Map (HeaderHash Blk) Blk
blocksInChainDB   = Model Blk -> Map (HeaderHash Blk) Blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
Model.blocks Model Blk
dbModel
    modelSupportsEBBs :: Bool
modelSupportsEBBs = ChunkInfo -> Bool
ImmutableDB.chunkInfoSupportsEBBs ChunkInfo
chunkInfo
    canContainEBB :: SlotNo -> Bool
canContainEBB     = Bool -> SlotNo -> Bool
forall a b. a -> b -> a
const Bool
modelSupportsEBBs -- TODO: we could be more precise

    empty :: Bool
    empty :: Bool
empty = Map TestHeaderHash Blk -> Bool
forall k a. Map k a -> Bool
Map.null Map (HeaderHash Blk) Blk
Map TestHeaderHash Blk
blocksInChainDB

    genBody :: Gen TestBody
    genBody :: Gen TestBody
genBody = do
      isValid <- [(Int, Gen Bool)] -> Gen Bool
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
4, Bool -> Gen Bool
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
        , (Int
1, Bool -> Gen Bool
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
        ]
      forkNo <- choose (1, 3)
      return TestBody
        { tbForkNo  = forkNo
        , tbIsValid = isValid
        }

    -- A block that already exists in the ChainDB
    genAlreadyInChain :: Gen TestBlock
    genAlreadyInChain :: Gen Blk
genAlreadyInChain = [Blk] -> Gen Blk
forall a. HasCallStack => [a] -> Gen a
elements ([Blk] -> Gen Blk) -> [Blk] -> Gen Blk
forall a b. (a -> b) -> a -> b
$ Map TestHeaderHash Blk -> [Blk]
forall k a. Map k a -> [a]
Map.elems Map (HeaderHash Blk) Blk
Map TestHeaderHash Blk
blocksInChainDB

    -- A block that fits onto the current chain
    genAppendToCurrentChain :: Gen TestBlock
    genAppendToCurrentChain :: Gen Blk
genAppendToCurrentChain = case Model Blk -> Maybe Blk
forall blk. Model blk -> Maybe blk
Model.tipBlock Model Blk
dbModel of
      Maybe Blk
Nothing -> Gen Blk
genFirstBlock
      Just Blk
b  -> Blk -> Gen Blk
genFitsOn Blk
b

    -- A block that fits onto some block @b@ in the ChainDB. The block @b@
    -- could be at the tip of the chain and the generated block might already
    -- be present in the ChainDB.
    genFitsOnSomewhere :: Gen TestBlock
    genFitsOnSomewhere :: Gen Blk
genFitsOnSomewhere = case Model Blk -> Maybe Blk
forall blk. Model blk -> Maybe blk
Model.tipBlock Model Blk
dbModel of
      Maybe Blk
Nothing -> Gen Blk
genFirstBlock
      Just Blk
_  -> Gen Blk
genAlreadyInChain Gen Blk -> (Blk -> Gen Blk) -> Gen Blk
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Blk -> Gen Blk
genFitsOn

    -- A block that doesn't fit onto a block in the ChainDB, but it creates a
    -- gap of a couple of blocks between genesis or an existing block in the
    -- ChainDB. We generate it by generating a few intermediary blocks first,
    -- which we don't add. But the chance exists that we will generate them
    -- again later on.
    genGap :: Gen TestBlock
    genGap :: Gen Blk
genGap = do
        gapSize <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
3)
        start   <- genFitsOnSomewhere
        go gapSize start
      where
        go :: Int -> TestBlock -> Gen TestBlock
        go :: Int -> Blk -> Gen Blk
go Int
0 Blk
b = Blk -> Gen Blk
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Blk
b
        go Int
n Blk
b = Blk -> Gen Blk
genFitsOn Blk
b Gen Blk -> (Blk -> Gen Blk) -> Gen Blk
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Blk -> Gen Blk
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

    -- Generate a block or EBB fitting on genesis
    genFirstBlock :: Gen TestBlock
    genFirstBlock :: Gen Blk
genFirstBlock = [(Int, Gen Blk)] -> Gen Blk
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ ( Int
1
        , SlotNo -> TestBody -> Blk
firstBlock (SlotNo -> TestBody -> Blk) -> Gen SlotNo -> Gen (TestBody -> Blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> SlotNo -> Gen SlotNo
chooseSlot SlotNo
0 SlotNo
2 Gen (TestBody -> Blk) -> Gen TestBody -> Gen Blk
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen TestBody
genBody
        )
      , ( if Bool
modelSupportsEBBs then Int
1 else Int
0
        , (SlotNo -> Bool) -> TestBody -> Blk
firstEBB SlotNo -> Bool
canContainEBB (TestBody -> Blk) -> Gen TestBody -> Gen Blk
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TestBody
genBody
        )
      ]

    -- Helper that generates a block that fits onto the given block.
    genFitsOn :: TestBlock -> Gen TestBlock
    genFitsOn :: Blk -> Gen Blk
genFitsOn Blk
b = [(Int, Gen Blk)] -> Gen Blk
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
4, do
                slotNo <- if IsEBB -> Bool
fromIsEBB (Blk -> IsEBB
testBlockIsEBB Blk
b)
                  then SlotNo -> SlotNo -> Gen SlotNo
chooseSlot (Blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Blk
b)     (Blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Blk
b SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
2)
                  else SlotNo -> SlotNo -> Gen SlotNo
chooseSlot (Blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Blk
b SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1) (Blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Blk
b SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
3)
                body   <- genBody
                return $ mkNextBlock b slotNo body)
        -- An EBB is never followed directly by another EBB, otherwise they
        -- would have the same 'BlockNo', as the EBB has the same 'BlockNo' of
        -- the block before it.
        , (if IsEBB -> Bool
fromIsEBB (Blk -> IsEBB
testBlockIsEBB Blk
b) Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
modelSupportsEBBs then Int
0 else Int
1, do
             let prevSlotNo :: SlotNo
prevSlotNo    = Blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Blk
b
                 prevChunk :: ChunkNo
prevChunk     = ChunkInfo -> SlotNo -> ChunkNo
ImmutableDB.chunkIndexOfSlot
                                   ChunkInfo
chunkInfo
                                   SlotNo
prevSlotNo
                 prevEpoch :: EpochNo
prevEpoch     = ChunkNo -> EpochNo
unsafeChunkNoToEpochNo ChunkNo
prevChunk
                 nextEBB :: ChunkSlot
nextEBB       = HasCallStack => ChunkInfo -> EpochNo -> ChunkSlot
ChunkInfo -> EpochNo -> ChunkSlot
ImmutableDB.chunkSlotForBoundaryBlock
                                   ChunkInfo
chunkInfo
                                   (EpochNo
prevEpoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1)
                 nextNextEBB :: ChunkSlot
nextNextEBB   = HasCallStack => ChunkInfo -> EpochNo -> ChunkSlot
ChunkInfo -> EpochNo -> ChunkSlot
ImmutableDB.chunkSlotForBoundaryBlock
                                   ChunkInfo
chunkInfo
                                   (EpochNo
prevEpoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
2)
             (slotNo, epoch) <-
               (ChunkSlot -> SlotNo) -> (ChunkSlot, EpochNo) -> (SlotNo, EpochNo)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: MapKind) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ChunkInfo -> ChunkSlot -> SlotNo
ImmutableDB.chunkSlotToSlot ChunkInfo
chunkInfo) ((ChunkSlot, EpochNo) -> (SlotNo, EpochNo))
-> Gen (ChunkSlot, EpochNo) -> Gen (SlotNo, EpochNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Gen (ChunkSlot, EpochNo))] -> Gen (ChunkSlot, EpochNo)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
                 [ (Int
7, (ChunkSlot, EpochNo) -> Gen (ChunkSlot, EpochNo)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChunkSlot
nextEBB, EpochNo
prevEpoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1))
                 , (Int
1, (ChunkSlot, EpochNo) -> Gen (ChunkSlot, EpochNo)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChunkSlot
nextNextEBB, EpochNo
prevEpoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
2))
                 ]
             body   <- genBody
             return $ mkNextEBB canContainEBB b slotNo epoch body
          )
        ]

{-------------------------------------------------------------------------------
  Top-level tests
-------------------------------------------------------------------------------}

mkTestCfg :: ImmutableDB.ChunkInfo -> TopLevelConfig TestBlock
mkTestCfg :: ChunkInfo -> TopLevelConfig Blk
mkTestCfg (ImmutableDB.UniformChunkSize ChunkSize
chunkSize) =
    SecurityParam -> ChunkSize -> TopLevelConfig Blk
mkTestConfig (NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> NonZero Word64 -> SecurityParam
forall a b. (a -> b) -> a -> b
$ forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @2) ChunkSize
chunkSize

envUnused :: ChainDBEnv m blk
envUnused :: forall (m :: * -> *) blk. ChainDBEnv m blk
envUnused = String -> ChainDBEnv m blk
forall a. HasCallStack => String -> a
error String
"ChainDBEnv used during command generation"

smUnused :: LoE ()
         -> ImmutableDB.ChunkInfo
         -> StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO)
smUnused :: LoE ()
-> ChunkInfo
-> StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO)
smUnused LoE ()
loe ChunkInfo
chunkInfo =
    LoE ()
-> ChainDBEnv IO Blk
-> BlockGen Blk IO
-> TopLevelConfig Blk
-> ExtLedgerState Blk EmptyMK
-> StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO)
forall blk.
TestConstraints blk =>
LoE ()
-> ChainDBEnv IO blk
-> BlockGen blk IO
-> TopLevelConfig blk
-> ExtLedgerState blk EmptyMK
-> StateMachine (Model blk IO) (At Cmd blk IO) IO (At Resp blk IO)
sm
      LoE ()
loe
      ChainDBEnv IO Blk
forall (m :: * -> *) blk. ChainDBEnv m blk
envUnused
      (ChunkInfo -> BlockGen Blk IO
forall (m :: * -> *). ChunkInfo -> BlockGen Blk m
genBlk ChunkInfo
chunkInfo)
      (ChunkInfo -> TopLevelConfig Blk
mkTestCfg ChunkInfo
chunkInfo)
      ExtLedgerState Blk EmptyMK
testInitExtLedger

prop_sequential :: LoE () -> SmallChunkInfo -> Property
prop_sequential :: LoE () -> SmallChunkInfo -> Property
prop_sequential LoE ()
loe smallChunkInfo :: SmallChunkInfo
smallChunkInfo@(SmallChunkInfo ChunkInfo
chunkInfo)  =
    StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO)
-> Maybe Int
-> (Commands (At Cmd Blk IO) (At Resp Blk IO) -> Property)
-> Property
forall prop (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *)
       (model :: (* -> *) -> *) (m :: * -> *).
(Testable prop, Show (cmd Symbolic), Show (resp Symbolic),
 Show (model Symbolic), Traversable cmd, Foldable resp) =>
StateMachine model cmd m resp
-> Maybe Int -> (Commands cmd resp -> prop) -> Property
forAllCommands (LoE ()
-> ChunkInfo
-> StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO)
smUnused LoE ()
loe ChunkInfo
chunkInfo) Maybe Int
forall a. Maybe a
Nothing ((Commands (At Cmd Blk IO) (At Resp Blk IO) -> Property)
 -> Property)
-> (Commands (At Cmd Blk IO) (At Resp Blk IO) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
      LoE ()
-> SmallChunkInfo
-> Commands (At Cmd Blk IO) (At Resp Blk IO)
-> Property
runCmdsLockstep LoE ()
loe SmallChunkInfo
smallChunkInfo

runCmdsLockstep ::
     LoE ()
  -> SmallChunkInfo
  -> QSM.Commands (At Cmd Blk IO) (At Resp Blk IO)
  -> Property
runCmdsLockstep :: LoE ()
-> SmallChunkInfo
-> Commands (At Cmd Blk IO) (At Resp Blk IO)
-> Property
runCmdsLockstep LoE ()
loe (SmallChunkInfo ChunkInfo
chunkInfo) Commands (At Cmd Blk IO) (At Resp Blk IO)
cmds =
    PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
QC.monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
        let
          -- Current test case command names.
          ctcCmdNames :: [String]
          ctcCmdNames :: Context
ctcCmdNames = (Command (At Cmd Blk IO) (At Resp Blk IO) -> String)
-> [Command (At Cmd Blk IO) (At Resp Blk IO)] -> Context
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS
forall a. Show a => a -> String
show ShowS
-> (Command (At Cmd Blk IO) (At Resp Blk IO) -> String)
-> Command (At Cmd Blk IO) (At Resp Blk IO)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. At Cmd Blk IO Symbolic -> String
forall k (cmd :: k -> *) (r :: k).
CommandNames cmd =>
cmd r -> String
forall (r :: * -> *). At Cmd Blk IO r -> String
cmdName (At Cmd Blk IO Symbolic -> String)
-> (Command (At Cmd Blk IO) (At Resp Blk IO)
    -> At Cmd Blk IO Symbolic)
-> Command (At Cmd Blk IO) (At Resp Blk IO)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command (At Cmd Blk IO) (At Resp Blk IO) -> At Cmd Blk IO Symbolic
forall (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *).
Command cmd resp -> cmd Symbolic
QSM.getCommand) ([Command (At Cmd Blk IO) (At Resp Blk IO)] -> Context)
-> [Command (At Cmd Blk IO) (At Resp Blk IO)] -> Context
forall a b. (a -> b) -> a -> b
$ Commands (At Cmd Blk IO) (At Resp Blk IO)
-> [Command (At Cmd Blk IO) (At Resp Blk IO)]
forall (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *).
Commands cmd resp -> [Command cmd resp]
QSM.unCommands Commands (At Cmd Blk IO) (At Resp Blk IO)
cmds

        (hist, prop) <- IO (History (At Cmd Blk IO) (At Resp Blk IO), Property)
-> PropertyM
     IO (History (At Cmd Blk IO) (At Resp Blk IO), Property)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
QC.run (IO (History (At Cmd Blk IO) (At Resp Blk IO), Property)
 -> PropertyM
      IO (History (At Cmd Blk IO) (At Resp Blk IO), Property))
-> IO (History (At Cmd Blk IO) (At Resp Blk IO), Property)
-> PropertyM
     IO (History (At Cmd Blk IO) (At Resp Blk IO), Property)
forall a b. (a -> b) -> a -> b
$ Commands (At Cmd Blk IO) (At Resp Blk IO)
-> IO (History (At Cmd Blk IO) (At Resp Blk IO), Property)
test Commands (At Cmd Blk IO) (At Resp Blk IO)
cmds
        prettyCommands (smUnused loe chunkInfo) hist
          $ tabulate
              "Tags"
              (map show $ tag (execCmds (QSM.initModel (smUnused loe chunkInfo)) cmds))
          $ tabulate "Command sequence length" [show $ length ctcCmdNames]
          $ tabulate "Commands"                ctcCmdNames
          $ prop
  where
    testCfg :: TopLevelConfig Blk
testCfg = ChunkInfo -> TopLevelConfig Blk
mkTestCfg ChunkInfo
chunkInfo

    test :: QSM.Commands (At Cmd Blk IO) (At Resp Blk IO)
         -> IO
            ( QSM.History (At Cmd Blk IO) (At Resp Blk IO)
            , Property
            )
    test :: Commands (At Cmd Blk IO) (At Resp Blk IO)
-> IO (History (At Cmd Blk IO) (At Resp Blk IO), Property)
test Commands (At Cmd Blk IO) (At Resp Blk IO)
cmds' = do
      threadRegistry     <- IO (ResourceRegistry IO)
forall (m :: * -> *).
(MonadSTM m, MonadThread m, HasCallStack) =>
m (ResourceRegistry m)
unsafeNewRegistry
      iteratorRegistry   <- unsafeNewRegistry
      (tracer, getTrace) <- recordingTracerIORef
      varCurSlot         <- uncheckedNewTVarM 0
      varNextId          <- uncheckedNewTVarM 0
      nodeDBs            <- emptyNodeDBs
      varLoEFragment     <- newTVarIO $ AF.Empty AF.AnchorGenesis
      let args = TopLevelConfig Blk
-> ChunkInfo
-> ExtLedgerState Blk ValuesMK
-> ResourceRegistry IO
-> NodeDBs (StrictTMVar IO MockFS)
-> Tracer IO (TraceEvent Blk)
-> LoE
     (StrictTVar
        IO
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime Blk))
           (HeaderWithTime Blk)))
-> ChainDbArgs Identity IO Blk
forall (m :: * -> *).
IOLike m =>
TopLevelConfig Blk
-> ChunkInfo
-> ExtLedgerState Blk ValuesMK
-> ResourceRegistry m
-> NodeDBs (StrictTMVar m MockFS)
-> Tracer m (TraceEvent Blk)
-> LoE
     (StrictTVar
        m
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime Blk))
           (HeaderWithTime Blk)))
-> ChainDbArgs Identity m Blk
mkArgs
                   TopLevelConfig Blk
testCfg
                   ChunkInfo
chunkInfo
                   (ExtLedgerState Blk EmptyMK
testInitExtLedger ExtLedgerState Blk EmptyMK
-> LedgerTables (ExtLedgerState Blk) ValuesMK
-> ExtLedgerState Blk ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
ExtLedgerState Blk any
-> LedgerTables (ExtLedgerState Blk) mk -> ExtLedgerState Blk mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (ExtLedgerState Blk) ValuesMK
forall (mk :: MapKind) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables)
                   ResourceRegistry IO
threadRegistry
                   NodeDBs (StrictTMVar IO MockFS)
nodeDBs
                   Tracer IO (TraceEvent Blk)
tracer
                   (LoE ()
loe LoE ()
-> StrictTVar
     IO
     (AnchoredSeq
        (WithOrigin SlotNo)
        (Anchor (HeaderWithTime Blk))
        (HeaderWithTime Blk))
-> LoE
     (StrictTVar
        IO
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime Blk))
           (HeaderWithTime Blk)))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StrictTVar
  IO
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime Blk))
     (HeaderWithTime Blk))
varLoEFragment)

      (hist, model, res, trace) <- bracket
        (open args >>= newTVarIO)
        -- Note: we might be closing a different ChainDB than the one we
        -- opened, as we can reopen it the ChainDB, swapping the ChainDB in
        -- the TVar.
        (\StrictTVar IO (ChainDBState IO Blk)
varDB -> StrictTVar IO (ChainDBState IO Blk) -> IO (ChainDBState IO Blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar IO (ChainDBState IO Blk)
varDB IO (ChainDBState IO Blk) -> (ChainDBState IO Blk -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChainDBState IO Blk -> IO ()
forall (m :: * -> *) blk. IOLike m => ChainDBState m blk -> m ()
close)

        $ \StrictTVar IO (ChainDBState IO Blk)
varDB -> do
          let env :: ChainDBEnv IO Blk
env = ChainDBEnv
                { StrictTVar IO (ChainDBState IO Blk)
varDB :: StrictTVar IO (ChainDBState IO Blk)
varDB :: StrictTVar IO (ChainDBState IO Blk)
varDB
                , registry :: ResourceRegistry IO
registry = ResourceRegistry IO
iteratorRegistry
                , StrictTVar IO SlotNo
varCurSlot :: StrictTVar IO SlotNo
varCurSlot :: StrictTVar IO SlotNo
varCurSlot
                , StrictTVar IO Id
varNextId :: StrictTVar IO Id
varNextId :: StrictTVar IO Id
varNextId
                , varVolatileDbFs :: StrictTMVar IO MockFS
varVolatileDbFs = NodeDBs (StrictTMVar IO MockFS) -> StrictTMVar IO MockFS
forall db. NodeDBs db -> db
nodeDBsVol NodeDBs (StrictTMVar IO MockFS)
nodeDBs
                , StrictTVar
  IO
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime Blk))
     (HeaderWithTime Blk))
varLoEFragment :: StrictTVar
  IO
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime Blk))
     (HeaderWithTime Blk))
varLoEFragment :: StrictTVar
  IO
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime Blk))
     (HeaderWithTime Blk))
varLoEFragment
                , ChainDbArgs Identity IO Blk
args :: ChainDbArgs Identity IO Blk
args :: ChainDbArgs Identity IO Blk
args
                }
              sm' :: StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO)
sm' = LoE ()
-> ChainDBEnv IO Blk
-> BlockGen Blk IO
-> TopLevelConfig Blk
-> ExtLedgerState Blk EmptyMK
-> StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO)
forall blk.
TestConstraints blk =>
LoE ()
-> ChainDBEnv IO blk
-> BlockGen blk IO
-> TopLevelConfig blk
-> ExtLedgerState blk EmptyMK
-> StateMachine (Model blk IO) (At Cmd blk IO) IO (At Resp blk IO)
sm LoE ()
loe ChainDBEnv IO Blk
env (ChunkInfo -> BlockGen Blk IO
forall (m :: * -> *). ChunkInfo -> BlockGen Blk m
genBlk ChunkInfo
chunkInfo) TopLevelConfig Blk
testCfg ExtLedgerState Blk EmptyMK
testInitExtLedger
          (hist, model, res) <- StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO)
-> Commands (At Cmd Blk IO) (At Resp Blk IO)
-> IO
     (History (At Cmd Blk IO) (At Resp Blk IO), Model Blk IO Concrete,
      Reason)
forall (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *) (m :: * -> *)
       (model :: (* -> *) -> *).
(Show (cmd Concrete), Show (resp Concrete), Traversable cmd,
 Foldable resp, MonadMask m, MonadIO m) =>
StateMachine model cmd m resp
-> Commands cmd resp
-> m (History cmd resp, model Concrete, Reason)
QSM.runCommands' StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO)
sm' Commands (At Cmd Blk IO) (At Resp Blk IO)
cmds'
          trace <- getTrace
          return (hist, model, res, trace)

      closeRegistry threadRegistry

      -- 'closeDB' should have closed all open 'Follower's and 'Iterator's,
      -- freeing up all resources, so there should be no more clean-up
      -- actions left.
      --
      -- Note that this is only true because we're not simulating exceptions
      -- (yet), in which case there /will be/ clean-up actions left. This is
      -- exactly the reason for introducing the 'ResourceRegistry' in the
      -- first place: to clean up resources in case exceptions get thrown.
      remainingCleanups <- countResources iteratorRegistry
      closeRegistry iteratorRegistry

      -- Read the final MockFS of each database
      fses <- atomically $ traverse readTMVar nodeDBs
      let
          modelChain = Model Blk -> Chain Blk
forall blk. Model blk -> Chain blk
Model.currentChain (Model Blk -> Chain Blk) -> Model Blk -> Chain Blk
forall a b. (a -> b) -> a -> b
$ Model Blk IO Concrete -> Model Blk
forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
dbModel Model Blk IO Concrete
model
          prop =
            String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (SecurityParam -> String
forall a. Show a => a -> String
show (TopLevelConfig Blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig Blk
testCfg))          (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Model chain: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Chain Blk -> String
forall a. Condense a => a -> String
condense Chain Blk
modelChain)      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"TraceEvents: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Context -> String
unlines ((TraceEvent Blk -> String) -> [TraceEvent Blk] -> Context
forall a b. (a -> b) -> [a] -> [b]
map TraceEvent Blk -> String
forall a. Show a => a -> String
show [TraceEvent Blk]
trace)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            String -> Context -> Property -> Property
forall prop. Testable prop => String -> Context -> prop -> Property
tabulate String
"Chain length" [Int -> String
forall a. Show a => a -> String
show (Chain Blk -> Int
forall block. Chain block -> Int
Chain.length Chain Blk
modelChain)]     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            String -> Context -> Property -> Property
forall prop. Testable prop => String -> Context -> prop -> Property
tabulate String
"TraceEvents" ((TraceEvent Blk -> String) -> [TraceEvent Blk] -> Context
forall a b. (a -> b) -> [a] -> [b]
map TraceEvent Blk -> String
forall blk. TraceEvent blk -> String
traceEventName [TraceEvent Blk]
trace)            (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Reason
res Reason -> Reason -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Reason
Ok Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
            TopLevelConfig Blk -> Model Blk -> [TraceEvent Blk] -> Property
prop_trace TopLevelConfig Blk
testCfg (Model Blk IO Concrete -> Model Blk
forall blk (m :: * -> *) (r :: * -> *).
Model blk m r -> DBModel blk
dbModel Model Blk IO Concrete
model) [TraceEvent Blk]
trace Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
            String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"ImmutableDB is leaking file handles"
                           (MockFS -> Int
Mock.numOpenHandles (NodeDBs MockFS -> MockFS
forall db. NodeDBs db -> db
nodeDBsImm NodeDBs MockFS
fses) Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
0) Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
            String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"VolatileDB is leaking file handles"
                           (MockFS -> Int
Mock.numOpenHandles (NodeDBs MockFS -> MockFS
forall db. NodeDBs db -> db
nodeDBsVol NodeDBs MockFS
fses) Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
0) Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
            String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"LedgerDB is leaking file handles"
                           (MockFS -> Int
Mock.numOpenHandles (NodeDBs MockFS -> MockFS
forall db. NodeDBs db -> db
nodeDBsLgr NodeDBs MockFS
fses) Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
0) Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
            String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"There were registered clean-up actions"
                           (Int
remainingCleanups Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
0)
      return (hist, prop)

prop_trace :: TopLevelConfig Blk -> DBModel Blk -> [TraceEvent Blk] -> Property
prop_trace :: TopLevelConfig Blk -> Model Blk -> [TraceEvent Blk] -> Property
prop_trace TopLevelConfig Blk
cfg Model Blk
dbModel [TraceEvent Blk]
trace =
    Property
invalidBlockNeverValidatedAgain Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    Property
tentativeHeaderMonotonicity
  where
    -- Whenever we validate a block that turns out to be invalid, check that
    -- we never again validate the same block.
    invalidBlockNeverValidatedAgain :: Property
invalidBlockNeverValidatedAgain =
      [TraceEvent Blk]
-> (TraceEvent Blk -> Maybe (RealPoint Blk))
-> ([TraceEvent Blk] -> RealPoint Blk -> Property)
-> Property
forall ev a.
[ev] -> (ev -> Maybe a) -> ([ev] -> a -> Property) -> Property
whenOccurs [TraceEvent Blk]
trace  TraceEvent Blk -> Maybe (RealPoint Blk)
forall blk. TraceEvent blk -> Maybe (RealPoint blk)
invalidBlock (([TraceEvent Blk] -> RealPoint Blk -> Property) -> Property)
-> ([TraceEvent Blk] -> RealPoint Blk -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[TraceEvent Blk]
trace' RealPoint Blk
invalidPoint  ->
      [TraceEvent Blk]
-> (TraceEvent Blk -> Maybe (RealPoint Blk))
-> ([TraceEvent Blk] -> RealPoint Blk -> Property)
-> Property
forall ev a.
[ev] -> (ev -> Maybe a) -> ([ev] -> a -> Property) -> Property
whenOccurs [TraceEvent Blk]
trace' TraceEvent Blk -> Maybe (RealPoint Blk)
forall blk. TraceEvent blk -> Maybe (RealPoint blk)
invalidBlock (([TraceEvent Blk] -> RealPoint Blk -> Property) -> Property)
-> ([TraceEvent Blk] -> RealPoint Blk -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[TraceEvent Blk]
_      RealPoint Blk
invalidPoint' ->
        -- If the database was reopened in the meantime, we have forgotten
        -- about the invalid block and might validate it again, that's fine
        if (TraceEvent Blk -> Bool) -> [TraceEvent Blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TraceEvent Blk -> Bool
forall blk. TraceEvent blk -> Bool
isOpened [TraceEvent Blk]
trace' then
          Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
        else
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"An invalid block is validated twice" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          RealPoint Blk
invalidPoint RealPoint Blk -> RealPoint Blk -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=/= RealPoint Blk
invalidPoint'

    invalidBlock :: TraceEvent blk -> Maybe (RealPoint blk)
    invalidBlock :: forall blk. TraceEvent blk -> Maybe (RealPoint blk)
invalidBlock = \case
        TraceAddBlockEvent (AddBlockValidation TraceValidationEvent blk
ev)         -> TraceValidationEvent blk -> Maybe (RealPoint blk)
forall {blk}. TraceValidationEvent blk -> Maybe (RealPoint blk)
extract TraceValidationEvent blk
ev
        TraceInitChainSelEvent (InitChainSelValidation TraceValidationEvent blk
ev) -> TraceValidationEvent blk -> Maybe (RealPoint blk)
forall {blk}. TraceValidationEvent blk -> Maybe (RealPoint blk)
extract TraceValidationEvent blk
ev
        TraceEvent blk
_                                                  -> Maybe (RealPoint blk)
forall a. Maybe a
Nothing
      where
        extract :: TraceValidationEvent blk -> Maybe (RealPoint blk)
extract (ChainDB.InvalidBlock ExtValidationError blk
_ RealPoint blk
pt) = RealPoint blk -> Maybe (RealPoint blk)
forall a. a -> Maybe a
Just RealPoint blk
pt
        extract TraceValidationEvent blk
_                           = Maybe (RealPoint blk)
forall a. Maybe a
Nothing

    isOpened :: TraceEvent blk -> Bool
    isOpened :: forall blk. TraceEvent blk -> Bool
isOpened (TraceOpenEvent (OpenedDB {})) = Bool
True
    isOpened TraceEvent blk
_                              = Bool
False

    tentativeHeaderMonotonicity :: Property
tentativeHeaderMonotonicity =
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Trap tentative headers did not improve monotonically" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([BftWithEBBsSelectView] -> Property
forall a. (Show a, Ord a) => [a] -> Property
strictlyIncreasing ([BftWithEBBsSelectView] -> Property)
-> [[BftWithEBBsSelectView]] -> [Property]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[SelectView (BlockProtocol Blk)]]
[[BftWithEBBsSelectView]]
trapTentativeSelectViews)
      where
        trapTentativeSelectViews :: [[SelectView (BlockProtocol Blk)]]
        trapTentativeSelectViews :: [[SelectView (BlockProtocol Blk)]]
trapTentativeSelectViews =
            [ [ BlockConfig Blk -> Header Blk -> SelectView (BlockProtocol Blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView (TopLevelConfig Blk -> BlockConfig Blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig Blk
cfg) Header Blk
hdr
              | TraceAddBlockEvent (PipeliningEvent TracePipeliningEvent Blk
ev) <- [TraceEvent Blk]
trace'
              , SetTentativeHeader Header Blk
hdr Enclosing' ()
FallingEdge <- [TracePipeliningEvent Blk
ev]
              , TestHeaderHash
-> Map TestHeaderHash (ExtValidationError Blk, SlotNo) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (Header Blk -> HeaderHash Blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header Blk
hdr) (Model Blk -> InvalidBlocks Blk
forall blk. Model blk -> InvalidBlocks blk
Model.invalid Model Blk
dbModel)
              ]
            | -- Check the property between DB reopenings
              [TraceEvent Blk]
trace' <- NonEmpty [TraceEvent Blk] -> [[TraceEvent Blk]]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty [TraceEvent Blk] -> [[TraceEvent Blk]])
-> NonEmpty [TraceEvent Blk] -> [[TraceEvent Blk]]
forall a b. (a -> b) -> a -> b
$ (TraceEvent Blk -> Bool)
-> [TraceEvent Blk] -> NonEmpty [TraceEvent Blk]
forall a. (a -> Bool) -> [a] -> NonEmpty [a]
split TraceEvent Blk -> Bool
forall blk. TraceEvent blk -> Bool
isOpened [TraceEvent Blk]
trace
            ]

-- | Given a trace of events, for each event in the trace for which the
-- predicate yields a @Just a@, call the continuation function with the
-- remaining events and @a@.
whenOccurs :: [ev] -> (ev -> Maybe a) -> ([ev] -> a -> Property) -> Property
whenOccurs :: forall ev a.
[ev] -> (ev -> Maybe a) -> ([ev] -> a -> Property) -> Property
whenOccurs [ev]
evs ev -> Maybe a
occurs [ev] -> a -> Property
k = [ev] -> Property
go [ev]
evs
  where
    go :: [ev] -> Property
go [] = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    go (ev
ev:[ev]
evs')
      | Just a
a <- ev -> Maybe a
occurs ev
ev
      = [ev] -> a -> Property
k [ev]
evs' a
a Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [ev] -> Property
go [ev]
evs'
      | Bool
otherwise
      = [ev] -> Property
go [ev]
evs'

traceEventName :: TraceEvent blk -> String
traceEventName :: forall blk. TraceEvent blk -> String
traceEventName = \case
    TraceAddBlockEvent          TraceAddBlockEvent blk
ev    -> String
"AddBlock."          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> case TraceAddBlockEvent blk
ev of
      AddBlockValidation        TraceValidationEvent blk
ev' -> TraceValidationEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceValidationEvent blk
ev'
      TraceAddBlockEvent blk
_                             -> TraceAddBlockEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceAddBlockEvent blk
ev
    TraceFollowerEvent          TraceFollowerEvent blk
ev    -> String
"Follower."            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TraceFollowerEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceFollowerEvent blk
ev
    TraceCopyToImmutableDBEvent TraceCopyToImmutableDBEvent blk
ev    -> String
"CopyToImmutableDB." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TraceCopyToImmutableDBEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceCopyToImmutableDBEvent blk
ev
    TraceInitChainSelEvent      TraceInitChainSelEvent blk
ev    -> String
"InitChainSel."      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> case TraceInitChainSelEvent blk
ev of
      InitChainSelValidation    TraceValidationEvent blk
ev' -> TraceValidationEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceValidationEvent blk
ev'
      TraceInitChainSelEvent blk
StartedInitChainSelection     -> String
"StartedInitChainSelection"
      TraceInitChainSelEvent blk
InitialChainSelected          -> String
"InitialChainSelected"
    TraceOpenEvent              TraceOpenEvent blk
ev    -> String
"Open."              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TraceOpenEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceOpenEvent blk
ev
    TraceGCEvent                TraceGCEvent blk
ev    -> String
"GC."                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TraceGCEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceGCEvent blk
ev
    TraceIteratorEvent          TraceIteratorEvent blk
ev    -> String
"Iterator."          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TraceIteratorEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceIteratorEvent blk
ev
    TraceLedgerDBEvent          TraceEvent blk
ev    -> String
"Ledger."            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TraceEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceEvent blk
ev
    TraceImmutableDBEvent       TraceEvent blk
ev    -> String
"ImmutableDB."       String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TraceEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceEvent blk
ev
    TraceVolatileDBEvent        TraceEvent blk
ev    -> String
"VolatileDB."        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TraceEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceEvent blk
ev
    TraceEvent blk
TraceLastShutdownUnclean          -> String
"LastShutdownUnclean"
    TraceChainSelStarvationEvent TraceChainSelStarvationEvent blk
ev   -> String
"ChainSelStarvation." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TraceChainSelStarvationEvent blk -> String
forall a. HasDatatypeInfo a => a -> String
constrName TraceChainSelStarvationEvent blk
ev

mkArgs :: IOLike m
       => TopLevelConfig Blk
       -> ImmutableDB.ChunkInfo
       -> ExtLedgerState Blk ValuesMK
       -> ResourceRegistry m
       -> NodeDBs (StrictTMVar m MockFS)
       -> CT.Tracer m (TraceEvent Blk)
       -> LoE (StrictTVar m (AnchoredFragment (HeaderWithTime Blk)))
       -> ChainDbArgs Identity m Blk
mkArgs :: forall (m :: * -> *).
IOLike m =>
TopLevelConfig Blk
-> ChunkInfo
-> ExtLedgerState Blk ValuesMK
-> ResourceRegistry m
-> NodeDBs (StrictTMVar m MockFS)
-> Tracer m (TraceEvent Blk)
-> LoE
     (StrictTVar
        m
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime Blk))
           (HeaderWithTime Blk)))
-> ChainDbArgs Identity m Blk
mkArgs TopLevelConfig Blk
cfg ChunkInfo
chunkInfo ExtLedgerState Blk ValuesMK
initLedger ResourceRegistry m
registry NodeDBs (StrictTMVar m MockFS)
nodeDBs Tracer m (TraceEvent Blk)
tracer LoE
  (StrictTVar
     m
     (AnchoredSeq
        (WithOrigin SlotNo)
        (Anchor (HeaderWithTime Blk))
        (HeaderWithTime Blk)))
varLoEFragment =
  let args :: Complete ChainDbArgs m Blk
args = MinimalChainDbArgs m Blk -> Complete ChainDbArgs m Blk
forall (m :: * -> *) blk.
(MonadThrow m, MonadSTM m, ConsensusProtocol (BlockProtocol blk),
 PrimMonad m) =>
MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk
fromMinimalChainDbArgs MinimalChainDbArgs {
            mcdbTopLevelConfig :: TopLevelConfig Blk
mcdbTopLevelConfig = TopLevelConfig Blk
cfg
          , mcdbChunkInfo :: ChunkInfo
mcdbChunkInfo = ChunkInfo
chunkInfo
          , mcdbInitLedger :: ExtLedgerState Blk ValuesMK
mcdbInitLedger = ExtLedgerState Blk ValuesMK
initLedger
          , mcdbRegistry :: ResourceRegistry m
mcdbRegistry = ResourceRegistry m
registry
          , mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs = NodeDBs (StrictTMVar m MockFS)
nodeDBs
          }
  in Tracer m (TraceEvent Blk)
-> Complete ChainDbArgs m Blk -> Complete ChainDbArgs m Blk
forall (m :: * -> *) blk (f :: * -> *).
Tracer m (TraceEvent blk)
-> ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.updateTracer Tracer m (TraceEvent Blk)
tracer (Complete ChainDbArgs m Blk -> Complete ChainDbArgs m Blk)
-> Complete ChainDbArgs m Blk -> Complete ChainDbArgs m Blk
forall a b. (a -> b) -> a -> b
$
      Complete ChainDbArgs m Blk
args { cdbsArgs = (cdbsArgs args) {
               ChainDB.cdbsBlocksToAddSize = 2
             , ChainDB.cdbsLoE = traverse (atomically . readTVar) varLoEFragment
             }
           , cdbImmDbArgs = (cdbImmDbArgs args) {
               ImmutableDB.immCheckIntegrity = testBlockIsValid
               }
           , cdbVolDbArgs = (cdbVolDbArgs args) {
               VolatileDB.volCheckIntegrity = testBlockIsValid
               }
          }

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"ChainDB q-s-m"
    [ (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ String -> (LoE () -> SmallChunkInfo -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"sequential" LoE () -> SmallChunkInfo -> Property
prop_sequential
    ]