Add BlockNo to the anchor of an AnchoredFragment

Closes #1578.
Closes #1584.

ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs

@@ -125,7 +125,7 @@ bracketChainSyncClient tracer ChainDbView { getIsInvalidBlock } varCandidates
         body varCandidate
   where
     register = do
-      varCandidate <- newTVarM $ AF.Empty GenesisPoint
+      varCandidate <- newTVarM $ AF.Empty AF.AnchorGenesis
       atomically $ modifyTVar varCandidates $ Map.insert peer varCandidate
       return varCandidate
 
@@ -432,14 +432,14 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime
           -- next block.
           atomically $ writeTVar varCandidate theirFrag
           let candTipBlockNo = case AF.headBlockNo theirFrag of
-                Just b  -> b
+                At b  -> b
                 -- If their fragment is somehow empty, base ourselves on our
                 -- fragment instead. We know they must have the same anchor
                 -- point. Look at the first block after the anchor point, use
                 -- its block number - 1, this should correspond to the synced
                 -- tip, i.e. their anchor point. If our fragment is empty too,
                 -- then we and they are at Genesis.
-                Nothing -> either
+                Origin -> either
                   (const genesisBlockNo)
                   (blockNoBefore . blockNo)
                   (AF.last ourFrag)

ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncServer.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -14,8 +15,8 @@ module Ouroboros.Consensus.ChainSyncServer
 
 import           Control.Tracer
 
-import           Ouroboros.Network.Block (ChainUpdate (..), HeaderHash,
-                     Point (..), Serialised, Tip (..), castPoint, legacyTip)
+import           Ouroboros.Network.Block (ChainUpdate (..), HasHeader (..),
+                     HeaderHash, Point (..), Serialised, Tip (..), castPoint)
 import           Ouroboros.Network.Protocol.ChainSync.Server
 
 import           Ouroboros.Storage.ChainDB.API (ChainDB, Reader,
@@ -33,7 +34,7 @@ import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
 -- headers (and fetches blocks separately with the block fetch mini-protocol).
 --
 chainSyncHeadersServer
-    :: forall m blk. IOLike m
+    :: forall m blk. (IOLike m, HasHeader (Header blk))
     => Tracer m (TraceChainSyncServerEvent blk (Header blk))
     -> ChainDB m blk
     -> ResourceRegistry m
@@ -50,7 +51,7 @@ chainSyncHeadersServer tracer chainDB registry =
 -- chains of full blocks (rather than a header \/ body split).
 --
 chainSyncBlocksServer
-    :: forall m blk. IOLike m
+    :: forall m blk. (IOLike m, HasHeader (Header blk))
     => Tracer m (TraceChainSyncServerEvent blk blk)
     -> ChainDB m blk
     -> ResourceRegistry m
@@ -75,6 +76,7 @@ chainSyncServerForReader
     :: forall m blk b.
        ( IOLike m
        , HeaderHash blk ~ HeaderHash b
+       , HasHeader (Header blk)
        )
     => Tracer m (TraceChainSyncServerEvent blk b)
     -> ChainDB m blk
@@ -97,15 +99,15 @@ chainSyncServerForReader tracer chainDB rdr =
                                 (m (ServerStNext (Serialised b) (Tip blk) m ())))
     handleRequestNext = ChainDB.readerInstruction rdr >>= \case
       Just update -> do
-        tip <- getTip
+        tip <- atomically $ ChainDB.getCurrentTip chainDB
         traceWith tracer $
           TraceChainSyncServerRead tip (point <$> update)
         return $ Left $ sendNext tip (serialised <$> update)
       Nothing     -> return $ Right $ do
         -- Reader is at the head, we have to block and wait for the chain to
         -- change.
         update <- ChainDB.readerInstructionBlocking rdr
-        tip    <- getTip
+        tip    <- atomically $ ChainDB.getCurrentTip chainDB
         traceWith tracer $
           TraceChainSyncServerReadBlocked tip (point <$> update)
         return $ sendNext tip (serialised <$> update)
@@ -122,17 +124,11 @@ chainSyncServerForReader tracer chainDB rdr =
     handleFindIntersect points = do
       -- TODO guard number of points
       changed <- ChainDB.readerForward rdr (map castPoint points)
-      tip     <- getTip
+      tip     <- atomically $ ChainDB.getCurrentTip chainDB
       return $ case changed :: Maybe (Point blk) of
         Just pt -> SendMsgIntersectFound    (castPoint pt) tip idle'
         Nothing -> SendMsgIntersectNotFound tip idle'
 
