{-# 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 #-}
module Test.Ouroboros.Storage.ChainDB.StateMachine
(
At (..)
, Cmd (..)
, FollowerRef
, IterRef
, IteratorResult (..)
, IteratorResultGCed (..)
, Resp (..)
, Success (..)
, Model
, ShouldGarbageCollect (..)
, runCmdsLockstep
, ChainDBEnv (..)
, ChainDBState (..)
, close
, mkTestCfg
, open
, persistBlks
, AllComponents
, allComponents
, TestConstraints
, traceEventName
, 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 GHC.Generics (Generic)
import qualified Generics.SOP as SOP
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 System.FS.Sim.MockFS (MockFS)
import qualified System.FS.Sim.MockFS as Mock
import Test.Ouroboros.Storage.ChainDB.Model
( FollowerId
, IteratorId
, ModelSupportsBlock
, ShouldGarbageCollect (DoNotGarbageCollect, GarbageCollect)
)
import qualified Test.Ouroboros.Storage.ChainDB.Model as Model
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 Test.Util.RefEnv (RefEnv)
import qualified Test.Util.RefEnv as RE
import Test.Util.SOP
import Test.Util.TestEnv (adjustQuickCheckTests)
import Test.Util.ToExpr ()
import Test.Util.Tracer (recordingTracerIORef)
import Test.Util.WithEq
data Cmd blk it flr
=
AddBlock blk
| GetCurrentChain
| GetTipBlock
|
| GetTipPoint
| GetBlockComponent (RealPoint blk)
|
GetGCedBlockComponent (RealPoint blk)
| GetMaxSlotNo
| GetIsValid (RealPoint blk)
| Stream (StreamFrom blk) (StreamTo blk)
|
UpdateLoE (AnchoredFragment blk)
| IteratorNext it
|
IteratorNextGCed it
| IteratorClose it
| NewFollower ChainType
|
FollowerInstruction flr
| FollowerForward flr [Point blk]
| FollowerClose flr
| Close
| Reopen
|
PersistBlks
|
PersistBlksThenGC
|
UpdateLedgerSnapshots
|
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)
deriving instance SOP.Generic (Cmd blk it flr)
deriving instance SOP.HasDatatypeInfo (Cmd blk it flr)
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))
| (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)
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
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)
type TestIterator m blk = WithEq (Iterator m blk (AllComponents blk))
type TestFollower m blk = WithEq (Follower m blk (AllComponents blk))
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
}
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)
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
, 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}
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)
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
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
data MaybeGCedBlock blk = MaybeGCedBlock
{ forall blk. MaybeGCedBlock blk -> Bool
real :: Bool
, forall blk. MaybeGCedBlock blk -> Maybe blk
mbBlock :: Maybe blk
}
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 =
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
data IteratorResultGCed blk = IteratorResultGCed
{ forall blk. IteratorResultGCed blk -> Bool
real :: Bool
, 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
data IsValidResult = IsValidResult
{ IsValidResult -> Bool
real :: Bool
, 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
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
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)
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)
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')
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)
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)
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 [])
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]
: [])
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
type IterRef blk m r = Reference (Opaque (TestIterator m blk)) r
type KnownIters blk m r = RefEnv (Opaque (TestIterator m blk)) IteratorId r
type FollowerRef blk m r = Reference (Opaque (TestFollower m blk)) r
type KnownFollowers blk m r = RefEnv (Opaque (TestFollower m blk)) FollowerId r
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)
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
}
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 ::
(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
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
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)
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
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
}
type BlockGen blk m = Model blk m Symbolic -> Gen blk
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 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)
,
(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)
,
(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)
,
(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)
,
(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)
,
(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
)
,
(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)
]
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
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
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)
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 []
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
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
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
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
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
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)
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
}
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)
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)
type EventPred m = C.Predicate (Event Blk m Symbolic) Tag
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 :: 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
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 ::
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
type Blk = TestBlock
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
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
}
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
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
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
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)
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
)
]
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
)
,
( 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
)
]
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
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)
(\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
remainingCleanups <- countResources iteratorRegistry
closeRegistry iteratorRegistry
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
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 (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)
]
|
[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
]
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
]