Skip to content

Commit

Permalink
ChainDB q-s-m test: add the LoE
Browse files Browse the repository at this point in the history 
Co-authored-by: Nicolas “Niols” Jeannerod <nicolas.jeannerod@tweag.io>
  • Loading branch information
@amesgen @Niols
amesgen and Niols committed Aug 30, 2024
1 parent 6442d81 commit 1357c1b
Show file tree
Hide file tree
Showing 7 changed files with 295 additions and 83 deletions.
10 changes: 10 additions & 0 deletions ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,6 +53,7 @@ import Ouroboros.Consensus.Ledger.Query
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.Protocol.Abstract (ChainDepState)
import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..))
import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal
(ChunkNo (..), ChunkSize (..), RelativeSlot (..))
import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Layout
Expand Down Expand Up @@ -407,3 +408,12 @@ instance Arbitrary Index.CacheConfig where
-- TODO create a Cmd that advances time, so this is being exercised too.
expireUnusedAfter <- (fromIntegral :: Int -> DiffTime) <$> choose (1, 100)
return Index.CacheConfig {Index.pastChunksToCache, Index.expireUnusedAfter}

{-------------------------------------------------------------------------------
LoE
-------------------------------------------------------------------------------}

instance Arbitrary a => Arbitrary (LoE a) where
arbitrary = oneof [pure LoEDisabled, LoEEnabled <$> arbitrary]
shrink LoEDisabled = []
shrink (LoEEnabled x) = LoEDisabled : map LoEEnabled (shrink x)
14 changes: 14 additions & 0 deletions ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

Expand All @@ -18,9 +19,12 @@ import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Storage.ChainDB (InvalidBlockReason)
import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..))
import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB
import Ouroboros.Consensus.Storage.ImmutableDB
import Ouroboros.Consensus.Util.STM (Fingerprint, WithFingerprint)
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as Fragment
import Ouroboros.Network.Block (MaxSlotNo)
import Ouroboros.Network.Mock.Chain
import Ouroboros.Network.Mock.ProducerState
Expand All @@ -37,6 +41,14 @@ instance ToExpr (HeaderHash blk) => ToExpr (Point blk)
instance ToExpr (HeaderHash blk) => ToExpr (RealPoint blk)
instance (ToExpr slot, ToExpr hash) => ToExpr (Block slot hash)

deriving instance ( ToExpr blk
, ToExpr (HeaderHash blk)
)
=> ToExpr (Fragment.Anchor blk)

instance (ToExpr blk, ToExpr (HeaderHash blk)) => ToExpr (AnchoredFragment blk) where
toExpr f = toExpr (Fragment.anchor f, Fragment.toOldestFirst f)

{-------------------------------------------------------------------------------
ouroboros-consensus
-------------------------------------------------------------------------------}
Expand Down Expand Up @@ -73,6 +85,8 @@ instance ToExpr ChunkInfo where
instance ToExpr FsError where
toExpr fsError = App (show fsError) []

deriving instance ToExpr a => ToExpr (LoE a)


