Introduce Chain.headTip and Chain.legacyHeadBlockNo

ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs

@@ -288,7 +288,7 @@ runChainSync securityParam maxClockSkew (ClientUpdates clientUpdates)
           , getCurrentLedger  = snd <$> readTVar varClientState
           , getOurTip         = do
               chain <- fst <$> readTVar varClientState
-              return $ legacyTip (Chain.headPoint chain) (Chain.headBlockNo chain)
+              return $ Chain.headTip chain
           , getIsInvalidBlock = return $
               WithFingerprint (const Nothing) (Fingerprint 0)
           }

ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs

@@ -228,7 +228,7 @@ lastK (SecurityParam k) f =
 -- In the real implementation this will correspond to the block number of the
 -- block at the tip of the Immutable DB.
 immutableBlockNo :: HasHeader blk
-                 => SecurityParam -> Model blk -> Block.BlockNo
+                 => SecurityParam -> Model blk -> WithOrigin Block.BlockNo
 immutableBlockNo (SecurityParam k) =
         Chain.headBlockNo
       . Chain.drop (fromIntegral k)
@@ -333,7 +333,7 @@ addBlock :: forall blk. ProtocolLedgerView blk
 addBlock cfg blk m
     -- If the block is as old as the tip of the ImmutableDB, i.e. older than
     -- @k@, we ignore it, as we can never switch to it. TODO what about EBBs?
-  | Block.blockNo blk <= immutableBlockNo secParam m
+  | At (Block.blockNo blk) <= immutableBlockNo secParam m
     -- Unless we're adding the first block to the empty chain: the empty chain
     -- has the same block number as the genesis EBB, i.e. 0, so we don't want
     -- to ignore it in this case.

ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model/Test.hs

@@ -15,6 +15,7 @@ import           Test.Tasty.QuickCheck
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (HasHeader (..), genesisPoint)
 import qualified Ouroboros.Network.MockChain.Chain as Chain
