{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Test.Ouroboros.Storage.ChainDB.Model (
Model
, CPS.FollowerId
, IteratorId
, addBlock
, addBlockPromise
, addBlocks
, empty
, currentChain
, currentLedger
, currentSlot
, futureBlocks
, getBlock
, getBlockByPoint
, getBlockComponentByPoint
, getIsValid
, getLedgerDB
, getMaxSlotNo
, hasBlock
, hasBlockByPoint
, immutableBlockNo
, immutableChain
, immutableSlotNo
, invalid
, isOpen
, isValid
, lastK
, maxClockSkew
, tipBlock
, tipPoint
, volatileChain
, iteratorClose
, iteratorNext
, stream
, followerClose
, followerForward
, followerInstruction
, newFollower
, ModelSupportsBlock
, ShouldGarbageCollect (GarbageCollect, DoNotGarbageCollect)
, advanceCurSlot
, 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 (..), InvalidBlockReason (..),
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
data Model blk = Model {
forall blk. Model blk -> Map (HeaderHash blk) blk
volatileDbBlocks :: Map (HeaderHash blk) blk
, forall blk. Model blk -> Chain blk
immutableDbChain :: Chain blk
, 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 -> SlotNo
currentSlot :: SlotNo
, forall blk. Model blk -> LoE (AnchoredFragment blk)
loeFragment :: LoE (AnchoredFragment blk)
, forall blk. Model blk -> Word64
maxClockSkew :: Word64
, forall blk. Model blk -> Bool
isOpen :: Bool
}
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 (InvalidBlockReason blk)
)
=> ToExpr (Model blk)
deriving instance (LedgerSupportsProtocol blk, Show blk) => Show (Model blk)
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
futureBlocks :: HasHeader blk => Model blk -> Map (HeaderHash blk) blk
futureBlocks :: forall blk. HasHeader blk => Model blk -> Map (HeaderHash blk) blk
futureBlocks Model blk
m =
(blk -> Bool)
-> Map (HeaderHash blk) blk -> Map (HeaderHash blk) blk
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Model blk -> SlotNo
forall blk. Model blk -> SlotNo
currentSlot Model blk
m SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<) (SlotNo -> Bool) -> (blk -> SlotNo) -> blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot) (Model blk -> Map (HeaderHash blk) blk
forall blk. Model blk -> Map (HeaderHash blk) blk
volatileDbBlocks 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)
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)
-> 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
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)
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
volatileChain ::
(HasHeader a, HasHeader blk)
=> SecurityParam
-> (blk -> a)
-> 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))
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
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
| 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) (InvalidBlockReason blk, SlotNo) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member HeaderHash blk
hash (Model blk -> Map (HeaderHash blk) (InvalidBlockReason 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
Word64
Set (HeaderHash blk)
Map IteratorId [blk]
Map (HeaderHash blk) blk
InvalidBlocks blk
SlotNo
ExtLedgerState blk
LoE (AnchoredFragment blk)
Chain blk
ChainProducerState blk
currentLedger :: forall blk. Model blk -> ExtLedgerState blk
currentSlot :: forall blk. Model blk -> SlotNo
invalid :: forall blk. Model blk -> InvalidBlocks blk
isOpen :: forall blk. Model blk -> Bool
maxClockSkew :: forall blk. Model blk -> Word64
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
currentSlot :: SlotNo
loeFragment :: LoE (AnchoredFragment blk)
maxClockSkew :: Word64
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
}
empty ::
HasHeader blk
=> LoE ()
-> ExtLedgerState blk
-> Word64
-> Model blk
empty :: forall blk.
HasHeader blk =>
LoE () -> ExtLedgerState blk -> Word64 -> Model blk
empty LoE ()
loe ExtLedgerState blk
initLedger Word64
maxClockSkew = 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
, currentSlot :: SlotNo
currentSlot = SlotNo
0
, maxClockSkew :: Word64
maxClockSkew = Word64
maxClockSkew
, 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
}
advanceCurSlot ::
SlotNo
-> Model blk -> Model blk
advanceCurSlot :: forall blk. SlotNo -> Model blk -> Model blk
advanceCurSlot SlotNo
curSlot Model blk
m = Model blk
m { currentSlot = curSlot `max` currentSlot m }
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 =
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
||
HeaderHash blk
-> Map (HeaderHash blk) (InvalidBlockReason 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) (InvalidBlockReason 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'
, currentSlot :: SlotNo
currentSlot = Model blk -> SlotNo
forall blk. Model blk -> SlotNo
currentSlot Model blk
m
, maxClockSkew :: Word64
maxClockSkew = Model blk -> Word64
forall blk. Model blk -> Word64
maxClockSkew Model blk
m
, 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' :: 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)
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
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]
go :: [blk] -> [Point blk] -> [blk]
go [] [Point blk]
_loePoints = []
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)
| 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
| Bool
otherwise = []
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
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)
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'
}
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}
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)
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 )
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
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
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) }
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
class ( HasHeader blk
, GetHeader blk
, HasHeader (Header blk)
, Serialise blk
, Serialise (Header blk)
, HasNestedContent Header blk
) => ModelSupportsBlock blk
type InvalidBlocks blk = Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
data ValidatedChain blk =
ValidatedChain
(Chain blk)
(ExtLedgerState blk)
(InvalidBlocks blk)
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 { SlotNo
currentSlot :: forall blk. Model blk -> SlotNo
currentSlot :: SlotNo
currentSlot, Word64
maxClockSkew :: forall blk. Model blk -> Word64
maxClockSkew :: Word64
maxClockSkew, ExtLedgerState blk
initLedger :: forall blk. Model blk -> ExtLedgerState blk
initLedger :: ExtLedgerState blk
initLedger, Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
invalid :: forall blk. Model blk -> InvalidBlocks blk
invalid :: Map (HeaderHash blk) (InvalidBlockReason 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 -> InvalidBlockReason blk -> InvalidBlocks blk
mkInvalid :: blk
-> InvalidBlockReason blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
mkInvalid blk
b InvalidBlockReason blk
reason =
HeaderHash blk
-> (InvalidBlockReason blk, SlotNo)
-> Map (HeaderHash blk) (InvalidBlockReason 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) (InvalidBlockReason blk
reason, blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
b)
go :: ExtLedgerState blk
-> Chain blk
-> [blk]
-> ValidatedChain blk
go :: ExtLedgerState blk -> Chain blk -> [blk] -> ValidatedChain blk
go ExtLedgerState blk
ledger Chain blk
validPrefix = \case
[] -> Chain blk
-> ExtLedgerState blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> ValidatedChain blk
forall blk.
Chain blk
-> ExtLedgerState blk -> InvalidBlocks blk -> ValidatedChain blk
ValidatedChain Chain blk
validPrefix ExtLedgerState blk
ledger Map (HeaderHash blk) (InvalidBlockReason 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
Left ExtValidationError blk
e
-> Chain blk
-> ExtLedgerState blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> ValidatedChain blk
forall blk.
Chain blk
-> ExtLedgerState blk -> InvalidBlocks blk -> ValidatedChain blk
ValidatedChain
Chain blk
validPrefix
ExtLedgerState blk
ledger
(Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
invalid Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
forall a. Semigroup a => a -> a -> a
<> blk
-> InvalidBlockReason blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
mkInvalid blk
b (ExtValidationError blk -> InvalidBlockReason blk
forall blk. ExtValidationError blk -> InvalidBlockReason blk
ValidationError ExtValidationError blk
e))
Right ExtLedgerState blk
ledger'
| HeaderHash blk
-> Map (HeaderHash blk) (InvalidBlockReason 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) (InvalidBlockReason blk, SlotNo)
invalid
-> Chain blk
-> ExtLedgerState blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> ValidatedChain blk
forall blk.
Chain blk
-> ExtLedgerState blk -> InvalidBlocks blk -> ValidatedChain blk
ValidatedChain Chain blk
validPrefix ExtLedgerState blk
ledger Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
invalid
| blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
b SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> SlotNo
SlotNo (SlotNo -> Word64
unSlotNo SlotNo
currentSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
maxClockSkew)
-> Chain blk
-> ExtLedgerState blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> ValidatedChain blk
forall blk.
Chain blk
-> ExtLedgerState blk -> InvalidBlocks blk -> ValidatedChain blk
ValidatedChain
Chain blk
validPrefix
ExtLedgerState blk
ledger
(Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
invalid Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
forall a. Semigroup a => a -> a -> a
<>
blk
-> InvalidBlockReason blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
mkInvalid blk
b (RealPoint blk -> InvalidBlockReason blk
forall blk. RealPoint blk -> InvalidBlockReason blk
InFutureExceedsClockSkew (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b)))
| blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
b SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
currentSlot
-> Chain blk
-> ExtLedgerState blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> ValidatedChain blk
forall blk.
Chain blk
-> ExtLedgerState blk -> InvalidBlocks blk -> ValidatedChain blk
ValidatedChain
Chain blk
validPrefix
ExtLedgerState blk
ledger
(Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
invalid Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
forall a. Semigroup a => a -> a -> a
<>
ExtLedgerState blk
-> [blk] -> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
findInvalidBlockInTheFuture ExtLedgerState blk
ledger' [blk]
bs')
| 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'
findInvalidBlockInTheFuture
:: ExtLedgerState blk
-> [blk]
-> InvalidBlocks blk
findInvalidBlockInTheFuture :: ExtLedgerState blk
-> [blk] -> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
findInvalidBlockInTheFuture ExtLedgerState blk
ledger = \case
[] -> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
forall k a. Map k a
Map.empty
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
Left ExtValidationError blk
e -> blk
-> InvalidBlockReason blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
mkInvalid blk
b (ExtValidationError blk -> InvalidBlockReason blk
forall blk. ExtValidationError blk -> InvalidBlockReason blk
ValidationError ExtValidationError blk
e)
Right ExtLedgerState blk
ledger'
| blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
b SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> SlotNo
SlotNo (SlotNo -> Word64
unSlotNo SlotNo
currentSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
maxClockSkew)
-> blk
-> InvalidBlockReason blk
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
mkInvalid blk
b (RealPoint blk -> InvalidBlockReason blk
forall blk. RealPoint blk -> InvalidBlockReason blk
InFutureExceedsClockSkew (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b)) Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
-> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
forall a. Semigroup a => a -> a -> a
<>
ExtLedgerState blk
-> [blk] -> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
findInvalidBlockInTheFuture ExtLedgerState blk
ledger' [blk]
bs'
| Bool
otherwise
-> ExtLedgerState blk
-> [blk] -> Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
findInvalidBlockInTheFuture ExtLedgerState blk
ledger' [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
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
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) (InvalidBlockReason blk, SlotNo),
[(Chain blk, ExtLedgerState blk)]))
-> [Chain blk]
-> (Map (HeaderHash blk) (InvalidBlockReason 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) (InvalidBlockReason blk, SlotNo),
[(Chain blk, ExtLedgerState blk)])
classify (ValidatedChain blk
-> (Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo),
[(Chain blk, ExtLedgerState blk)]))
-> (Chain blk -> ValidatedChain blk)
-> Chain blk
-> (Map (HeaderHash blk) (InvalidBlockReason 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) (InvalidBlockReason blk, SlotNo),
[(Chain blk, ExtLedgerState blk)]))
-> [Chain blk]
-> (Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo),
[(Chain blk, ExtLedgerState blk)])
forall a b. (a -> b) -> a -> b
$
[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) (InvalidBlockReason blk, SlotNo),
[(Chain blk, ExtLedgerState blk)])
classify (ValidatedChain Chain blk
chain ExtLedgerState blk
ledger Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
invalid) =
(Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
invalid, [(Chain blk
chain, ExtLedgerState blk
ledger)])
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
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
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))
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
errFork :: Either (UnknownRange blk) (AnchoredFragment blk)
errFork :: Either (UnknownRange blk) (AnchoredFragment blk)
errFork = do
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
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
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
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
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
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 =
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
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
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
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
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
Word64
Set (HeaderHash blk)
Map IteratorId [blk]
Map (HeaderHash blk) blk
InvalidBlocks blk
SlotNo
ExtLedgerState blk
LoE (AnchoredFragment blk)
Chain blk
ChainProducerState blk
currentLedger :: forall blk. Model blk -> ExtLedgerState blk
currentSlot :: forall blk. Model blk -> SlotNo
invalid :: forall blk. Model blk -> InvalidBlocks blk
isOpen :: forall blk. Model blk -> Bool
maxClockSkew :: forall blk. Model blk -> Word64
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
currentSlot :: SlotNo
loeFragment :: LoE (AnchoredFragment blk)
maxClockSkew :: Word64
isOpen :: Bool
..} = Model blk
m {
volatileDbBlocks = Map.filter (not . collectable) volatileDbBlocks
}
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)
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
Word64
Set (HeaderHash blk)
Map IteratorId [blk]
Map (HeaderHash blk) blk
InvalidBlocks blk
SlotNo
ExtLedgerState blk
LoE (AnchoredFragment blk)
Chain blk
ChainProducerState blk
currentLedger :: forall blk. Model blk -> ExtLedgerState blk
currentSlot :: forall blk. Model blk -> SlotNo
invalid :: forall blk. Model blk -> InvalidBlocks blk
isOpen :: forall blk. Model blk -> Bool
maxClockSkew :: forall blk. Model blk -> Word64
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
currentSlot :: SlotNo
loeFragment :: LoE (AnchoredFragment blk)
maxClockSkew :: Word64
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
}
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) (InvalidBlockReason blk, SlotNo),
[(Chain blk, ExtLedgerState blk)])
-> [(Chain blk, ExtLedgerState blk)]
forall a b. (a, b) -> b
snd
((Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo),
[(Chain blk, ExtLedgerState blk)])
-> [(Chain blk, ExtLedgerState blk)])
-> (Map (HeaderHash blk) (InvalidBlockReason 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) (InvalidBlockReason 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
getFragmentBetween ::
forall blk. GetPrevHash blk
=> Map (HeaderHash blk) blk
-> Fragment.Anchor blk
-> ChainHash blk
-> 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