Add an extra header parameter to BlockFetchConsensusInterface

This parameter is currently called `selectionHeader`. This change
allow us to use two header types in the interface. The `header` type,
now is intended to convey additional information, in particular the
slot time at which the header was downloaded. In this way we can
address [this
issue](IntersectMBO/ouroboros-consensus#1301)
which allow us to simplify Consensus time conversions. Additionally,
this change will enable us to remove `FromConsensus` data and
the precondition of `headerForgeUTCTime`.

The `selectionHeader` type will typically denote a raw header.

ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs

@@ -47,7 +47,8 @@ data FetchMode =
 --
 -- These are provided as input to the block fetch by the consensus layer.
 --
-data BlockFetchConsensusInterface peer header block m =
+-- REVIEW: Explain why we have two types of headers.
+data BlockFetchConsensusInterface peer selectionHeader header block m =
      BlockFetchConsensusInterface {
 
        -- | Read the K-suffixes of the candidate chains.
@@ -63,7 +64,7 @@ data BlockFetchConsensusInterface peer header block m =
        -- This must contain info on the last @K@ blocks (unless we're near
        -- the chain genesis of course).
        --
-       readCurrentChain       :: STM m (AnchoredFragment header),
+       readCurrentChain       :: STM m (AnchoredFragment selectionHeader),
 
        -- | Read the current fetch mode that the block fetch logic should use.
        --
@@ -105,7 +106,7 @@ data BlockFetchConsensusInterface peer header block m =
        -- we would consider a chain of equal length to the current chain.
        --
        plausibleCandidateChain :: HasCallStack
-                               => AnchoredFragment header
+                               => AnchoredFragment selectionHeader
                                -> AnchoredFragment header -> Bool,
 
        -- | Compare two candidate chains and return a preference ordering.

ouroboros-network/demo/chain-sync.hs

@@ -418,7 +418,7 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do
                                     nullTracer clientCtx)
 
         blockFetchPolicy :: BlockFetchConsensusInterface
-                             LocalConnectionId BlockHeader Block IO
+                             LocalConnectionId BlockHeader BlockHeader Block IO
         blockFetchPolicy =
             BlockFetchConsensusInterface {
               readCandidateChains    = readTVar candidateChainsVar

ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs

@@ -272,7 +272,7 @@ sampleBlockFetchPolicy1 :: (MonadSTM m, HasHeader header, HasHeader block)
                         -> TestFetchedBlockHeap m block
                         -> AnchoredFragment header
                         -> Map peer (AnchoredFragment header)
-                        -> BlockFetchConsensusInterface peer header block m
+                        -> BlockFetchConsensusInterface peer header header block m
 sampleBlockFetchPolicy1 headerFieldsForgeUTCTime blockHeap currentChain candidateChains =
     BlockFetchConsensusInterface {
       readCandidateChains    = return candidateChains,

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs

@@ -298,7 +298,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch =
         })
 
     blockFetchPolicy :: NodeKernel BlockHeader Block s m
-                     -> BlockFetchConsensusInterface NtNAddr BlockHeader Block m
+                     -> BlockFetchConsensusInterface NtNAddr BlockHeader BlockHeader Block m
     blockFetchPolicy nodeKernel =
         BlockFetchConsensusInterface {
           readCandidateChains    = readTVar (nkClientChains nodeKernel)

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

@@ -152,9 +152,11 @@ data BlockFetchConfiguration =
 --
 -- This runs forever and should be shut down using mechanisms such as async.
 --
-blockFetchLogic :: forall addr header block m.
-                   ( HasHeader header
+blockFetchLogic :: forall addr selectionHeader header block m.
+                   ( HasHeader selectionHeader
+                   , HasHeader header
                    , HasHeader block
+                   , HeaderHash selectionHeader ~ HeaderHash block
                    , HeaderHash header ~ HeaderHash block
                    , MonadDelay m
                    , MonadSTM m
@@ -163,7 +165,7 @@ blockFetchLogic :: forall addr header block m.
                    )
                 => Tracer m [TraceLabelPeer addr (FetchDecision [Point header])]
                 -> Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
-                -> BlockFetchConsensusInterface addr header block m
+                -> BlockFetchConsensusInterface addr selectionHeader header block m
                 -> FetchClientRegistry addr header block m
                 -> BlockFetchConfiguration
                 -> m Void
@@ -190,7 +192,7 @@ blockFetchLogic decisionTracer clientStateTracer
           blockForgeUTCTime
         }
 
-    fetchDecisionPolicy :: FetchDecisionPolicy header
+    fetchDecisionPolicy :: FetchDecisionPolicy selectionHeader header
     fetchDecisionPolicy =
       FetchDecisionPolicy {
         maxInFlightReqsPerPeer   = bfcMaxRequestsInflight,
@@ -204,7 +206,7 @@ blockFetchLogic decisionTracer clientStateTracer
         blockFetchSize
       }
 
-    fetchTriggerVariables :: FetchTriggerVariables addr header m
+    fetchTriggerVariables :: FetchTriggerVariables addr selectionHeader header m
     fetchTriggerVariables =
       FetchTriggerVariables {
         readStateCurrentChain    = readCurrentChain,

ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs

@@ -50,7 +50,7 @@ import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..),
            estimateResponseDeadlineProbability)
 
 
-data FetchDecisionPolicy header = FetchDecisionPolicy {
+data FetchDecisionPolicy selectionHeader header = FetchDecisionPolicy {
        maxInFlightReqsPerPeer  :: Word,  -- A protocol constant.
 
        maxConcurrencyBulkSync  :: Word,
@@ -59,7 +59,7 @@ data FetchDecisionPolicy header = FetchDecisionPolicy {
        peerSalt                :: Int,
 
        plausibleCandidateChain :: HasCallStack
-                               => AnchoredFragment header
+                               => AnchoredFragment selectionHeader
                                -> AnchoredFragment header -> Bool,
 
        compareCandidateChains  :: HasCallStack
@@ -251,10 +251,13 @@ fetchDecisions
   :: (Ord peer,
       Hashable peer,
       HasHeader header,
-      HeaderHash header ~ HeaderHash block)
-  => FetchDecisionPolicy header
+      HeaderHash header ~ HeaderHash block,
+      HeaderHash selectionHeader ~ HeaderHash block,
+      HasHeader selectionHeader
+     )
+  => FetchDecisionPolicy selectionHeader header
   -> FetchMode
-  -> AnchoredFragment header
+  -> AnchoredFragment selectionHeader
   -> (Point block -> Bool)
   -> MaxSlotNo
   -> [(AnchoredFragment header, PeerInfo header peer extra)]
@@ -399,8 +402,8 @@ current chain. So our first task is to filter down to this set.
 -- the current chain.
 --
 filterPlausibleCandidates
-  :: (AnchoredFragment block -> AnchoredFragment header -> Bool)
-  -> AnchoredFragment block  -- ^ The current chain
+  :: (AnchoredFragment selectionHeader -> AnchoredFragment header -> Bool)
+  -> AnchoredFragment selectionHeader  -- ^ The current chain
   -> [(AnchoredFragment header, peerinfo)]
   -> [(FetchDecision (AnchoredFragment header), peerinfo)]
 filterPlausibleCandidates plausibleCandidateChain currentChain chains =
@@ -507,11 +510,11 @@ interested in this candidate at all.
 -- current chain.
 --
 chainForkSuffix
-  :: (HasHeader header, HasHeader block,
-      HeaderHash header ~ HeaderHash block)
-  => AnchoredFragment block  -- ^ Current chain.
-  -> AnchoredFragment header -- ^ Candidate chain
-  -> Maybe (ChainSuffix header)
+  :: (HasHeader header1, HasHeader header2,
+      HeaderHash header1 ~ HeaderHash header2)
+  => AnchoredFragment header2 -- ^ Current chain.
+  -> AnchoredFragment header1 -- ^ Candidate chain
+  -> Maybe (ChainSuffix header1)
 chainForkSuffix current candidate =
     case AF.intersect current candidate of
       Nothing                         -> Nothing
@@ -523,9 +526,9 @@ chainForkSuffix current candidate =
         Just (ChainSuffix candidateSuffix)
 
 selectForkSuffixes
-  :: (HasHeader header, HasHeader block,
-      HeaderHash header ~ HeaderHash block)
-  => AnchoredFragment block
+  :: (HasHeader selectionHeader, HasHeader header,
+      HeaderHash selectionHeader ~ HeaderHash header)
+  => AnchoredFragment selectionHeader
   -> [(FetchDecision (AnchoredFragment header), peerinfo)]
   -> [(FetchDecision (ChainSuffix      header), peerinfo)]
 selectForkSuffixes current chains =
@@ -889,12 +892,12 @@ obviously take that into account when considering later peer chains.
 
 
 fetchRequestDecisions
-  :: forall extra header peer.
+  :: forall extra selectionHeader header peer.
       ( Hashable peer
       , HasHeader header
       , Ord peer
       )
-  => FetchDecisionPolicy header
+  => FetchDecisionPolicy selectionHeader header
   -> FetchMode
   -> [( FetchDecision [AnchoredFragment header]
       , PeerFetchStatus header
@@ -1009,7 +1012,7 @@ fetchRequestDecisions fetchDecisionPolicy fetchMode chains =
 
 fetchRequestDecision
   :: HasHeader header
-  => FetchDecisionPolicy header
+  => FetchDecisionPolicy selectionHeader header
   -> FetchMode
   -> Word
   -> PeerFetchInFlightLimits

ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs

@@ -45,18 +45,20 @@ import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..))
 
 
 fetchLogicIterations
-  :: ( HasHeader header
+  :: ( HasHeader selectionHeader
      , HasHeader block
+     , HeaderHash selectionHeader ~ HeaderHash block
      , HeaderHash header ~ HeaderHash block
+     , HasHeader header
      , MonadDelay m
      , MonadSTM m
      , Ord peer
      , Hashable peer
      )
   => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
   -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-  -> FetchDecisionPolicy header
-  -> FetchTriggerVariables peer header m
+  -> FetchDecisionPolicy selectionHeader header
+  -> FetchTriggerVariables peer selectionHeader header m
   -> FetchNonTriggerVariables peer header block m
   -> m Void
 fetchLogicIterations decisionTracer clientStateTracer
@@ -98,12 +100,15 @@ iterateForever x0 m = go x0 where go x = m x >>= go
 --
 fetchLogicIteration
   :: (Hashable peer, MonadSTM m, Ord peer,
-      HasHeader header, HasHeader block,
-      HeaderHash header ~ HeaderHash block)
+      HeaderHash header ~ HeaderHash block,
+      HasHeader header,
+      HasHeader selectionHeader, HasHeader block,
+      HeaderHash selectionHeader ~ HeaderHash block
+     )
   => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
   -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-  -> FetchDecisionPolicy header
-  -> FetchTriggerVariables peer header m
+  -> FetchDecisionPolicy selectionHeader header
+  -> FetchTriggerVariables peer selectionHeader header m
   -> FetchNonTriggerVariables peer header block m
   -> FetchStateFingerprint peer header block
   -> m (FetchStateFingerprint peer header block)
@@ -163,11 +168,13 @@ fetchLogicIteration decisionTracer clientStateTracer
 --
 fetchDecisionsForStateSnapshot
   :: (HasHeader header,
+      HasHeader selectionHeader,
+      HeaderHash selectionHeader ~ HeaderHash block,
       HeaderHash header ~ HeaderHash block,
       Ord peer,
       Hashable peer)
-  => FetchDecisionPolicy header
-  -> FetchStateSnapshot peer header block m
+  => FetchDecisionPolicy selectionHeader header
+  -> FetchStateSnapshot peer selectionHeader header block m
   -> [( FetchDecision (FetchRequest header),
         PeerInfo header peer (FetchClientStateVars m header, peer)
       )]
@@ -213,7 +220,7 @@ fetchDecisionsForStateSnapshot
 --
 fetchLogicIterationAct :: (MonadSTM m, HasHeader header)
                        => Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-                       -> FetchDecisionPolicy header
+                       -> FetchDecisionPolicy selectionHeader header
                        -> [(FetchDecision (FetchRequest header),
                             PeerGSV,
                             FetchClientStateVars m header,
@@ -240,8 +247,8 @@ fetchLogicIterationAct clientStateTracer FetchDecisionPolicy{blockFetchSize}
 -- and it is not necessary to determine exactly what changed, just that there
 -- was some change.
 --
-data FetchTriggerVariables peer header m = FetchTriggerVariables {
-       readStateCurrentChain    :: STM m (AnchoredFragment header),
+data FetchTriggerVariables peer selectionHeader header m = FetchTriggerVariables {
+       readStateCurrentChain    :: STM m (AnchoredFragment selectionHeader),
        readStateCandidateChains :: STM m (Map peer (AnchoredFragment header)),
        readStatePeerStatus      :: STM m (Map peer (PeerFetchStatus header))
      }
@@ -289,8 +296,8 @@ updateFetchStateFingerprintPeerStatus statuses'
 -- Note that the domain of 'fetchStatePeerChains' is a subset of the domain
 -- of 'fetchStatePeerStates' and 'fetchStatePeerReqVars'.
 --
-data FetchStateSnapshot peer header block m = FetchStateSnapshot {
-       fetchStateCurrentChain     :: AnchoredFragment header,
+data FetchStateSnapshot peer selectionHeader header block m = FetchStateSnapshot {
+       fetchStateCurrentChain     :: AnchoredFragment selectionHeader,
        fetchStatePeerChains       :: Map peer (AnchoredFragment header),
        fetchStatePeerStates       :: Map peer (PeerFetchStatus   header,
                                                PeerFetchInFlight header,
@@ -302,12 +309,14 @@ data FetchStateSnapshot peer header block m = FetchStateSnapshot {
      }
 
 readStateVariables :: (MonadSTM m, Eq peer,
-                       HasHeader header, HasHeader block,
-                       HeaderHash header ~ HeaderHash block)
-                   => FetchTriggerVariables peer header m
+                       HasHeader selectionHeader, HasHeader block,
+                       HeaderHash selectionHeader ~ HeaderHash block,
+                       HasHeader header
+                      )
+                   => FetchTriggerVariables peer selectionHeader header m
                    -> FetchNonTriggerVariables peer header block m
                    -> FetchStateFingerprint peer header block
-                   -> STM m (FetchStateSnapshot peer header block m,
+                   -> STM m (FetchStateSnapshot peer selectionHeader header block m,
                              FetchStateFingerprint peer header block)
 readStateVariables FetchTriggerVariables{..}
                    FetchNonTriggerVariables{..}