From 00f2c3aeec1cd6579507cbc0a2d0026d7fb54417 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 25 Jun 2020 14:15:31 +0200 Subject: [PATCH] Remove blockPrevHash from HasHeader This is the first step towards the master plan for getting rid of EBBs (#2156). Given blocks `A, EBB, B`, we will reinterpret the prev hash of `B` to be `A`. However, in order to support legacy nodes, we must do this rewrite conditionally. The network layer does not, and should not, need to know anything about this, but `HasHeader` _did_ insist that the prevhash of a block was known, even though the network layer actually never depended on that information at all, except in some assertion checks -- and in one other place (see below). Those assertion checks were useful in early developemnt but header validation is of course the responsibility of consensus, and the assertions don't add much on top. This means `HasHeader` now no longer has `blockPrevHash` or indeed `blockInvariant`; they are both still available as `HasFullHeader`, used in the network tests only. The one other place where the network layer depended on this was in joining `FetchRequest`: it was joining to fetch requests if the two fragments happened to fit together, and it was using the prev hash for this. This is no longer possible, _but_ there was no reason for `FetchRequest` to use `ChainFragment` instead of `AnchoredFragment`: we start with an `AnchoredFragment`, and then _lose that information_ by dropping the anchor. Now `FetchRequest` _does_ use `AnchoredFragment` all the way, which means that we can use the anchor to see if two fetch requests fit together. --- .../Ouroboros/Consensus/Byron/Ledger/Block.hs | 22 ++-- .../Consensus/ByronSpec/Ledger/Block.hs | 22 ++-- .../Consensus/Shelley/Ledger/Block.hs | 22 ++-- .../Ouroboros/Consensus/Mock/Ledger/Block.hs | 22 ++-- .../Ouroboros/Consensus/Mock/Ledger/State.hs | 8 +- .../src/Test/ThreadNet/Util.hs | 7 +- .../src/Test/Util/TestBlock.hs | 28 ++--- .../src/Ouroboros/Consensus/Block/Abstract.hs | 22 +++- .../Consensus/Block/SupportsProtocol.hs | 4 +- .../HardFork/Combinator/AcrossEras.hs | 34 +++--- .../Consensus/HardFork/Combinator/Block.hs | 23 ++-- .../HardFork/Combinator/Degenerate.hs | 22 ++-- .../Ouroboros/Consensus/HeaderValidation.hs | 13 ++- .../src/Ouroboros/Consensus/Ledger/Dual.hs | 22 ++-- .../Storage/ChainDB/Impl/ChainSel.hs | 7 +- .../Consensus/Storage/ChainDB/Impl/ImmDB.hs | 4 +- .../Consensus/Storage/ChainDB/Impl/VolDB.hs | 12 +- .../Consensus/Storage/ImmutableDB/Parser.hs | 67 ++++------- .../Test/Consensus/HardFork/Combinator/A.hs | 22 ++-- .../Test/Consensus/HardFork/Combinator/B.hs | 22 ++-- .../Ouroboros/Storage/ChainDB/Iterator.hs | 2 +- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 10 +- .../Storage/ImmutableDB/StateMachine.hs | 4 +- .../Test/Ouroboros/Storage/TestBlock.hs | 26 +++-- .../src/Ouroboros/Network/AnchoredFragment.hs | 87 +++++++++++--- .../src/Ouroboros/Network/Block.hs | 13 ++- .../Ouroboros/Network/BlockFetch/Client.hs | 18 +-- .../Network/BlockFetch/ClientState.hs | 18 +-- .../Ouroboros/Network/BlockFetch/Decision.hs | 90 ++++++++------- .../src/Ouroboros/Network/BlockFetch/State.hs | 10 +- .../src/Ouroboros/Network/ChainFragment.hs | 107 ++++-------------- .../src/Ouroboros/Network/MockChain/Chain.hs | 17 +-- .../Network/MockChain/ProducerState.hs | 4 +- .../Network/Testing/ConcreteBlock.hs | 20 ++-- .../test/Ouroboros/Network/MockNode.hs | 8 +- .../test/Test/AnchoredFragment.hs | 80 ++++++++++++- ouroboros-network/test/Test/ChainFragment.hs | 73 +----------- .../test/Test/Ouroboros/Network/BlockFetch.hs | 7 +- 38 files changed, 514 insertions(+), 485 deletions(-) diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Block.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Block.hs index d1cdb88c80..03f9cceceb 100644 --- a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Block.hs +++ b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Block.hs @@ -195,18 +195,20 @@ type instance HeaderHash ByronBlock = ByronHash instance StandardHash ByronBlock instance HasHeader ByronBlock where - blockHash = blockHash . getHeader - blockPrevHash = castHash . blockPrevHash . getHeader - blockSlot = blockSlot . getHeader - blockNo = blockNo . getHeader - blockInvariant = const True + blockHash = blockHash . getHeader + blockSlot = blockSlot . getHeader + blockNo = blockNo . getHeader instance HasHeader (Header ByronBlock) where - blockHash = byronHeaderHash - blockSlot = byronHeaderSlotNo - blockPrevHash = fromByronPrevHash' . CC.abobHdrPrevHash . byronHeaderRaw - blockNo = fromByronBlockNo . CC.abobHdrChainDifficulty . byronHeaderRaw - blockInvariant = const True + blockHash = byronHeaderHash + blockSlot = byronHeaderSlotNo + blockNo = fromByronBlockNo . CC.abobHdrChainDifficulty . byronHeaderRaw + +instance GetPrevHash ByronBlock where + getPrevHash = castHash . getPrevHash . getHeader + +instance GetPrevHash (Header ByronBlock) where + getPrevHash = fromByronPrevHash' . CC.abobHdrPrevHash . byronHeaderRaw instance Measured BlockMeasure ByronBlock where measure = blockMeasure diff --git a/ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Block.hs b/ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Block.hs index 1663b62c75..f743c0076c 100644 --- a/ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Block.hs +++ b/ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Block.hs @@ -81,20 +81,20 @@ instance Measured BlockMeasure ByronSpecBlock where measure = blockMeasure instance HasHeader ByronSpecBlock where - blockHash = blockHash . getHeader - blockNo = blockNo . getHeader - blockPrevHash = castHash . blockPrevHash . getHeader - blockSlot = blockSlot . getHeader - - blockInvariant = const True + blockHash = blockHash . getHeader + blockNo = blockNo . getHeader + blockSlot = blockSlot . getHeader instance HasHeader ByronSpecHeader where - blockHash = byronSpecHeaderHash - blockNo = byronSpecHeaderNo - blockPrevHash = fromByronSpecPrevHash id . Spec._bhPrevHash . byronSpecHeader - blockSlot = fromByronSpecSlotNo . Spec._bhSlot . byronSpecHeader + blockHash = byronSpecHeaderHash + blockNo = byronSpecHeaderNo + blockSlot = fromByronSpecSlotNo . Spec._bhSlot . byronSpecHeader + +instance GetPrevHash ByronSpecBlock where + getPrevHash = castHash . getPrevHash . getHeader - blockInvariant = const True +instance GetPrevHash ByronSpecHeader where + getPrevHash = fromByronSpecPrevHash id . Spec._bhPrevHash . byronSpecHeader {------------------------------------------------------------------------------- Config diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs index f719322005..4cb0fc2455 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -135,25 +135,25 @@ mkShelleyHeader raw = ShelleyHeader { } instance Crypto c => HasHeader (ShelleyBlock c) where - blockHash = blockHash . getHeader - blockPrevHash = castHash . blockPrevHash . getHeader - blockSlot = blockSlot . getHeader - blockNo = blockNo . getHeader - blockInvariant = const True + blockHash = blockHash . getHeader + blockSlot = blockSlot . getHeader + blockNo = blockNo . getHeader instance Crypto c => HasHeader (Header (ShelleyBlock c)) where - blockHash = shelleyHeaderHash + blockHash = shelleyHeaderHash + blockSlot = SL.bheaderSlotNo . SL.bhbody . shelleyHeaderRaw + blockNo = coerce . SL.bheaderBlockNo . SL.bhbody . shelleyHeaderRaw - blockPrevHash = +instance Crypto c => GetPrevHash (ShelleyBlock c) where + getPrevHash = castHash . getPrevHash . getHeader + +instance Crypto c => GetPrevHash (Header (ShelleyBlock c)) where + getPrevHash = fromShelleyPrevHash . SL.bheaderPrev . SL.bhbody . shelleyHeaderRaw - blockSlot = SL.bheaderSlotNo . SL.bhbody . shelleyHeaderRaw - blockNo = coerce . SL.bheaderBlockNo . SL.bhbody . shelleyHeaderRaw - blockInvariant = const True - instance Crypto c => Measured BlockMeasure (ShelleyBlock c) where measure = blockMeasure diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs index 189eddfa35..54b99a3cc6 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -197,11 +197,12 @@ countSimpleGenTxs = fromIntegral . length . extractTxs -------------------------------------------------------------------------------} instance (SimpleCrypto c, Typeable ext) => HasHeader (SimpleHeader c ext) where - blockHash = simpleHeaderHash - blockPrevHash = castHash . simplePrev . simpleHeaderStd - blockSlot = simpleSlotNo . simpleHeaderStd - blockNo = simpleBlockNo . simpleHeaderStd - blockInvariant = const True + blockHash = simpleHeaderHash + blockSlot = simpleSlotNo . simpleHeaderStd + blockNo = simpleBlockNo . simpleHeaderStd + +instance (SimpleCrypto c, Typeable ext) => GetPrevHash (SimpleHeader c ext) where + getPrevHash = castHash . simplePrev . simpleHeaderStd {------------------------------------------------------------------------------- HasHeader instance for SimpleBlock @@ -215,11 +216,12 @@ instance (SimpleCrypto c, Typeable ext) measure = blockMeasure instance (SimpleCrypto c, Typeable ext) => HasHeader (SimpleBlock c ext) where - blockHash = blockHash . simpleHeader - blockPrevHash = castHash . blockPrevHash . simpleHeader - blockSlot = blockSlot . simpleHeader - blockNo = blockNo . simpleHeader - blockInvariant = const True + blockHash = blockHash . simpleHeader + blockSlot = blockSlot . simpleHeader + blockNo = blockNo . simpleHeader + +instance (SimpleCrypto c, Typeable ext) => GetPrevHash (SimpleBlock c ext) where + getPrevHash = castHash . getPrevHash . simpleHeader instance (SimpleCrypto c, Typeable ext) => StandardHash (SimpleBlock c ext) diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/State.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/State.hs index c5a317b89c..f24bfdd98a 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/State.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/State.hs @@ -26,8 +26,8 @@ import Cardano.Crypto.Hash import Cardano.Prelude (NoUnexpectedThunks) import Cardano.Slotting.Slot (SlotNo) -import Ouroboros.Network.Block (ChainHash, HasHeader, HeaderHash, - Point, StandardHash, blockSlot, genesisPoint, pointHash) +import Ouroboros.Network.Block (ChainHash, HeaderHash, Point, + StandardHash, blockSlot, genesisPoint, pointHash) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Mock.Ledger.Address @@ -60,7 +60,7 @@ deriving instance StandardHash blk => Eq (MockError blk) deriving instance Serialise (HeaderHash blk) => Serialise (MockError blk) updateMockState :: ( GetHeader blk - , HasHeader (Header blk) + , GetPrevHash (Header blk) , StandardHash blk , HasMockTxs blk ) @@ -72,7 +72,7 @@ updateMockState blk st = do st' <- updateMockTip hdr st updateMockUTxO (blockSlot hdr) blk st' -updateMockTip :: (HasHeader (Header blk), StandardHash blk) +updateMockTip :: (GetPrevHash (Header blk), StandardHash blk) => Header blk -> MockState blk -> Except (MockError blk) (MockState blk) diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Util.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Util.hs index 2e9c9edb29..477b8a7724 100644 --- a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Util.hs +++ b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Util.hs @@ -36,6 +36,7 @@ import Ouroboros.Network.Block import Ouroboros.Network.MockChain.Chain (Chain (..)) import qualified Ouroboros.Network.MockChain.Chain as Chain +import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..)) import Ouroboros.Consensus.NodeId @@ -119,13 +120,13 @@ genesisBlockInfo = BlockInfo } -blockInfo :: (HasHeader b, HasCreator b) +blockInfo :: (GetPrevHash b, HasCreator b) => b -> BlockInfo b blockInfo b = BlockInfo { biSlot = blockSlot b , biCreator = Just $ getCreator b , biHash = BlockHash $ blockHash b - , biPrevious = Just $ blockPrevHash b + , biPrevious = Just $ getPrevHash b } data NodeLabel = NodeLabel @@ -158,7 +159,7 @@ data EdgeLabel = EdgeLabel instance Labellable EdgeLabel where toLabelValue = const $ StrLabel Text.empty -tracesToDot :: forall b. (HasHeader b, HasCreator b) +tracesToDot :: forall b. (GetPrevHash b, HasCreator b) => Map NodeId (NodeOutput b) -> String tracesToDot traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs index 4ead34a116..50afb29cb9 100644 --- a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs @@ -191,20 +191,22 @@ instance GetHeader TestBlock where type instance HeaderHash TestBlock = TestHash instance Block.HasHeader TestBlock where - blockHash = tbHash - blockPrevHash b = case NE.nonEmpty . NE.tail . unTestHash . tbHash $ b of + blockHash = tbHash + blockSlot = tbSlot + blockNo = fromIntegral . NE.length . unTestHash . tbHash + +instance Block.HasHeader (Header TestBlock) where + blockHash = Block.blockHash . testHeader + blockSlot = Block.blockSlot . testHeader + blockNo = Block.blockNo . testHeader + +instance GetPrevHash TestBlock where + getPrevHash b = case NE.nonEmpty . NE.tail . unTestHash . tbHash $ b of Nothing -> GenesisHash Just prevHash -> BlockHash (TestHash prevHash) - blockSlot = tbSlot - blockNo = fromIntegral . NE.length . unTestHash . tbHash - blockInvariant = const True -instance Block.HasHeader (Header TestBlock) where - blockHash = Block.blockHash . testHeader - blockPrevHash = Block.castHash . Block.blockPrevHash . testHeader - blockSlot = Block.blockSlot . testHeader - blockNo = Block.blockNo . testHeader - blockInvariant = const True +instance GetPrevHash (Header TestBlock) where + getPrevHash = Block.castHash . getPrevHash . testHeader instance Block.StandardHash TestBlock @@ -286,8 +288,8 @@ instance IsLedger (LedgerState TestBlock) where instance ApplyBlock (LedgerState TestBlock) TestBlock where applyLedgerBlock _ tb@TestBlock{..} (Ticked _ TestLedger{..}) - | Block.blockPrevHash tb /= Block.pointHash lastAppliedPoint - = throwError $ InvalidHash (Block.pointHash lastAppliedPoint) (Block.blockPrevHash tb) + | getPrevHash tb /= Block.pointHash lastAppliedPoint + = throwError $ InvalidHash (Block.pointHash lastAppliedPoint) (getPrevHash tb) | not tbValid = throwError $ InvalidBlock | otherwise diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Block/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Block/Abstract.hs index 4d25a1cc26..ca048f53b4 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Block/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Block/Abstract.hs @@ -10,10 +10,12 @@ module Ouroboros.Consensus.Block.Abstract ( -- * Configuration , BlockConfig , HasCodecConfig(..) + -- * Previous hash + , GetPrevHash(..) + , headerPrevHash -- * Working with headers , GetHeader(..) , headerHash - , headerPrevHash , headerPoint , headerToIsEBB , blockIsEBB @@ -66,6 +68,21 @@ class NoUnexpectedThunks (CodecConfig blk) => HasCodecConfig blk where getCodecConfig :: BlockConfig blk -> CodecConfig blk +{------------------------------------------------------------------------------- + Get hash of previous block +-------------------------------------------------------------------------------} + +class HasHeader blk => GetPrevHash blk where + -- | Get the hash of the predecessor of this block + -- + -- This gets its own abstraction, because it will be a key part of the path + -- to getting rid of EBBs: when we have blocks @A - EBB - B@, the prev hash + -- of @B@ will be reported as @A@. + getPrevHash :: blk -> ChainHash blk + +headerPrevHash :: GetPrevHash (Header blk) => Header blk -> ChainHash blk +headerPrevHash = castHash . getPrevHash + {------------------------------------------------------------------------------- Link block to its header -------------------------------------------------------------------------------} @@ -120,9 +137,6 @@ instance HasHeader (Header blk) => Measured BlockMeasure (Header blk) where headerHash :: HasHeader (Header blk) => Header blk -> HeaderHash blk headerHash = blockHash -headerPrevHash :: HasHeader (Header blk) => Header blk -> ChainHash blk -headerPrevHash = castHash . blockPrevHash - headerPoint :: HasHeader (Header blk) => Header blk -> Point blk headerPoint = castPoint . blockPoint diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Block/SupportsProtocol.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Block/SupportsProtocol.hs index 1353ce03ef..13eb6a56ab 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Block/SupportsProtocol.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Block/SupportsProtocol.hs @@ -19,8 +19,8 @@ import Ouroboros.Consensus.Protocol.Abstract -- | Evidence that a block supports its protocol class ( GetHeader blk - , HasHeader blk - , HasHeader (Header blk) + , GetPrevHash blk + , GetPrevHash (Header blk) , ConsensusProtocol (BlockProtocol blk) , NoUnexpectedThunks (Header blk) , NoUnexpectedThunks (BlockConfig blk) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs index 44437f7aef..03929a43f3 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs @@ -227,30 +227,29 @@ instance CanHardFork xs => Measured BlockMeasure (OneEraHeader xs) where measure = blockMeasure instance CanHardFork xs => HasHeader (OneEraHeader xs) where - blockHash = hcollapse - . hcmap proxySingle (K . getOneHash) - . getOneEraHeader + blockHash = hcollapse + . hcmap proxySingle (K . getOneHash) + . getOneEraHeader where getOneHash :: forall blk. SingleEraBlock blk => Header blk -> OneEraHash xs getOneHash = OneEraHash . toRawHash (Proxy @blk) . blockHash - blockPrevHash = hcollapse - . hcmap proxySingle (K . getOnePrev) - . getOneEraHeader + blockSlot = hcollapse . hcmap proxySingle (K . blockSlot) . getOneEraHeader + blockNo = hcollapse . hcmap proxySingle (K . blockNo) . getOneEraHeader + +instance CanHardFork xs => GetPrevHash (OneEraHeader xs) where + getPrevHash = hcollapse + . hcmap proxySingle (K . getOnePrev) + . getOneEraHeader where getOnePrev :: forall blk. SingleEraBlock blk => Header blk -> ChainHash (OneEraHeader xs) getOnePrev hdr = - case blockPrevHash hdr of + case getPrevHash hdr of GenesisHash -> GenesisHash BlockHash h -> BlockHash (OneEraHash $ toRawHash (Proxy @blk) h) - blockSlot = hcollapse . hcmap proxySingle (K . blockSlot) . getOneEraHeader - blockNo = hcollapse . hcmap proxySingle (K . blockNo) . getOneEraHeader - - blockInvariant = const True - {------------------------------------------------------------------------------- HasHeader instance for OneEraBlock -------------------------------------------------------------------------------} @@ -263,11 +262,12 @@ instance CanHardFork xs => Measured BlockMeasure (OneEraBlock xs) where measure = blockMeasure instance CanHardFork xs => HasHeader (OneEraBlock xs) where - blockHash = blockHash . oneEraBlockHeader - blockPrevHash = castHash . blockPrevHash . oneEraBlockHeader - blockSlot = blockSlot . oneEraBlockHeader - blockNo = blockNo . oneEraBlockHeader - blockInvariant = const True + blockHash = blockHash . oneEraBlockHeader + blockSlot = blockSlot . oneEraBlockHeader + blockNo = blockNo . oneEraBlockHeader + +instance CanHardFork xs => GetPrevHash (OneEraBlock xs) where + getPrevHash = castHash . getPrevHash . oneEraBlockHeader {------------------------------------------------------------------------------- NoUnexpectedThunks instances diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Block.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Block.hs index a840e9e441..c1c4bb8160 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Block.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Block.hs @@ -83,18 +83,20 @@ instance CanHardFork xs => Measured BlockMeasure (HardForkBlock xs) where measure = blockMeasure instance CanHardFork xs => HasHeader (HardForkBlock xs) where - blockHash = blockHash . getHeader - blockPrevHash = castHash . blockPrevHash . getHeader - blockSlot = blockSlot . getHeader - blockNo = blockNo . getHeader - blockInvariant = const True + blockHash = blockHash . getHeader + blockSlot = blockSlot . getHeader + blockNo = blockNo . getHeader instance CanHardFork xs => HasHeader (Header (HardForkBlock xs)) where - blockHash = blockHash . getHardForkHeader - blockPrevHash = castHash . blockPrevHash . getHardForkHeader - blockSlot = blockSlot . getHardForkHeader - blockNo = blockNo . getHardForkHeader - blockInvariant = const True + blockHash = blockHash . getHardForkHeader + blockSlot = blockSlot . getHardForkHeader + blockNo = blockNo . getHardForkHeader + +instance CanHardFork xs => GetPrevHash (HardForkBlock xs) where + getPrevHash = castHash . getPrevHash . getHeader + +instance CanHardFork xs => GetPrevHash (Header (HardForkBlock xs)) where + getPrevHash = castHash . getPrevHash . getHardForkHeader {------------------------------------------------------------------------------- Codec config @@ -113,7 +115,6 @@ instance CanHardFork xs => HasCodecConfig (HardForkBlock xs) where . getPerEraBlockConfig . hardForkBlockConfigPerEra - {------------------------------------------------------------------------------- NestedContent -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs index 2da0dc0448..d86146d419 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs @@ -164,18 +164,20 @@ instance SingleEraBlock b => Measured BlockMeasure (DegenFork b) where measure = blockMeasure instance SingleEraBlock b => HasHeader (DegenFork b) where - blockHash = DHash . blockHash . unDBlk - blockPrevHash = castHash . blockPrevHash . unDBlk - blockSlot = blockSlot . unDBlk - blockNo = blockNo . unDBlk - blockInvariant = const True + blockHash = DHash . blockHash . unDBlk + blockSlot = blockSlot . unDBlk + blockNo = blockNo . unDBlk instance SingleEraBlock b => HasHeader (Header (DegenFork b)) where - blockHash = DHash . blockHash . unDHdr - blockPrevHash = castHash . blockPrevHash . unDHdr - blockSlot = blockSlot . unDHdr - blockNo = blockNo . unDHdr - blockInvariant = const True + blockHash = DHash . blockHash . unDHdr + blockSlot = blockSlot . unDHdr + blockNo = blockNo . unDHdr + +instance SingleEraBlock b => GetPrevHash (DegenFork b) where + getPrevHash = castHash . getPrevHash . unDBlk + +instance SingleEraBlock b => GetPrevHash (Header (DegenFork b)) where + getPrevHash = castHash . getPrevHash . unDHdr {------------------------------------------------------------------------------- Forward the 'ConsensusProtocol' instance diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs index 708e19d5e5..cc84455f1b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs @@ -280,7 +280,9 @@ castHeaderEnvelopeError = \case UnexpectedPrevHash oldTip prevHash -> UnexpectedPrevHash oldTip (castHash prevHash) -- | Ledger-independent envelope validation (block, slot, hash) -class HasAnnTip blk => BasicEnvelopeValidation blk where +class ( HasHeader (Header blk) + , HasAnnTip blk + ) => BasicEnvelopeValidation blk where -- | The block number of the first block on the chain expectedFirstBlockNo :: proxy blk -> BlockNo expectedFirstBlockNo _ = BlockNo 0 @@ -308,6 +310,7 @@ class HasAnnTip blk => BasicEnvelopeValidation blk where -- | Validate header envelope class ( BasicEnvelopeValidation blk + , GetPrevHash (Header blk) , Eq (OtherHeaderEnvelopeError blk) , Show (OtherHeaderEnvelopeError blk) , NoUnexpectedThunks (OtherHeaderEnvelopeError blk) @@ -325,7 +328,7 @@ class ( BasicEnvelopeValidation blk additionalEnvelopeChecks _ _ _ = return () -- | Validate the header envelope -validateEnvelope :: forall blk. (ValidateEnvelope blk, HasHeader (Header blk)) +validateEnvelope :: forall blk. (ValidateEnvelope blk) => TopLevelConfig blk -> Ticked (LedgerView (BlockProtocol blk)) -> WithOrigin (AnnTip blk) -- ^ Old tip @@ -352,9 +355,9 @@ validateEnvelope cfg ledgerView oldTip hdr = do actualBlockNo :: BlockNo actualPrevHash :: ChainHash blk - actualSlotNo = blockSlot hdr - actualBlockNo = blockNo hdr - actualPrevHash = castHash $ blockPrevHash hdr + actualSlotNo = blockSlot hdr + actualBlockNo = blockNo hdr + actualPrevHash = headerPrevHash hdr expectedSlotNo :: SlotNo -- Lower bound only expectedSlotNo = diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs index a9f55fc0d2..c6201ae4df 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs @@ -240,20 +240,20 @@ instance Bridge m a => Measured BlockMeasure (DualBlock m a) where measure = blockMeasure instance Bridge m a => HasHeader (DualBlock m a) where - blockHash = blockHash . getHeader - blockPrevHash = castHash . blockPrevHash . getHeader - blockSlot = blockSlot . getHeader - blockNo = blockNo . getHeader - - blockInvariant = const True + blockHash = blockHash . getHeader + blockSlot = blockSlot . getHeader + blockNo = blockNo . getHeader instance Bridge m a => HasHeader (DualHeader m a) where - blockHash = blockHash . dualHeaderMain - blockPrevHash = castHash . blockPrevHash . dualHeaderMain - blockSlot = blockSlot . dualHeaderMain - blockNo = blockNo . dualHeaderMain + blockHash = blockHash . dualHeaderMain + blockSlot = blockSlot . dualHeaderMain + blockNo = blockNo . dualHeaderMain + +instance Bridge m a => GetPrevHash (DualBlock m a) where + getPrevHash = castHash . getPrevHash . getHeader - blockInvariant = const True +instance Bridge m a => GetPrevHash (DualHeader m a) where + getPrevHash = castHash . getPrevHash . dualHeaderMain {------------------------------------------------------------------------------- Protocol diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 4f0cbcb410..a533620088 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -233,7 +233,7 @@ addBlockAsync CDB { cdbTracer, cdbBlocksToAdd } = addBlockSync :: forall m blk. ( IOLike m - , HasHeader blk + , GetPrevHash blk , LedgerSupportsProtocol blk , HasHardForkHistory blk , VolDbSerialiseConstraints blk @@ -458,7 +458,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr = do return tipPoint -- The block @b@ fits onto the end of our current chain - | pointHash tipPoint == castHash (blockPrevHash hdr) -> do + | pointHash tipPoint == castHash (getPrevHash hdr) -> do -- ### Add to current chain trace (TryAddToCurrentChain p) addToCurrentChain succsOf' curChainAndLedger @@ -509,8 +509,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr = do -> ChainAndLedger blk -- ^ The current chain and ledger -> m (Point blk) - addToCurrentChain succsOf curChainAndLedger - = assert (AF.validExtension curChain hdr) $ do + addToCurrentChain succsOf curChainAndLedger = do let suffixesAfterB = VolDB.candidates succsOf (realPointToPoint p) -- Fragments that are anchored at @curHead@, i.e. suffixes of the diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ImmDB.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ImmDB.hs index b84a46e60f..e2bdf9b32d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ImmDB.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ImmDB.hs @@ -216,7 +216,7 @@ hashInfo p = HashInfo { hashSize, getHash, putHash } withImmDB :: ( IOLike m - , HasHeader blk + , GetPrevHash blk , GetHeader blk , ConvertRawHash blk , ImmDbSerialiseConstraints blk @@ -228,7 +228,7 @@ withImmDB args = bracket (openDB args) closeDB openDB :: forall m blk. ( IOLike m - , HasHeader blk + , GetPrevHash blk , GetHeader blk , ConvertRawHash blk , ImmDbSerialiseConstraints blk diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/VolDB.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/VolDB.hs index 0c0379e033..b9fe14c9c4 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/VolDB.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/VolDB.hs @@ -167,7 +167,7 @@ defaultArgs fp = VolDbArgs { openDB :: forall m blk. - (IOLike m, HasHeader blk, GetHeader blk, VolDbSerialiseConstraints blk) + (IOLike m, GetPrevHash blk, GetHeader blk, VolDbSerialiseConstraints blk) => VolDbArgs m blk -> m (VolDB m blk) openDB args@VolDbArgs{..} = do createDirectoryIfMissing volHasFS True (mkFsPath []) @@ -220,7 +220,7 @@ getMaxSlotNo :: VolDB m blk getMaxSlotNo db = withSTM db VolDB.getMaxSlotNo putBlock - :: (MonadCatch m, HasHeader blk, GetHeader blk, VolDbSerialiseConstraints blk) + :: (MonadCatch m, GetPrevHash blk, GetHeader blk, VolDbSerialiseConstraints blk) => VolDB m blk -> blk -> m () putBlock db@VolDB{..} b = withDB db $ \vol -> VolDB.putBlock vol (extractInfo b binaryBlockInfo) binaryBlob @@ -490,7 +490,7 @@ type BlockFileParserError hash = blockFileParser :: forall m blk. ( IOLike m - , HasHeader blk + , GetPrevHash blk , GetHeader blk , VolDbSerialiseConstraints blk ) @@ -522,7 +522,7 @@ blockFileParser VolDbArgs{..} = -- | A version which is easier to use for tests, since it does not require -- the whole @VolDbArgs@. blockFileParser' - :: forall m blk h. (IOLike m, HasHeader blk, GetHeader blk) + :: forall m blk h. (IOLike m, GetPrevHash blk, GetHeader blk) => HasFS m h -> (blk -> BinaryBlockInfo) -> (forall s. Decoder s (Lazy.ByteString -> (ShortByteString, blk))) @@ -611,14 +611,14 @@ fromChainHash :: ChainHash blk -> WithOrigin (HeaderHash blk) fromChainHash GenesisHash = Origin fromChainHash (BlockHash hash) = At hash -extractInfo :: (HasHeader blk, GetHeader blk) +extractInfo :: (GetPrevHash blk, GetHeader blk) => blk -> BinaryBlockInfo -> VolDB.BlockInfo (HeaderHash blk) extractInfo b BinaryBlockInfo{..} = VolDB.BlockInfo { bbid = blockHash b , bslot = blockSlot b - , bpreBid = fromChainHash (blockPrevHash b) + , bpreBid = fromChainHash (getPrevHash b) , bisEBB = blockToIsEBB b , bheaderOffset = headerOffset , bheaderSize = headerSize diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Parser.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Parser.hs index c051ecb067..b39ae5b136 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Parser.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Parser.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} -- | The ImmutableDB doesn't care about the serialisation format, but in -- practice we use CBOR. If we were to change the serialisation format, we -- would have to write a new 'ChunkFileParser' implementation, but the rest of @@ -14,7 +15,6 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Parser ChunkFileError (..) , BlockSummary(..) , chunkFileParser - , chunkFileParser' ) where import Codec.CBOR.Decoding (Decoder) @@ -27,13 +27,13 @@ import qualified Streaming as S import qualified Streaming.Prelude as S import Cardano.Slotting.Block -import Cardano.Slotting.Slot import Ouroboros.Network.Block (ChainHash (..), HasHeader (..), HeaderHash) import Ouroboros.Network.Point (WithOrigin (..)) -import Ouroboros.Consensus.Block (GetHeader, blockIsEBB) +import Ouroboros.Consensus.Block (GetHeader (..), GetPrevHash (..), + blockIsEBB) import qualified Ouroboros.Consensus.Util.CBOR as Util.CBOR import Ouroboros.Consensus.Util.IOLike @@ -69,25 +69,23 @@ data BlockSummary hash = BlockSummary { , summaryBlockNo :: !BlockNo } -chunkFileParser' - :: forall m blk hash h. (IOLike m, Eq hash) - => (blk -> SlotNo) - -> (blk -> BlockNo) - -> (blk -> hash) - -> (blk -> WithOrigin hash) -- ^ Previous hash - -> (blk -> Maybe EpochNo) -- ^ If an EBB, return the epoch number - -> HasFS m h +chunkFileParser + :: forall m blk h hash. ( + IOLike m + , GetHeader blk + , GetPrevHash blk + , hash ~ HeaderHash blk + ) + => HasFS m h -> (forall s. Decoder s (BL.ByteString -> blk)) -> (blk -> BinaryBlockInfo) - -> (blk -> Bool) -- ^ Check integrity of the block. 'False' = - -- corrupt. + -> (blk -> Bool) -- ^ Check integrity of the block. 'False' = corrupt. -> ChunkFileParser (ChunkFileError hash) m (BlockSummary hash) hash -chunkFileParser' getSlotNo getBlockNo getHash getPrevHash isEBB hasFS decodeBlock - getBinaryBlockInfo isNotCorrupt = +chunkFileParser hasFS decodeBlock getBinaryBlockInfo isNotCorrupt = ChunkFileParser $ \fsPath expectedChecksums k -> Util.CBOR.withStreamIncrementalOffsets hasFS decoder fsPath ( k @@ -96,6 +94,10 @@ chunkFileParser' getSlotNo getBlockNo getHash getPrevHash isEBB hasFS decodeBloc . fmap (fmap (first ChunkErrRead)) ) where + convertPrevHash :: ChainHash blk -> WithOrigin (HeaderHash blk) + convertPrevHash GenesisHash = Origin + convertPrevHash (BlockHash h) = At h + decoder :: forall s. Decoder s (BL.ByteString -> (blk, CRC)) decoder = decodeBlock <&> \mkBlk bs -> let !blk = mkBlk bs @@ -152,19 +154,19 @@ chunkFileParser' getSlotNo getBlockNo getHash getPrevHash isEBB hasFS decodeBloc :: (Word64, (Word64, (blk, CRC))) -> (BlockSummary hash, WithOrigin hash) entryForBlockAndInfo (offset, (_size, (blk, checksum))) = - (BlockSummary entry (getBlockNo blk), prevHash) + (BlockSummary entry (blockNo blk), prevHash) where -- Don't accidentally hold on to the block! - !prevHash = getPrevHash blk + !prevHash = convertPrevHash $ getPrevHash blk !entry = Secondary.Entry { blockOffset = Secondary.BlockOffset offset , headerOffset = Secondary.HeaderOffset headerOffset , headerSize = Secondary.HeaderSize headerSize , checksum = checksum - , headerHash = getHash blk - , blockOrEBB = case isEBB blk of + , headerHash = blockHash blk + , blockOrEBB = case blockIsEBB blk of Just epoch -> EBB epoch - Nothing -> Block (getSlotNo blk) + Nothing -> Block (blockSlot blk) } BinaryBlockInfo { headerOffset, headerSize } = getBinaryBlockInfo blk @@ -190,31 +192,6 @@ chunkFileParser' getSlotNo getBlockNo getHash getPrevHash isEBB hasFS decodeBloc err = ChunkErrHashMismatch (At hashOfPrevBlock) prevHash offset = Secondary.unBlockOffset $ Secondary.blockOffset entry --- | A version of 'chunkFileParser'' for blocks that implement 'HasHeader'. -chunkFileParser - :: forall m blk h. (IOLike m, HasHeader blk, GetHeader blk) - => HasFS m h - -> (forall s. Decoder s (BL.ByteString -> blk)) - -> (blk -> BinaryBlockInfo) - -> (blk -> Bool) -- ^ Check integrity of the block. 'False' = - -- corrupt. - -> ChunkFileParser - (ChunkFileError (HeaderHash blk)) - m - (BlockSummary (HeaderHash blk)) - (HeaderHash blk) -chunkFileParser = - chunkFileParser' - blockSlot - blockNo - blockHash - (convertPrevHash . blockPrevHash) - blockIsEBB - where - convertPrevHash :: ChainHash blk -> WithOrigin (HeaderHash blk) - convertPrevHash GenesisHash = Origin - convertPrevHash (BlockHash h) = At h - {------------------------------------------------------------------------------- Streaming utilities -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs index 981a340ab6..1e600d5e38 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs @@ -179,18 +179,20 @@ instance Measured BlockMeasure BlockA where measure = blockMeasure instance HasHeader BlockA where - blockHash = blockHash . getHeader - blockPrevHash = castHash . blockPrevHash . getHeader - blockSlot = blockSlot . getHeader - blockNo = blockNo . getHeader - blockInvariant = const True + blockHash = blockHash . getHeader + blockSlot = blockSlot . getHeader + blockNo = blockNo . getHeader instance HasHeader (Header BlockA) where - blockHash = headerFieldHash . hdrA_fields - blockPrevHash = castHash . headerFieldPrevHash . hdrA_fields - blockSlot = headerFieldSlot . hdrA_fields - blockNo = headerFieldNo . hdrA_fields - blockInvariant = const True + blockHash = headerFieldHash . hdrA_fields + blockSlot = headerFieldSlot . hdrA_fields + blockNo = headerFieldNo . hdrA_fields + +instance GetPrevHash BlockA where + getPrevHash = castHash . getPrevHash . getHeader + +instance GetPrevHash (Header BlockA) where + getPrevHash = castHash . headerFieldPrevHash . hdrA_fields instance HasAnnTip BlockA where diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs index 8e4d27b0d2..ccefaf6530 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs @@ -158,18 +158,20 @@ instance Measured BlockMeasure BlockB where measure = blockMeasure instance HasHeader BlockB where - blockHash = blockHash . getHeader - blockPrevHash = castHash . blockPrevHash . getHeader - blockSlot = blockSlot . getHeader - blockNo = blockNo . getHeader - blockInvariant = const True + blockHash = blockHash . getHeader + blockSlot = blockSlot . getHeader + blockNo = blockNo . getHeader instance HasHeader (Header BlockB) where - blockHash = headerFieldHash . hdrB_fields - blockPrevHash = castHash . headerFieldPrevHash . hdrB_fields - blockSlot = headerFieldSlot . hdrB_fields - blockNo = headerFieldNo . hdrB_fields - blockInvariant = const True + blockHash = headerFieldHash . hdrB_fields + blockSlot = headerFieldSlot . hdrB_fields + blockNo = headerFieldNo . hdrB_fields + +instance GetPrevHash BlockB where + getPrevHash = castHash . getPrevHash . getHeader + +instance GetPrevHash (Header BlockB) where + getPrevHash = castHash . headerFieldPrevHash . hdrB_fields instance HasAnnTip BlockB where diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Iterator.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Iterator.hs index 49120dd39a..c2f263f2f8 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Iterator.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Iterator.hs @@ -400,7 +400,7 @@ initIteratorEnv TestSetup { immutable, volatile } tracer = do blockInfo tb = VolDB.BlockInfo { VolDB.bbid = blockHash tb , VolDB.bslot = blockSlot tb - , VolDB.bpreBid = case blockPrevHash tb of + , VolDB.bpreBid = case getPrevHash tb of GenesisHash -> Origin BlockHash h -> At h , VolDB.bisEBB = testBlockIsEBB tb diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs index bf81d95a6b..1c86d955e9 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -469,7 +469,7 @@ addBlockPromise cfg blk m = (result, m') -------------------------------------------------------------------------------} stream - :: HasHeader blk + :: GetPrevHash blk => SecurityParam -> StreamFrom blk -> StreamTo blk -> Model blk @@ -762,7 +762,7 @@ validate cfg Model { currentSlot, maxClockSkew, initLedger, invalid } chain = -> findInvalidBlockInTheFuture ledger' bs' -chains :: forall blk. (HasHeader blk) +chains :: forall blk. (GetPrevHash blk) => Map (HeaderHash blk) blk -> [Chain blk] chains bs = go Chain.Genesis where @@ -819,15 +819,15 @@ validChains cfg m bs = (invalid, [(chain, ledger)]) -- Map (HeaderHash blk) blk maps a block's hash to the block itself -successors :: forall blk. HasHeader blk +successors :: forall blk. GetPrevHash blk => [blk] -> Map (ChainHash blk) (Map (HeaderHash blk) blk) successors = Map.unionsWith Map.union . map single where single :: blk -> Map (ChainHash blk) (Map (HeaderHash blk) blk) - single b = Map.singleton (Block.blockPrevHash b) + single b = Map.singleton (getPrevHash b) (Map.singleton (Block.blockHash b) b) -between :: forall blk. HasHeader blk +between :: forall blk. GetPrevHash blk => SecurityParam -> StreamFrom blk -> StreamTo blk -> Model blk -> Either (UnknownRange blk) [blk] between k from to m = do diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs index 82ae8b4827..35e5c9181b 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs @@ -790,8 +790,8 @@ precondition Model {..} (At (CmdErr { cmd })) = where fitsOnTip :: TestBlock -> Logic fitsOnTip b = case dbmTipBlock dbModel of - Nothing -> blockPrevHash b .== Block.GenesisHash - Just bPrev -> blockPrevHash b .== Block.BlockHash (blockHash bPrev) + Nothing -> getPrevHash b .== Block.GenesisHash + Just bPrev -> getPrevHash b .== Block.BlockHash (blockHash bPrev) transition :: (Show1 r, Eq1 r) => Model m r -> At CmdErr m r -> At Resp m r -> Model m r diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs index ba1d19f251..71998216c9 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs @@ -216,18 +216,20 @@ instance Measured BlockMeasure TestBlock where measure = blockMeasure instance HasHeader TestBlock where - blockHash = blockHash . getHeader - blockPrevHash = castHash . blockPrevHash . getHeader - blockSlot = blockSlot . getHeader - blockNo = blockNo . getHeader - blockInvariant = blockInvariant . getHeader + blockHash = blockHash . getHeader + blockSlot = blockSlot . getHeader + blockNo = blockNo . getHeader instance HasHeader (Header TestBlock) where - blockHash = thHash . unTestHeader - blockPrevHash = castHash . thPrevHash . unTestHeader - blockSlot = thSlotNo . unTestHeader - blockNo = thBlockNo . unTestHeader - blockInvariant = const True + blockHash = thHash . unTestHeader + blockSlot = thSlotNo . unTestHeader + blockNo = thBlockNo . unTestHeader + +instance GetPrevHash TestBlock where + getPrevHash = castHash . getPrevHash . getHeader + +instance GetPrevHash (Header TestBlock) where + getPrevHash = castHash . thPrevHash . unTestHeader data instance BlockConfig TestBlock = TestBlockConfig { -- | Whether the test block can be EBBs or not. This can vary per test @@ -554,8 +556,8 @@ instance IsLedger (LedgerState TestBlock) where instance ApplyBlock (LedgerState TestBlock) TestBlock where applyLedgerBlock _ tb@TestBlock{..} (Ticked _ TestLedger{..}) - | blockPrevHash tb /= lastAppliedHash - = throwError $ InvalidHash lastAppliedHash (blockPrevHash tb) + | getPrevHash tb /= lastAppliedHash + = throwError $ InvalidHash lastAppliedHash (getPrevHash tb) | not $ tbIsValid testBody = throwError $ InvalidBlock | otherwise diff --git a/ouroboros-network/src/Ouroboros/Network/AnchoredFragment.hs b/ouroboros-network/src/Ouroboros/Network/AnchoredFragment.hs index 66260e83ca..44ac4ecf2b 100644 --- a/ouroboros-network/src/Ouroboros/Network/AnchoredFragment.hs +++ b/ouroboros-network/src/Ouroboros/Network/AnchoredFragment.hs @@ -78,18 +78,19 @@ module Ouroboros.Network.AnchoredFragment ( intersect, intersectionPoint, mapAnchoredFragment, - anchorNewest, + filter, + filterWithStop, -- * Helper functions prettyPrint ) where -import Prelude hiding (head, last, length, null) +import Prelude hiding (head, last, length, null, filter) -import Control.Exception (assert) import Data.Functor ((<&>)) import Data.List (find) +import Data.Maybe (fromMaybe) import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack @@ -226,13 +227,9 @@ anchorToTip :: (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b anchorToTip AnchorGenesis = TipGenesis anchorToTip (Anchor s h b) = Tip s h b -mkAnchoredFragment :: HasHeader block - => Anchor block -> ChainFragment block +mkAnchoredFragment :: Anchor block -> ChainFragment block -> AnchoredFragment block -mkAnchoredFragment a c = case CF.last c of - Nothing -> AnchoredFragment a CF.Empty - Just b -> assert (validExtension (Empty a) b) $ - AnchoredFragment a c +mkAnchoredFragment = AnchoredFragment -- | \( O(1) \). Pattern for matching on or creating an empty -- 'AnchoredFragment'. An empty fragment has/needs an anchor point. @@ -256,11 +253,10 @@ pattern (:>) :: (HasHeader block, HasCallStack) => AnchoredFragment block -> block -> AnchoredFragment block pattern af' :> b <- (viewRight -> ConsR af' b) where - af@(AnchoredFragment a c) :> b = case c of + (AnchoredFragment a c) :> b = case c of -- When the chain fragment is empty, validate to check whether the block -- fits onto the anchor point. - CF.Empty -> assert (validExtension af b) $ - AnchoredFragment a (c CF.:> b) + CF.Empty -> AnchoredFragment a (c CF.:> b) -- Don't validate when we're just appending a block to the chain -- fragment, as 'CF.:>' will already validate for us. _ -> AnchoredFragment a (c CF.:> b) @@ -278,7 +274,8 @@ viewLeft (AnchoredFragment a c) = case c of -- | \( O(1) \). View the first, leftmost block of the anchored fragment. -- -- This is only a view, not a constructor, as adding a block to the left would --- change the anchor of the fragment. +-- change the anchor of the fragment, but we have no information about the +-- predecessor of the block we'd be prepending. pattern (:<) :: HasHeader block => block -> AnchoredFragment block -> AnchoredFragment block pattern b :< af' <- (viewLeft -> ConsL b af') @@ -299,12 +296,12 @@ prettyPrint nl ppPoint ppBlock (AnchoredFragment a c) = -- | \( O(n) \). -valid :: HasHeader block => AnchoredFragment block -> Bool +valid :: HasFullHeader block => AnchoredFragment block -> Bool valid (Empty _) = True valid (af :> b) = valid af && validExtension af b -- | \( O(1) \). -validExtension :: HasHeader block => AnchoredFragment block -> block -> Bool +validExtension :: HasFullHeader block => AnchoredFragment block -> block -> Bool validExtension af bSucc = blockInvariant bSucc && case head af of @@ -633,7 +630,7 @@ join af1@(AnchoredFragment a1 c1) af2@(AnchoredFragment a2 c2) = -> Nothing Right b1Head | blockPoint b1Head == anchorToPoint a2 - -> mkAnchoredFragment a1 <$> CF.joinChainFragments c1 c2 + -> Just $ mkAnchoredFragment a1 (CF.joinSuccessor c1 c2) | otherwise -> Nothing @@ -779,3 +776,61 @@ mapAnchoredFragment :: (HasHeader block1, HasHeader block2, -> AnchoredFragment block2 mapAnchoredFragment f (AnchoredFragment a c) = AnchoredFragment (castAnchor a) (CF.mapChainFragment f c) + +-- | \( O\(n\) \). Variation on 'filterWithStop' without a stop condition. +filter :: forall block. HasHeader block + => (block -> Bool) -- ^ Filtering predicate + -> AnchoredFragment block + -> [AnchoredFragment block] +filter p = filterWithStop p (const False) + +-- | \( O\(n\) \). Filter out blocks that don't match the predicate. +-- +-- As filtering removes blocks the result is a sequence of disconnected +-- fragments. The fragments are in the original order and are of maximum size. +-- +-- As soon as the stop condition is true, the filtering stops and the remaining +-- fragment (starting with the first element for which the stop condition is +-- true) is the final fragment in the returned list. +-- +-- The stop condition wins from the filtering predicate: if the stop condition +-- is true for an element, but the filter predicate not, then the element +-- still ends up in final fragment. +-- +-- For example, given the fragment containing @[1, 2, 3, 4, 5, 6]@: +-- +-- > filter odd -> [[1], [3], [5]] +-- > filterWithStop odd (>= 4) -> [[1], [3], [4, 5, 6]] +filterWithStop :: forall block. HasHeader block + => (block -> Bool) -- ^ Filtering predicate + -> (block -> Bool) -- ^ Stop condition + -> AnchoredFragment block + -> [AnchoredFragment block] +filterWithStop p stop = goNext [] + where + goNext :: [AnchoredFragment block] -- Previously constructed fragments + -> AnchoredFragment block -- Fragment still to process + -> [AnchoredFragment block] + goNext cs af = go cs (Empty (anchor af)) af + + go :: [AnchoredFragment block] -- Previously constructed fragments + -> AnchoredFragment block -- Currently accumulating fragment + -> AnchoredFragment block -- Fragment still to process + -> [AnchoredFragment block] + go cs c' af@(b :< c) | stop b = reverse (addToAcc (join' c' af) cs) + | p b = go cs (c' :> b) c + go cs c' (_ :< c) = goNext (addToAcc c' cs) c + go cs c' (Empty _) = reverse (addToAcc c' cs) + + addToAcc :: AnchoredFragment block + -> [AnchoredFragment block] + -> [AnchoredFragment block] + addToAcc (Empty _) acc = acc + addToAcc c' acc = c':acc + + -- This is called with @c'@ and @(b : < c)@. @c'@ is the fragment + -- containing the blocks before @b@, so they must be joinable. + join' :: AnchoredFragment block + -> AnchoredFragment block + -> AnchoredFragment block + join' a b = fromMaybe (error "could not join fragments") $ join a b diff --git a/ouroboros-network/src/Ouroboros/Network/Block.hs b/ouroboros-network/src/Ouroboros/Network/Block.hs index 03c169b8da..76ad4f795a 100644 --- a/ouroboros-network/src/Ouroboros/Network/Block.hs +++ b/ouroboros-network/src/Ouroboros/Network/Block.hs @@ -22,6 +22,7 @@ module Ouroboros.Network.Block ( , BlockNo(..) , HeaderHash , HasHeader(..) + , HasFullHeader(..) , StandardHash , ChainHash(..) , castHash @@ -104,11 +105,15 @@ type family HeaderHash b :: * -- | Abstract over the shape of blocks (or indeed just block headers) class (StandardHash b, Measured BlockMeasure b, Typeable b) => HasHeader b where - blockHash :: b -> HeaderHash b - blockPrevHash :: b -> ChainHash b - blockSlot :: b -> SlotNo - blockNo :: b -> BlockNo + blockHash :: b -> HeaderHash b + blockSlot :: b -> SlotNo + blockNo :: b -> BlockNo +-- | Extension of 'HasHeader' with some additional information +-- +-- Used in tests and assertions only. +class HasHeader b => HasFullHeader b where + blockPrevHash :: b -> ChainHash b blockInvariant :: b -> Bool -- | When implementing 'HasHeader', use this method to implement the 'measure' diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs index f59f6fbcbf..e4c199a2f5 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs @@ -34,8 +34,8 @@ import Ouroboros.Network.Protocol.BlockFetch.Type import Network.TypedProtocol.Core import Network.TypedProtocol.Pipelined -import qualified Ouroboros.Network.ChainFragment as ChainFragment -import Ouroboros.Network.ChainFragment (ChainFragment) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.BlockFetch.ClientState ( FetchClientContext(..) , FetchClientPolicy(..) @@ -145,7 +145,7 @@ blockFetchClient _version Nat n -> PeerGSV -> PeerFetchInFlightLimits - -> [ChainFragment header] + -> [AnchoredFragment header] -> PeerSender (BlockFetch block) AsClient BFIdle n () m void @@ -171,12 +171,12 @@ blockFetchClient _version atomically (writeTVar _ PeerFetchStatusAberrant) -} let range :: ChainRange header - !range = assert (not (ChainFragment.null fragment)) $ + !range = assert (not (AF.null fragment)) $ ChainRange (blockPoint lower) (blockPoint upper) where - Just lower = ChainFragment.last fragment - Just upper = ChainFragment.head fragment + Right lower = AF.last fragment + Right upper = AF.head fragment return $ SenderPipeline @@ -190,7 +190,7 @@ blockFetchClient _version receiverBusy :: ChainRange header - -> ChainFragment header + -> AnchoredFragment header -> PeerFetchInFlightLimits -> PeerReceiver (BlockFetch block) AsClient BFBusy BFIdle m () @@ -215,14 +215,14 @@ blockFetchClient _version range headers stateVars return (ReceiverDone ()) where - headers = ChainFragment.toOldestFirst fragment + headers = AF.toOldestFirst fragment MsgStartBatch -> ReceiverEffect $ do startedFetchBatch tracer inflightlimits range stateVars return (receiverStreaming inflightlimits range headers) where - headers = ChainFragment.toOldestFirst fragment + headers = AF.toOldestFirst fragment receiverStreaming :: PeerFetchInFlightLimits -> ChainRange header diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index 0f8c00b115..b55eafc19f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -38,15 +38,16 @@ import Control.Monad.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Tracer (Tracer, traceWith) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block ( HasHeader, MaxSlotNo (..), Point, blockPoint ) -import qualified Ouroboros.Network.ChainFragment as CF -import Ouroboros.Network.ChainFragment (ChainFragment) import Ouroboros.Network.Protocol.BlockFetch.Type (ChainRange(..)) import Ouroboros.Network.BlockFetch.DeltaQ ( PeerFetchInFlightLimits(..) , calculatePeerFetchInFlightLimits , SizeInBytes, PeerGSV ) +import Ouroboros.Network.Point (withOriginToMaybe) -- | The context that is passed into the block fetch protocol client when it -- is started. @@ -244,7 +245,7 @@ addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = -- command merging. assert (and [ blockPoint header `Set.notMember` peerFetchBlocksInFlight inflight | fragment <- fetchRequestFragments addedReq - , header <- CF.toOldestFirst fragment ]) $ + , header <- AF.toOldestFirst fragment ]) $ PeerFetchInFlight { @@ -262,13 +263,13 @@ addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = peerFetchBytesInFlight = peerFetchBytesInFlight inflight + sum [ blockFetchSize header | fragment <- fetchRequestFragments addedReq - , header <- CF.toOldestFirst fragment ], + , header <- AF.toOldestFirst fragment ], peerFetchBlocksInFlight = peerFetchBlocksInFlight inflight `Set.union` Set.fromList [ blockPoint header | fragment <- fetchRequestFragments addedReq - , header <- CF.toOldestFirst fragment ], + , header <- AF.toOldestFirst fragment ], peerFetchMaxSlotNo = peerFetchMaxSlotNo inflight `max` fetchRequestMaxSlotNo addedReq @@ -305,7 +306,7 @@ deleteHeadersInFlight blockFetchSize headers inflight = newtype FetchRequest header = - FetchRequest { fetchRequestFragments :: [ChainFragment header] } + FetchRequest { fetchRequestFragments :: [AnchoredFragment header] } deriving Show -- | We sometimes have the opportunity to merge fetch request fragments to @@ -328,7 +329,7 @@ newtype FetchRequest header = -- instance HasHeader header => Semigroup (FetchRequest header) where FetchRequest afs@(_:_) <> FetchRequest bfs@(_:_) - | Just f <- CF.joinChainFragments (last afs) (head bfs) + | Just f <- AF.join (last afs) (head bfs) = FetchRequest (init afs ++ f : tail bfs) FetchRequest afs <> FetchRequest bfs @@ -336,7 +337,8 @@ instance HasHeader header => Semigroup (FetchRequest header) where fetchRequestMaxSlotNo :: HasHeader header => FetchRequest header -> MaxSlotNo fetchRequestMaxSlotNo (FetchRequest afs) = - foldl' max NoMaxSlotNo $ map MaxSlotNo $ mapMaybe CF.headSlot afs + foldl' max NoMaxSlotNo $ map MaxSlotNo $ + mapMaybe (withOriginToMaybe . AF.headSlot) afs -- | Tracing types for the various events that change the state -- (i.e. 'FetchClientStateVars') for a block fetch client. diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 35bb4cddf5..005199ce73 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -32,11 +32,10 @@ import Data.Set (Set) import Control.Exception (assert) import Control.Monad (guard) -import Ouroboros.Network.AnchoredFragment (AnchoredFragment) -import qualified Ouroboros.Network.AnchoredFragment as AnchoredFragment +import Ouroboros.Network.AnchoredFragment (AnchoredFragment(..)) +import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.ChainFragment (ChainFragment(..)) -import qualified Ouroboros.Network.ChainFragment as ChainFragment +import Ouroboros.Network.Point (withOriginToMaybe) import Ouroboros.Network.BlockFetch.ClientState ( FetchRequest(..) @@ -139,7 +138,7 @@ Nothing ?! e = Left e -- * To track which blocks of that candidate still have to be downloaded, we -- use a list of discontiguous 'ChainFragment's. -- -type CandidateFragments header = (ChainSuffix header, [ChainFragment header]) +type CandidateFragments header = (ChainSuffix header, [AnchoredFragment header]) fetchDecisions @@ -355,8 +354,8 @@ empty fetch range, but this is ok since we never request empty ranges. -- current chain. -- -- The anchor point of a 'ChainSuffix' will be a point within the bounds of --- the currrent chain ('AnchoredFragment.withinFragmentBounds'), indicating --- that it forks off in the last @K@ blocks. +-- the currrent chain ('AF.withinFragmentBounds'), indicating that it forks off +-- in the last @K@ blocks. -- -- A 'ChainSuffix' must be non-empty, as an empty suffix, i.e. the candidate -- chain is equal to the current chain, would not be a plausible candidate. @@ -404,13 +403,13 @@ chainForkSuffix -> AnchoredFragment header -- ^ Candidate chain -> Maybe (ChainSuffix header) chainForkSuffix current candidate = - case AnchoredFragment.intersect current candidate of + case AF.intersect current candidate of Nothing -> Nothing Just (_, _, _, candidateSuffix) -> -- If the suffix is empty, it means the candidate chain was equal to -- the current chain and didn't fork off. Such a candidate chain is -- not a plausible candidate, so it must have been filtered out. - assert (not (AnchoredFragment.null candidateSuffix)) $ + assert (not (AF.null candidateSuffix)) $ Just (ChainSuffix candidateSuffix) selectForkSuffixes @@ -477,12 +476,10 @@ filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo chains = | (mcandidate, peer) <- chains , let mcandidates = do candidate <- mcandidate - let chainfragment = AnchoredFragment.unanchorFragment - $ getChainSuffix candidate - fragments = filterWithMaxSlotNo + let fragments = filterWithMaxSlotNo notAlreadyFetched fetchedMaxSlotNo - chainfragment + (getChainSuffix candidate) guard (not (null fragments)) ?! FetchDeclineAlreadyFetched return (candidate, fragments) ] @@ -523,10 +520,11 @@ filterNotAlreadyInFlightWithPeer chains = filterNotAlreadyInFlightWithOtherPeers :: HasHeader header => FetchMode - -> [(FetchDecision [ChainFragment header], PeerFetchStatus header, - PeerFetchInFlight header, - peerinfo)] - -> [(FetchDecision [ChainFragment header], peerinfo)] + -> [( FetchDecision [AnchoredFragment header] + , PeerFetchStatus header + , PeerFetchInFlight header + , peerinfo )] + -> [(FetchDecision [AnchoredFragment header], peerinfo)] filterNotAlreadyInFlightWithOtherPeers FetchModeDeadline chains = [ (mchainfragments, peer) @@ -593,10 +591,10 @@ filterWithMaxSlotNo :: forall header. HasHeader header => (header -> Bool) -> MaxSlotNo -- ^ @maxSlotNo@ - -> ChainFragment header - -> [ChainFragment header] + -> AnchoredFragment header + -> [AnchoredFragment header] filterWithMaxSlotNo p maxSlotNo = - ChainFragment.filterWithStop p ((> maxSlotNo) . MaxSlotNo . blockSlot) + AF.filterWithStop p ((> maxSlotNo) . MaxSlotNo . blockSlot) prioritisePeerChains :: forall header peer. HasHeader header @@ -606,7 +604,7 @@ prioritisePeerChains -> [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, PeerGSV, peer)] - -> [(FetchDecision [ChainFragment header], peer)] + -> [(FetchDecision [AnchoredFragment header], peer)] prioritisePeerChains FetchModeDeadline compareCandidateChains blockFetchSize = --TODO: last tie-breaker is still original order (which is probably -- peerid order). We should use a random tie breaker so that adversaries @@ -659,7 +657,7 @@ prioritisePeerChains FetchModeDeadline compareCandidateChains blockFetchSize = | EQ <- compareCandidateChains chain1 chain2 = True | otherwise = False - chainHeadPoint (_,ChainSuffix c,_) = AnchoredFragment.headPoint c + chainHeadPoint (_,ChainSuffix c,_) = AF.headPoint c prioritisePeerChains FetchModeBulkSync compareCandidateChains blockFetchSize = map (\(decision, peer) -> @@ -686,12 +684,12 @@ prioritisePeerChains FetchModeBulkSync compareCandidateChains blockFetchSize = (totalFetchSize blockFetchSize fragments) totalFetchSize :: (header -> SizeInBytes) - -> [ChainFragment header] + -> [AnchoredFragment header] -> SizeInBytes totalFetchSize blockFetchSize fragments = sum [ blockFetchSize header | fragment <- fragments - , header <- ChainFragment.toOldestFirst fragment ] + , header <- AF.toOldestFirst fragment ] type Comparing a = a -> a -> Ordering type Equating a = a -> a -> Bool @@ -777,10 +775,11 @@ fetchRequestDecisions :: forall header peer. HasHeader header => FetchDecisionPolicy header -> FetchMode - -> [(FetchDecision [ChainFragment header], PeerFetchStatus header, - PeerFetchInFlight header, - PeerGSV, - peer)] + -> [( FetchDecision [AnchoredFragment header] + , PeerFetchStatus header + , PeerFetchInFlight header + , PeerGSV + , peer )] -> [(FetchDecision (FetchRequest header), peer)] fetchRequestDecisions fetchDecisionPolicy fetchMode chains = go nConcurrentFetchPeers0 Set.empty NoMaxSlotNo chains @@ -788,7 +787,7 @@ fetchRequestDecisions fetchDecisionPolicy fetchMode chains = go :: Word -> Set (Point header) -> MaxSlotNo - -> [(Either FetchDecline [ChainFragment header], + -> [(Either FetchDecline [AnchoredFragment header], PeerFetchStatus header, PeerFetchInFlight header, PeerGSV, b)] -> [(FetchDecision (FetchRequest header), b)] go !_ !_ !_ [] = [] @@ -843,13 +842,13 @@ fetchRequestDecisions fetchDecisionPolicy fetchMode chains = where maxSlotNoFetchedThisDecision = foldl' max NoMaxSlotNo $ map MaxSlotNo $ - mapMaybe ChainFragment.headSlot fragments + mapMaybe (withOriginToMaybe . AF.headSlot) fragments blocksFetchedThisDecision = Set.fromList [ blockPoint header | fragment <- fragments - , header <- ChainFragment.toOldestFirst fragment ] + , header <- AF.toOldestFirst fragment ] nConcurrentFetchPeers0 = fromIntegral @@ -868,7 +867,7 @@ fetchRequestDecision -> PeerFetchInFlightLimits -> PeerFetchInFlight header -> PeerFetchStatus header - -> FetchDecision [ChainFragment header] + -> FetchDecision [AnchoredFragment header] -> FetchDecision (FetchRequest header) fetchRequestDecision _ _ _ _ _ _ (Left decline) @@ -941,20 +940,20 @@ fetchRequestDecision FetchDecisionPolicy { fetchFragments --- | +-- | -- -- Precondition: The result will be non-empty if -- -- Property: result is non-empty if preconditions satisfied -- selectBlocksUpToLimits - :: HasHeader header + :: forall header. HasHeader header => (header -> SizeInBytes) -- ^ Block body size -> Word -- ^ Current number of requests in flight -> Word -- ^ Maximum number of requests in flight allowed -> SizeInBytes -- ^ Current number of bytes in flight -> SizeInBytes -- ^ Maximum number of bytes in flight allowed - -> [ChainFragment header] + -> [AnchoredFragment header] -> FetchRequest header selectBlocksUpToLimits blockFetchSize nreqs0 maxreqs nbytes0 maxbytes fragments = assert (nreqs0 < maxreqs && nbytes0 < maxbytes && not (null fragments)) $ @@ -962,24 +961,31 @@ selectBlocksUpToLimits blockFetchSize nreqs0 maxreqs nbytes0 maxbytes fragments -- outside of this function. From here on however we check for limits. let fragments' = goFrags nreqs0 nbytes0 fragments in - assert (all (not . ChainFragment.null) fragments') $ + assert (all (not . AF.null) fragments') $ FetchRequest fragments' where + goFrags :: Word + -> SizeInBytes + -> [AnchoredFragment header] -> [AnchoredFragment header] goFrags _ _ [] = [] goFrags nreqs nbytes (c:cs) | nreqs+1 > maxreqs = [] - | otherwise = goFrag (nreqs+1) nbytes Empty c cs + | otherwise = goFrag (nreqs+1) nbytes (AF.Empty (AF.anchor c)) c cs -- Each time we have to pick from a new discontiguous chain fragment then -- that will become a new request, which contributes to our in-flight -- request count. We never break the maxreqs limit. - goFrag nreqs nbytes c' Empty cs = c' : goFrags nreqs nbytes cs - goFrag nreqs nbytes c' (b :< c) cs - | nbytes' >= maxbytes = [c' :> b] - | otherwise = goFrag nreqs nbytes' (c' :> b) c cs + goFrag :: Word + -> SizeInBytes + -> AnchoredFragment header + -> AnchoredFragment header + -> [AnchoredFragment header] -> [AnchoredFragment header] + goFrag nreqs nbytes c' (Empty _) cs = c' : goFrags nreqs nbytes cs + goFrag nreqs nbytes c' (b :< c) cs + | nbytes' >= maxbytes = [c' :> b] + | otherwise = goFrag nreqs nbytes' (c' :> b) c cs where nbytes' = nbytes + blockFetchSize b -- Note that we always pick the one last block that crosses the maxbytes -- limit. This cover the case where we otherwise wouldn't even be able to -- request a single block, as it's too large. - diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index a0ec60aae6..3a699d67b3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -28,8 +28,7 @@ import Control.Tracer (Tracer, traceWith) import Ouroboros.Network.Block import Ouroboros.Network.AnchoredFragment (AnchoredFragment(..)) -import qualified Ouroboros.Network.AnchoredFragment as AnchoredFragment -import qualified Ouroboros.Network.ChainFragment as ChainFragment +import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.BlockFetch.ClientState ( FetchRequest(..) @@ -155,7 +154,7 @@ fetchLogicIteration decisionTracer clientStateTracer -- Flatten multiple fragments and trace points, not full headers [ blockPoint header | headers <- headerss - , header <- ChainFragment.toOldestFirst headers ] + , header <- AF.toOldestFirst headers ] -- | Do a bit of rearranging of data before calling 'fetchDecisions' to do the -- real work. @@ -319,8 +318,8 @@ readStateVariables FetchTriggerVariables{..} -- Construct the change detection fingerprint let !fetchStateFingerprint' = FetchStateFingerprint - (Just (castPoint (AnchoredFragment.headPoint fetchStateCurrentChain))) - (Map.map AnchoredFragment.headPoint fetchStatePeerChains) + (Just (castPoint (AF.headPoint fetchStateCurrentChain))) + (Map.map AF.headPoint fetchStatePeerChains) fetchStatePeerStatus -- Check the fingerprint changed, or block and wait until it does @@ -348,4 +347,3 @@ readStateVariables FetchTriggerVariables{..} } return (fetchStateSnapshot, fetchStateFingerprint') - diff --git a/ouroboros-network/src/Ouroboros/Network/ChainFragment.hs b/ouroboros-network/src/Ouroboros/Network/ChainFragment.hs index 2902a0413b..a648592fa6 100644 --- a/ouroboros-network/src/Ouroboros/Network/ChainFragment.hs +++ b/ouroboros-network/src/Ouroboros/Network/ChainFragment.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ouroboros.Network.ChainFragment ( -- * ChainFragment type and fundamental operations @@ -60,13 +61,11 @@ module Ouroboros.Network.ChainFragment ( splitBeforePoint, sliceRange, lookupByIndexFromEnd, FT.SearchResult(..), - filter, - filterWithStop, selectPoints, findFirstPoint, intersectChainFragments, isPrefixOf, - joinChainFragments, + joinSuccessor, -- * Helper functions prettyPrintChainFragment, @@ -82,13 +81,11 @@ import Prelude hiding (drop, filter, head, last, length, null) import Codec.CBOR.Decoding (decodeListLen) import Codec.CBOR.Encoding (encodeListLen) import Codec.Serialise (Serialise (..)) -import Control.Exception (assert) import Data.Either (isRight) import Data.FingerTree.Strict (StrictFingerTree) import qualified Data.FingerTree.Strict as FT import qualified Data.Foldable as Foldable import qualified Data.List as L -import Data.Maybe (fromMaybe) import GHC.Stack import Cardano.Prelude (NoUnexpectedThunks (..), @@ -145,16 +142,13 @@ pattern Empty <- (viewRight -> FT.EmptyR) where pattern (:>) :: (HasHeader block, HasCallStack) => ChainFragment block -> block -> ChainFragment block pattern c :> b <- (viewRight -> (c FT.:> b)) where - ChainFragment c :> b = assert (validExtension (ChainFragment c) b) $ - ChainFragment (c FT.|> b) + ChainFragment c :> b = ChainFragment (c FT.|> b) -- | \( O(1) \). Add a block to the left of the chain fragment. pattern (:<) :: HasHeader block => block -> ChainFragment block -> ChainFragment block pattern b :< c <- (viewLeft -> (b FT.:< c)) where - b :< ChainFragment c = assert (maybe True (`isValidSuccessorOf` b) - (last (ChainFragment c))) $ - ChainFragment (b FT.<| c) + b :< ChainFragment c = ChainFragment (b FT.<| c) infixl 5 :>, :< @@ -192,7 +186,7 @@ mapChainFragment :: (HasHeader block1, HasHeader block2) mapChainFragment f (ChainFragment c) = ChainFragment (FT.fmap' f c) -- | \( O(n) \). -valid :: HasHeader block => ChainFragment block -> Bool +valid :: HasFullHeader block => ChainFragment block -> Bool valid Empty = True valid (c :> b) = valid c && validExtension c b @@ -205,14 +199,14 @@ valid (c :> b) = valid c && validExtension c b -- -- This function does not check whether any of the two blocks satisfy -- 'blockInvariant'. -isValidSuccessorOf :: (HasCallStack, HasHeader block) +isValidSuccessorOf :: (HasCallStack, HasFullHeader block) => block -- ^ @bSucc@ -> block -- ^ @b@ -> Bool isValidSuccessorOf bSucc b = isRight $ isValidSuccessorOf' bSucc b -- | Variation on 'isValidSuccessorOf' that provides more information -isValidSuccessorOf' :: (HasCallStack, HasHeader block) +isValidSuccessorOf' :: (HasCallStack, HasFullHeader block) => block -- ^ @bSucc@ -> block -- ^ @b@ -> Either String () @@ -264,11 +258,12 @@ isValidSuccessorOf' bSucc b p = blockPoint b -- | \( O(1) \). -validExtension :: (HasHeader block, HasCallStack) => ChainFragment block -> block -> Bool +validExtension :: (HasFullHeader block, HasCallStack) + => ChainFragment block -> block -> Bool validExtension c bSucc = isRight $ validExtension' c bSucc -- | Variation on 'validExtension' that provides more information -validExtension' :: (HasHeader block, HasCallStack) +validExtension' :: (HasFullHeader block, HasCallStack) => ChainFragment block -> block -> Either String () validExtension' c bSucc | not (blockInvariant bSucc) @@ -330,9 +325,7 @@ fromNewestFirst = foldr (flip (:>)) Empty -- | \( O(n) \). Make a 'ChainFragment' from a list of blocks in -- oldest-to-newest order. fromOldestFirst :: HasHeader block => [block] -> ChainFragment block -fromOldestFirst bs = assert (valid c) c - where - c = ChainFragment $ FT.fromList bs +fromOldestFirst bs = ChainFragment $ FT.fromList bs -- | \( O(\log(\min(i,n-i)) \). Drop the newest @n@ blocks from the -- 'ChainFragment'. @@ -479,51 +472,6 @@ lookupByIndexFromEnd (ChainFragment t) n = where len = bmSize (FT.measure t) --- | \( O\(n\) \). Filter the chain based on a predicate. As filtering --- removes blocks the result is a sequence of disconnected fragments. --- The fragments are in the original order and are of maximum size. --- -filter :: HasHeader block - => (block -> Bool) - -> ChainFragment block - -> [ChainFragment block] -filter p = filterWithStop p (const False) - --- | \( O\(n\) \). Same as 'filter', but as soon as the stop condition is --- true, the filtering stops and the remaining fragment (starting with the --- first element for which the stop condition is true) is the final fragment --- in the returned list. --- --- The stop condition wins from the filtering predicate: if the stop condition --- is true for an element, but the filter predicate not, then the element --- still ends up in final fragment. --- --- For example, given the fragment containing @[1, 2, 3, 4, 5, 6]@: --- --- > filter odd -> [[1], [3], [5]] --- > filterWithStop odd (>= 4) -> [[1], [3], [4, 5, 6]] --- -filterWithStop :: HasHeader block - => (block -> Bool) -- ^ Filtering predicate - -> (block -> Bool) -- ^ Stop condition - -> ChainFragment block - -> [ChainFragment block] -filterWithStop p stop = go [] Empty - where - go cs c' (b :< c) | stop b = reverse (addToAcc (join c' (b :< c)) cs) - | p b = go cs (c' :> b) c - go cs c' (_ :< c) = go (addToAcc c' cs) Empty c - - go cs c' Empty = reverse (addToAcc c' cs) - - addToAcc Empty acc = acc - addToAcc c' acc = c':acc - - -- This is called with @c'@ and @(b : < c)@. @c'@ is the fragment - -- containing the blocks before @b@, so they must be joinable. - join a b = fromMaybe (error "could not join fragments") $ - joinChainFragments a b - -- | \( O(o \log(\min(i,n-i))) \). Select a bunch of 'Point's based on offsets -- from the head of the chain fragment. This is used in the chain consumer -- protocol as part of finding the intersection between a local and remote @@ -791,21 +739,16 @@ isPrefixOf :: Eq block => ChainFragment block -> ChainFragment block -> Bool a `isPrefixOf` b = toOldestFirst a `L.isPrefixOf` toOldestFirst b - --- | \( O(\log(\min(n_1, n_2))) \). Join two 'ChainFragment's if the first --- (oldest) block of the second fragment is the successor of the last (newest) --- block of the first fragment. -joinChainFragments :: HasHeader block - => ChainFragment block - -> ChainFragment block - -> Maybe (ChainFragment block) -joinChainFragments c1@(ChainFragment t1) c2@(ChainFragment t2) = - case (FT.viewr t1, FT.viewl t2) of - (FT.EmptyR, _) -> Just c2 - (_, FT.EmptyL) -> Just c1 - (_ FT.:> b1, b2 FT.:< _) | b2 `isValidSuccessorOf` b1 - -> Just (ChainFragment (t1 FT.>< t2)) - _ -> Nothing +-- | \( O(\log(\min(n_1, n_2))) \). Join two 'ChainFragment's. +-- +-- PRECONDITION: the first (oldest) block of the second fragment is the +-- successor of the last (newest) block of the first fragment. +joinSuccessor :: HasHeader block + => ChainFragment block + -> ChainFragment block + -> ChainFragment block +joinSuccessor (ChainFragment t1) (ChainFragment t2) = + ChainFragment (t1 FT.>< t2) -- -- Serialisation diff --git a/ouroboros-network/src/Ouroboros/Network/MockChain/Chain.hs b/ouroboros-network/src/Ouroboros/Network/MockChain/Chain.hs index 04548f0dd6..b2640b2ec0 100644 --- a/ouroboros-network/src/Ouroboros/Network/MockChain/Chain.hs +++ b/ouroboros-network/src/Ouroboros/Network/MockChain/Chain.hs @@ -116,12 +116,12 @@ prettyPrintChain nl ppBlock = foldChain (\s b -> s ++ nl ++ " " ++ ppBlock b) genesis :: Chain b genesis = Genesis -valid :: HasHeader block => Chain block -> Bool +valid :: HasFullHeader block => Chain block -> Bool valid Genesis = True valid (c :> b) = valid c && validExtension c b validExtension - :: (HasCallStack, HasHeader block) + :: (HasCallStack, HasFullHeader block) => Chain block -> block -> Bool validExtension c b = blockInvariant b && headHash c == blockPrevHash b @@ -183,15 +183,11 @@ toOldestFirst = reverse . toNewestFirst -- of the chain. -- fromNewestFirst :: HasHeader block => [block] -> Chain block -fromNewestFirst bs = assert (valid c) c - where - c = foldr (flip (:>)) Genesis bs +fromNewestFirst bs = foldr (flip (:>)) Genesis bs -- | Construct chain from list of blocks from oldest to newest fromOldestFirst :: HasHeader block => [block] -> Chain block -fromOldestFirst bs = assert (valid c) c - where - c = L.foldl' (:>) Genesis bs +fromOldestFirst bs = L.foldl' (:>) Genesis bs drop :: Int -> Chain block -> Chain block drop 0 c = c @@ -205,9 +201,8 @@ null :: Chain block -> Bool null Genesis = True null _ = False -addBlock :: (HasCallStack, HasHeader block) => block -> Chain block -> Chain block -addBlock b c = assert (validExtension c b) $ - c :> b +addBlock :: HasHeader block => block -> Chain block -> Chain block +addBlock b c = c :> b pointOnChain :: HasHeader block => Point block -> Chain block -> Bool pointOnChain GenesisPoint _ = True diff --git a/ouroboros-network/src/Ouroboros/Network/MockChain/ProducerState.hs b/ouroboros-network/src/Ouroboros/Network/MockChain/ProducerState.hs index e730239944..a601907f4d 100644 --- a/ouroboros-network/src/Ouroboros/Network/MockChain/ProducerState.hs +++ b/ouroboros-network/src/Ouroboros/Network/MockChain/ProducerState.hs @@ -4,7 +4,7 @@ module Ouroboros.Network.MockChain.ProducerState where -import Ouroboros.Network.Block (castPoint, genesisPoint) +import Ouroboros.Network.Block (HasFullHeader, castPoint, genesisPoint) import Ouroboros.Network.MockChain.Chain (Chain, ChainUpdate (..), HasHeader, HeaderHash, Point (..), blockPoint, pointOnChain) @@ -86,7 +86,7 @@ data ReaderNext = ReaderBackTo | ReaderForwardFrom -- Invariant -- -invChainProducerState :: HasHeader block => ChainProducerState block -> Bool +invChainProducerState :: HasFullHeader block => ChainProducerState block -> Bool invChainProducerState (ChainProducerState c rs nrid) = Chain.valid c && invReaderStates c rs diff --git a/ouroboros-network/src/Ouroboros/Network/Testing/ConcreteBlock.hs b/ouroboros-network/src/Ouroboros/Network/Testing/ConcreteBlock.hs index baf912be9f..e6f560191a 100644 --- a/ouroboros-network/src/Ouroboros/Network/Testing/ConcreteBlock.hs +++ b/ouroboros-network/src/Ouroboros/Network/Testing/ConcreteBlock.hs @@ -150,10 +150,12 @@ type instance HeaderHash Block = ConcreteHeaderHash instance HasHeader BlockHeader where blockHash = headerHash - blockPrevHash = headerPrevHash blockSlot = headerSlot blockNo = headerBlockNo +instance HasFullHeader BlockHeader where + blockPrevHash = headerPrevHash + -- | The header invariant is that the cached header hash is correct. -- blockInvariant b = @@ -162,10 +164,12 @@ instance HasHeader BlockHeader where instance HasHeader Block where blockHash = headerHash . blockHeader - blockPrevHash = castHash . headerPrevHash . blockHeader blockSlot = headerSlot . blockHeader blockNo = headerBlockNo . blockHeader +instance HasFullHeader Block where + blockPrevHash = castHash . headerPrevHash . blockHeader + -- | The block invariant is just that the actual block body hash matches the -- body hash listed in the header. -- @@ -277,7 +281,7 @@ fixupBlockAfterBlock prev = prevhash = BlockHash (blockHash prev) prevblockno = blockNo prev -fixupBlocks :: HasHeader b +fixupBlocks :: HasFullHeader b => (c -> b -> c) -> c -> (Maybe (ChainHash b)) -- ^ optionally set anchor hash @@ -303,7 +307,7 @@ fixupBlocks f z anchorHash anchorBlockNo fixup (b0:c0) = -- first block to chain-on from genesis, since by construction the 'Chain' type -- starts from genesis. -- -fixupChain :: HasHeader b +fixupChain :: HasFullHeader b => (ChainHash b -> BlockNo -> b -> b) -> [b] -> Chain b fixupChain = @@ -313,7 +317,7 @@ fixupChain = (Just (BlockNo 0)) -fixupChainFragmentFrom :: HasHeader b +fixupChainFragmentFrom :: HasFullHeader b => ChainHash b -> BlockNo -> (ChainHash b -> BlockNo -> b -> b) @@ -324,7 +328,7 @@ fixupChainFragmentFrom anchorhash anchorblockno = (Just anchorhash) (Just anchorblockno) -fixupChainFragmentFromGenesis :: HasHeader b +fixupChainFragmentFromGenesis :: HasFullHeader b => (ChainHash b -> BlockNo -> b -> b) -> [b] -> ChainFragment b fixupChainFragmentFromGenesis = @@ -333,7 +337,7 @@ fixupChainFragmentFromGenesis = (Just GenesisHash) (Just (BlockNo 0)) -fixupChainFragmentFromSame :: HasHeader b +fixupChainFragmentFromSame :: HasFullHeader b => (ChainHash b -> BlockNo -> b -> b) -> [b] -> ChainFragment b fixupChainFragmentFromSame = @@ -342,7 +346,7 @@ fixupChainFragmentFromSame = Nothing Nothing -fixupAnchoredFragmentFrom :: HasHeader b +fixupAnchoredFragmentFrom :: HasFullHeader b => Point b -> BlockNo -> (ChainHash b -> BlockNo -> b -> b) diff --git a/ouroboros-network/test/Ouroboros/Network/MockNode.hs b/ouroboros-network/test/Ouroboros/Network/MockNode.hs index ebcccea6f1..45f8315ec0 100644 --- a/ouroboros-network/test/Ouroboros/Network/MockNode.hs +++ b/ouroboros-network/test/Ouroboros/Network/MockNode.hs @@ -86,7 +86,7 @@ longestChainSelection candidateChainVars cpsVar = else writeTVar cpsVar (switchFork chain' cps) -chainValidation :: forall block m. (HasHeader block, MonadSTM m) +chainValidation :: forall block m. (HasFullHeader block, MonadSTM m) => StrictTVar m (Chain block) -> StrictTVar m (Maybe (Chain block)) -> m () @@ -239,7 +239,7 @@ data ProducerId = ProducerId NodeId Int -- @StrictTVar ('ChainProducerState' block)@. This allows to extend the relay -- node to a core node. forkRelayKernel :: forall block m. - ( HasHeader block + ( HasFullHeader block , MonadSTM m , MonadFork m ) @@ -274,7 +274,7 @@ relayNode :: forall m block. , MonadFork m , MonadThrow m , MonadSay m - , HasHeader block + , HasFullHeader block , Show block , MonadTimer m ) @@ -338,7 +338,7 @@ relayNode _nid initChain chans = do -- public network layer altogether. -- forkCoreKernel :: forall block m. - ( HasHeader block + ( HasFullHeader block , MonadSTM m , MonadFork m , MonadTimer m diff --git a/ouroboros-network/test/Test/AnchoredFragment.hs b/ouroboros-network/test/Test/AnchoredFragment.hs index c8eddbf6d8..88134a19af 100644 --- a/ouroboros-network/test/Test/AnchoredFragment.hs +++ b/ouroboros-network/test/Test/AnchoredFragment.hs @@ -9,7 +9,7 @@ module Test.AnchoredFragment ) where import qualified Data.List as L -import Data.Maybe (isJust, listToMaybe, maybe, maybeToList) +import Data.Maybe (isJust, isNothing, listToMaybe, maybe, maybeToList) import Data.Word (Word64) import Test.QuickCheck @@ -77,6 +77,11 @@ tests = testGroup "AnchoredFragment" , testProperty "intersect when within bounds" prop_intersect_bounds , testProperty "toChain/fromChain" prop_toChain_fromChain , testProperty "anchorNewest" prop_anchorNewest + , testProperty "filter" prop_filter + , testProperty "filterWithStop_always_stop" prop_filterWithStop_always_stop + , testProperty "filterWithStop_never_stop" prop_filterWithStop_never_stop + , testProperty "filterWithStop" prop_filterWithStop + , testProperty "filterWithStop_filter" prop_filterWithStop_filter ] -- @@ -644,3 +649,76 @@ instance Arbitrary TestAnchoredFragmentFork where , let cf1' = CF.dropNewest n1 cf1 cf2' = CF.dropNewest n2 cf2 ] + +-- +-- Test filtering +-- + +prop_filter :: (Block -> Bool) -> TestBlockAnchoredFragment -> Property +prop_filter p (TestBlockAnchoredFragment chain) = + let fragments = AF.filter p chain in + cover 70 (length fragments > 1) "multiple fragments" $ + counterexample ("fragments: " ++ show fragments) $ + + -- The fragments contain exactly the blocks where p holds, in order + ( L.map AF.blockPoint (L.filter p (AF.toOldestFirst chain)) + === + L.map AF.blockPoint (concatMap AF.toOldestFirst fragments) + ) + .&&. + -- The fragments are non-empty + all (not . AF.null) fragments + .&&. + -- The fragments are of maximum size + and [ isNothing (AF.join a b) + | (a,b) <- zip fragments (tail fragments) ] + +prop_filterWithStop_always_stop :: (Block -> Bool) -> TestBlockAnchoredFragment -> Property +prop_filterWithStop_always_stop p (TestBlockAnchoredFragment chain) = + AF.filterWithStop p (const True) chain === + if AF.null chain then [] else [chain] + +prop_filterWithStop_never_stop :: (Block -> Bool) -> TestBlockAnchoredFragment -> Property +prop_filterWithStop_never_stop p (TestBlockAnchoredFragment chain) = + AF.filterWithStop p (const False) chain === AF.filter p chain + +-- If the stop condition implies that the predicate is true for all the +-- remaining arguments, 'filterWithStop' must be equivalent to 'filter', just +-- optimised. +prop_filterWithStop :: (Block -> Bool) -> (Block -> Bool) -> TestBlockAnchoredFragment -> Property +prop_filterWithStop p stop (TestBlockAnchoredFragment_ anchor chain) = + AF.filterWithStop p stop chain === + if AF.null chain + then [] + else appendStopped $ AF.filter p (AF.fromOldestFirst (AF.anchorFromBlock anchor) before) + where + before, stopped :: [Block] + (before, stopped) = break stop $ AF.toOldestFirst chain + + anchor' :: Block + anchor' = if null before + then anchor + else last before + + stoppedFrag :: AnchoredFragment Block + stoppedFrag = AF.fromOldestFirst (AF.anchorFromBlock anchor') stopped + + -- If the last fragment in @c@ can be joined with @stoppedFrag@, do so, + -- otherwise append @stoppedFrag@ as a separate, final fragment. If it is + -- empty, ignore it. + appendStopped :: [AnchoredFragment Block] -> [AnchoredFragment Block] + appendStopped c + | null stopped + = c + | lastFrag:frags <- reverse c + , Just lastFrag' <- AF.join lastFrag stoppedFrag + = reverse $ lastFrag':frags + | otherwise + = c ++ [stoppedFrag] + +prop_filterWithStop_filter :: TestBlockAnchoredFragment -> Property +prop_filterWithStop_filter (TestBlockAnchoredFragment chain) = + AF.filterWithStop p stop chain === AF.filter p chain + where + p = (> 5) . blockSlot + stop = (> 10) . blockSlot diff --git a/ouroboros-network/test/Test/ChainFragment.hs b/ouroboros-network/test/Test/ChainFragment.hs index 551ff7d8d6..a61d5f37de 100644 --- a/ouroboros-network/test/Test/ChainFragment.hs +++ b/ouroboros-network/test/Test/ChainFragment.hs @@ -96,11 +96,6 @@ tests = testGroup "ChainFragment" , testProperty "serialise chain" prop_serialise_chain , testProperty "pointOnChainFragment" prop_pointOnChainFragment , testProperty "lookupByIndexFromEnd" prop_lookupByIndexFromEnd - , testProperty "filter" prop_filter - , testProperty "filterWithStop always stop" prop_filterWithStop_always_stop - , testProperty "filterWithStop never stop" prop_filterWithStop_never_stop - , testProperty "filterWithStop" prop_filterWithStop - , testProperty "filterWithStop filter" prop_filterWithStop_filter , testProperty "selectPoints" prop_selectPoints , testProperty "splitAfterPoint" prop_splitAfterPoint , testProperty "splitBeforePoint" prop_splitBeforePoint @@ -233,8 +228,8 @@ prop_intersectChainFragments (TestChainFragmentFork origL1 origL2 c1 c2) = .&&. L.intersect (CF.toNewestFirst c1) (CF.toNewestFirst c2) === [] Just (l1, l2, r1, r2) -> counterexample "headPoint" (CF.headPoint l1 === CF.headPoint l2) - .&&. counterexample "c1" (CF.joinChainFragments l1 r1 === Just c1) - .&&. counterexample "c2" (CF.joinChainFragments l2 r2 === Just c2) + .&&. counterexample "c1" (CF.joinSuccessor l1 r1 === c1) + .&&. counterexample "c2" (CF.joinSuccessor l2 r2 === c2) prop_serialise_chain :: TestBlockChainFragment -> Property prop_serialise_chain (TestBlockChainFragment chain) = @@ -251,7 +246,7 @@ prop_splitAfterPoint (TestChainFragmentAndPoint c p) = CF.pointOnChainFragment p c && not (CF.pointOnChainFragment p r) && CF.headPoint l == Just p - && CF.joinChainFragments l r == Just c + && CF.joinSuccessor l r == c && all (<= slot) (slots l) && all (>= slot) (slots r) where @@ -271,7 +266,7 @@ prop_splitBeforePoint (TestChainFragmentAndPoint c p) = CF.pointOnChainFragment p c && not (CF.pointOnChainFragment p l) && CF.lastPoint r == Just p - && CF.joinChainFragments l r == Just c + && CF.joinSuccessor l r == c && all (<= slot) (slots l) && all (>= slot) (slots r) where @@ -310,66 +305,6 @@ prop_lookupByIndexFromEnd (TestChainFragmentAndIndex c i) = CF.Position _ b _ -> b === CF.toNewestFirst c !! i _ -> property (i < 0 || i >= CF.length c) -prop_filter :: (Block -> Bool) -> TestBlockChainFragment -> Property -prop_filter p (TestBlockChainFragment chain) = - let fragments = CF.filter p chain in - cover 70 (length fragments > 1) "multiple fragments" $ - counterexample ("fragments: " ++ show fragments) $ - - -- The fragments contain exactly the blocks where p holds, in order - ( L.map CF.blockPoint (L.filter p (CF.toOldestFirst chain)) - === - L.map CF.blockPoint (concatMap CF.toOldestFirst fragments) - ) - .&&. - -- The fragments are non-empty - all (not . CF.null) fragments - .&&. - -- The fragments are of maximum size - and [ isNothing (CF.joinChainFragments a b) - | (a,b) <- zip fragments (tail fragments) ] - -prop_filterWithStop_always_stop :: (Block -> Bool) -> TestBlockChainFragment -> Property -prop_filterWithStop_always_stop p (TestBlockChainFragment chain) = - CF.filterWithStop p (const True) chain === - if CF.null chain then [] else [chain] - -prop_filterWithStop_never_stop :: (Block -> Bool) -> TestBlockChainFragment -> Property -prop_filterWithStop_never_stop p (TestBlockChainFragment chain) = - CF.filterWithStop p (const False) chain === CF.filter p chain - --- If the stop condition implies that the predicate is true for all the --- remaining arguments, 'filterWithStop' must be equivalent to 'filter', just --- optimised. -prop_filterWithStop :: (Block -> Bool) -> (Block -> Bool) -> TestBlockChainFragment -> Property -prop_filterWithStop p stop (TestBlockChainFragment chain) = - CF.filterWithStop p stop chain === - if CF.null chain - then [] - else appendStopped $ CF.filter p (CF.fromOldestFirst before) - where - (before, stopped) = break stop $ CF.toOldestFirst chain - stoppedFrag = CF.fromOldestFirst stopped - - -- If the last fragment in @c@ can be joined with @stoppedFrag@, do so, - -- otherwise append @stoppedFrag@ as a separate, final fragment. If it is - -- empty, ignore it. - appendStopped c - | null stopped - = c - | lastFrag:frags <- reverse c - , Just lastFrag' <- CF.joinChainFragments lastFrag stoppedFrag - = reverse $ lastFrag':frags - | otherwise - = c ++ [stoppedFrag] - -prop_filterWithStop_filter :: TestBlockChainFragment -> Property -prop_filterWithStop_filter (TestBlockChainFragment chain) = - CF.filterWithStop p stop chain === CF.filter p chain - where - p = (> 5) . blockSlot - stop = (> 10) . blockSlot - prop_selectPoints :: TestBlockChainFragment -> Property prop_selectPoints (TestBlockChainFragment c) = CF.selectPoints offsets c === CF.selectPointsSpec offsets c .&&. diff --git a/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs index 308accf4bf..504524b8ef 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs @@ -39,7 +39,6 @@ import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.ClientRegistry import Ouroboros.Network.BlockFetch.ClientState import Ouroboros.Network.BlockFetch.Examples -import qualified Ouroboros.Network.ChainFragment as ChainFragment import qualified Ouroboros.Network.MockChain.Chain as Chain import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch) import Ouroboros.Network.Testing.ConcreteBlock @@ -229,7 +228,7 @@ tracePropertyBlocksRequestedAndRecievedPerPeer fork1 fork2 es = requestedFetchPoints :: Map Int [Point BlockHeader] requestedFetchPoints = Map.fromListWith (flip (++)) - [ (peer, map blockPoint (ChainFragment.toOldestFirst fragment)) + [ (peer, map blockPoint (AnchoredFragment.toOldestFirst fragment)) | TraceFetchClientState (TraceLabelPeer peer (AddedFetchRequest @@ -278,7 +277,7 @@ tracePropertyBlocksRequestedAndRecievedAllPeers fork1 fork2 es = (AddedFetchRequest (FetchRequest fragments) _ _ _)) <- es , fragment <- fragments - , block <- ChainFragment.toOldestFirst fragment + , block <- AnchoredFragment.toOldestFirst fragment ] receivedFetchPoints :: Set (Point BlockHeader) @@ -331,7 +330,7 @@ tracePropertyNoDuplicateBlocksBetweenPeers fork1 fork2 es = (FetchRequest fragments) _ _ _)) <- es , fragment <- fragments , let points = Set.fromList . map blockPoint - . ChainFragment.toOldestFirst + . AnchoredFragment.toOldestFirst ]