{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Model implementation of the chain DB
--
-- Intended for qualified import
module Test.Ouroboros.Storage.ChainDB.Model (
    Model
    -- opaque
  , CPS.FollowerId
  , IteratorId
    -- * Construction
  , addBlock
  , addBlockPromise
  , addBlocks
  , empty
    -- * Queries
  , currentChain
  , currentLedger
  , getBlock
  , getBlockByPoint
  , getBlockComponentByPoint
  , getIsValid
  , getLedgerDB
  , getLoEFragment
  , getMaxSlotNo
  , hasBlock
  , hasBlockByPoint
  , immutableBlockNo
  , immutableChain
  , immutableSlotNo
  , invalid
  , isOpen
  , isValid
  , lastK
  , tipBlock
  , tipPoint
  , volatileChain
    -- * Iterators
  , iteratorClose
  , iteratorNext
  , stream
    -- * Followers
  , followerClose
  , followerForward
  , followerInstruction
  , newFollower
    -- * ModelSupportsBlock
  , ModelSupportsBlock
    -- * Exported for testing purposes
  , ShouldGarbageCollect (GarbageCollect, DoNotGarbageCollect)
  , between
  , blocks
  , chains
  , closeDB
  , copyToImmutableDB
  , garbageCollectable
  , garbageCollectableIteratorNext
  , garbageCollectablePoint
  , getFragmentBetween
  , immutableDbChain
  , initLedger
  , reopen
  , updateLoE
  , validChains
  , volatileDbBlocks
  , wipeVolatileDB
  ) where

import           Codec.Serialise (Serialise, serialise)
import           Control.Monad (unless)
import           Control.Monad.Except (runExcept)
import           Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as Lazy
import           Data.Containers.ListUtils (nubOrdOn)
import           Data.Function (on, (&))
import           Data.Functor (($>), (<&>))
import           Data.List (isInfixOf, isPrefixOf, sortBy)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe, isJust)
import           Data.Proxy
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.TreeDiff
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Protocol.MockChainSel
import           Ouroboros.Consensus.Storage.ChainDB.API (AddBlockPromise (..),
                     AddBlockResult (..), BlockComponent (..),
                     ChainDbError (..), IteratorResult (..), LoE (..),
                     StreamFrom (..), StreamTo (..), UnknownRange (..),
                     validBounds)
import           Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel (olderThanK)
import           Ouroboros.Consensus.Storage.LedgerDB
import           Ouroboros.Consensus.Util (repeatedly)
import qualified Ouroboros.Consensus.Util.AnchoredFragment as Fragment
import           Ouroboros.Consensus.Util.IOLike (MonadSTM)
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as Fragment
import           Ouroboros.Network.Block (MaxSlotNo (..))
import           Ouroboros.Network.Mock.Chain (Chain (..), ChainUpdate)
import qualified Ouroboros.Network.Mock.Chain as Chain
import           Ouroboros.Network.Mock.ProducerState (ChainProducerState)
import qualified Ouroboros.Network.Mock.ProducerState as CPS
import           Test.Cardano.Slotting.TreeDiff ()
import           Test.Util.Orphans.ToExpr ()

type IteratorId = Int

-- | Model of the chain DB
data Model blk = Model {
      forall blk. Model blk -> Map (HeaderHash blk) blk
volatileDbBlocks :: Map (HeaderHash blk) blk
      -- ^ The VolatileDB
    , forall blk. Model blk -> Chain blk
immutableDbChain :: Chain blk
      -- ^ The ImmutableDB
    , forall blk. Model blk -> ChainProducerState blk
cps              :: CPS.ChainProducerState blk
    , forall blk. Model blk -> ExtLedgerState blk
currentLedger    :: ExtLedgerState blk
    , forall blk. Model blk -> ExtLedgerState blk
initLedger       :: ExtLedgerState blk
    , forall blk. Model blk -> Map IteratorId [blk]
iterators        :: Map IteratorId [blk]
    , forall blk. Model blk -> Set (HeaderHash blk)
valid            :: Set (HeaderHash blk)
    , forall blk. Model blk -> InvalidBlocks blk
invalid          :: InvalidBlocks blk
    , forall blk. Model blk -> LoE (AnchoredFragment blk)
loeFragment      :: LoE (AnchoredFragment blk)
    , forall blk. Model blk -> Bool
isOpen           :: Bool
      -- ^ While the model tracks whether it is closed or not, the queries and
      -- other functions in this module ignore this for simplicity. The mock
      -- ChainDB that wraps this model will throw a 'ClosedDBError' whenever
      -- it is used while closed.
    }
  deriving ((forall x. Model blk -> Rep (Model blk) x)
-> (forall x. Rep (Model blk) x -> Model blk)
-> Generic (Model blk)
forall x. Rep (Model blk) x -> Model blk
forall x. Model blk -> Rep (Model blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (Model blk) x -> Model blk
forall blk x. Model blk -> Rep (Model blk) x
$cfrom :: forall blk x. Model blk -> Rep (Model blk) x
from :: forall x. Model blk -> Rep (Model blk) x
$cto :: forall blk x. Rep (Model blk) x -> Model blk
to :: forall x. Rep (Model blk) x -> Model blk
Generic)

deriving instance ( ToExpr blk
                  , ToExpr (HeaderHash blk)
                  , ToExpr (ChainDepState (BlockProtocol blk))
                  , ToExpr (TipInfo blk)
                  , ToExpr (LedgerState blk)
                  , ToExpr (ExtValidationError blk)
                  , ToExpr (Chain blk)
                  , ToExpr (ChainProducerState blk)
                  , ToExpr (ExtLedgerState blk)
                  )
                 => ToExpr (Model blk)

deriving instance (LedgerSupportsProtocol blk, Show blk) => Show (Model blk)

{-------------------------------------------------------------------------------
  Queries
-------------------------------------------------------------------------------}

immutableDbBlocks :: HasHeader blk => Model blk -> Map (HeaderHash blk) blk
immutableDbBlocks :: forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
immutableDbBlocks Model { Chain blk
immutableDbChain :: forall blk. Model blk -> Chain blk
immutableDbChain :: Chain blk
immutableDbChain } = [(HeaderHash blk, blk)] -> Map (HeaderHash blk) blk
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(HeaderHash blk, blk)] -> Map (HeaderHash blk) blk)
-> [(HeaderHash blk, blk)] -> Map (HeaderHash blk) blk
forall a b. (a -> b) -> a -> b
$
    [ (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk, blk
blk)
    | blk
blk <- Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain blk
immutableDbChain
    ]

blocks :: HasHeader blk => Model blk -> Map (HeaderHash blk) blk
blocks :: forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
blocks Model blk
m = Model blk -> Map (HeaderHash blk) blk
forall blk. Model blk -> Map (HeaderHash blk) blk
volatileDbBlocks Model blk
m Map (HeaderHash blk) blk
-> Map (HeaderHash blk) blk -> Map (HeaderHash blk) blk
forall a. Semigroup a => a -> a -> a
<> Model blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
immutableDbBlocks Model blk
m

currentChain :: Model blk -> Chain blk
currentChain :: forall blk. Model blk -> Chain blk
currentChain = ChainProducerState blk -> Chain blk
forall block. ChainProducerState block -> Chain block
CPS.producerChain (ChainProducerState blk -> Chain blk)
-> (Model blk -> ChainProducerState blk) -> Model blk -> Chain blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> ChainProducerState blk
forall blk. Model blk -> ChainProducerState blk
cps

getBlock :: HasHeader blk => HeaderHash blk -> Model blk -> Maybe blk
getBlock :: forall blk.
HasHeader blk =>
HeaderHash blk -> Model blk -> Maybe blk
getBlock HeaderHash blk
hash Model blk
m = HeaderHash blk -> Map (HeaderHash blk) blk -> Maybe blk
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderHash blk
hash (Model blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
blocks Model blk
m)

hasBlock :: HasHeader blk => HeaderHash blk -> Model blk -> Bool
hasBlock :: forall blk. HasHeader blk => HeaderHash blk -> Model blk -> Bool
hasBlock HeaderHash blk
hash = Maybe blk -> Bool
forall a. Maybe a -> Bool
isJust (Maybe blk -> Bool)
-> (Model blk -> Maybe blk) -> Model blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderHash blk -> Model blk -> Maybe blk
forall blk.
HasHeader blk =>
HeaderHash blk -> Model blk -> Maybe blk
getBlock HeaderHash blk
hash

getBlockByPoint :: HasHeader blk
                => RealPoint blk -> Model blk
                -> Maybe blk
getBlockByPoint :: forall blk.
HasHeader blk =>
RealPoint blk -> Model blk -> Maybe blk
getBlockByPoint (RealPoint SlotNo
_ HeaderHash blk
hash) = HeaderHash blk -> Model blk -> Maybe blk
forall blk.
HasHeader blk =>
HeaderHash blk -> Model blk -> Maybe blk
getBlock HeaderHash blk
hash

getBlockComponentByPoint ::
     ModelSupportsBlock blk
  => BlockComponent blk b
  -> RealPoint blk -> Model blk
  -> Either (ChainDbError blk) (Maybe b) -- Just to satify the API
getBlockComponentByPoint :: forall blk b.
ModelSupportsBlock blk =>
BlockComponent blk b
-> RealPoint blk
-> Model blk
-> Either (ChainDbError blk) (Maybe b)
getBlockComponentByPoint BlockComponent blk b
blockComponent RealPoint blk
pt Model blk
m = Maybe b -> Either (ChainDbError blk) (Maybe b)
forall a b. b -> Either a b
Right (Maybe b -> Either (ChainDbError blk) (Maybe b))
-> Maybe b -> Either (ChainDbError blk) (Maybe b)
forall a b. (a -> b) -> a -> b
$
    (blk -> BlockComponent blk b -> b
forall blk b.
ModelSupportsBlock blk =>
blk -> BlockComponent blk b -> b
`getBlockComponent` BlockComponent blk b
blockComponent) (blk -> b) -> Maybe blk -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealPoint blk -> Model blk -> Maybe blk
forall blk.
HasHeader blk =>
RealPoint blk -> Model blk -> Maybe blk
getBlockByPoint RealPoint blk
pt Model blk
m

hasBlockByPoint :: HasHeader blk
                => Point blk -> Model blk -> Bool
hasBlockByPoint :: forall blk. HasHeader blk => Point blk -> Model blk -> Bool
hasBlockByPoint Point blk
pt = case Point blk -> ChainHash blk
forall {k} (block :: k). Point block -> ChainHash block
pointHash Point blk
pt of
    ChainHash blk
GenesisHash    -> Bool -> Model blk -> Bool
forall a b. a -> b -> a
const Bool
False
    BlockHash HeaderHash blk
hash -> HeaderHash blk -> Model blk -> Bool
forall blk. HasHeader blk => HeaderHash blk -> Model blk -> Bool
hasBlock HeaderHash blk
hash

tipBlock :: Model blk -> Maybe blk
tipBlock :: forall blk. Model blk -> Maybe blk
tipBlock = Chain blk -> Maybe blk
forall b. Chain b -> Maybe b
Chain.head (Chain blk -> Maybe blk)
-> (Model blk -> Chain blk) -> Model blk -> Maybe blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain

tipPoint :: HasHeader blk => Model blk -> Point blk
tipPoint :: forall blk. HasHeader blk => Model blk -> Point blk
tipPoint = Point blk -> (blk -> Point blk) -> Maybe blk -> Point blk
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Point blk
forall {k} (block :: k). Point block
GenesisPoint blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint (Maybe blk -> Point blk)
-> (Model blk -> Maybe blk) -> Model blk -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> Maybe blk
forall blk. Model blk -> Maybe blk
tipBlock

getMaxSlotNo :: HasHeader blk => Model blk -> MaxSlotNo
getMaxSlotNo :: forall blk. HasHeader blk => Model blk -> MaxSlotNo
getMaxSlotNo = (blk -> MaxSlotNo) -> Map (HeaderHash blk) blk -> MaxSlotNo
forall m a. Monoid m => (a -> m) -> Map (HeaderHash blk) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (SlotNo -> MaxSlotNo
MaxSlotNo (SlotNo -> MaxSlotNo) -> (blk -> SlotNo) -> blk -> MaxSlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot) (Map (HeaderHash blk) blk -> MaxSlotNo)
-> (Model blk -> Map (HeaderHash blk) blk)
-> Model blk
-> MaxSlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
blocks

lastK :: HasHeader a
      => SecurityParam
      -> (blk -> a)  -- ^ Provided since `AnchoredFragment` is not a functor
      -> Model blk
      -> AnchoredFragment a
lastK :: forall a blk.
HasHeader a =>
SecurityParam -> (blk -> a) -> Model blk -> AnchoredFragment a
lastK (SecurityParam Word64
k) blk -> a
f =
      Word64
-> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a
-> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
Fragment.anchorNewest Word64
k
    (AnchoredSeq (WithOrigin SlotNo) (Anchor a) a
 -> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a)
-> (Model blk -> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a)
-> Model blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain a -> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment
    (Chain a -> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a)
-> (Model blk -> Chain a)
-> Model blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk -> a) -> Chain blk -> Chain a
forall a b. (a -> b) -> Chain a -> Chain b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap blk -> a
f
    (Chain blk -> Chain a)
-> (Model blk -> Chain blk) -> Model blk -> Chain a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain

-- | Actual number of blocks that can be rolled back. Equal to @k@, except
-- when:
--
-- * Near genesis, the chain might not be @k@ blocks long yet.
-- * After VolatileDB corruption, the whole chain might be >= @k@ blocks, but
--   the tip of the ImmutableDB might be closer than @k@ blocks away from the
--   current chain's tip.
--
maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> Word64
maxActualRollback :: forall blk. HasHeader blk => SecurityParam -> Model blk -> Word64
maxActualRollback SecurityParam
k Model blk
m =
      IteratorId -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    (IteratorId -> Word64)
-> (Model blk -> IteratorId) -> Model blk -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point blk] -> IteratorId
forall a. [a] -> IteratorId
forall (t :: * -> *) a. Foldable t => t a -> IteratorId
length
    ([Point blk] -> IteratorId)
-> (Model blk -> [Point blk]) -> Model blk -> IteratorId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point blk -> Bool) -> [Point blk] -> [Point blk]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
/= Point blk
immutableTipPoint)
    ([Point blk] -> [Point blk])
-> (Model blk -> [Point blk]) -> Model blk -> [Point blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk -> Point blk) -> [blk] -> [Point blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint
    ([blk] -> [Point blk])
-> (Model blk -> [blk]) -> Model blk -> [Point blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toNewestFirst
    (Chain blk -> [blk])
-> (Model blk -> Chain blk) -> Model blk -> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain
    (Model blk -> Word64) -> Model blk -> Word64
forall a b. (a -> b) -> a -> b
$ Model blk
m
  where
    immutableTipPoint :: Point blk
immutableTipPoint = Chain blk -> Point blk
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint (SecurityParam -> Model blk -> Chain blk
forall blk. SecurityParam -> Model blk -> Chain blk
immutableChain SecurityParam
k Model blk
m)

-- | Return the immutable prefix of the current chain.
--
-- This is the longest of the given two chains:
--
-- 1. The current chain with the last @k@ blocks dropped.
-- 2. The chain formed by the blocks in 'immutableDbChain', i.e., the
--    \"ImmutableDB\". We need to take this case in consideration because the
--    VolatileDB might have been wiped.
--
-- We need this because we do not allow rolling back more than @k@ blocks, but
-- the background thread copying blocks from the VolatileDB to the ImmutableDB
-- might not have caught up yet. This means we cannot use the tip of the
-- ImmutableDB to know the most recent \"immutable\" block.
immutableChain ::
     SecurityParam
  -> Model blk
  -> Chain blk
immutableChain :: forall blk. SecurityParam -> Model blk -> Chain blk
immutableChain (SecurityParam Word64
k) Model blk
m =
    (Chain blk -> IteratorId) -> Chain blk -> Chain blk -> Chain blk
forall {a} {t}. Ord a => (t -> a) -> t -> t -> t
maxBy
      Chain blk -> IteratorId
forall block. Chain block -> IteratorId
Chain.length
      (IteratorId -> Chain blk -> Chain blk
forall block. IteratorId -> Chain block -> Chain block
Chain.drop (Word64 -> IteratorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k) (Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain Model blk
m))
      (Model blk -> Chain blk
forall blk. Model blk -> Chain blk
immutableDbChain Model blk
m)
  where
    maxBy :: (t -> a) -> t -> t -> t
maxBy t -> a
f t
a t
b
      | t -> a
f t
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= t -> a
f t
b = t
a
      | Bool
otherwise  = t
b

-- | Return the volatile suffix of the current chain.
--
-- The opposite of 'immutableChain'.
--
-- This is the shortest of the given two chain fragments:
--
-- 1. The last @k@ blocks of the current chain.
-- 2. The suffix of the current chain not part of the 'immutableDbChain', i.e.,
--    the \"ImmutableDB\".
volatileChain ::
       (HasHeader a, HasHeader blk)
    => SecurityParam
    -> (blk -> a)  -- ^ Provided since 'AnchoredFragment' is not a functor
    -> Model blk
    -> AnchoredFragment a
volatileChain :: forall a blk.
(HasHeader a, HasHeader blk) =>
SecurityParam -> (blk -> a) -> Model blk -> AnchoredFragment a
volatileChain SecurityParam
k blk -> a
f Model blk
m =
      Anchor a -> [a] -> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
Fragment.fromNewestFirst Anchor a
anchor
    ([a] -> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a)
-> (Model blk -> [a])
-> Model blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk -> a) -> [blk] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map blk -> a
f
    ([blk] -> [a]) -> (Model blk -> [blk]) -> Model blk -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk -> Bool) -> [blk] -> [blk]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
/= Point blk
immutableTipPoint) (Point blk -> Bool) -> (blk -> Point blk) -> blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint)
    ([blk] -> [blk]) -> (Model blk -> [blk]) -> Model blk -> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toNewestFirst
    (Chain blk -> [blk])
-> (Model blk -> Chain blk) -> Model blk -> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain
    (Model blk -> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a)
-> Model blk -> AnchoredSeq (WithOrigin SlotNo) (Anchor a) a
forall a b. (a -> b) -> a -> b
$ Model blk
m
  where
    (Point blk
immutableTipPoint, Anchor a
anchor) = case Chain blk -> Maybe blk
forall b. Chain b -> Maybe b
Chain.head (SecurityParam -> Model blk -> Chain blk
forall blk. SecurityParam -> Model blk -> Chain blk
immutableChain SecurityParam
k Model blk
m) of
        Maybe blk
Nothing -> (Point blk
forall {k} (block :: k). Point block
GenesisPoint, Anchor a
forall block. Anchor block
Fragment.AnchorGenesis)
        Just blk
b  -> (blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
b, a -> Anchor a
forall block. HasHeader block => block -> Anchor block
Fragment.anchorFromBlock (blk -> a
f blk
b))

-- | The block number of the most recent \"immutable\" block, i.e. the oldest
-- block we can roll back to. We cannot roll back the block itself.
--
-- Note that this is not necessarily the block at the tip of the ImmutableDB,
-- because the background thread copying blocks to the ImmutableDB might not
-- have caught up.
immutableBlockNo :: HasHeader blk
                 => SecurityParam -> Model blk -> WithOrigin BlockNo
immutableBlockNo :: forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> WithOrigin BlockNo
immutableBlockNo SecurityParam
k = Chain blk -> WithOrigin BlockNo
forall block. HasHeader block => Chain block -> WithOrigin BlockNo
Chain.headBlockNo (Chain blk -> WithOrigin BlockNo)
-> (Model blk -> Chain blk) -> Model blk -> WithOrigin BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> Model blk -> Chain blk
forall blk. SecurityParam -> Model blk -> Chain blk
immutableChain SecurityParam
k

-- | The slot number of the most recent \"immutable\" block (see
-- 'immutableBlockNo').
--
-- This is used for garbage collection of the VolatileDB, which is done in
-- terms of slot numbers, not in terms of block numbers.
immutableSlotNo :: HasHeader blk
                => SecurityParam
                -> Model blk
                -> WithOrigin SlotNo
immutableSlotNo :: forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> WithOrigin SlotNo
immutableSlotNo SecurityParam
k = Chain blk -> WithOrigin SlotNo
forall block. HasHeader block => Chain block -> WithOrigin SlotNo
Chain.headSlot (Chain blk -> WithOrigin SlotNo)
-> (Model blk -> Chain blk) -> Model blk -> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> Model blk -> Chain blk
forall blk. SecurityParam -> Model blk -> Chain blk
immutableChain SecurityParam
k

getIsValid :: forall blk. LedgerSupportsProtocol blk
           => Model blk
           -> (RealPoint blk -> Maybe Bool)
