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 ]