{-------------------------------------------------------------------------------
si-timers
Expand Down
171 changes: 138 additions & 33 deletions ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -70,9 +70,11 @@ module Test.Ouroboros.Storage.ChainDB.Model (
, garbageCollectable
, garbageCollectableIteratorNext
, garbageCollectablePoint
, getFragmentBetween
, immutableDbChain
, initLedger
, reopen
, updateLoE
, validChains
, volatileDbBlocks
, wipeVolatileDB
Expand All @@ -81,8 +83,11 @@ module Test.Ouroboros.Storage.ChainDB.Model (
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.Function (on)
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
Expand All @@ -104,8 +109,8 @@ import Ouroboros.Consensus.Protocol.MockChainSel
import Ouroboros.Consensus.Storage.ChainDB.API (AddBlockPromise (..),
AddBlockResult (..), BlockComponent (..),
ChainDbError (..), InvalidBlockReason (..),
IteratorResult (..), StreamFrom (..), StreamTo (..),
UnknownRange (..), validBounds)
IteratorResult (..), LoE (..), StreamFrom (..),
StreamTo (..), UnknownRange (..), validBounds)
import Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel (olderThanK)
import Ouroboros.Consensus.Storage.LedgerDB
import Ouroboros.Consensus.Util (repeatedly)
Expand All @@ -119,7 +124,7 @@ 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

Expand All @@ -136,6 +141,7 @@ data Model blk = Model {
, valid :: Set (HeaderHash blk)
, invalid :: InvalidBlocks blk
, currentSlot :: SlotNo
, loeFragment :: LoE (AnchoredFragment blk)
, maxClockSkew :: Word64
-- ^ Max clock skew in terms of slots. A static configuration parameter.
, isOpen :: Bool
Expand Down Expand Up @@ -364,10 +370,12 @@ getLedgerDB cfg m@Model{..} =
-------------------------------------------------------------------------------}

empty ::
ExtLedgerState blk
HasHeader blk
=> LoE ()
-> ExtLedgerState blk
-> Word64 -- ^ Max clock skew in number of blocks
-> Model blk
empty initLedger maxClockSkew = Model {
empty loe initLedger maxClockSkew = Model {
volatileDbBlocks = Map.empty
, immutableDbChain = Chain.Genesis
, cps = CPS.initChainProducerState Chain.Genesis
Expand All @@ -379,6 +387,7 @@ empty initLedger maxClockSkew = Model {
, currentSlot = 0
, maxClockSkew = maxClockSkew
, isOpen = True
, loeFragment = loe $> Fragment.Empty Fragment.AnchorGenesis
}

-- | Advance the 'currentSlot' of the model to the given 'SlotNo' if the
Expand All @@ -392,22 +401,13 @@ addBlock :: forall blk. LedgerSupportsProtocol blk
=> TopLevelConfig blk
-> blk
-> Model blk -> Model blk
addBlock cfg blk m = Model {
volatileDbBlocks = volatileDbBlocks'
, immutableDbChain = immutableDbChain m
, cps = CPS.switchFork newChain (cps m)
, currentLedger = newLedger
, initLedger = initLedger m
, iterators = iterators m
, valid = valid'
, invalid = invalid'
, currentSlot = currentSlot m
, maxClockSkew = maxClockSkew m
, isOpen = True
}
addBlock cfg blk m
| ignoreBlock = m
| otherwise = chainSelection cfg m {
volatileDbBlocks = Map.insert (blockHash blk) blk (volatileDbBlocks m)
}
where
secParam = configSecurityParam cfg

immBlockNo = immutableBlockNo secParam m

hdr = getHeader blk
Expand All @@ -419,34 +419,105 @@ addBlock cfg blk m = Model {
-- If it's an invalid block we've seen before, ignore it.
Map.member (blockHash blk) (invalid m)

volatileDbBlocks' :: Map (HeaderHash blk) blk
volatileDbBlocks'
| ignoreBlock
= volatileDbBlocks m
| otherwise
= Map.insert (blockHash blk) blk (volatileDbBlocks m)
chainSelection :: forall blk. LedgerSupportsProtocol blk
=> TopLevelConfig blk
-> Model blk -> Model blk
chainSelection cfg m = Model {
volatileDbBlocks = volatileDbBlocks m
, immutableDbChain = immutableDbChain m
, cps = CPS.switchFork newChain (cps m)
, currentLedger = newLedger
, initLedger = initLedger m
, iterators = iterators m
, valid = valid'
, invalid = invalid'
, currentSlot = currentSlot m
, maxClockSkew = maxClockSkew m
, isOpen = True
, loeFragment = loeFragment m
}
where
secParam = configSecurityParam cfg

-- @invalid'@ will be a (non-strict) superset of the previous value of
-- @invalid@, see 'validChains', thus no need to union.
invalid' :: InvalidBlocks blk
candidates :: [(Chain blk, ExtLedgerState blk)]
(invalid', candidates) =
validChains cfg m (immutableDbBlocks m <> volatileDbBlocks')
(invalid', candidates) = validChains cfg m (blocks m)

immutableChainHashes =
map blockHash
. Chain.toOldestFirst
. immutableChain secParam
$ m
$ immutableChain'

immutableChain' = immutableChain secParam m

extendsImmutableChain :: Chain blk -> Bool
extendsImmutableChain fork =
immutableChainHashes `isPrefixOf`
map blockHash (Chain.toOldestFirst fork)

-- Note that this includes the currently selected chain, but that does not
-- influence chain selection via 'selectChain'.
consideredCandidates = filter (extendsImmutableChain . fst) candidates
-- influence chain selection via 'selectChain'. Note that duplicates might
-- be introduced by `trimToLoE` so we deduplicate explicitly here.
consideredCandidates =
candidates
& filter (extendsImmutableChain . fst)
& map (first trimToLoE)
& nubOrdOn (Chain.headPoint . fst)

currentChain' = currentChain m

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

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

-- If the LoE fragment does not intersect with the current volatile chain,
-- then we use the immutable chain instead.
loeChain =
loeFragment m <&> \loeFragment' -> fromMaybe immutableChain' $ do
_ <- Fragment.intersect volatileFrag loeFragment'
(_, loeChain') <- Fragment.cross currentFrag loeFragment'
Chain.fromAnchoredFragment loeChain'
where
currentFrag = Chain.toAnchoredFragment currentChain'
volatileFrag = volatileChain secParam id m

newChain :: Chain blk
newLedger :: ExtLedgerState blk
Expand Down Expand Up @@ -491,6 +562,18 @@ addBlockPromise cfg blk m = (result, m')
, blockProcessed = return $ SuccesfullyAddedBlock $ tipPoint m'
}

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

{-------------------------------------------------------------------------------
Iterators
-------------------------------------------------------------------------------}
Expand Down Expand Up @@ -756,7 +839,6 @@ validate cfg Model { currentSlot, maxClockSkew, initLedger, invalid } chain =
| otherwise
-> findInvalidBlockInTheFuture ledger' bs'


chains :: forall blk. (GetPrevHash blk)
=> Map (HeaderHash blk) blk -> [Chain blk]
chains bs = go Chain.Genesis
Expand Down Expand Up @@ -1041,3 +1123,26 @@ wipeVolatileDB cfg m =
-> error "Did not select the ImmutableDB's chain"

toHashes = map blockHash . Chain.toOldestFirst

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

0 comments on commit 1357c1b

Please sign in to comment.