getIsValid :: forall blk.
LedgerSupportsProtocol blk =>
Model blk -> RealPoint blk -> Maybe Bool
getIsValid Model blk
m = \(RealPoint SlotNo
_ HeaderHash blk
hash) -> if
    -- Note that we are not checking whether the block is in the VolatileDB.
    -- This is justified as we already assume that the model knows more about
    -- valid blocks (see 'IsValidResult') and garbage collection of invalid
    -- blocks differs between the model and the SUT (see the "Invalid blocks"
    -- note in @./StateMachine.hs@).
    | HeaderHash blk -> Set (HeaderHash blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member HeaderHash blk
hash (Model blk -> Set (HeaderHash blk)
forall blk. Model blk -> Set (HeaderHash blk)
valid Model blk
m)   -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    | HeaderHash blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member HeaderHash blk
hash (Model blk -> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
forall blk. Model blk -> InvalidBlocks blk
invalid Model blk
m) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    | Bool
otherwise                   -> Maybe Bool
forall a. Maybe a
Nothing

isValid :: forall blk. LedgerSupportsProtocol blk
        => RealPoint blk
        -> Model blk
        -> Maybe Bool
isValid :: forall blk.
LedgerSupportsProtocol blk =>
RealPoint blk -> Model blk -> Maybe Bool
isValid = (Model blk -> RealPoint blk -> Maybe Bool)
-> RealPoint blk -> Model blk -> Maybe Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Model blk -> RealPoint blk -> Maybe Bool
forall blk.
LedgerSupportsProtocol blk =>
Model blk -> RealPoint blk -> Maybe Bool
getIsValid

getLedgerDB ::
     LedgerSupportsProtocol blk
  => TopLevelConfig blk
  -> Model blk
  -> LedgerDB (ExtLedgerState blk)
getLedgerDB :: forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> Model blk -> LedgerDB (ExtLedgerState blk)
getLedgerDB TopLevelConfig blk
cfg m :: Model blk
m@Model{Bool
Set (HeaderHash blk)
Map IteratorId [blk]
Map (HeaderHash blk) blk
InvalidBlocks blk
ExtLedgerState blk
LoE (AnchoredFragment blk)
Chain blk
ChainProducerState blk
currentLedger :: forall blk. Model blk -> ExtLedgerState blk
invalid :: forall blk. Model blk -> InvalidBlocks blk
isOpen :: forall blk. Model blk -> Bool
immutableDbChain :: forall blk. Model blk -> Chain blk
initLedger :: forall blk. Model blk -> ExtLedgerState blk
volatileDbBlocks :: forall blk. Model blk -> Map (HeaderHash blk) blk
cps :: forall blk. Model blk -> ChainProducerState blk
iterators :: forall blk. Model blk -> Map IteratorId [blk]
valid :: forall blk. Model blk -> Set (HeaderHash blk)
loeFragment :: forall blk. Model blk -> LoE (AnchoredFragment blk)
volatileDbBlocks :: Map (HeaderHash blk) blk
immutableDbChain :: Chain blk
cps :: ChainProducerState blk
currentLedger :: ExtLedgerState blk
initLedger :: ExtLedgerState blk
iterators :: Map IteratorId [blk]
valid :: Set (HeaderHash blk)
invalid :: InvalidBlocks blk
loeFragment :: LoE (AnchoredFragment blk)
isOpen :: Bool
..} =
      SecurityParam
-> LedgerDB (ExtLedgerState blk) -> LedgerDB (ExtLedgerState blk)
forall l. GetTip l => SecurityParam -> LedgerDB l -> LedgerDB l
ledgerDbPrune (Word64 -> SecurityParam
SecurityParam (SecurityParam -> Model blk -> Word64
forall blk. HasHeader blk => SecurityParam -> Model blk -> Word64
maxActualRollback SecurityParam
k Model blk
m))
    (LedgerDB (ExtLedgerState blk) -> LedgerDB (ExtLedgerState blk))
-> LedgerDB (ExtLedgerState blk) -> LedgerDB (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ LedgerDbCfg (ExtLedgerState blk)
-> [blk]
-> LedgerDB (ExtLedgerState blk)
-> LedgerDB (ExtLedgerState blk)
forall l blk.
ApplyBlock l blk =>
LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l
ledgerDbPushMany' LedgerDbCfg (ExtLedgerState blk)
ledgerDbCfg [blk]
blks
    (LedgerDB (ExtLedgerState blk) -> LedgerDB (ExtLedgerState blk))
-> LedgerDB (ExtLedgerState blk) -> LedgerDB (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk -> LedgerDB (ExtLedgerState blk)
forall l. GetTip l => l -> LedgerDB l
ledgerDbWithAnchor ExtLedgerState blk
initLedger
  where
    blks :: [blk]
blks = Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst (Chain blk -> [blk]) -> Chain blk -> [blk]
forall a b. (a -> b) -> a -> b
$ Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain Model blk
m

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

    ledgerDbCfg :: LedgerDbCfg (ExtLedgerState blk)
ledgerDbCfg = LedgerDbCfg {
          ledgerDbCfgSecParam :: SecurityParam
ledgerDbCfgSecParam = SecurityParam
k
        , ledgerDbCfg :: LedgerCfg (ExtLedgerState blk)
ledgerDbCfg         = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg
        }

getLoEFragment :: Model blk -> LoE (AnchoredFragment blk)
getLoEFragment :: forall blk. Model blk -> LoE (AnchoredFragment blk)
getLoEFragment = Model blk -> LoE (AnchoredFragment blk)
forall blk. Model blk -> LoE (AnchoredFragment blk)
loeFragment

{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

empty ::
     HasHeader blk
  => LoE ()
  -> ExtLedgerState blk
  -> Model blk
empty :: forall blk.
HasHeader blk =>
LoE () -> ExtLedgerState blk -> Model blk
empty LoE ()
loe ExtLedgerState blk
initLedger = Model {
      volatileDbBlocks :: Map (HeaderHash blk) blk
volatileDbBlocks = Map (HeaderHash blk) blk
forall k a. Map k a
Map.empty
    , immutableDbChain :: Chain blk
immutableDbChain = Chain blk
forall block. Chain block
Chain.Genesis
    , cps :: ChainProducerState blk
cps              = Chain blk -> ChainProducerState blk
forall block. Chain block -> ChainProducerState block
CPS.initChainProducerState Chain blk
forall block. Chain block
Chain.Genesis
    , currentLedger :: ExtLedgerState blk
currentLedger    = ExtLedgerState blk
initLedger
    , initLedger :: ExtLedgerState blk
initLedger       = ExtLedgerState blk
initLedger
    , iterators :: Map IteratorId [blk]
iterators        = Map IteratorId [blk]
forall k a. Map k a
Map.empty
    , valid :: Set (HeaderHash blk)
valid            = Set (HeaderHash blk)
forall a. Set a
Set.empty
    , invalid :: InvalidBlocks blk
invalid          = InvalidBlocks blk
forall k a. Map k a
Map.empty
    , isOpen :: Bool
isOpen           = Bool
True
    , loeFragment :: LoE (AnchoredFragment blk)
loeFragment      = LoE ()
loe LoE () -> AnchoredFragment blk -> LoE (AnchoredFragment blk)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Anchor blk -> AnchoredFragment blk
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
Fragment.Empty Anchor blk
forall block. Anchor block
Fragment.AnchorGenesis
    }

addBlock :: forall blk. LedgerSupportsProtocol blk
         => TopLevelConfig blk
         -> blk
         -> Model blk -> Model blk
addBlock :: forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> blk -> Model blk -> Model blk
addBlock TopLevelConfig blk
cfg blk
blk Model blk
m
  | Bool
ignoreBlock = Model blk
m
  | Bool
otherwise   = TopLevelConfig blk -> Model blk -> Model blk
forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> Model blk -> Model blk
chainSelection TopLevelConfig blk
cfg Model blk
m {
        volatileDbBlocks = Map.insert (blockHash blk) blk (volatileDbBlocks m)
      }
  where
    secParam :: SecurityParam
secParam = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg
    immBlockNo :: WithOrigin BlockNo
immBlockNo = SecurityParam -> Model blk -> WithOrigin BlockNo
forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> WithOrigin BlockNo
immutableBlockNo SecurityParam
secParam Model blk
m

    hdr :: Header blk
hdr = blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk

    ignoreBlock :: Bool
ignoreBlock =
        -- If the block is as old as the tip of the ImmutableDB, i.e. older
        -- than @k@, we ignore it, as we can never switch to it.
        Header blk -> IsEBB -> WithOrigin BlockNo -> Bool
forall blk.
HasHeader (Header blk) =>
Header blk -> IsEBB -> WithOrigin BlockNo -> Bool
olderThanK Header blk
hdr (Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header blk
hdr) WithOrigin BlockNo
immBlockNo Bool -> Bool -> Bool
||
        -- If it's an invalid block we've seen before, ignore it.
        HeaderHash blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk) (Model blk -> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
forall blk. Model blk -> InvalidBlocks blk
invalid Model blk
m)

chainSelection :: forall blk. LedgerSupportsProtocol blk
         => TopLevelConfig blk
         -> Model blk -> Model blk
chainSelection :: forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> Model blk -> Model blk
chainSelection TopLevelConfig blk
cfg Model blk
m = Model {
      volatileDbBlocks :: Map (HeaderHash blk) blk
volatileDbBlocks = Model blk -> Map (HeaderHash blk) blk
forall blk. Model blk -> Map (HeaderHash blk) blk
volatileDbBlocks Model blk
m
    , immutableDbChain :: Chain blk
immutableDbChain = Model blk -> Chain blk
forall blk. Model blk -> Chain blk
immutableDbChain Model blk
m
    , cps :: ChainProducerState blk
cps              = Chain blk -> ChainProducerState blk -> ChainProducerState blk
forall block.
HasHeader block =>
Chain block -> ChainProducerState block -> ChainProducerState block
CPS.switchFork Chain blk
newChain (Model blk -> ChainProducerState blk
forall blk. Model blk -> ChainProducerState blk
cps Model blk
m)
    , currentLedger :: ExtLedgerState blk
currentLedger    = ExtLedgerState blk
newLedger
    , initLedger :: ExtLedgerState blk
initLedger       = Model blk -> ExtLedgerState blk
forall blk. Model blk -> ExtLedgerState blk
initLedger Model blk
m
    , iterators :: Map IteratorId [blk]
iterators        = Model blk -> Map IteratorId [blk]
forall blk. Model blk -> Map IteratorId [blk]
iterators  Model blk
m
    , valid :: Set (HeaderHash blk)
valid            = Set (HeaderHash blk)
valid'
    , invalid :: InvalidBlocks blk
invalid          = InvalidBlocks blk
invalid'
    , isOpen :: Bool
isOpen           = Bool
True
    , loeFragment :: LoE (AnchoredFragment blk)
loeFragment      = Model blk -> LoE (AnchoredFragment blk)
forall blk. Model blk -> LoE (AnchoredFragment blk)
loeFragment Model blk
m
    }
  where
    secParam :: SecurityParam
secParam = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg

    -- @invalid'@ will be a (non-strict) superset of the previous value of
    -- @invalid@, see 'validChains', thus no need to union.
    invalid'   :: InvalidBlocks blk
    candidates :: [(Chain blk, ExtLedgerState blk)]
    (InvalidBlocks blk
invalid', [(Chain blk, ExtLedgerState blk)]
candidates) = TopLevelConfig blk
-> Model blk
-> Map (HeaderHash blk) blk
-> (InvalidBlocks blk, [(Chain blk, ExtLedgerState blk)])
forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk
-> Model blk
-> Map (HeaderHash blk) blk
-> (InvalidBlocks blk, [(Chain blk, ExtLedgerState blk)])
validChains TopLevelConfig blk
cfg Model blk
m (Model blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
blocks Model blk
m)

    immutableChainHashes :: [HeaderHash blk]
immutableChainHashes =
        (blk -> HeaderHash blk) -> [blk] -> [HeaderHash blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash
      ([blk] -> [HeaderHash blk])
-> (Chain blk -> [blk]) -> Chain blk -> [HeaderHash blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst
      (Chain blk -> [HeaderHash blk]) -> Chain blk -> [HeaderHash blk]
forall a b. (a -> b) -> a -> b
$ Chain blk
immutableChain'

    immutableChain' :: Chain blk
immutableChain' = SecurityParam -> Model blk -> Chain blk
forall blk. SecurityParam -> Model blk -> Chain blk
immutableChain SecurityParam
secParam Model blk
m

    extendsImmutableChain :: Chain blk -> Bool
    extendsImmutableChain :: Chain blk -> Bool
extendsImmutableChain Chain blk
fork =
      [HeaderHash blk]
immutableChainHashes [HeaderHash blk] -> [HeaderHash blk] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`
      (blk -> HeaderHash blk) -> [blk] -> [HeaderHash blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash (Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain blk
fork)

    -- Note that this includes the currently selected chain, but that does not
    -- influence chain selection via 'selectChain'. Note that duplicates might
    -- be introduced by `trimToLoE` so we deduplicate explicitly here.
    consideredCandidates :: [(Chain blk, ExtLedgerState blk)]
consideredCandidates =
      [(Chain blk, ExtLedgerState blk)]
candidates
        [(Chain blk, ExtLedgerState blk)]
-> ([(Chain blk, ExtLedgerState blk)]
    -> [(Chain blk, ExtLedgerState blk)])
-> [(Chain blk, ExtLedgerState blk)]
forall a b. a -> (a -> b) -> b
& ((Chain blk, ExtLedgerState blk) -> Bool)
-> [(Chain blk, ExtLedgerState blk)]
-> [(Chain blk, ExtLedgerState blk)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Chain blk -> Bool
extendsImmutableChain (Chain blk -> Bool)
-> ((Chain blk, ExtLedgerState blk) -> Chain blk)
-> (Chain blk, ExtLedgerState blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain blk, ExtLedgerState blk) -> Chain blk
forall a b. (a, b) -> a
fst)
        [(Chain blk, ExtLedgerState blk)]
-> ([(Chain blk, ExtLedgerState blk)]
    -> [(Chain blk, ExtLedgerState blk)])
-> [(Chain blk, ExtLedgerState blk)]
forall a b. a -> (a -> b) -> b
& ((Chain blk, ExtLedgerState blk)
 -> (Chain blk, ExtLedgerState blk))
-> [(Chain blk, ExtLedgerState blk)]
-> [(Chain blk, ExtLedgerState blk)]
forall a b. (a -> b) -> [a] -> [b]
map ((Chain blk -> Chain blk)
-> (Chain blk, ExtLedgerState blk)
-> (Chain blk, ExtLedgerState blk)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Chain blk -> Chain blk
trimToLoE)
        [(Chain blk, ExtLedgerState blk)]
-> ([(Chain blk, ExtLedgerState blk)]
    -> [(Chain blk, ExtLedgerState blk)])
-> [(Chain blk, ExtLedgerState blk)]
forall a b. a -> (a -> b) -> b
& ((Chain blk, ExtLedgerState blk) -> Point blk)
-> [(Chain blk, ExtLedgerState blk)]
-> [(Chain blk, ExtLedgerState blk)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (Chain blk -> Point blk
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint (Chain blk -> Point blk)
-> ((Chain blk, ExtLedgerState blk) -> Chain blk)
-> (Chain blk, ExtLedgerState blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain blk, ExtLedgerState blk) -> Chain blk
forall a b. (a, b) -> a
fst)

    currentChain' :: Chain blk
currentChain' = Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain Model blk
m

    -- | Trim a candidate fragment to the LoE fragment.
    --
    -- - A (sanitized) LoE fragment @loe@ is some fragment containing the
    --   immutable tip.
    --
    -- - A candidate fragment @cf@ is valid according to the LoE in one of two
    --   cases:
    --   - @loe@ is an extension of @cf@.
    --   - @cf@ is an extension of @loe@, and @cf@ has at most @k@ blocks after
    --     the tip of loe.
    --
    -- - Trimming a candidate fragment according to the LoE is defined to be the
    --   longest prefix that is valid according to the LoE.
    --
    -- NOTE: It is possible that `trimToLoE a == trimToLoE b` even though `a /=
    -- b` if the longest prefix is the same.
    trimToLoE :: Chain blk -> Chain blk
    trimToLoE :: Chain blk -> Chain blk
trimToLoE Chain blk
candidate =
      case LoE (Chain blk)
loeChain of
        LoE (Chain blk)
LoEDisabled          -> Chain blk
candidate
        LoEEnabled Chain blk
loeChain' ->
          [blk] -> Chain blk
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst ([blk] -> Chain blk) -> [blk] -> Chain blk
forall a b. (a -> b) -> a -> b
$ [blk] -> [Point blk] -> [blk]
go (Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain blk
candidate) [Point blk]
loePoints
          where
            loePoints :: [Point blk]
loePoints = blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint (blk -> Point blk) -> [blk] -> [Point blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain blk
loeChain'
      where
        SecurityParam Word64
k = SecurityParam
secParam

        go :: [blk] -> [Point blk] -> [blk]
        -- The LoE chain is an extension of the candidate, return the candidate.
        go :: [blk] -> [Point blk] -> [blk]
go []           [Point blk]
_loePoints       = []
        -- The candidate is an extension of the LoE chain, return at most the
        -- next k blocks on the candidate.
        go [blk]
blks         []               = IteratorId -> [blk] -> [blk]
forall a. IteratorId -> [a] -> [a]
take (Word64 -> IteratorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k) [blk]
blks
        go (blk
blk : [blk]
blks) (Point blk
pt : [Point blk]
loePoints)
          -- The candidate and the LoE chain agree on the next point, continue
          -- recursively.
          | blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
blk Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
pt         = blk
blk blk -> [blk] -> [blk]
forall a. a -> [a] -> [a]
: [blk] -> [Point blk] -> [blk]
go [blk]
blks [Point blk]
loePoints
          -- The candidate forks off from the LoE chain; stop here.
          | Bool
otherwise                    = []

    -- If the LoE fragment does not intersect with the current volatile chain,
    -- then we use the immutable chain instead.
    loeChain :: LoE (Chain blk)
loeChain =
      Model blk -> LoE (AnchoredFragment blk)
forall blk. Model blk -> LoE (AnchoredFragment blk)
loeFragment Model blk
m LoE (AnchoredFragment blk)
-> (AnchoredFragment blk -> Chain blk) -> LoE (Chain blk)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \AnchoredFragment blk
loeFragment' -> Chain blk -> Maybe (Chain blk) -> Chain blk
forall a. a -> Maybe a -> a
fromMaybe Chain blk
immutableChain' (Maybe (Chain blk) -> Chain blk) -> Maybe (Chain blk) -> Chain blk
forall a b. (a -> b) -> a -> b
$ do
        (AnchoredFragment blk, AnchoredFragment blk, AnchoredFragment blk,
 AnchoredFragment blk)
_ <- AnchoredFragment blk
-> AnchoredFragment blk
-> Maybe
     (AnchoredFragment blk, AnchoredFragment blk, AnchoredFragment blk,
      AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
Fragment.intersect AnchoredFragment blk
volatileFrag AnchoredFragment blk
loeFragment'
        (Point blk
_, AnchoredFragment blk
loeChain') <- AnchoredFragment blk
-> AnchoredFragment blk -> Maybe (Point blk, AnchoredFragment blk)
forall block.
HasHeader block =>
AnchoredFragment block
-> AnchoredFragment block
-> Maybe (Point block, AnchoredFragment block)
Fragment.cross AnchoredFragment blk
currentFrag AnchoredFragment blk
loeFragment'
        AnchoredFragment blk -> Maybe (Chain blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Maybe (Chain block)
Chain.fromAnchoredFragment AnchoredFragment blk
loeChain'
      where
        currentFrag :: AnchoredFragment blk
currentFrag  = Chain blk -> AnchoredFragment blk
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment Chain blk
currentChain'
        volatileFrag :: AnchoredFragment blk
volatileFrag = SecurityParam -> (blk -> blk) -> Model blk -> AnchoredFragment blk
forall a blk.
(HasHeader a, HasHeader blk) =>
SecurityParam -> (blk -> a) -> Model blk -> AnchoredFragment a
volatileChain SecurityParam
secParam blk -> blk
forall a. a -> a
id Model blk
m

    newChain  :: Chain blk
    newLedger :: ExtLedgerState blk
    (Chain blk
newChain, ExtLedgerState blk
newLedger) =
        (Chain blk, ExtLedgerState blk)
-> Maybe (Chain blk, ExtLedgerState blk)
-> (Chain blk, ExtLedgerState blk)
forall a. a -> Maybe a -> a
fromMaybe (Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain Model blk
m, Model blk -> ExtLedgerState blk
forall blk. Model blk -> ExtLedgerState blk
currentLedger Model blk
m)
      (Maybe (Chain blk, ExtLedgerState blk)
 -> (Chain blk, ExtLedgerState blk))
-> ([(Chain blk, ExtLedgerState blk)]
    -> Maybe (Chain blk, ExtLedgerState blk))
-> [(Chain blk, ExtLedgerState blk)]
-> (Chain blk, ExtLedgerState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (BlockProtocol blk)
-> ChainOrderConfig (SelectView (BlockProtocol blk))
-> (blk -> SelectView (BlockProtocol blk))
-> Chain blk
-> [(Chain blk, ExtLedgerState blk)]
-> Maybe (Chain blk, ExtLedgerState blk)
forall (proxy :: * -> *) p hdr l.
ConsensusProtocol p =>
proxy p
-> ChainOrderConfig (SelectView p)
-> (hdr -> SelectView p)
-> Chain hdr
-> [(Chain hdr, l)]
-> Maybe (Chain hdr, l)
selectChain
          (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(BlockProtocol blk))
          (BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
projectChainOrderConfig (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg))
          (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 -> SelectView (BlockProtocol blk))
-> (blk -> Header blk) -> blk -> SelectView (BlockProtocol blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader)
          (Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain Model blk
m)
      ([(Chain blk, ExtLedgerState blk)]
 -> (Chain blk, ExtLedgerState blk))
-> [(Chain blk, ExtLedgerState blk)]
-> (Chain blk, ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ [(Chain blk, ExtLedgerState blk)]
consideredCandidates

    -- We update the set of valid blocks with all valid blocks on all candidate
    -- chains that are considered by the modeled chain selection. This ensures
    -- that the model always knows about more valid blocks than the system under
    -- test. See 'IsValidResult' for more context.
    valid' :: Set (HeaderHash blk)
valid' =
        Model blk -> Set (HeaderHash blk)
forall blk. Model blk -> Set (HeaderHash blk)
valid Model blk
m Set (HeaderHash blk)
-> Set (HeaderHash blk) -> Set (HeaderHash blk)
forall a. Semigroup a => a -> a -> a
<> ((Chain blk, ExtLedgerState blk) -> Set (HeaderHash blk))
-> [(Chain blk, ExtLedgerState blk)] -> Set (HeaderHash blk)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
          ([HeaderHash blk] -> Set (HeaderHash blk)
forall a. Ord a => [a] -> Set a
Set.fromList ([HeaderHash blk] -> Set (HeaderHash blk))
-> ((Chain blk, ExtLedgerState blk) -> [HeaderHash blk])
-> (Chain blk, ExtLedgerState blk)
-> Set (HeaderHash blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk -> HeaderHash blk) -> [blk] -> [HeaderHash blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash ([blk] -> [HeaderHash blk])
-> ((Chain blk, ExtLedgerState blk) -> [blk])
-> (Chain blk, ExtLedgerState blk)
-> [HeaderHash blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst (Chain blk -> [blk])
-> ((Chain blk, ExtLedgerState blk) -> Chain blk)
-> (Chain blk, ExtLedgerState blk)
-> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain blk, ExtLedgerState blk) -> Chain blk
forall a b. (a, b) -> a
fst)
          [(Chain blk, ExtLedgerState blk)]
consideredCandidates

addBlocks :: LedgerSupportsProtocol blk
          => TopLevelConfig blk
          -> [blk]
          -> Model blk -> Model blk
addBlocks :: forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> [blk] -> Model blk -> Model blk
addBlocks TopLevelConfig blk
cfg = (blk -> Model blk -> Model blk) -> [blk] -> Model blk -> Model blk
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly (TopLevelConfig blk -> blk -> Model blk -> Model blk
forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> blk -> Model blk -> Model blk
addBlock TopLevelConfig blk
cfg)

-- | Wrapper around 'addBlock' that returns an 'AddBlockPromise'.
addBlockPromise ::
     forall m blk. (LedgerSupportsProtocol blk, MonadSTM m)
  => TopLevelConfig blk
  -> blk
  -> Model blk
  -> (AddBlockPromise m blk, Model blk)
addBlockPromise :: forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, MonadSTM m) =>
TopLevelConfig blk
-> blk -> Model blk -> (AddBlockPromise m blk, Model blk)
addBlockPromise TopLevelConfig blk
cfg blk
blk Model blk
m = (AddBlockPromise m blk
result, Model blk
m')
  where
    m' :: Model blk
m' = TopLevelConfig blk -> blk -> Model blk -> Model blk
forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> blk -> Model blk -> Model blk
addBlock TopLevelConfig blk
cfg blk
blk Model blk
m
    blockWritten :: Bool
blockWritten = HeaderHash blk -> Map (HeaderHash blk) blk -> 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) (Model blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
blocks Model blk
m)
                Bool -> Bool -> Bool
&& HeaderHash blk -> Map (HeaderHash blk) blk -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member    (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk) (Model blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
blocks Model blk
m')
    result :: AddBlockPromise m blk
result = AddBlockPromise
      { blockWrittenToDisk :: STM m Bool
blockWrittenToDisk = Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
blockWritten
      , blockProcessed :: STM m (AddBlockResult blk)
blockProcessed     = AddBlockResult blk -> STM m (AddBlockResult blk)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddBlockResult blk -> STM m (AddBlockResult blk))
-> AddBlockResult blk -> STM m (AddBlockResult blk)
forall a b. (a -> b) -> a -> b
$ Point blk -> AddBlockResult blk
forall blk. Point blk -> AddBlockResult blk
SuccesfullyAddedBlock (Point blk -> AddBlockResult blk)
-> Point blk -> AddBlockResult blk
forall a b. (a -> b) -> a -> b
$ Model blk -> Point blk
forall blk. HasHeader blk => Model blk -> Point blk
tipPoint Model blk
m'
      }

-- | Update the LoE fragment, trigger chain selection and return the new tip
-- point.
updateLoE ::
     forall blk. LedgerSupportsProtocol blk
  => TopLevelConfig blk
  -> AnchoredFragment blk
  -> Model blk
  -> (Point blk, Model blk)
updateLoE :: forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk
-> AnchoredFragment blk -> Model blk -> (Point blk, Model blk)
updateLoE TopLevelConfig blk
cfg AnchoredFragment blk
f Model blk
m = (Model blk -> Point blk
forall blk. HasHeader blk => Model blk -> Point blk
tipPoint Model blk
m', Model blk
m')
  where
    m' :: Model blk
m' = TopLevelConfig blk -> Model blk -> Model blk
forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> Model blk -> Model blk
chainSelection TopLevelConfig blk
cfg (Model blk -> Model blk) -> Model blk -> Model blk
forall a b. (a -> b) -> a -> b
$ Model blk
m {loeFragment = loeFragment m $> f}

{-------------------------------------------------------------------------------
  Iterators
-------------------------------------------------------------------------------}

stream ::
     GetPrevHash blk
  => SecurityParam
  -> StreamFrom  blk
  -> StreamTo    blk
  -> Model       blk
  -> Either (ChainDbError blk)
            (Either (UnknownRange blk) IteratorId, Model blk)
stream :: forall blk.
GetPrevHash blk =>
SecurityParam
-> StreamFrom blk
-> StreamTo blk
-> Model blk
-> Either
     (ChainDbError blk)
     (Either (UnknownRange blk) IteratorId, Model blk)
stream SecurityParam
securityParam StreamFrom blk
from StreamTo blk
to Model blk
m = do
    Bool
-> Either (ChainDbError blk) () -> Either (ChainDbError blk) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (StreamFrom blk -> StreamTo blk -> Bool
forall blk.
StandardHash blk =>
StreamFrom blk -> StreamTo blk -> Bool
validBounds StreamFrom blk
from StreamTo blk
to) (Either (ChainDbError blk) () -> Either (ChainDbError blk) ())
-> Either (ChainDbError blk) () -> Either (ChainDbError blk) ()
forall a b. (a -> b) -> a -> b
$ ChainDbError blk -> Either (ChainDbError blk) ()
forall a b. a -> Either a b
Left (StreamFrom blk -> StreamTo blk -> ChainDbError blk
forall blk. StreamFrom blk -> StreamTo blk -> ChainDbError blk
InvalidIteratorRange StreamFrom blk
from StreamTo blk
to)
    case SecurityParam
-> StreamFrom blk
-> StreamTo blk
-> Model blk
-> Either (UnknownRange blk) [blk]
forall blk.
GetPrevHash blk =>
SecurityParam
-> StreamFrom blk
-> StreamTo blk
-> Model blk
-> Either (UnknownRange blk) [blk]
between SecurityParam
securityParam StreamFrom blk
from StreamTo blk
to Model blk
m of
      Left  UnknownRange blk
e    -> (Either (UnknownRange blk) IteratorId, Model blk)
-> Either
     (ChainDbError blk)
     (Either (UnknownRange blk) IteratorId, Model blk)
forall a. a -> Either (ChainDbError blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnknownRange blk -> Either (UnknownRange blk) IteratorId
forall a b. a -> Either a b
Left UnknownRange blk
e,      Model blk
m)
      Right [blk]
blks -> (Either (UnknownRange blk) IteratorId, Model blk)
-> Either
     (ChainDbError blk)
     (Either (UnknownRange blk) IteratorId, Model blk)
forall a. a -> Either (ChainDbError blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IteratorId -> Either (UnknownRange blk) IteratorId
forall a b. b -> Either a b
Right IteratorId
itrId, Model blk
m {
          iterators = Map.insert itrId blks (iterators m)
        })
  where
    itrId :: IteratorId
    itrId :: IteratorId
itrId = Map IteratorId [blk] -> IteratorId
forall k a. Map k a -> IteratorId
Map.size (Model blk -> Map IteratorId [blk]
forall blk. Model blk -> Map IteratorId [blk]
iterators Model blk
m) -- we never delete iterators

iteratorNext ::
     ModelSupportsBlock blk
  => IteratorId
  -> BlockComponent blk b
  -> Model blk
  -> (IteratorResult blk b, Model blk)
iteratorNext :: forall blk b.
ModelSupportsBlock blk =>
IteratorId
-> BlockComponent blk b
-> Model blk
-> (IteratorResult blk b, Model blk)
iteratorNext IteratorId
itrId BlockComponent blk b
blockComponent Model blk
m =
  case IteratorId -> Map IteratorId [blk] -> Maybe [blk]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup IteratorId
itrId (Model blk -> Map IteratorId [blk]
forall blk. Model blk -> Map IteratorId [blk]
iterators Model blk
m) of
    Just []                                         ->
      ( IteratorResult blk b
forall blk b. IteratorResult blk b
IteratorExhausted, Model blk
m )
    Just (blk
b:[blk]
bs) | blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
b HeaderHash blk -> Map (HeaderHash blk) blk -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Model blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
blocks Model blk
m ->
      ( b -> IteratorResult blk b
forall blk b. b -> IteratorResult blk b
IteratorResult (b -> IteratorResult blk b) -> b -> IteratorResult blk b
forall a b. (a -> b) -> a -> b
$ blk -> BlockComponent blk b -> b
forall blk b.
ModelSupportsBlock blk =>
blk -> BlockComponent blk b -> b
getBlockComponent blk
b BlockComponent blk b
blockComponent, [blk] -> Model blk
updateIter [blk]
bs )
      -- The next block `b` was part of a dead fork and has been garbage
      -- collected.  The system-under-test then closes the iterator, and we set
      -- the state of the iterator to the empty list to mimic that behaviour.
    Just (blk
b:[blk]
_)                                     ->
      ( RealPoint blk -> IteratorResult blk b
forall blk b. RealPoint blk -> IteratorResult blk b
IteratorBlockGCed (RealPoint blk -> IteratorResult blk b)
-> RealPoint blk -> IteratorResult blk b
forall a b. (a -> b) -> a -> b
$ blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b, [blk] -> Model blk
updateIter [] )
    Maybe [blk]
Nothing                                         ->
      String -> (IteratorResult blk b, Model blk)
forall a. HasCallStack => String -> a
error String
"iteratorNext: unknown iterator ID"
  where
    updateIter :: [blk] -> Model blk
updateIter [blk]
bs = Model blk
m { iterators = Map.insert itrId bs (iterators m) }

getBlockComponent ::
     forall blk b. ModelSupportsBlock blk
  => blk -> BlockComponent blk b -> b
getBlockComponent :: forall blk b.
ModelSupportsBlock blk =>
blk -> BlockComponent blk b -> b
getBlockComponent blk
blk = \case
    BlockComponent blk b
GetVerifiedBlock -> blk
b
blk  -- We don't verify it
    BlockComponent blk b
GetBlock         -> blk
b
blk
    BlockComponent blk b
GetRawBlock      -> blk -> ByteString
forall a. Serialise a => a -> ByteString
serialise blk
blk

    BlockComponent blk b
GetHeader        -> blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk
    BlockComponent blk b
GetRawHeader     -> Header blk -> ByteString
forall a. Serialise a => a -> ByteString
serialise (Header blk -> ByteString) -> Header blk -> ByteString
forall a b. (a -> b) -> a -> b
$ blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk

    BlockComponent blk b
GetHash          -> blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk
    BlockComponent blk b
GetSlot          -> blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk
    BlockComponent blk b
GetIsEBB         -> Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk)
    BlockComponent blk b
GetBlockSize     -> Int64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> b) -> Int64 -> b
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
Lazy.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ blk -> ByteString
forall a. Serialise a => a -> ByteString
serialise blk
blk
    BlockComponent blk b
GetHeaderSize    -> Int64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> b) -> Int64 -> b
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
Lazy.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Header blk -> ByteString
forall a. Serialise a => a -> ByteString
serialise (Header blk -> ByteString) -> Header blk -> ByteString
forall a b. (a -> b) -> a -> b
$ blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk
    BlockComponent blk b
GetNestedCtxt    -> case Header blk -> DepPair (NestedCtxt Header blk)
forall (f :: * -> *) blk.
HasNestedContent f blk =>
f blk -> DepPair (NestedCtxt f blk)
unnest (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk) of
                          DepPair NestedCtxt Header blk a
nestedCtxt a
_ -> NestedCtxt Header blk a -> SomeSecond (NestedCtxt Header) blk
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond NestedCtxt Header blk a
nestedCtxt
    GetPure b
a        -> b
a
    GetApply BlockComponent blk (a1 -> b)
f BlockComponent blk a1
bc    -> blk -> BlockComponent blk (a1 -> b) -> a1 -> b
forall blk b.
ModelSupportsBlock blk =>
blk -> BlockComponent blk b -> b
getBlockComponent blk
blk BlockComponent blk (a1 -> b)
f (a1 -> b) -> a1 -> b
forall a b. (a -> b) -> a -> b
$ blk -> BlockComponent blk a1 -> a1
forall blk b.
ModelSupportsBlock blk =>
blk -> BlockComponent blk b -> b
getBlockComponent blk
blk BlockComponent blk a1
bc

-- We never delete iterators such that we can use the size of the map as the
-- next iterator id.
iteratorClose :: IteratorId -> Model blk -> Model blk
iteratorClose :: forall blk. IteratorId -> Model blk -> Model blk
iteratorClose IteratorId
itrId Model blk
m = Model blk
m { iterators = Map.insert itrId [] (iterators m) }

{-------------------------------------------------------------------------------
  Followers
-------------------------------------------------------------------------------}

followerExists :: CPS.FollowerId -> Model blk -> Bool
followerExists :: forall blk. IteratorId -> Model blk -> Bool
followerExists IteratorId
flrId = IteratorId -> ChainProducerState blk -> Bool
forall block. IteratorId -> ChainProducerState block -> Bool
CPS.followerExists IteratorId
flrId (ChainProducerState blk -> Bool)
-> (Model blk -> ChainProducerState blk) -> Model blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> ChainProducerState blk
forall blk. Model blk -> ChainProducerState blk
cps

checkIfFollowerExists ::
     CPS.FollowerId
  -> Model blk
  -> a
  -> Either (ChainDbError blk) a
checkIfFollowerExists :: forall blk a.
IteratorId -> Model blk -> a -> Either (ChainDbError blk) a
checkIfFollowerExists IteratorId
flrId Model blk
m a
a
    | IteratorId -> Model blk -> Bool
forall blk. IteratorId -> Model blk -> Bool
followerExists IteratorId
flrId Model blk
m
    = a -> Either (ChainDbError blk) a
forall a b. b -> Either a b
Right a
a
    | Bool
otherwise
    = ChainDbError blk -> Either (ChainDbError blk) a
forall a b. a -> Either a b
Left ChainDbError blk
forall blk. ChainDbError blk
ClosedFollowerError

newFollower :: HasHeader blk => Model blk -> (CPS.FollowerId, Model blk)
newFollower :: forall blk. HasHeader blk => Model blk -> (IteratorId, Model blk)
newFollower Model blk
m = (IteratorId
flrId, Model blk
m { cps = cps' })
  where
    (ChainProducerState blk
cps', IteratorId
flrId) = Point blk
-> ChainProducerState blk -> (ChainProducerState blk, IteratorId)
forall block.
HasHeader block =>
Point block
-> ChainProducerState block
-> (ChainProducerState block, IteratorId)
CPS.initFollower Point blk
forall {k} (block :: k). Point block
GenesisPoint (Model blk -> ChainProducerState blk
forall blk. Model blk -> ChainProducerState blk
cps Model blk
m)

followerInstruction ::
     forall blk b. ModelSupportsBlock blk
  => CPS.FollowerId
  -> BlockComponent blk b
  -> Model blk
  -> Either (ChainDbError blk)
            (Maybe (ChainUpdate blk b), Model blk)
followerInstruction :: forall blk b.
ModelSupportsBlock blk =>
IteratorId
-> BlockComponent blk b
-> Model blk
-> Either (ChainDbError blk) (Maybe (ChainUpdate blk b), Model blk)
followerInstruction IteratorId
flrId BlockComponent blk b
blockComponent Model blk
m = IteratorId
-> Model blk
-> (Maybe (ChainUpdate blk b), Model blk)
-> Either (ChainDbError blk) (Maybe (ChainUpdate blk b), Model blk)
forall blk a.
IteratorId -> Model blk -> a -> Either (ChainDbError blk) a
checkIfFollowerExists IteratorId
flrId Model blk
m ((Maybe (ChainUpdate blk b), Model blk)
 -> Either
      (ChainDbError blk) (Maybe (ChainUpdate blk b), Model blk))
-> (Maybe (ChainUpdate blk b), Model blk)
-> Either (ChainDbError blk) (Maybe (ChainUpdate blk b), Model blk)
forall a b. (a -> b) -> a -> b
$
    Maybe (ChainUpdate blk blk, ChainProducerState blk)
-> (Maybe (ChainUpdate blk b), Model blk)
rewrap (Maybe (ChainUpdate blk blk, ChainProducerState blk)
 -> (Maybe (ChainUpdate blk b), Model blk))
-> Maybe (ChainUpdate blk blk, ChainProducerState blk)
-> (Maybe (ChainUpdate blk b), Model blk)
forall a b. (a -> b) -> a -> b
$ IteratorId
-> ChainProducerState blk
-> Maybe (ChainUpdate blk blk, ChainProducerState blk)
forall block.
HasHeader block =>
IteratorId
-> ChainProducerState block
-> Maybe (ChainUpdate block block, ChainProducerState block)
CPS.followerInstruction IteratorId
flrId (Model blk -> ChainProducerState blk
forall blk. Model blk -> ChainProducerState blk
cps Model blk
m)
  where
    toB :: blk -> b
    toB :: blk -> b
toB blk
blk = blk -> BlockComponent blk b -> b
forall blk b.
ModelSupportsBlock blk =>
blk -> BlockComponent blk b -> b
getBlockComponent blk
blk BlockComponent blk b
blockComponent

    rewrap
      :: Maybe (ChainUpdate blk blk, CPS.ChainProducerState blk)
      -> (Maybe (ChainUpdate blk b), Model blk)
    rewrap :: Maybe (ChainUpdate blk blk, ChainProducerState blk)
-> (Maybe (ChainUpdate blk b), Model blk)
rewrap Maybe (ChainUpdate blk blk, ChainProducerState blk)
Nothing            = (Maybe (ChainUpdate blk b)
forall a. Maybe a
Nothing, Model blk
m)
    rewrap (Just (ChainUpdate blk blk
upd, ChainProducerState blk
cps')) = (ChainUpdate blk b -> Maybe (ChainUpdate blk b)
forall a. a -> Maybe a
Just (blk -> b
toB (blk -> b) -> ChainUpdate blk blk -> ChainUpdate blk b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainUpdate blk blk
upd), Model blk
m { cps = cps' })

followerForward ::
     HasHeader blk
  => CPS.FollowerId
  -> [Point blk]
  -> Model blk
  -> Either (ChainDbError blk) (Maybe (Point blk), Model blk)
followerForward :: forall blk.
HasHeader blk =>
IteratorId
-> [Point blk]
-> Model blk
-> Either (ChainDbError blk) (Maybe (Point blk), Model blk)
followerForward IteratorId
flrId [Point blk]
points Model blk
m = IteratorId
-> Model blk
-> (Maybe (Point blk), Model blk)
-> Either (ChainDbError blk) (Maybe (Point blk), Model blk)
forall blk a.
IteratorId -> Model blk -> a -> Either (ChainDbError blk) a
checkIfFollowerExists IteratorId
flrId Model blk
m ((Maybe (Point blk), Model blk)
 -> Either (ChainDbError blk) (Maybe (Point blk), Model blk))
-> (Maybe (Point blk), Model blk)
-> Either (ChainDbError blk) (Maybe (Point blk), Model blk)
forall a b. (a -> b) -> a -> b
$
    case [Point blk] -> ChainProducerState blk -> Maybe (Point blk)
forall block.
HasHeader block =>
[Point block] -> ChainProducerState block -> Maybe (Point block)
CPS.findFirstPoint [Point blk]
points (Model blk -> ChainProducerState blk
forall blk. Model blk -> ChainProducerState blk
cps Model blk
m) of
      Maybe (Point blk)
Nothing     -> (Maybe (Point blk)
forall a. Maybe a
Nothing, Model blk
m)
      Just Point blk
ipoint -> (Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just Point blk
ipoint, Model blk
m { cps = cps' })
        where
          cps' :: ChainProducerState blk
cps' = IteratorId
-> Point blk -> ChainProducerState blk -> ChainProducerState blk
forall block.
HasHeader block =>
IteratorId
-> Point block
-> ChainProducerState block
-> ChainProducerState block
CPS.updateFollower IteratorId
flrId Point blk
ipoint (Model blk -> ChainProducerState blk
forall blk. Model blk -> ChainProducerState blk
cps Model blk
m)

followerClose ::
     CPS.FollowerId
  -> Model blk
  -> Model blk
followerClose :: forall blk. IteratorId -> Model blk -> Model blk
followerClose IteratorId
flrId Model blk
m
    | IteratorId -> Model blk -> Bool
forall blk. IteratorId -> Model blk -> Bool
followerExists IteratorId
flrId Model blk
m
    = Model blk
m { cps = CPS.deleteFollower flrId (cps m) }
    | Bool
otherwise
    = Model blk
m

{-------------------------------------------------------------------------------
  ModelSupportsBlock
-------------------------------------------------------------------------------}

-- | Functionality the block needs to support so that it can be used in the
-- 'Model'.
class ( HasHeader blk
      , GetHeader blk
      , HasHeader (Header blk)
      , Serialise blk
      , Serialise (Header blk)
      , HasNestedContent Header blk
      ) => ModelSupportsBlock blk

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

type InvalidBlocks blk = Map (HeaderHash blk) (ExtValidationError blk, SlotNo)

-- | Result of 'validate', also used internally.
data ValidatedChain blk =
    ValidatedChain
      (Chain blk)           -- ^ Valid prefix
      (ExtLedgerState blk)  -- ^ Corresponds to the tip of the valid prefix
      (InvalidBlocks blk)   -- ^ Invalid blocks encountered while validating
                            -- the candidate chain.

-- | Validate the given 'Chain'.
--
-- The 'InvalidBlocks' in the returned 'ValidatedChain' will be >= the
-- 'invalid' of the given 'Model'.
validate :: forall blk. LedgerSupportsProtocol blk
         => TopLevelConfig blk
         -> Model blk
         -> Chain blk
         -> ValidatedChain blk
validate :: forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> Model blk -> Chain blk -> ValidatedChain blk
validate TopLevelConfig blk
cfg Model { ExtLedgerState blk
initLedger :: forall blk. Model blk -> ExtLedgerState blk
initLedger :: ExtLedgerState blk
initLedger, Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
invalid :: forall blk. Model blk -> InvalidBlocks blk
invalid :: Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
invalid } Chain blk
chain =
    ExtLedgerState blk -> Chain blk -> [blk] -> ValidatedChain blk
go ExtLedgerState blk
initLedger Chain blk
forall block. Chain block
Genesis (Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain blk
chain)
  where
    mkInvalid :: blk -> ExtValidationError blk -> InvalidBlocks blk
    mkInvalid :: blk
-> ExtValidationError blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
mkInvalid blk
b ExtValidationError blk
reason =
      HeaderHash blk
-> (ExtValidationError blk, SlotNo)
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
forall k a. k -> a -> Map k a
Map.singleton (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
b) (ExtValidationError blk
reason, blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
b)

    go :: ExtLedgerState blk  -- ^ Corresponds to the tip of the valid prefix
       -> Chain blk           -- ^ Valid prefix
       -> [blk]               -- ^ Remaining blocks to validate
       -> ValidatedChain blk
    go :: ExtLedgerState blk -> Chain blk -> [blk] -> ValidatedChain blk
go ExtLedgerState blk
ledger Chain blk
validPrefix = \case
      -- Return 'mbFinal' if it contains an "earlier" result
      []    -> Chain blk
-> ExtLedgerState blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
-> ValidatedChain blk
forall blk.
Chain blk
-> ExtLedgerState blk -> InvalidBlocks blk -> ValidatedChain blk
ValidatedChain Chain blk
validPrefix ExtLedgerState blk
ledger Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
invalid
      blk
b:[blk]
bs' -> case Except (ExtValidationError blk) (ExtLedgerState blk)
-> Either (ExtValidationError blk) (ExtLedgerState blk)
forall e a. Except e a -> Either e a
runExcept (LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk
-> Except (LedgerErr (ExtLedgerState blk)) (ExtLedgerState blk)
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply (TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg) blk
b ExtLedgerState blk
ledger) of
        -- Invalid block according to the ledger
        Left ExtValidationError blk
e
          -> Chain blk
-> ExtLedgerState blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
-> ValidatedChain blk
forall blk.
Chain blk
-> ExtLedgerState blk -> InvalidBlocks blk -> ValidatedChain blk
ValidatedChain
               Chain blk
validPrefix
               ExtLedgerState blk
ledger
               (Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
invalid Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
forall a. Semigroup a => a -> a -> a
<> blk
-> ExtValidationError blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
mkInvalid blk
b ExtValidationError blk
e)

        -- Valid block according to the ledger
        Right ExtLedgerState blk
ledger'

          -- But the block has been recorded as an invalid block. It must be
          -- that it exceeded the clock skew in the past.
          | HeaderHash blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
b) Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
invalid
          -> Chain blk
-> ExtLedgerState blk
-> Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
-> ValidatedChain blk
forall blk.
Chain blk
-> ExtLedgerState blk -> InvalidBlocks blk -> ValidatedChain blk
ValidatedChain Chain blk
validPrefix ExtLedgerState blk
ledger Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
invalid

          -- This is the good path
          | Bool
otherwise
          -> ExtLedgerState blk -> Chain blk -> [blk] -> ValidatedChain blk
go ExtLedgerState blk
ledger' (Chain blk
validPrefix Chain blk -> blk -> Chain blk
forall block. Chain block -> block -> Chain block
:> blk
b) [blk]
bs'

chains :: forall blk. (GetPrevHash blk)
       => Map (HeaderHash blk) blk -> [Chain blk]
chains :: forall blk.
GetPrevHash blk =>
Map (HeaderHash blk) blk -> [Chain blk]
chains Map (HeaderHash blk) blk
bs = Chain blk -> [Chain blk]
go Chain blk
forall block. Chain block
Chain.Genesis
  where
    -- Construct chains,
    go :: Chain blk -> [Chain blk]
    go :: Chain blk -> [Chain blk]
go Chain blk
ch | [Chain blk] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Chain blk]
extensions = [Chain blk
ch]
          | Bool
otherwise       = [Chain blk]
extensions
          -- If we can extend the chain, don't include the chain itself. See
          -- the property "Always Extend".
      where
        extensions :: [Chain blk]
        extensions :: [Chain blk]
extensions = [[Chain blk]] -> [Chain blk]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Chain blk -> [Chain blk]
go (Chain blk
ch Chain blk -> blk -> Chain blk
forall block. Chain block -> block -> Chain block
:> blk
b) | blk
b <- [blk]
succs]

        succs :: [blk]
        succs :: [blk]
succs = 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
$
          Map (HeaderHash blk) blk
-> ChainHash blk
-> Map (ChainHash blk) (Map (HeaderHash blk) blk)
-> Map (HeaderHash blk) blk
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map (HeaderHash blk) blk
forall k a. Map k a
Map.empty (Chain blk -> ChainHash blk
forall block. HasHeader block => Chain block -> ChainHash block
Chain.headHash Chain blk
ch) Map (ChainHash blk) (Map (HeaderHash blk) blk)
fwd

    fwd :: Map (ChainHash blk) (Map (HeaderHash blk) blk)
    fwd :: Map (ChainHash blk) (Map (HeaderHash blk) blk)
fwd = [blk] -> Map (ChainHash blk) (Map (HeaderHash blk) blk)
forall blk.
GetPrevHash blk =>
[blk] -> Map (ChainHash blk) (Map (HeaderHash blk) blk)
successors (Map (HeaderHash blk) blk -> [blk]
forall k a. Map k a -> [a]
Map.elems Map (HeaderHash blk) blk
bs)

validChains :: forall blk. LedgerSupportsProtocol blk
            => TopLevelConfig blk
            -> Model blk
            -> Map (HeaderHash blk) blk
            -> (InvalidBlocks blk, [(Chain blk, ExtLedgerState blk)])
validChains :: forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk
-> Model blk
-> Map (HeaderHash blk) blk
-> (InvalidBlocks blk, [(Chain blk, ExtLedgerState blk)])
validChains TopLevelConfig blk
cfg Model blk
m Map (HeaderHash blk) blk
bs =
    (Chain blk
 -> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
     [(Chain blk, ExtLedgerState blk)]))
-> [Chain blk]
-> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
    [(Chain blk, ExtLedgerState blk)])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ValidatedChain blk
-> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
    [(Chain blk, ExtLedgerState blk)])
classify (ValidatedChain blk
 -> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
     [(Chain blk, ExtLedgerState blk)]))
-> (Chain blk -> ValidatedChain blk)
-> Chain blk
-> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
    [(Chain blk, ExtLedgerState blk)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig blk -> Model blk -> Chain blk -> ValidatedChain blk
forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> Model blk -> Chain blk -> ValidatedChain blk
validate TopLevelConfig blk
cfg Model blk
m) ([Chain blk]
 -> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
     [(Chain blk, ExtLedgerState blk)]))
-> [Chain blk]
-> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
    [(Chain blk, ExtLedgerState blk)])
forall a b. (a -> b) -> a -> b
$
    -- Note that we sort here to make sure we pick the same chain as the real
    -- chain selection in case there are multiple equally preferable chains
    -- after detecting invalid blocks. For example:
    --
    -- We add the following blocks: B, B', C', A where C' is invalid. Without
    -- sorting here (in the model), this results in the following two
    -- unvalidated chains: A->B and A->B'->C'. After validation, this results
    -- in the following two validated chains: A->B and A->B'. The first of
    -- these two will be chosen.
    --
    -- In the real implementation, we sort the candidate chains before
    -- validation so that in the best case (no invalid blocks) we only have to
    -- validate the most preferable candidate chain. So A->B'->C' is validated
    -- first, which results in the valid chain A->B', which is then chosen
    -- over the equally preferable A->B as it will be the first in the list
    -- after a stable sort.
    [Chain blk] -> [Chain blk]
sortChains ([Chain blk] -> [Chain blk]) -> [Chain blk] -> [Chain blk]
forall a b. (a -> b) -> a -> b
$ Map (HeaderHash blk) blk -> [Chain blk]
forall blk.
GetPrevHash blk =>
Map (HeaderHash blk) blk -> [Chain blk]
chains Map (HeaderHash blk) blk
bs
  where
    sortChains :: [Chain blk] -> [Chain blk]
    sortChains :: [Chain blk] -> [Chain blk]
sortChains =
      (Chain blk -> Chain blk -> Ordering) -> [Chain blk] -> [Chain blk]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Chain blk -> Chain blk -> Ordering)
 -> [Chain blk] -> [Chain blk])
-> (Chain blk -> Chain blk -> Ordering)
-> [Chain blk]
-> [Chain blk]
forall a b. (a -> b) -> a -> b
$ (Chain blk -> Chain blk -> Ordering)
-> Chain blk -> Chain blk -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (
               BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
Fragment.compareAnchoredFragments (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg)
          (AnchoredFragment (Header blk)
 -> AnchoredFragment (Header blk) -> Ordering)
-> (Chain blk -> AnchoredFragment (Header blk))
-> Chain blk
-> Chain blk
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Chain (Header blk) -> AnchoredFragment (Header blk)
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment (Chain (Header blk) -> AnchoredFragment (Header blk))
-> (Chain blk -> Chain (Header blk))
-> Chain blk
-> AnchoredFragment (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk -> Header blk) -> Chain blk -> Chain (Header blk)
forall a b. (a -> b) -> Chain a -> Chain 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)
        )

    classify :: ValidatedChain blk
             -> (InvalidBlocks blk, [(Chain blk, ExtLedgerState blk)])
    classify :: ValidatedChain blk
-> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
    [(Chain blk, ExtLedgerState blk)])
classify (ValidatedChain Chain blk
chain ExtLedgerState blk
ledger Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
invalid) =
      (Map (HeaderHash blk) (ExtValidationError blk, SlotNo)
invalid, [(Chain blk
chain, ExtLedgerState blk
ledger)])

-- Map (HeaderHash blk) blk maps a block's hash to the block itself
successors :: forall blk. GetPrevHash blk
           => [blk]
           -> Map (ChainHash blk) (Map (HeaderHash blk) blk)
successors :: forall blk.
GetPrevHash blk =>
[blk] -> Map (ChainHash blk) (Map (HeaderHash blk) blk)
successors = (Map (HeaderHash blk) blk
 -> Map (HeaderHash blk) blk -> Map (HeaderHash blk) blk)
-> [Map (ChainHash blk) (Map (HeaderHash blk) blk)]
-> Map (ChainHash blk) (Map (HeaderHash blk) blk)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Map (HeaderHash blk) blk
-> Map (HeaderHash blk) blk -> Map (HeaderHash blk) blk
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([Map (ChainHash blk) (Map (HeaderHash blk) blk)]
 -> Map (ChainHash blk) (Map (HeaderHash blk) blk))
-> ([blk] -> [Map (ChainHash blk) (Map (HeaderHash blk) blk)])
-> [blk]
-> Map (ChainHash blk) (Map (HeaderHash blk) blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk -> Map (ChainHash blk) (Map (HeaderHash blk) blk))
-> [blk] -> [Map (ChainHash blk) (Map (HeaderHash blk) blk)]
forall a b. (a -> b) -> [a] -> [b]
map blk -> Map (ChainHash blk) (Map (HeaderHash blk) blk)
single
  where
    single :: blk -> Map (ChainHash blk) (Map (HeaderHash blk) blk)
    single :: blk -> Map (ChainHash blk) (Map (HeaderHash blk) blk)
single blk
b = ChainHash blk
-> Map (HeaderHash blk) blk
-> Map (ChainHash blk) (Map (HeaderHash blk) blk)
forall k a. k -> a -> Map k a
Map.singleton (blk -> ChainHash blk
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash blk
b)
                             (HeaderHash blk -> blk -> Map (HeaderHash blk) blk
forall k a. k -> a -> Map k a
Map.singleton (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
b) blk
b)

between :: forall blk. GetPrevHash blk
        => SecurityParam
        -> StreamFrom  blk
        -> StreamTo    blk
        -> Model       blk
        -> Either (UnknownRange blk) [blk]
between :: forall blk.
GetPrevHash blk =>
SecurityParam
-> StreamFrom blk
-> StreamTo blk
-> Model blk
-> Either (UnknownRange blk) [blk]
between SecurityParam
k StreamFrom blk
from StreamTo blk
to Model blk
m = do
    AnchoredFragment blk
fork <- Either (UnknownRange blk) (AnchoredFragment blk)
errFork
    -- See #871.
    if AnchoredFragment blk -> Bool
partOfCurrentChain AnchoredFragment blk
fork Bool -> Bool -> Bool
||
       Word64 -> AnchoredFragment blk -> AnchoredFragment blk -> Bool
forall b.
HasHeader b =>
Word64 -> AnchoredFragment b -> AnchoredFragment b -> Bool
Fragment.forksAtMostKBlocks (SecurityParam -> Model blk -> Word64
forall blk. HasHeader blk => SecurityParam -> Model blk -> Word64
maxActualRollback SecurityParam
k Model blk
m) AnchoredFragment blk
currentFrag AnchoredFragment blk
fork
      then [blk] -> Either (UnknownRange blk) [blk]
forall a. a -> Either (UnknownRange blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([blk] -> Either (UnknownRange blk) [blk])
-> [blk] -> Either (UnknownRange blk) [blk]
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
Fragment.toOldestFirst AnchoredFragment blk
fork
           -- We cannot stream from an old fork
      else UnknownRange blk -> Either (UnknownRange blk) [blk]
forall a b. a -> Either a b
Left (UnknownRange blk -> Either (UnknownRange blk) [blk])
-> UnknownRange blk -> Either (UnknownRange blk) [blk]
forall a b. (a -> b) -> a -> b
$ StreamFrom blk -> UnknownRange blk
forall blk. StreamFrom blk -> UnknownRange blk
ForkTooOld StreamFrom blk
from
  where
    currentFrag :: AnchoredFragment blk
    currentFrag :: AnchoredFragment blk
currentFrag = Chain blk -> AnchoredFragment blk
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment (Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain Model blk
m)

    partOfCurrentChain :: AnchoredFragment blk -> Bool
    partOfCurrentChain :: AnchoredFragment blk -> Bool
partOfCurrentChain AnchoredFragment blk
fork =
      (blk -> Point blk) -> [blk] -> [Point blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint (AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
Fragment.toOldestFirst AnchoredFragment blk
fork) [Point blk] -> [Point blk] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`
      (blk -> Point blk) -> [blk] -> [Point blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint (Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst (Model blk -> Chain blk
forall blk. Model blk -> Chain blk
currentChain Model blk
m))

    -- A fragment for each possible chain in the database
    fragments :: [AnchoredFragment blk]
    fragments :: [AnchoredFragment blk]
fragments = (Chain blk -> AnchoredFragment blk)
-> [Chain blk] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
map Chain blk -> AnchoredFragment blk
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment
              ([Chain blk] -> [AnchoredFragment blk])
-> (Model blk -> [Chain blk])
-> Model blk
-> [AnchoredFragment blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (HeaderHash blk) blk -> [Chain blk]
forall blk.
GetPrevHash blk =>
Map (HeaderHash blk) blk -> [Chain blk]
chains
              (Map (HeaderHash blk) blk -> [Chain blk])
-> (Model blk -> Map (HeaderHash blk) blk)
-> Model blk
-> [Chain blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
blocks
              (Model blk -> [AnchoredFragment blk])
-> Model blk -> [AnchoredFragment blk]
forall a b. (a -> b) -> a -> b
$ Model blk
m

    -- The fork that contained the start and end point, i.e. the fork to
    -- stream from. This relies on the fact that each block uniquely
    -- determines its prefix.
    errFork :: Either (UnknownRange blk) (AnchoredFragment blk)
    errFork :: Either (UnknownRange blk) (AnchoredFragment blk)
errFork = do
      -- The error refers to @to@, because if the list is empty, @to@ was not
      -- found on any chain
      let err :: UnknownRange blk
err = RealPoint blk -> UnknownRange blk
forall blk. RealPoint blk -> UnknownRange blk
MissingBlock (RealPoint blk -> UnknownRange blk)
-> RealPoint blk -> UnknownRange blk
forall a b. (a -> b) -> a -> b
$ case StreamTo blk
to of
            StreamToInclusive RealPoint blk
p -> RealPoint blk
p
      -- Note that any chain that contained @to@, must have an identical
      -- prefix because the hashes of the blocks enforce this. So we can just
      -- pick any fork.
      AnchoredFragment blk
afterTo <- [Either (UnknownRange blk) (AnchoredFragment blk)]
-> UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
anyFork ((AnchoredFragment blk
 -> Either (UnknownRange blk) (AnchoredFragment blk))
-> [AnchoredFragment blk]
-> [Either (UnknownRange blk) (AnchoredFragment blk)]
forall a b. (a -> b) -> [a] -> [b]
map AnchoredFragment blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
cutOffAfterTo [AnchoredFragment blk]
fragments) UnknownRange blk
err
      AnchoredFragment blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
cutOffBeforeFrom AnchoredFragment blk
afterTo

    -- Select the first 'Right' in the list, otherwise return the last 'Left'.
    -- If the list is empty, return the error given as second argument.
    --
    -- See 'errFork' for why it doesn't matter which fork we return.
    anyFork :: [Either (UnknownRange blk) (AnchoredFragment blk)]
            ->  UnknownRange blk
            ->  Either (UnknownRange blk) (AnchoredFragment blk)
    anyFork :: [Either (UnknownRange blk) (AnchoredFragment blk)]
-> UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
anyFork (Right AnchoredFragment blk
f : [Either (UnknownRange blk) (AnchoredFragment blk)]
_ ) UnknownRange blk
_ = AnchoredFragment blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a b. b -> Either a b
Right AnchoredFragment blk
f
    anyFork (Left  UnknownRange blk
u : []) UnknownRange blk
_ = UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a b. a -> Either a b
Left UnknownRange blk
u
    anyFork (Left  UnknownRange blk
_ : [Either (UnknownRange blk) (AnchoredFragment blk)]
fs) UnknownRange blk
e = [Either (UnknownRange blk) (AnchoredFragment blk)]
-> UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
anyFork [Either (UnknownRange blk) (AnchoredFragment blk)]
fs UnknownRange blk
e
    anyFork []             UnknownRange blk
e = UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a b. a -> Either a b
Left UnknownRange blk
e

    -- If @to@ is on the fragment, remove all blocks after it. If it is not on
    -- the fragment, return a 'MissingBlock' error.
    cutOffAfterTo :: AnchoredFragment blk
                  -> Either (UnknownRange blk) (AnchoredFragment blk)
    cutOffAfterTo :: AnchoredFragment blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
cutOffAfterTo AnchoredFragment blk
frag = case StreamTo blk
to of
      StreamToInclusive RealPoint blk
p
        | Just AnchoredFragment blk
frag' <- (AnchoredFragment blk, AnchoredFragment blk)
-> AnchoredFragment blk
forall a b. (a, b) -> a
fst ((AnchoredFragment blk, AnchoredFragment blk)
 -> AnchoredFragment blk)
-> Maybe (AnchoredFragment blk, AnchoredFragment blk)
-> Maybe (AnchoredFragment blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredFragment blk
-> Point blk -> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
Fragment.splitAfterPoint AnchoredFragment blk
frag (RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint RealPoint blk
p)
        -> AnchoredFragment blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a. a -> Either (UnknownRange blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return AnchoredFragment blk
frag'
        | Bool
otherwise
        -> UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a b. a -> Either a b
Left (UnknownRange blk
 -> Either (UnknownRange blk) (AnchoredFragment blk))
-> UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> UnknownRange blk
forall blk. RealPoint blk -> UnknownRange blk
MissingBlock RealPoint blk
p

    -- If @from@ is on the fragment, remove all blocks before it, including
    -- @from@ itself in case of 'StreamFromExclusive'. It it is not on the
    -- fragment, return a 'MissingBlock' error.
    cutOffBeforeFrom :: AnchoredFragment blk
                     -> Either (UnknownRange blk) (AnchoredFragment blk)
    cutOffBeforeFrom :: AnchoredFragment blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
cutOffBeforeFrom AnchoredFragment blk
frag = case StreamFrom blk
from of
      StreamFromInclusive RealPoint blk
p
        | Just AnchoredFragment blk
frag' <- (AnchoredFragment blk, AnchoredFragment blk)
-> AnchoredFragment blk
forall a b. (a, b) -> b
snd ((AnchoredFragment blk, AnchoredFragment blk)
 -> AnchoredFragment blk)
-> Maybe (AnchoredFragment blk, AnchoredFragment blk)
-> Maybe (AnchoredFragment blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredFragment blk
-> Point blk -> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
Fragment.splitBeforePoint AnchoredFragment blk
frag (RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint RealPoint blk
p)
        -> AnchoredFragment blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a. a -> Either (UnknownRange blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return AnchoredFragment blk
frag'
        | Bool
otherwise
        -> UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a b. a -> Either a b
Left (UnknownRange blk
 -> Either (UnknownRange blk) (AnchoredFragment blk))
-> UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> UnknownRange blk
forall blk. RealPoint blk -> UnknownRange blk
MissingBlock RealPoint blk
p
      StreamFromExclusive p :: Point blk
p@(BlockPoint SlotNo
s HeaderHash blk
h)
        | Just AnchoredFragment blk
frag' <- (AnchoredFragment blk, AnchoredFragment blk)
-> AnchoredFragment blk
forall a b. (a, b) -> b
snd ((AnchoredFragment blk, AnchoredFragment blk)
 -> AnchoredFragment blk)
-> Maybe (AnchoredFragment blk, AnchoredFragment blk)
-> Maybe (AnchoredFragment blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredFragment blk
-> Point blk -> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
Fragment.splitAfterPoint AnchoredFragment blk
frag Point blk
p
        -> AnchoredFragment blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a. a -> Either (UnknownRange blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return AnchoredFragment blk
frag'
        | Bool
otherwise
        -> UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a b. a -> Either a b
Left (UnknownRange blk
 -> Either (UnknownRange blk) (AnchoredFragment blk))
-> UnknownRange blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> UnknownRange blk
forall blk. RealPoint blk -> UnknownRange blk
MissingBlock (SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s HeaderHash blk
h)
      StreamFromExclusive Point blk
GenesisPoint
        -> AnchoredFragment blk
-> Either (UnknownRange blk) (AnchoredFragment blk)
forall a. a -> Either (UnknownRange blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return AnchoredFragment blk
frag

-- | Should the given block be garbage collected from the VolatileDB?
--
-- Blocks can be garbage collected when their slot number is older than the
-- slot number of the immutable block (the block @k@ blocks after the current
-- tip).
garbageCollectable :: forall blk. HasHeader blk
                   => SecurityParam -> Model blk -> blk -> Bool
garbageCollectable :: forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> blk -> Bool
garbageCollectable SecurityParam
secParam Model blk
m blk
b =
    -- Note: we don't use the block number but the slot number, as the
    -- VolatileDB's garbage collection is in terms of slot numbers.
    SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
b) WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SecurityParam -> Model blk -> WithOrigin SlotNo
forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> WithOrigin SlotNo
immutableSlotNo SecurityParam
secParam Model blk
m

-- | Return 'True' when the model contains the block corresponding to the point
-- and the block itself is eligible for garbage collection, i.e. the real
-- implementation might have garbage collected it.
--
-- If the block is not in the model, return 'True', as it has likely been
-- garbage-collected from the model too. Note that we cannot distinguish this
-- case from a block that was never added to the model in the first place.
garbageCollectablePoint :: forall blk. HasHeader blk
                        => SecurityParam -> Model blk -> RealPoint blk -> Bool
garbageCollectablePoint :: forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> RealPoint blk -> Bool
garbageCollectablePoint SecurityParam
secParam Model blk
m RealPoint blk
pt
    | Just blk
blk <- HeaderHash blk -> Model blk -> Maybe blk
forall blk.
HasHeader blk =>
HeaderHash blk -> Model blk -> Maybe blk
getBlock (RealPoint blk -> HeaderHash blk
forall blk. RealPoint blk -> HeaderHash blk
realPointHash RealPoint blk
pt) Model blk
m
    = SecurityParam -> Model blk -> blk -> Bool
forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> blk -> Bool
garbageCollectable SecurityParam
secParam Model blk
m blk
blk
    | Bool
otherwise
    = Bool
True

-- | Return 'True' when the next block the given iterator would produced is
-- eligible for garbage collection, i.e. the real implementation might have
-- garbage collected it.
garbageCollectableIteratorNext ::
     forall blk. ModelSupportsBlock blk
  => SecurityParam -> Model blk -> IteratorId -> Bool
garbageCollectableIteratorNext :: forall blk.
ModelSupportsBlock blk =>
SecurityParam -> Model blk -> IteratorId -> Bool
garbageCollectableIteratorNext SecurityParam
secParam Model blk
m IteratorId
itId =
    case (IteratorResult blk blk, Model blk) -> IteratorResult blk blk
forall a b. (a, b) -> a
fst (IteratorId
-> BlockComponent blk blk
-> Model blk
-> (IteratorResult blk blk, Model blk)
forall blk b.
ModelSupportsBlock blk =>
IteratorId
-> BlockComponent blk b
-> Model blk
-> (IteratorResult blk b, Model blk)
iteratorNext IteratorId
itId BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock Model blk
m) of
      IteratorResult blk blk
IteratorExhausted    -> Bool
True -- TODO
      IteratorBlockGCed {} -> Bool
True
      IteratorResult blk
blk   -> SecurityParam -> Model blk -> blk -> Bool
forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> blk -> Bool
garbageCollectable SecurityParam
secParam Model blk
m blk
blk

-- | Delete blocks that are older than the security parameter from the volatile
-- DB. This function assumes that the blocks that will be deleted are copied to
-- the immutable DB.
--
-- If this function collects blocks that are not yet copied to the immutable DB
-- the volatile fragment of the current chain will not be connected to the
-- immutable part of the chain. For this reason, this function should not be
-- used in isolation and is not exported.
--
garbageCollect :: forall blk. HasHeader blk
               => SecurityParam -> Model blk -> Model blk
garbageCollect :: forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> Model blk
garbageCollect SecurityParam
secParam m :: Model blk
m@Model{Bool
Set (HeaderHash blk)
Map IteratorId [blk]
Map (HeaderHash blk) blk
InvalidBlocks blk
ExtLedgerState blk
LoE (AnchoredFragment blk)
Chain blk
ChainProducerState blk
currentLedger :: forall blk. Model blk -> ExtLedgerState blk
invalid :: forall blk. Model blk -> InvalidBlocks blk
isOpen :: forall blk. Model blk -> Bool
immutableDbChain :: forall blk. Model blk -> Chain blk
initLedger :: forall blk. Model blk -> ExtLedgerState blk
volatileDbBlocks :: forall blk. Model blk -> Map (HeaderHash blk) blk
cps :: forall blk. Model blk -> ChainProducerState blk
iterators :: forall blk. Model blk -> Map IteratorId [blk]
valid :: forall blk. Model blk -> Set (HeaderHash blk)
loeFragment :: forall blk. Model blk -> LoE (AnchoredFragment blk)
volatileDbBlocks :: Map (HeaderHash blk) blk
immutableDbChain :: Chain blk
cps :: ChainProducerState blk
currentLedger :: ExtLedgerState blk
initLedger :: ExtLedgerState blk
iterators :: Map IteratorId [blk]
valid :: Set (HeaderHash blk)
invalid :: InvalidBlocks blk
loeFragment :: LoE (AnchoredFragment blk)
isOpen :: Bool
..} = Model blk
m {
      volatileDbBlocks = Map.filter (not . collectable) volatileDbBlocks
    }
    -- TODO what about iterators that will stream garbage collected blocks?
  where
    collectable :: blk -> Bool
    collectable :: blk -> Bool
collectable = SecurityParam -> Model blk -> blk -> Bool
forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> blk -> Bool
garbageCollectable SecurityParam
secParam Model blk
m

data ShouldGarbageCollect = GarbageCollect | DoNotGarbageCollect
  deriving (ShouldGarbageCollect -> ShouldGarbageCollect -> Bool
(ShouldGarbageCollect -> ShouldGarbageCollect -> Bool)
-> (ShouldGarbageCollect -> ShouldGarbageCollect -> Bool)
-> Eq ShouldGarbageCollect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShouldGarbageCollect -> ShouldGarbageCollect -> Bool
== :: ShouldGarbageCollect -> ShouldGarbageCollect -> Bool
$c/= :: ShouldGarbageCollect -> ShouldGarbageCollect -> Bool
/= :: ShouldGarbageCollect -> ShouldGarbageCollect -> Bool
Eq, IteratorId -> ShouldGarbageCollect -> ShowS
[ShouldGarbageCollect] -> ShowS
ShouldGarbageCollect -> String
(IteratorId -> ShouldGarbageCollect -> ShowS)
-> (ShouldGarbageCollect -> String)
-> ([ShouldGarbageCollect] -> ShowS)
-> Show ShouldGarbageCollect
forall a.
(IteratorId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: IteratorId -> ShouldGarbageCollect -> ShowS
showsPrec :: IteratorId -> ShouldGarbageCollect -> ShowS
$cshow :: ShouldGarbageCollect -> String
show :: ShouldGarbageCollect -> String
$cshowList :: [ShouldGarbageCollect] -> ShowS
showList :: [ShouldGarbageCollect] -> ShowS
Show)

-- | Copy all blocks on the current chain older than @k@ to the \"mock
-- ImmutableDB\" ('immutableDbChain').
--
-- The 'ShouldGarbageCollect' parameter determines if garbage collection should
-- be performed __after__ copying.
--
-- Idempotent.
copyToImmutableDB :: forall blk. HasHeader blk
                  => SecurityParam -> ShouldGarbageCollect -> Model blk -> Model blk
copyToImmutableDB :: forall blk.
HasHeader blk =>
SecurityParam -> ShouldGarbageCollect -> Model blk -> Model blk
copyToImmutableDB SecurityParam
secParam ShouldGarbageCollect
shouldCollectGarbage Model blk
m =
      ShouldGarbageCollect -> Model blk -> Model blk
garbageCollectIf ShouldGarbageCollect
shouldCollectGarbage
    (Model blk -> Model blk) -> Model blk -> Model blk
forall a b. (a -> b) -> a -> b
$ Model blk
m { immutableDbChain = immutableChain secParam m }
  where
    garbageCollectIf :: ShouldGarbageCollect -> Model blk -> Model blk
garbageCollectIf ShouldGarbageCollect
GarbageCollect      = SecurityParam -> Model blk -> Model blk
forall blk.
HasHeader blk =>
SecurityParam -> Model blk -> Model blk
garbageCollect SecurityParam
secParam
    garbageCollectIf ShouldGarbageCollect
DoNotGarbageCollect = Model blk -> Model blk
forall a. a -> a
id

closeDB :: Model blk -> Model blk
closeDB :: forall blk. Model blk -> Model blk
closeDB m :: Model blk
m@Model{Bool
Set (HeaderHash blk)
Map IteratorId [blk]
Map (HeaderHash blk) blk
InvalidBlocks blk
ExtLedgerState blk
LoE (AnchoredFragment blk)
Chain blk
ChainProducerState blk
currentLedger :: forall blk. Model blk -> ExtLedgerState blk
invalid :: forall blk. Model blk -> InvalidBlocks blk
isOpen :: forall blk. Model blk -> Bool
immutableDbChain :: forall blk. Model blk -> Chain blk
initLedger :: forall blk. Model blk -> ExtLedgerState blk
volatileDbBlocks :: forall blk. Model blk -> Map (HeaderHash blk) blk
cps :: forall blk. Model blk -> ChainProducerState blk
iterators :: forall blk. Model blk -> Map IteratorId [blk]
valid :: forall blk. Model blk -> Set (HeaderHash blk)
loeFragment :: forall blk. Model blk -> LoE (AnchoredFragment blk)
volatileDbBlocks :: Map (HeaderHash blk) blk
immutableDbChain :: Chain blk
cps :: ChainProducerState blk
currentLedger :: ExtLedgerState blk
initLedger :: ExtLedgerState blk
iterators :: Map IteratorId [blk]
valid :: Set (HeaderHash blk)
invalid :: InvalidBlocks blk
loeFragment :: LoE (AnchoredFragment blk)
isOpen :: Bool
..} = Model blk
m {
      isOpen        = False
    , cps           = cps { CPS.chainFollowers = Map.empty }
    , iterators     = Map.empty
    }

reopen :: Model blk -> Model blk
reopen :: forall blk. Model blk -> Model blk
reopen Model blk
m = Model blk
m { isOpen = True }

wipeVolatileDB ::
     forall blk. LedgerSupportsProtocol blk
  => TopLevelConfig blk
  -> Model blk
  -> (Point blk, Model blk)
wipeVolatileDB :: forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk -> Model blk -> (Point blk, Model blk)
wipeVolatileDB TopLevelConfig blk
cfg Model blk
m =
    (Model blk -> Point blk
forall blk. HasHeader blk => Model blk -> Point blk
tipPoint Model blk
m', Model blk -> Model blk
forall blk. Model blk -> Model blk
reopen Model blk
m')
  where
    m' :: Model blk
m' = (Model blk -> Model blk
forall blk. Model blk -> Model blk
closeDB Model blk
m) {
        volatileDbBlocks = Map.empty
      , cps              = CPS.switchFork newChain (cps m)
      , currentLedger    = newLedger
      , invalid          = Map.empty
        -- The LoE fragment must be anchored in an immutable point. Wiping the
        -- VolDB can invalidate this when some immutable blocks have not yet
        -- been persisted.
      , loeFragment      = Fragment.Empty Fragment.AnchorGenesis <$ loeFragment m
      }

    -- Get the chain ending at the ImmutableDB by doing chain selection on the
    -- sole candidate (or none) in the ImmutableDB.
    newChain  :: Chain blk
    newLedger :: ExtLedgerState blk
    (Chain blk
newChain, ExtLedgerState blk
newLedger) =
        Maybe (Chain blk, ExtLedgerState blk)
-> (Chain blk, ExtLedgerState blk)
isSameAsImmutableDbChain
      (Maybe (Chain blk, ExtLedgerState blk)
 -> (Chain blk, ExtLedgerState blk))
-> Maybe (Chain blk, ExtLedgerState blk)
-> (Chain blk, ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ Proxy (BlockProtocol blk)
-> ChainOrderConfig (SelectView (BlockProtocol blk))
-> (blk -> SelectView (BlockProtocol blk))
-> Chain blk
-> [(Chain blk, ExtLedgerState blk)]
-> Maybe (Chain blk, ExtLedgerState blk)
forall (proxy :: * -> *) p hdr l.
ConsensusProtocol p =>
proxy p
-> ChainOrderConfig (SelectView p)
-> (hdr -> SelectView p)
-> Chain hdr
-> [(Chain hdr, l)]
-> Maybe (Chain hdr, l)
selectChain
          (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(BlockProtocol blk))
          (BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
projectChainOrderConfig (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg))
          (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 -> SelectView (BlockProtocol blk))
-> (blk -> Header blk) -> blk -> SelectView (BlockProtocol blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader)
          Chain blk
forall block. Chain block
Chain.genesis
      ([(Chain blk, ExtLedgerState blk)]
 -> Maybe (Chain blk, ExtLedgerState blk))
-> [(Chain blk, ExtLedgerState blk)]
-> Maybe (Chain blk, ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
 [(Chain blk, ExtLedgerState blk)])
-> [(Chain blk, ExtLedgerState blk)]
forall a b. (a, b) -> b
snd
      ((Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
  [(Chain blk, ExtLedgerState blk)])
 -> [(Chain blk, ExtLedgerState blk)])
-> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
    [(Chain blk, ExtLedgerState blk)])
-> [(Chain blk, ExtLedgerState blk)]
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk
-> Model blk
-> Map (HeaderHash blk) blk
-> (Map (HeaderHash blk) (ExtValidationError blk, SlotNo),
    [(Chain blk, ExtLedgerState blk)])
forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk
-> Model blk
-> Map (HeaderHash blk) blk
-> (InvalidBlocks blk, [(Chain blk, ExtLedgerState blk)])
validChains TopLevelConfig blk
cfg Model blk
m (Model blk -> Map (HeaderHash blk) blk
forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
immutableDbBlocks Model blk
m)

    isSameAsImmutableDbChain :: Maybe (Chain blk, ExtLedgerState blk)
-> (Chain blk, ExtLedgerState blk)
isSameAsImmutableDbChain = \case
      Maybe (Chain blk, ExtLedgerState blk)
Nothing
        | Chain blk -> Bool
forall block. Chain block -> Bool
Chain.null (Model blk -> Chain blk
forall blk. Model blk -> Chain blk
immutableDbChain Model blk
m)
        -> (Chain blk
forall block. Chain block
Chain.Genesis, Model blk -> ExtLedgerState blk
forall blk. Model blk -> ExtLedgerState blk
initLedger Model blk
m)
        | Bool
otherwise
        -> String -> (Chain blk, ExtLedgerState blk)
forall a. HasCallStack => String -> a
error String
"Did not select any chain"
      Just res :: (Chain blk, ExtLedgerState blk)
res@(Chain blk
chain, ExtLedgerState blk
_ledger)
        | Chain blk -> [HeaderHash blk]
toHashes Chain blk
chain [HeaderHash blk] -> [HeaderHash blk] -> Bool
forall a. Eq a => a -> a -> Bool
== Chain blk -> [HeaderHash blk]
toHashes (Model blk -> Chain blk
forall blk. Model blk -> Chain blk
immutableDbChain Model blk
m)
        -> (Chain blk, ExtLedgerState blk)
res
        | Bool
otherwise
        -> String -> (Chain blk, ExtLedgerState blk)
forall a. HasCallStack => String -> a
error String
"Did not select the ImmutableDB's chain"

    toHashes :: Chain blk -> [HeaderHash blk]
toHashes = (blk -> HeaderHash blk) -> [blk] -> [HeaderHash blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash ([blk] -> [HeaderHash blk])
-> (Chain blk -> [blk]) -> Chain blk -> [HeaderHash blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst

-- | Look in the given blocks database for a fragment spanning from the given
-- anchor to the given hash, and return the fragment in question, or 'Nothing'.
getFragmentBetween ::
     forall blk. GetPrevHash blk
  => Map (HeaderHash blk) blk
    -- ^ A map of blocks; usually the 'volatileDbBlocks' of a 'Model'.
  -> Fragment.Anchor blk
  -- ^ The anchor of the fragment to get.
  -> ChainHash blk
  -- ^ The hash of the block to get the fragment up to.
  -> Maybe (AnchoredFragment blk)
getFragmentBetween :: forall blk.
GetPrevHash blk =>
Map (HeaderHash blk) blk
-> Anchor blk -> ChainHash blk -> Maybe (AnchoredFragment blk)
getFragmentBetween Map (HeaderHash blk) blk
bs Anchor blk
anchor = ChainHash blk -> Maybe (AnchoredFragment blk)
go
  where
    go :: ChainHash blk -> Maybe (AnchoredFragment blk)
    go :: ChainHash blk -> Maybe (AnchoredFragment blk)
go ChainHash blk
hash | ChainHash blk
hash ChainHash blk -> ChainHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== Anchor blk -> ChainHash blk
forall block. Anchor block -> ChainHash block
Fragment.anchorToHash Anchor blk
anchor =
        AnchoredFragment blk -> Maybe (AnchoredFragment blk)
forall a. a -> Maybe a
Just (AnchoredFragment blk -> Maybe (AnchoredFragment blk))
-> AnchoredFragment blk -> Maybe (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
Fragment.Empty Anchor blk
anchor
    go ChainHash blk
GenesisHash =
        Maybe (AnchoredFragment blk)
forall a. Maybe a
Nothing
    go (BlockHash HeaderHash blk
hash) = do
        blk
block <- HeaderHash blk -> Map (HeaderHash blk) blk -> Maybe blk
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderHash blk
hash Map (HeaderHash blk) blk
bs
        AnchoredFragment blk
prevFragment <- ChainHash blk -> Maybe (AnchoredFragment blk)
go (ChainHash blk -> Maybe (AnchoredFragment blk))
-> ChainHash blk -> Maybe (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ blk -> ChainHash blk
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash blk
block
        AnchoredFragment blk -> Maybe (AnchoredFragment blk)
forall a. a -> Maybe a
Just (AnchoredFragment blk -> Maybe (AnchoredFragment blk))
-> AnchoredFragment blk -> Maybe (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
prevFragment AnchoredFragment blk -> blk -> AnchoredFragment blk
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
Fragment.:> blk
block