diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs index 8c395ec161d..a80f41bfb29 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs @@ -498,7 +498,7 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime Nothing (handleNext kis mkPipelineDecision' n') where - theirTipBlockNo = tipBlockNo (unTheir theirTip) + theirTipBlockNo = getLegacyTipBlockNo (unTheir theirTip) decision = runPipelineDecision mkPipelineDecision n diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncServer.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncServer.hs index b66bdc241af..205320b802b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncServer.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncServer.hs @@ -15,7 +15,7 @@ module Ouroboros.Consensus.ChainSyncServer import Control.Tracer import Ouroboros.Network.Block (ChainUpdate (..), HeaderHash, - Point (..), Serialised, Tip (..), castPoint) + Point (..), Serialised, Tip (..), castPoint, legacyTip) import Ouroboros.Network.Protocol.ChainSync.Server import Ouroboros.Storage.ChainDB.API (ChainDB, Reader, @@ -131,7 +131,7 @@ chainSyncServerForReader tracer chainDB rdr = getTip = atomically $ do tipPoint <- castPoint <$> ChainDB.getTipPoint chainDB tipBlockNo <- ChainDB.getTipBlockNo chainDB - return Tip { tipPoint, tipBlockNo } + return $ legacyTip tipPoint tipBlockNo {------------------------------------------------------------------------------- Trace events diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs index 20ab288b949..28a5c53b85e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs @@ -585,9 +585,9 @@ consensusNetworkApps kernel ProtocolTracers {..} ProtocolCodecs {..} ProtocolHan chainDbView :: IOLike m => ChainDB m blk -> ChainDbView m blk chainDbView chainDB = ChainDbView - { getCurrentChain = ChainDB.getCurrentChain chainDB - , getCurrentLedger = ChainDB.getCurrentLedger chainDB - , getOurTip = Tip <$> ChainDB.getTipPoint chainDB - <*> ChainDB.getTipBlockNo chainDB - , getIsInvalidBlock = ChainDB.getIsInvalidBlock chainDB + { getCurrentChain = ChainDB.getCurrentChain chainDB + , getCurrentLedger = ChainDB.getCurrentLedger chainDB + , getOurTip = legacyTip <$> ChainDB.getTipPoint chainDB + <*> ChainDB.getTipBlockNo chainDB + , getIsInvalidBlock = ChainDB.getIsInvalidBlock chainDB } diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs b/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs index 2f433ed341d..a01a45242a4 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs @@ -113,12 +113,10 @@ prop_chainSync ChainSyncClientSetup {..} = label "InvalidRollBack" $ counterexample ("InvalidRollBack intersection: " <> ppPoint intersection) $ not (withinFragmentBounds intersection synchedFragment) - Just (NoMoreIntersection { _ourTip = Our (Tip ourHead _) - , _theirTip = Their (Tip theirHead _) - }) -> + Just (NoMoreIntersection {_ourTip = Our ourTip, _theirTip = Their theirTip}) -> label "NoMoreIntersection" $ - counterexample ("NoMoreIntersection ourHead: " <> ppPoint ourHead <> - ", theirHead: " <> ppPoint theirHead) $ + counterexample ("NoMoreIntersection ourHead: " <> ppPoint (getTipPoint ourTip) <> + ", theirHead: " <> ppPoint (getTipPoint theirTip)) $ not (clientFragment `forksWithinK` synchedFragment) Just e -> counterexample ("Exception: " ++ displayException e) False @@ -290,7 +288,7 @@ runChainSync securityParam maxClockSkew (ClientUpdates clientUpdates) , getCurrentLedger = snd <$> readTVar varClientState , getOurTip = do chain <- fst <$> readTVar varClientState - return $ Tip (Chain.headPoint chain) (Chain.headBlockNo chain) + return $ legacyTip (Chain.headPoint chain) (Chain.headBlockNo chain) , getIsInvalidBlock = return $ WithFingerprint (const Nothing) (Fingerprint 0) } diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/ExamplesPipelined.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/ExamplesPipelined.hs index 4106e5145dc..54f49d1892e 100644 --- a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/ExamplesPipelined.hs +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/ExamplesPipelined.hs @@ -16,7 +16,8 @@ import Control.Monad.Class.MonadSTM.Strict import Network.TypedProtocol.Pipelined -import Ouroboros.Network.Block (BlockNo, HasHeader (..), Tip(..)) +import Ouroboros.Network.Block (BlockNo, HasHeader (..), Tip (..), + getLegacyTipBlockNo) import Ouroboros.Network.MockChain.Chain (Chain (..), Point (..)) import qualified Ouroboros.Network.MockChain.Chain as Chain @@ -63,7 +64,8 @@ chainSyncClientPipelined mkPipelineDecision0 chainvar = -> Client header (Tip header) m a -> ClientPipelinedStIdle n header (Tip header) m a - go mkPipelineDecision n cliTipBlockNo srvTip@(Tip _ srvTipBlockNo) client@Client {rollforward, rollbackward} = + go mkPipelineDecision n cliTipBlockNo srvTip client@Client {rollforward, rollbackward} = + let srvTipBlockNo = getLegacyTipBlockNo srvTip in case (n, runPipelineDecision mkPipelineDecision n cliTipBlockNo srvTipBlockNo) of (_Zero, (Request, mkPipelineDecision')) -> SendMsgRequestNext diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/Test.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/Test.hs index 9abd2b412a9..a3853094548 100644 --- a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/Test.hs +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/Test.hs @@ -31,8 +31,8 @@ import Network.TypedProtocol.Proofs (connect, connectPipelined) import Ouroboros.Network.Channel -import Ouroboros.Network.Block (StandardHash, Tip (..), decodeTip, - encodeTip, Serialised (..), castPoint) +import Ouroboros.Network.Block (Serialised (..), StandardHash, + Tip (..), castPoint, decodeTip, encodeTip, legacyTip) import Ouroboros.Network.MockChain.Chain (Chain, Point) import qualified Ouroboros.Network.MockChain.Chain as Chain import qualified Ouroboros.Network.MockChain.ProducerState as ChainProducerState @@ -365,14 +365,14 @@ genChainSync genPoint genHeader genTip = oneof instance Arbitrary (AnyMessageAndAgency (ChainSync BlockHeader (Tip BlockHeader))) where arbitrary = genChainSync arbitrary arbitrary genTip where - genTip = Tip <$> arbitrary <*> arbitrary + genTip = legacyTip <$> arbitrary <*> arbitrary instance Arbitrary (AnyMessageAndAgency (ChainSync (Serialised BlockHeader) (Tip BlockHeader))) where arbitrary = genChainSync (castPoint <$> genPoint) (serialiseBlock <$> arbitrary) genTip where - genTip = Tip <$> arbitrary <*> arbitrary + genTip = legacyTip <$> arbitrary <*> arbitrary genPoint :: Gen (Point BlockHeader) genPoint = arbitrary @@ -507,7 +507,7 @@ prop_codec_binary_compat_ChainSyncSerialised_ChainSync msg = stokEq (ClientAgency ca) = case ca of TokIdle -> SamePeerHasAgency $ ClientAgency TokIdle stokEq (ServerAgency sa) = case sa of - TokNext k -> SamePeerHasAgency $ ServerAgency (TokNext k) + TokNext k -> SamePeerHasAgency $ ServerAgency (TokNext k) TokIntersect -> SamePeerHasAgency $ ServerAgency TokIntersect chainSyncDemo diff --git a/ouroboros-network/src/Ouroboros/Network/Block.hs b/ouroboros-network/src/Ouroboros/Network/Block.hs index df7597bf293..deece9ceb78 100644 --- a/ouroboros-network/src/Ouroboros/Network/Block.hs +++ b/ouroboros-network/src/Ouroboros/Network/Block.hs @@ -33,6 +33,11 @@ module Ouroboros.Network.Block ( , atSlot , withHash , Tip(..) + , getTipPoint + , getTipBlockNo + , getLegacyTipBlockNo + , legacyTip + , toLegacyTip , encodeTip , decodeTip , ChainUpdate(..) @@ -66,10 +71,10 @@ import GHC.Generics (Generic) import Cardano.Prelude (NoUnexpectedThunks) import Cardano.Slotting.Block -import Cardano.Slotting.Slot (SlotNo(..), genesisSlotNo) +import Cardano.Slotting.Slot (SlotNo (..), genesisSlotNo) -import Ouroboros.Network.Point (WithOrigin (..), block, origin, - withOriginToMaybe) +import Ouroboros.Network.Point (WithOrigin (..), block, + fromWithOrigin, origin, withOriginToMaybe) import qualified Ouroboros.Network.Point as Point (Block (..)) genesisPoint :: Point block @@ -181,18 +186,55 @@ blockPoint b = Point (block (blockSlot b) (blockHash b)) -- | Used in chain-sync protocol to advertise the tip of the server's chain. -- -data Tip b = Tip - { tipPoint :: !(Point b) - , tipBlockNo :: !BlockNo - } deriving (Eq, Show, Generic, NoUnexpectedThunks) +data Tip b = + -- | The tip is genesis + TipGenesis + + -- | The tip is not genesis + | Tip !SlotNo !(HeaderHash b) !BlockNo + deriving (Generic) + +deriving instance StandardHash b => Eq (Tip b) +deriving instance StandardHash b => Show (Tip b) +deriving instance StandardHash b => NoUnexpectedThunks (Tip b) + +getTipPoint :: Tip b -> Point b +getTipPoint TipGenesis = GenesisPoint +getTipPoint (Tip s h _) = BlockPoint s h + +getTipBlockNo :: Tip b -> WithOrigin BlockNo +getTipBlockNo TipGenesis = Origin +getTipBlockNo (Tip _ _ b) = At b + +-- | Get the block number associated with a 'Tip', or 'genesisBlockNo' otherwise +-- +-- TODO: This is /wrong/. There /is/ no block number if we are at genesis +-- ('genesisBlockNo' is the block number of the first block on the chain). +-- Usage of this function should be phased out. +getLegacyTipBlockNo :: Tip b -> BlockNo +getLegacyTipBlockNo = fromWithOrigin genesisBlockNo . getTipBlockNo + +-- | Translate to the format it was before (to maintain binary compatibility) +toLegacyTip :: Tip b -> (Point b, BlockNo) +toLegacyTip tip = (getTipPoint tip, getLegacyTipBlockNo tip) + +-- | Inverse of 'toLegacyTip' +-- +-- TODO: This should be phased out, since it makes no sense to have a +-- 'BlockNo' for the genesis point. +legacyTip :: Point b -> BlockNo -> Tip b +legacyTip GenesisPoint _ = TipGenesis -- Ignore block number +legacyTip (BlockPoint s h) b = Tip s h b encodeTip :: (HeaderHash blk -> Encoding) -> (Tip blk -> Encoding) -encodeTip encodeHeaderHash Tip { tipPoint, tipBlockNo } = mconcat +encodeTip encodeHeaderHash tip = mconcat [ Enc.encodeListLen 2 , encodePoint encodeHeaderHash tipPoint , encode tipBlockNo ] + where + (tipPoint, tipBlockNo) = toLegacyTip tip decodeTip :: (forall s. Decoder s (HeaderHash blk)) -> (forall s. Decoder s (Tip blk)) @@ -200,7 +242,7 @@ decodeTip decodeHeaderHash = do Dec.decodeListLenOf 2 tipPoint <- decodePoint decodeHeaderHash tipBlockNo <- decode - return Tip { tipPoint, tipBlockNo } + return $ legacyTip tipPoint tipBlockNo {------------------------------------------------------------------------------- ChainUpdate type diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/ChainSync/Examples.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/ChainSync/Examples.hs index a08716bb265..65f5eb81d0b 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/ChainSync/Examples.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/ChainSync/Examples.hs @@ -21,7 +21,7 @@ module Ouroboros.Network.Protocol.ChainSync.Examples ( import Control.Monad.Class.MonadSTM.Strict import Ouroboros.Network.Block (BlockNo, HasHeader (..), HeaderHash, - castPoint, genesisPoint, Tip(..)) + Tip (..), castPoint, genesisPoint, legacyTip) import Ouroboros.Network.MockChain.Chain (Chain (..), ChainUpdate (..), Point (..)) import qualified Ouroboros.Network.MockChain.Chain as Chain @@ -173,8 +173,8 @@ chainSyncServerExample recvMsgDoneClient chainvar = ChainSyncServer $ sendNext :: ReaderId -> (Point blk, BlockNo, ChainUpdate header header) -> ServerStNext header (Tip blk) m a - sendNext r (tip, blkNo, AddBlock b) = SendMsgRollForward b (Tip tip blkNo) (idle' r) - sendNext r (tip, blkNo, RollBack p) = SendMsgRollBackward (castPoint p) (Tip tip blkNo) (idle' r) + sendNext r (tip, blkNo, AddBlock b) = SendMsgRollForward b (legacyTip tip blkNo) (idle' r) + sendNext r (tip, blkNo, RollBack p) = SendMsgRollBackward (castPoint p) (legacyTip tip blkNo) (idle' r) handleFindIntersect :: ReaderId -> [Point header] @@ -184,8 +184,8 @@ chainSyncServerExample recvMsgDoneClient chainvar = ChainSyncServer $ -- Find the first point that is on our chain changed <- improveReadPoint r points case changed of - (Just pt, tip, blkNo) -> return $ SendMsgIntersectFound pt (Tip tip blkNo) (idle' r) - (Nothing, tip, blkNo) -> return $ SendMsgIntersectNotFound (Tip tip blkNo) (idle' r) + (Just pt, tip, blkNo) -> return $ SendMsgIntersectFound pt (legacyTip tip blkNo) (idle' r) + (Nothing, tip, blkNo) -> return $ SendMsgIntersectNotFound (legacyTip tip blkNo) (idle' r) newReader :: m ReaderId newReader = atomically $ do