[Blocked, waiting for UTxO HD] consensus: annotate headers with their slot's RelativeTime

ouroboros-consensus-cardano/changelog.d/20241218_095046_nick.frisby_annotate_headers_with_time.md

@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Update now that `ImmutableEraParams` was split out
+

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/ByronHFC.hs

@@ -30,9 +30,11 @@ type ByronBlockHFC = HardForkBlock '[ByronBlock]
   NoHardForks instance
 -------------------------------------------------------------------------------}
 
-instance NoHardForks ByronBlock where
-  getEraParams cfg =
+instance ImmutableEraParams ByronBlock where
+  immutableEraParams cfg =
       byronEraParamsNeverHardForks (byronGenesisConfig (configBlock cfg))
+
+instance NoHardForks ByronBlock where
   toPartialLedgerConfig _ cfg = ByronPartialLedgerConfig {
         byronLedgerConfig    = cfg
       , byronTriggerHardFork = TriggerHardForkNotDuringThisExecution

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs

@@ -79,12 +79,16 @@ type ShelleyBlockHFC proto era = HardForkBlock '[ShelleyBlock proto era]
 
 instance ( ShelleyCompatible proto era
          , LedgerSupportsProtocol (ShelleyBlock proto era)
-         , TxLimits               (ShelleyBlock proto era)
-         ) => NoHardForks (ShelleyBlock proto era) where
-  getEraParams =
+         ) => ImmutableEraParams (ShelleyBlock proto era) where
+  immutableEraParams =
         shelleyEraParamsNeverHardForks
       . shelleyLedgerGenesis
       . configLedger
