ChainSyncClient: No BlockNo when tip is genesis

The `Tip` data-type was

```haskell
data Tip b = Tip
  { tipPoint   :: !(Point b)
  , tipBlockNo :: !BlockNo
  }
```

where `Point` uses `WithOrigin`. This is not correct. When `tipPoint` is
`Origin`, then there _is_ no `tipBlockNo` (`genesisBlockNo` is the block
number of the first block on the chain). In this commit we change this
to

```haskell
data Tip b =
    -- | The tip is genesis
    TipGenesis

    -- | The tip is not genesis
  | Tip !SlotNo !(HeaderHash b) !BlockNo
```

It doesn't, however, make any real changes, providing instead some
"legacy" API that pretends that we _do_ always have a `BlockNo`. This
primarily affects consensus only, in networking this only appears in
examples and tests.

We also use this legacy format to avoid changing the binary presentation
of `Tip`, so that this PR does _not_ break backwards compatibility.

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

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

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
   }

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)
           }

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

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

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,26 +186,63 @@ 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))
 decodeTip decodeHeaderHash = do
   Dec.decodeListLenOf 2
   tipPoint    <- decodePoint decodeHeaderHash
   tipBlockNo  <- decode
-  return Tip { tipPoint, tipBlockNo }
+  return $ legacyTip tipPoint tipBlockNo
 
 {-------------------------------------------------------------------------------
   ChainUpdate type

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