-    getTip :: m (Tip blk)
-    getTip = atomically $ do
-      tipPoint   <- castPoint <$> ChainDB.getTipPoint   chainDB
-      tipBlockNo <-               ChainDB.getTipBlockNo chainDB
-      return $ legacyTip tipPoint tipBlockNo
-
 {-------------------------------------------------------------------------------
   Trace events
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs

@@ -25,7 +25,6 @@ module Ouroboros.Consensus.NodeKernel (
   , ProtocolM
   ) where
 
-import           Control.Exception (assert)
 import           Control.Monad
 import           Crypto.Random (ChaChaDRG)
 import           Data.Map.Strict (Map)
@@ -35,8 +34,8 @@ import           Data.Word (Word16, Word32)
 import           Cardano.Prelude (UseIsNormalForm (..))
 import           Control.Tracer
 
-import           Ouroboros.Network.AnchoredFragment (AnchoredFragment (..),
-                     headPoint, headSlot)
+import           Ouroboros.Network.AnchoredFragment (AnchoredFragment (..))
+import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block
 import           Ouroboros.Network.BlockFetch
 import           Ouroboros.Network.BlockFetch.State (FetchMode (..))
@@ -303,7 +302,7 @@ initBlockFetchConsensusInterface cfg chainDB getCandidates blockFetchSize
     readFetchMode :: STM m FetchMode
     readFetchMode = do
       curSlot      <- getCurrentSlot btime
-      curChainSlot <- headSlot <$> ChainDB.getCurrentChain chainDB
+      curChainSlot <- AF.headSlot <$> ChainDB.getCurrentChain chainDB
       let slotsBehind = case curChainSlot of
             -- There's nothing in the chain. If the current slot is 0, then
             -- we're 1 slot behind.
@@ -363,7 +362,6 @@ forkBlockProduction maxBlockSizeOverride IS{..} BlockProduction{..} =
           eBlkCtx <- lift $ atomically $
             mkCurrentBlockContext currentSlot
                 <$> ChainDB.getCurrentChain chainDB
-                <*> ChainDB.getTipBlockNo chainDB
           case eBlkCtx of
             Right blkCtx -> return blkCtx
             Left failure -> do
@@ -533,28 +531,34 @@ blockContextFromPrevHeader hdr =
 -- predecessor. If the chain is empty, then it will refer to the chain's anchor
 -- point, which may be genesis.
 mkCurrentBlockContext
-  :: RunNode blk
+  :: forall blk. RunNode blk
   => SlotNo
      -- ^ the current slot, i.e. the slot of the block about to be forged
   -> AnchoredFragment (Header blk)
      -- ^ the current chain fragment
      --
      -- Recall that the anchor point is the tip of the ImmDB.
-  -> BlockNo
-     -- ^ the block number of the tip of the ChainDB
-     --
-     -- If the fragment is 'Empty', then this is the block number of the
-     -- tip of the ImmDB.
   -> Either (TraceForgeEvent blk (GenTx blk)) (BlockContext blk)
      -- ^ the event records the cause of the failure
-mkCurrentBlockContext currentSlot c bno = case c of
-    Empty p   -- thus: bno and p both refer to the tip of the ImmDB
-      | pointSlot p < At currentSlot
-      -> Right $ BlockContext (succ bno) (castPoint p)
-      | otherwise
-      -> Left $ TraceSlotIsImmutable currentSlot (castPoint p) bno
-    c' :> hdr -> assert (bno == blockNo hdr) $
-                 case blockSlot hdr `compare` currentSlot of
+mkCurrentBlockContext currentSlot c = case c of
+    Empty AF.AnchorGenesis ->
+      -- The chain is entirely empty.
+      --
+      -- NOTE:
+      --
+      -- o 'genesisBlockNo' is the block number of the first block
+      -- o 'genesisPoint' is the point /before/ the first block
+      --
+      -- which is precisely what we need for 'BlockContext'
+      Right $ BlockContext genesisBlockNo genesisPoint
+
+    Empty (AF.Anchor anchorSlot anchorHash anchorBlockNo) ->
+      let p :: Point blk = BlockPoint anchorSlot anchorHash
+      in if anchorSlot < currentSlot
+           then Right $ BlockContext (succ anchorBlockNo) p
+           else Left  $ TraceSlotIsImmutable currentSlot p anchorBlockNo
+
+    c' :> hdr -> case blockSlot hdr `compare` currentSlot of
 
       -- The block at the tip of our chain has a slot number /before/ the
       -- current slot number. This is the common case, and we just want to
@@ -591,7 +595,7 @@ mkCurrentBlockContext currentSlot c bno = case c of
         then blockContextFromPrevHeader hdr
         -- If @hdr@ is not an EBB, then forge an alternative to @hdr@: same
         -- block no and same predecessor.
-        else BlockContext (blockNo hdr) $ castPoint $ headPoint c'
+        else BlockContext (blockNo hdr) $ castPoint $ AF.headPoint c'
 
 {-------------------------------------------------------------------------------
   TxSubmission integration

ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs

@@ -600,11 +600,11 @@ consensusNetworkApps kernel ProtocolTracers {..} ProtocolCodecs {..} ProtocolHan
         channel
         (localStateQueryServerPeer phLocalStateQueryServer)
 
-chainDbView :: IOLike m => ChainDB m blk -> ChainDbView m blk
+chainDbView :: (IOLike m, HasHeader (Header blk))
+            => ChainDB m blk -> ChainDbView m blk
 chainDbView chainDB = ChainDbView
-  { getCurrentChain   = ChainDB.getCurrentChain             chainDB
-  , getCurrentLedger  = ChainDB.getCurrentLedger            chainDB
-  , getOurTip         = legacyTip <$> ChainDB.getTipPoint   chainDB
-                                  <*> ChainDB.getTipBlockNo chainDB
-  , getIsInvalidBlock = ChainDB.getIsInvalidBlock           chainDB
+  { getCurrentChain   = ChainDB.getCurrentChain   chainDB
+  , getCurrentLedger  = ChainDB.getCurrentLedger  chainDB
+  , getOurTip         = ChainDB.getCurrentTip     chainDB
+  , getIsInvalidBlock = ChainDB.getIsInvalidBlock chainDB
   }

ouroboros-consensus/src/Ouroboros/Consensus/Util/AnchoredFragment.hs

@@ -159,7 +159,7 @@ preferAnchoredCandidate cfg ours theirs =
         False
       (Empty ourAnchor, _ :> theirTip) ->
         -- Case 3
-        blockPoint theirTip /= ourAnchor
+        blockPoint theirTip /= AF.anchorToPoint ourAnchor
       (_ :> ourTip, _ :> theirTip) ->
         -- Case 4
         preferCandidate cfg (selectView cfg ourTip) (selectView cfg theirTip)

ouroboros-consensus/src/Ouroboros/Consensus/Util/Condense.hs

@@ -33,6 +33,7 @@ import           Cardano.Crypto.KES (MockKES, NeverKES, SigKES,
                      pattern SigMockKES, pattern SigSimpleKES,
                      pattern SignKeyMockKES, SignedKES (..), SimpleKES,
                      pattern VerKeyMockKES)
+import           Cardano.Slotting.Slot (WithOrigin (..))
 
 import           Ouroboros.Network.Block (BlockNo (..), ChainHash (..),
                      HeaderHash, SlotNo (..))
@@ -154,6 +155,10 @@ instance Condense (HeaderHash b) => Condense (ChainHash b) where
   condense GenesisHash   = "genesis"
   condense (BlockHash h) = condense h
 
+instance Condense a => Condense (WithOrigin a) where
+  condense Origin = "origin"
+  condense (At a) = condense a
+
 {-------------------------------------------------------------------------------
   Orphans for cardano-crypto-wrapper
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/Ouroboros/Consensus/Util/Orphans.hs

@@ -56,7 +56,7 @@ instance Condense block => Condense (Chain block) where
 
 instance (Condense block, HasHeader block, Condense (HeaderHash block))
     => Condense (AnchoredFragment block) where
-    condense (AF.Empty pt) = "EmptyAnchor " <> condense pt
+    condense (AF.Empty pt) = "EmptyAnchor " <> condense (AF.anchorToPoint pt)
     condense (cs AF.:> b)  = condense cs <> " :> " <> condense b
 
 {-------------------------------------------------------------------------------

ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs

@@ -17,6 +17,8 @@
 module Ouroboros.Storage.ChainDB.API (
     -- * Main ChainDB API
     ChainDB(..)
+  , getCurrentTip
+  , getTipBlockNo
     -- * Useful utilities
   , getBlock
   , streamBlocks
@@ -67,10 +69,13 @@ import           GHC.Stack
 import           Cardano.Prelude (NoUnexpectedThunks)
 
 import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
+import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (BlockNo, pattern BlockPoint,
                      ChainUpdate, pattern GenesisPoint, HasHeader (..),
                      HeaderHash, MaxSlotNo, Point, Serialised (..), SlotNo,
                      StandardHash, atSlot, genesisPoint)
+import qualified Ouroboros.Network.Block as Network
+import           Ouroboros.Network.Point (WithOrigin)
 
 import           Ouroboros.Consensus.Block (GetHeader (..), IsEBB (..))
 import           Ouroboros.Consensus.Ledger.Abstract (ProtocolLedgerView)
@@ -179,11 +184,6 @@ data ChainDB m blk = ChainDB {
       -- 'getTipPoint' will return the tip of the immutable DB.
     , getTipPoint        :: STM m (Point blk)
 
-      -- | Get block number of the tip of the chain
-      --
-      -- Will return 'genesisBlockNo' if the database is empty.
-    , getTipBlockNo      :: STM m BlockNo
-
       -- | Get the given component(s) of the block at the specified point. If
       -- there is no block at the given point, 'Nothing' is returned.
     , getBlockComponent  :: forall b. BlockComponent (ChainDB m blk) b
@@ -303,6 +303,19 @@ data ChainDB m blk = ChainDB {
     , isOpen             :: STM m Bool
     }
 
+getCurrentTip :: (Monad (STM m), HasHeader (Header blk))
+              => ChainDB m blk -> STM m (Network.Tip blk)
+getCurrentTip chainDB =
+    mkTip . AF.headAnchor <$> getCurrentChain chainDB
+  where
+    mkTip :: AF.Anchor (Header blk) -> Network.Tip blk
+    mkTip AF.AnchorGenesis  = Network.TipGenesis
+    mkTip (AF.Anchor s h b) = Network.Tip s h b
+
+getTipBlockNo :: (Monad (STM m), HasHeader (Header blk))
+              => ChainDB m blk -> STM m (WithOrigin BlockNo)
+getTipBlockNo = fmap Network.getTipBlockNo . getCurrentTip
+
 instance DB (ChainDB m blk) where
   -- Returning a block or header requires parsing. In case of failure, a
   -- 'ChainDbFailure' exception is thrown

ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl.hs

@@ -36,12 +36,11 @@ import           Control.Monad.Class.MonadThrow (bracket)
 
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (HasHeader (..), castPoint,
-                     genesisBlockNo, genesisPoint)
+                     genesisPoint)
 
 import           Ouroboros.Consensus.Block (headerPoint, toIsEBB)
 import           Ouroboros.Consensus.BlockchainTime (getCurrentSlot)
 import           Ouroboros.Consensus.Ledger.Abstract
-import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Consensus.Util.STM (Fingerprint (..),
                      WithFingerprint (..))
@@ -95,9 +94,8 @@ openDBInternal args launchBgTasks = do
     -- Note that 'immDbTipBlockNo' might not end up being the \"immutable\"
     -- block(no), because the current chain computed from the VolatileDB could
     -- be longer than @k@.
-    let immDbTipBlockNo = maybe genesisBlockNo blockNo     immDbTipHeader
-        immDbTipPoint   = maybe genesisPoint   headerPoint immDbTipHeader
-    immDbTipEpoch      <- maybe (return 0)     blockEpoch  immDbTipHeader
+    let immDbTipPoint = maybe genesisPoint headerPoint immDbTipHeader
+    immDbTipEpoch    <- maybe (return 0)   blockEpoch  immDbTipHeader
     traceWith tracer $ TraceOpenEvent $ OpenedImmDB
       { _immDbTip      = immDbTipPoint
       , _immDbTipEpoch = immDbTipEpoch
@@ -127,15 +125,12 @@ openDBInternal args launchBgTasks = do
       varInvalid
       curSlot
 
-    let chain      = ChainSel.clChain  chainAndLedger
-        ledger     = ChainSel.clLedger chainAndLedger
-        cfg        = Args.cdbNodeConfig args
-        secParam   = protocolSecurityParam cfg
-        immBlockNo = ChainSel.getImmBlockNo secParam chain immDbTipBlockNo
+    let chain  = ChainSel.clChain  chainAndLedger
+        ledger = ChainSel.clLedger chainAndLedger
+        cfg    = Args.cdbNodeConfig args
 
     atomically $ LgrDB.setCurrent lgrDB ledger
     varChain           <- newTVarM chain
-    varImmBlockNo      <- newTVarM immBlockNo
     varIterators       <- newTVarM Map.empty
     varReaders         <- newTVarM Map.empty
     varNextIteratorKey <- newTVarM (IteratorKey 0)
@@ -148,7 +143,6 @@ openDBInternal args launchBgTasks = do
                   , cdbVolDB           = volDB
                   , cdbLgrDB           = lgrDB
                   , cdbChain           = varChain
-                  , cdbImmBlockNo      = varImmBlockNo
                   , cdbIterators       = varIterators
                   , cdbReaders         = varReaders
                   , cdbNodeConfig      = cfg
@@ -174,7 +168,6 @@ openDBInternal args launchBgTasks = do
           , getTipBlock        = getEnv     h Query.getTipBlock
           , getTipHeader       = getEnv     h Query.getTipHeader
           , getTipPoint        = getEnvSTM  h Query.getTipPoint
-          , getTipBlockNo      = getEnvSTM  h Query.getTipBlockNo
           , getBlockComponent  = getEnv2    h Query.getBlockComponent
           , getIsFetched       = getEnvSTM  h Query.getIsFetched
           , getMaxSlotNo       = getEnvSTM  h Query.getMaxSlotNo