+
+instance ( ShelleyCompatible proto era
+         , LedgerSupportsProtocol (ShelleyBlock proto era)
+         , TxLimits               (ShelleyBlock proto era)
+         ) => NoHardForks (ShelleyBlock proto era) where
   toPartialLedgerConfig _ cfg = ShelleyPartialLedgerConfig {
         shelleyLedgerConfig    = cfg
       , shelleyTriggerHardFork = TriggerHardForkNotDuringThisExecution

ouroboros-consensus-diffusion/changelog.d/20241218_095040_nick.frisby_annotate_headers_with_time.md

@@ -0,0 +1,22 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Use `HeaderWithTime` for the ChainSync candidates

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -55,6 +55,7 @@ import           Data.Void (Void)
 import           Network.TypedProtocol.Codec
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config (DiffusionPipeliningSupport (..))
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime)
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
@@ -152,7 +153,7 @@ data Handlers m addr blk = Handlers {
         :: NodeToNodeVersion
         -> ControlMessageSTM m
         -> FetchedMetricsTracer m
-        -> BlockFetchClient (Header blk) blk m ()
+        -> BlockFetchClient (HeaderWithTime blk) blk m ()
 
     , hBlockFetchServer
         :: ConnectionId addr

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Genesis.hs

@@ -19,7 +19,9 @@ module Ouroboros.Consensus.Node.Genesis (
 
 import           Control.Monad (join)
 import           Data.Traversable (for)
+import           Data.Typeable (Typeable)
 import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (CSJConfig (..), CSJEnabledConfig (..),
                      ChainSyncLoPBucketConfig (..),
@@ -89,7 +91,7 @@ data GenesisNodeKernelArgs m blk = GenesisNodeKernelArgs {
 -- 'ChainDB.GetLoEFragment' that will be replaced via 'setGetLoEFragment') and a
 -- function to update the 'ChainDbArgs' accordingly.
 mkGenesisNodeKernelArgs ::
-     forall m blk. (IOLike m, GetHeader blk)
+     forall m blk. (IOLike m, GetHeader blk, Typeable blk)
   => GenesisConfig
   -> m ( GenesisNodeKernelArgs m blk
        , Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
@@ -113,9 +115,9 @@ mkGenesisNodeKernelArgs gcfg = do
 -- | Set 'gnkaGetLoEFragment' to the actual logic for determining the current
 -- LoE fragment.
 setGetLoEFragment ::
-     forall m blk. (IOLike m, GetHeader blk)
+     forall m blk. (IOLike m, GetHeader blk, Typeable blk)
   => STM m GSM.GsmState
-  -> STM m (AnchoredFragment (Header blk))
+  -> STM m (AnchoredFragment (HeaderWithTime blk))
      -- ^ The LoE fragment.
   -> StrictTVar m (ChainDB.GetLoEFragment m blk)
   -> m ()

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

@@ -11,6 +11,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Ouroboros.Consensus.NodeKernel (
     -- * Node kernel
@@ -45,6 +46,7 @@ import           Data.List.NonEmpty (NonEmpty)
 import           Data.Map.Strict (Map)
 import           Data.Maybe (isJust, mapMaybe)
 import           Data.Proxy
+import qualified Data.Set as Set
 import qualified Data.Text as Text
 import           Data.Void (Void)
 import           Ouroboros.Consensus.Block hiding (blockMatchesHeader)
@@ -94,6 +96,7 @@ import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (castTip, tipFromHeader)
 import           Ouroboros.Network.BlockFetch
+import qualified Ouroboros.Network.BlockFetch.ClientState as BF
 import           Ouroboros.Network.Diffusion (PublicPeerSelectionState)
 import           Ouroboros.Network.NodeToNode (ConnectionId,
                      MiniProtocolParameters (..))
@@ -131,7 +134,7 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel {
     , getTopLevelConfig       :: TopLevelConfig blk
 
       -- | The fetch client registry, used for the block fetch clients.
-    , getFetchClientRegistry  :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
+    , getFetchClientRegistry  :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m
 
       -- | The fetch mode, used by diffusion.
       --
@@ -254,8 +257,8 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
               , GSM.equivalent                = (==) `on` (AF.headPoint . fst)
               , GSM.getChainSyncStates        = fmap cschState <$> readTVar varChainSyncHandles
               , GSM.getCurrentSelection       = do
-                  headers        <- ChainDB.getCurrentChain  chainDB
-                  extLedgerState <- ChainDB.getCurrentLedger chainDB
+                  headers        <- ChainDB.getCurrentChainWithTime chainDB
+                  extLedgerState <- ChainDB.getCurrentLedger        chainDB
                   return (headers, ledgerState extLedgerState)
               , GSM.minCaughtUpDuration       = gsmMinCaughtUpDuration
               , GSM.setCaughtUpPersistentMark = \upd ->
@@ -309,8 +312,8 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
     -- 'addFetchedBlock' whenever a new block is downloaded.
     void $ forkLinkedThread registry "NodeKernel.blockFetchLogic" $
       blockFetchLogic
-        (blockFetchDecisionTracer tracers)
-        (blockFetchClientTracer   tracers)
+        (contramap (map (fmap (fmap (map castPoint)))) $ blockFetchDecisionTracer tracers)
+        (contramap (fmap castTraceFetchClientState)    $ blockFetchClientTracer   tracers)
         blockFetchInterface
         fetchClientRegistry
         blockFetchConfiguration
@@ -344,6 +347,45 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
           blockForging' <- traverse (forkBlockForging st) blockForging
           go blockForging'
 
+castTraceFetchClientState ::
+     forall blk. HasHeader (Header blk)
+  => TraceFetchClientState (HeaderWithTime blk) -> TraceFetchClientState (Header blk)
+castTraceFetchClientState = mapTraceFetchClientState hwtHeader
+
+mapTraceFetchClientState ::
+     (HeaderHash h1 ~ HeaderHash h2, HasHeader h2)
+  => (h1 -> h2) -> TraceFetchClientState h1 -> TraceFetchClientState h2
+mapTraceFetchClientState fheader = \case
+    AddedFetchRequest request inflight inflightLimits status -> AddedFetchRequest (frequest request) (finflight inflight) inflightLimits (fstatus status)
+
+    AcknowledgedFetchRequest request -> AcknowledgedFetchRequest (frequest request)
+
+    SendFetchRequest headers gsv -> SendFetchRequest (AF.mapAnchoredFragment fheader headers) gsv
+
+    StartedFetchBatch   range inflight inflightLimits status           -> StartedFetchBatch   (frange range) (finflight inflight) inflightLimits (fstatus status)
+    CompletedBlockFetch point inflight inflightLimits status time size -> CompletedBlockFetch (fpoint point) (finflight inflight) inflightLimits (fstatus status) time size
+    CompletedFetchBatch range inflight inflightLimits status           -> CompletedFetchBatch (frange range) (finflight inflight) inflightLimits (fstatus status)
+    RejectedFetchBatch  range inflight inflightLimits status           -> RejectedFetchBatch  (frange range) (finflight inflight) inflightLimits (fstatus status)
+
+    ClientTerminating i -> ClientTerminating i
+  where
+    frequest (BF.FetchRequest headers) = BF.FetchRequest $ map (AF.mapAnchoredFragment fheader) headers
+
+    finflight inflight = inflight { BF.peerFetchBlocksInFlight = fpoints (BF.peerFetchBlocksInFlight inflight) }
+
+    fstatus = \case
+      BF.PeerFetchStatusShutdown          -> BF.PeerFetchStatusShutdown
+      BF.PeerFetchStatusStarting          -> BF.PeerFetchStatusStarting
+      BF.PeerFetchStatusAberrant          -> BF.PeerFetchStatusAberrant
+      BF.PeerFetchStatusBusy              -> BF.PeerFetchStatusBusy
+      BF.PeerFetchStatusReady points idle -> BF.PeerFetchStatusReady (fpoints points) idle
+
+    fpoints = Set.mapMonotonic fpoint
+
+    frange (BF.ChainRange p1 p2) = BF.ChainRange (fpoint p1) (fpoint p2)
+
+    fpoint = castPoint
+
 {-------------------------------------------------------------------------------
   Internal node components
 -------------------------------------------------------------------------------}
@@ -354,8 +396,8 @@ data InternalState m addrNTN addrNTC blk = IS {
     , registry            :: ResourceRegistry m
     , btime               :: BlockchainTime m
     , chainDB             :: ChainDB m blk
-    , blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) blk m
-    , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
+    , blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m
+    , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m
     , varChainSyncHandles :: StrictTVar m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
     , varGsmState         :: StrictTVar m GSM.GsmState
     , mempool             :: Mempool m blk
@@ -394,7 +436,7 @@ initInternalState NodeKernelArgs { tracers, chainDB, registry, cfg
 
     fetchClientRegistry <- newFetchClientRegistry
 
-    let getCandidates :: STM m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
+    let getCandidates :: STM m (Map (ConnectionId addrNTN) (AnchoredFragment (HeaderWithTime blk)))
         getCandidates = viewChainSyncState varChainSyncHandles csCandidate
 
     slotForgeTimeOracle <- BlockFetchClientInterface.initSlotForgeTimeOracle cfg chainDB
@@ -403,7 +445,7 @@ initInternalState NodeKernelArgs { tracers, chainDB, registry, cfg
           (ChainDB.getCurrentChain chainDB)
           getUseBootstrapPeers
           (GSM.gsmStateToLedgerJudgement <$> readTVar varGsmState)
-        blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) blk m
+        blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m
         blockFetchInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface
           (configBlock cfg)
           (BlockFetchClientInterface.defaultChainDbView chainDB)

ouroboros-consensus-diffusion/src/unstable-mock-testlib/Test/ThreadNet/Util/SimpleBlock.hs

@@ -2,7 +2,7 @@
 
 module Test.ThreadNet.Util.SimpleBlock (prop_validSimpleBlock) where
 
-import           Data.Typeable
+import           Data.Typeable (Typeable)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Mock.Ledger
 import           Ouroboros.Consensus.Util.Condense (condense)