+import           Ouroboros.Network.Point (WithOrigin (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Protocol.Abstract
@@ -44,7 +45,7 @@ addBlocks blks = M.addBlocks cfg blks m
 prop_getBlock_addBlock :: BlockTree -> Permutation -> Property
 prop_getBlock_addBlock bt p =
         M.getBlock (blockHash newBlock) (M.addBlock singleNodeTestConfig newBlock model)
-    === if blockNo newBlock > M.immutableBlockNo secParam model
+    === if At (blockNo newBlock) > M.immutableBlockNo secParam model
         then Just newBlock
         else Nothing
   where

ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/ExamplesPipelined.hs

@@ -48,10 +48,10 @@ chainSyncClientPipelined mkPipelineDecision0 chainvar =
       -- found an intersection or not. If not, we'll just sync from genesis.
       ClientPipelinedStIntersect {
         recvMsgIntersectFound    = \_ srvTip -> do
-          cliTipBlockNo <- At . Chain.headBlockNo <$> atomically (readTVar chainvar)
+          cliTipBlockNo <- Chain.headBlockNo <$> atomically (readTVar chainvar)
           pure $ go mkPipelineDecision0 Zero cliTipBlockNo srvTip client,
         recvMsgIntersectNotFound = \  srvTip -> do
-          cliTipBlockNo <- At . Chain.headBlockNo <$> atomically (readTVar chainvar)
+          cliTipBlockNo <- Chain.headBlockNo <$> atomically (readTVar chainvar)
           pure $ go mkPipelineDecision0 Zero cliTipBlockNo srvTip client
       }
 
@@ -175,8 +175,7 @@ chainSyncClientPipelined mkPipelineDecision0 chainvar =
         --TODO: handle rollback failure
         let (Just !chain') = Chain.rollback p chain
         writeTVar chainvar chain'
-        -- TODO update Chain.headBlockNo to return @WithOrigin BlockNo@
-        pure $ if Chain.null chain' then Origin else At (Chain.headBlockNo chain')
+        pure $ Chain.headBlockNo chain'
 
 -- | Offsets from the head of the chain to select points on the consumer's
 -- chain to send to the producer. The specific choice here is fibonacci up

ouroboros-network/protocol-tests/Test/ChainGenerators.hs

@@ -287,7 +287,7 @@ instance Arbitrary TestAddBlock where
     [ TestAddBlock c' b'
     | TestBlockChain c' <- shrink (TestBlockChain c)
     , let b' = fixupBlock (Chain.headHash c')
-                          (Chain.headBlockNo c') b
+                          (Chain.legacyHeadBlockNo c') b
     ]
 
 genAddBlock :: (HasHeader block, HeaderHash block ~ ConcreteHeaderHash)
@@ -300,7 +300,7 @@ genAddBlock chain = do
           At slotNo -> addSlotGap slotGap slotNo
         pb = mkPartialBlock nextSlotNo body
         b  = fixupBlock (Chain.headHash chain)
-                        (Chain.headBlockNo chain) pb
+                        (Chain.legacyHeadBlockNo chain) pb
     return b
 
 prop_arbitrary_TestAddBlock :: TestAddBlock -> Bool
@@ -407,8 +407,8 @@ countChainUpdateNetProgress = go 0
     go n c  (u:us) = go n' c' us
       where
         Just c' = Chain.applyChainUpdate u c
-        n'      = n + fromEnum (Chain.headBlockNo c')
-                    - fromEnum (Chain.headBlockNo c)
+        n'      = n + fromEnum (Chain.legacyHeadBlockNo c')
+                    - fromEnum (Chain.legacyHeadBlockNo c)
 
 
 --

ouroboros-network/src/Ouroboros/Network/Block.hs

@@ -33,6 +33,7 @@ module Ouroboros.Network.Block (
   , atSlot
   , withHash
   , Tip(..)
+  , castTip
   , getTipPoint
   , getTipBlockNo
   , getLegacyTipBlockNo
@@ -198,6 +199,11 @@ deriving instance StandardHash b => Eq                 (Tip b)
 deriving instance StandardHash b => Show               (Tip b)
 deriving instance StandardHash b => NoUnexpectedThunks (Tip b)
 
+-- | The equivalent of 'castPoint' for 'Tip'
+castTip :: (HeaderHash a ~ HeaderHash b) => Tip a -> Tip b
+castTip TipGenesis  = TipGenesis
+castTip (Tip s h b) = Tip s h b
+
 getTipPoint :: Tip b -> Point b
 getTipPoint TipGenesis  = GenesisPoint
 getTipPoint (Tip s h _) = BlockPoint s h

ouroboros-network/src/Ouroboros/Network/MockChain/Chain.hs

@@ -28,7 +28,9 @@ module Ouroboros.Network.MockChain.Chain (
   headPoint,
   headSlot,
   headHash,
+  headTip,
   headBlockNo,
+  legacyHeadBlockNo,
 
   -- ** Basic operations
   head,
@@ -126,7 +128,11 @@ validExtension c b = blockInvariant b
                   -- The block number must be non-strictly increasing. An EBB
                   -- has the same block number as its parent. It can increase
                   -- by at most one.
-                  && (headBlockNo c == blockNo b || succ (headBlockNo c) == blockNo b)
+                  && case headBlockNo c of
+                       -- TODO The rhs of (||) is only needed because
+                       -- 'legacyHeadBlockNo' is still being used.
+                       Origin    -> blockNo b == 0 || blockNo b == 1
+                       At prevNo -> blockNo b == succ prevNo || blockNo b == prevNo
 
 head :: Chain b -> Maybe b
 head Genesis  = Nothing
@@ -142,9 +148,20 @@ headSlot = pointSlot . headPoint
 headHash :: HasHeader block => Chain block -> ChainHash block
 headHash = pointHash . headPoint
 
-headBlockNo :: HasHeader block => Chain block -> BlockNo
-headBlockNo Genesis  = genesisBlockNo
-headBlockNo (_ :> b) = blockNo b
+headTip :: HasHeader block => Chain block -> Tip block
+headTip Genesis  = TipGenesis
+headTip (_ :> b) = Tip (blockSlot b) (blockHash b) (blockNo b)
+
+headBlockNo :: HasHeader block => Chain block -> WithOrigin BlockNo
+headBlockNo Genesis  = Origin
+headBlockNo (_ :> b) = At (blockNo b)
+
+-- | 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.
+legacyHeadBlockNo :: HasHeader block => Chain block -> BlockNo
+legacyHeadBlockNo Genesis  = genesisBlockNo
+legacyHeadBlockNo (_ :> b) = blockNo b
 
 -- | Produce the list of blocks, from most recent back to genesis
 --

ouroboros-network/src/Ouroboros/Network/Protocol/ChainSync/Examples.hs

@@ -1,12 +1,8 @@
 {-# LANGUAGE BangPatterns         #-}
-{-# LANGUAGE DeriveAnyClass       #-}
-{-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE NamedFieldPuns       #-}
-{-# LANGUAGE RecordWildCards      #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
-{-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -20,8 +16,8 @@ module Ouroboros.Network.Protocol.ChainSync.Examples (
 
 import           Control.Monad.Class.MonadSTM.Strict
 
-import           Ouroboros.Network.Block (BlockNo, HasHeader (..), HeaderHash,
-                     Tip (..), castPoint, genesisPoint, legacyTip)
+import           Ouroboros.Network.Block (HasHeader (..), HeaderHash, Tip (..),
+                     castPoint, castTip, genesisPoint)
 import           Ouroboros.Network.MockChain.Chain (Chain (..),
                      ChainUpdate (..), Point (..))
 import qualified Ouroboros.Network.MockChain.Chain as Chain
@@ -171,10 +167,10 @@ chainSyncServerExample recvMsgDoneClient chainvar = ChainSyncServer $
                        -- the producer's state to change.
 
     sendNext :: ReaderId
-             -> (Point blk, BlockNo, ChainUpdate header header)
+             -> (Tip blk, ChainUpdate header header)
              -> ServerStNext header (Tip blk) m a
-    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)
+    sendNext r (tip, AddBlock b) = SendMsgRollForward  b             tip (idle' r)
+    sendNext r (tip, RollBack p) = SendMsgRollBackward (castPoint p) tip (idle' r)
 
     handleFindIntersect :: ReaderId
                         -> [Point header]
@@ -184,8 +180,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 (legacyTip tip blkNo) (idle' r)
-        (Nothing, tip, blkNo) -> return $ SendMsgIntersectNotFound     (legacyTip tip blkNo) (idle' r)
+        (Just pt, tip) -> return $ SendMsgIntersectFound     pt tip (idle' r)
+        (Nothing, tip) -> return $ SendMsgIntersectNotFound     tip (idle' r)
 
     newReader :: m ReaderId
     newReader = atomically $ do
@@ -196,27 +192,21 @@ chainSyncServerExample recvMsgDoneClient chainvar = ChainSyncServer $
 
     improveReadPoint :: ReaderId
                      -> [Point header]
-                     -> m (Maybe (Point header), Point blk, BlockNo)
+                     -> m (Maybe (Point header), Tip blk)
     improveReadPoint rid points =
       atomically $ do
         cps <- readTVar chainvar
         case ChainProducerState.findFirstPoint (map castPoint points) cps of
           Nothing     -> let chain = ChainProducerState.chainState cps
-                         in pure ( Nothing
-                                 , castPoint (Chain.headPoint chain)
-                                 , Chain.headBlockNo chain
-                                 )
+                         in return (Nothing, castTip (Chain.headTip chain))
           Just ipoint -> do
             let !cps' = ChainProducerState.updateReader rid ipoint cps
             writeTVar chainvar cps'
             let chain = ChainProducerState.chainState cps'
-            pure ( Just ipoint
-                 , castPoint (Chain.headPoint chain)
-                 , Chain.headBlockNo chain
-                 )
+            return (Just ipoint, castTip (Chain.headTip chain))
 
     tryReadChainUpdate :: ReaderId
-                       -> m (Maybe (Point blk, BlockNo, ChainUpdate header header))
+                       -> m (Maybe (Tip blk, ChainUpdate header header))
     tryReadChainUpdate rid =
       atomically $ do
         cps <- readTVar chainvar
@@ -225,12 +215,9 @@ chainSyncServerExample recvMsgDoneClient chainvar = ChainSyncServer $
           Just (u, cps') -> do
             writeTVar chainvar cps'
             let chain = ChainProducerState.chainState cps'
-            return $ Just ( castPoint (Chain.headPoint chain)
-                          , Chain.headBlockNo chain
-                          , u
-                          )
+            return $ Just (castTip (Chain.headTip chain), u)
 
-    readChainUpdate :: ReaderId -> m (Point blk, BlockNo, ChainUpdate header header)
+    readChainUpdate :: ReaderId -> m (Tip blk, ChainUpdate header header)
     readChainUpdate rid =
       atomically $ do
         cps <- readTVar chainvar
@@ -239,7 +226,4 @@ chainSyncServerExample recvMsgDoneClient chainvar = ChainSyncServer $
           Just (u, cps') -> do
             writeTVar chainvar cps'
             let chain = ChainProducerState.chainState cps'
-            return ( castPoint (Chain.headPoint chain)
-                   , Chain.headBlockNo chain
-                   , u
-                   )
+            return (castTip (Chain.headTip chain), u)

ouroboros-network/test/Ouroboros/Network/MockNode.hs

@@ -407,4 +407,4 @@ coreNode nid slotDuration gchain chans = do
     fixupBlock c =
       Concrete.fixupBlock
         (Chain.headHash c)
-        (Chain.headBlockNo c)
+        (Chain.legacyHeadBlockNo c)