fully squashed HeaderWithTime PR, from 3ea291c

docs/website/contents/for-developers/AbstractProtocol.md

@@ -169,12 +169,11 @@ Classes connected to headers and blocks:
  class (StandardHash blk, Typeable blk) => HasHeader blk where -- abstract over block headers
    getHeaderFields :: blk → HeaderFields blk    -- i.e., return three fields: slot, blockno, hash
 
- class HasHeader (Header blk) => GetHeader blk where
-   getHeader          :: blk → Header blk             -- extract header from the block
+ class HasHeader (Header blk) => BlockSupportsHeader blk where
    blockMatchesHeader :: Header blk → blk → Bool      -- check if the header is the header of the block
    headerIsEBB        :: Header blk → Maybe EpochNo   -- when the header of an Epoch Boundary Block (EBB), ...
 
- class (HasHeader blk, GetHeader blk) => GetPrevHash blk where
+ class (HasHeader blk, BlockSupportsHeader blk) => GetPrevHash blk where
    headerPrevHash :: Header blk → ChainHash blk       -- get the hash of predecessor
 
  -- construct the two views on block 'b' required by protocol 'p'
@@ -278,8 +277,8 @@ blockNo = headerFieldBlockNo . getHeaderFields
    -  `p` in place of `BlockProtocol blk`
    -  `cds` in place of `ChainDepState p`
 
-- `a ───(X :: A→B)───▶ b` should be interpreted as `type family X A :: B` or 
-  `data family X A :: B`, where `a` and `b` are typical names for the type 
+- `a ───(X :: A→B)───▶ b` should be interpreted as `type family X A :: B` or
+  `data family X A :: B`, where `a` and `b` are typical names for the type
   family's index and result, respectively.
 
 - To reduce the "noise", these type-class constraints are being ignored:

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Block.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -132,7 +133,7 @@ data instance Header ByronBlock = ByronHeader {
     }
   deriving (Eq, Show, Generic)
 
-instance GetHeader ByronBlock where
+instance GetHeader ByronBlock ByronBlock where
   getHeader ByronBlock{..} = ByronHeader {
         byronHeaderRaw           = CC.abobHdrFromBlock byronBlockRaw
       , byronHeaderSlotNo        = byronBlockSlotNo
@@ -153,6 +154,7 @@ instance GetHeader ByronBlock where
       -- Which is 7 bytes, enough for up to 4294967295 bytes.
       overhead = 7 {- CBOR-in-CBOR -} + 2 {- EBB tag -}
 
+instance BlockSupportsHeader ByronBlock where
   -- Check if a block matches its header
   --
   -- Note that we cannot check this for an EBB, as the EBB header doesn't

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/Ledger/Block.hs

@@ -15,7 +15,7 @@
 {-# LANGUAGE UndecidableSuperClasses #-}
 
 module Ouroboros.Consensus.Shelley.Ledger.Block (
-    GetHeader (..)
+    BlockSupportsHeader (..)
   , Header (..)
   , IsShelleyBlock
   , NestedCtxt_ (..)
@@ -166,12 +166,14 @@ deriving instance ShelleyCompatible proto era => NoThunks (Header (ShelleyBlock
 instance (Typeable era, Typeable proto)
   => ShowProxy (Header (ShelleyBlock proto era)) where
 
-instance ShelleyCompatible proto era => GetHeader (ShelleyBlock proto era) where
+instance ShelleyCompatible proto era
+  => GetHeader (ShelleyBlock proto era) (ShelleyBlock proto era) where
   getHeader (ShelleyBlock rawBlk hdrHash) = ShelleyHeader {
       shelleyHeaderRaw  = SL.bheader rawBlk
     , shelleyHeaderHash = hdrHash
     }
 
+instance ShelleyCompatible proto era => BlockSupportsHeader (ShelleyBlock proto era) where
   blockMatchesHeader hdr blk =
       -- Compute the hash the body of the block (the transactions) and compare
       -- that against the hash of the body stored in the header.

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-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Block.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -41,7 +42,7 @@ data ByronSpecBlock = ByronSpecBlock {
   deriving (Show, Eq, Generic, Serialise)
 
 {-------------------------------------------------------------------------------
-  GetHeader
+  BlockSupportsHeader
 -------------------------------------------------------------------------------}
 
 data instance Header ByronSpecBlock = ByronSpecHeader {
@@ -51,13 +52,14 @@ data instance Header ByronSpecBlock = ByronSpecHeader {
     }
   deriving (Show, Eq, Generic, Serialise)
 
-instance GetHeader ByronSpecBlock where
+instance GetHeader ByronSpecBlock ByronSpecBlock where
   getHeader ByronSpecBlock{..} = ByronSpecHeader {
         byronSpecHeader     = Spec._bHeader byronSpecBlock
       , byronSpecHeaderNo   = byronSpecBlockNo
       , byronSpecHeaderHash = byronSpecBlockHash
       }
 
+instance BlockSupportsHeader ByronSpecBlock where
   -- We don't care about integrity checks, so we don't bother checking whether
   -- the hashes of the body are correct
   blockMatchesHeader hdr blk = blockHash hdr == blockHash blk

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs

@@ -111,7 +111,7 @@ instance Arbitrary (Coherent (CardanoBlock MockCryptoCompatByron)) where
       mk f = K $ Just $ f . getCoherent <$> arbitrary
 
 instance Arbitrary (CardanoHeader MockCryptoCompatByron) where
-  arbitrary = getHeader <$> arbitrary
+  arbitrary = getHeader <$> (arbitrary :: Gen (CardanoBlock MockCryptoCompatByron))
 
 instance (CanMock (TPraos c) (ShelleyEra c), CardanoHardForkConstraints c)
       => Arbitrary (OneEraHash (CardanoEras c)) where

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/HasAnalysis.hs

@@ -27,7 +27,7 @@ data WithLedgerState blk = WithLedgerState
   , wlsStateAfter  :: LedgerState blk
   }
 
-class (HasAnnTip blk, GetPrevHash blk, Condense (HeaderHash blk)) => HasAnalysis blk where
+class (HasAnnTip blk, GetPrevHash blk, BlockSupportsHeader blk, Condense (HeaderHash blk)) => HasAnalysis blk where
 
   countTxOutputs :: blk -> Int
   blockTxSizes   :: blk -> [SizeInBytes]

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs

@@ -203,7 +203,7 @@ blockContextFromPrevHeader hdr =
 -- current slot, ChainDB chain fragment, and ChainDB tip block number
 mkCurrentBlockContext ::
      forall blk.
-     ( GetHeader blk
+     ( BlockSupportsHeader blk
      , BasicEnvelopeValidation blk )
   => SlotNo
   -> AnchoredFragment (Header blk)

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs

@@ -70,7 +70,7 @@ serve sockAddr application = withIOManager \iocp -> do
 
 run ::
      forall blk.
-     ( GetPrevHash blk
+     ( BlockSupportsHeader blk
      , ShowProxy blk
      , SupportedNetworkProtocolVersion blk
      , SerialiseNodeToNodeConstraints blk

ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs

@@ -114,7 +114,7 @@ instance (CanMock (Praos crypto) era, crypto ~ EraCrypto era)
 
 instance (CanMock (TPraos crypto) era, crypto ~ EraCrypto era)
   => Arbitrary (Header (ShelleyBlock (TPraos crypto) era)) where
-  arbitrary = getHeader <$> arbitrary
+  arbitrary = getHeader <$> (arbitrary :: Gen (ShelleyBlock (TPraos crypto) era))
 
 instance (CanMock (Praos crypto) era, crypto ~ EraCrypto era)
   => Arbitrary (Header (ShelleyBlock (Praos crypto) era)) where

ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Serialisation.hs

@@ -11,6 +11,7 @@ import qualified Data.ByteString.Lazy as Lazy
 import           Data.Constraint
 import           Data.Proxy (Proxy (..))
 import           Data.Word (Word64)
+import           Ouroboros.Consensus.Block.Abstract (getHeader)
 import           Ouroboros.Consensus.Protocol.TPraos (TPraos)
 import           Ouroboros.Consensus.Shelley.HFEras ()
 import           Ouroboros.Consensus.Shelley.Ledger

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

@@ -20,6 +20,7 @@ module Ouroboros.Consensus.Node.Genesis (
 import           Control.Monad (join)
 import           Data.Traversable (for)
 import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (CSJConfig (..), CSJEnabledConfig (..),
                      ChainSyncLoPBucketConfig (..),
@@ -89,7 +90,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, BlockSupportsHeader blk)
   => GenesisConfig
   -> m ( GenesisNodeKernelArgs m blk
        , Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
@@ -113,9 +114,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, BlockSupportsHeader 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/Consensus/Ledger/Mock/Generators.hs

@@ -82,7 +82,7 @@ instance (SimpleCrypto c, Arbitrary ext, Serialise ext)
 
 instance (SimpleCrypto c, Arbitrary ext, Serialise ext, Typeable ext)
       => Arbitrary (Header (SimpleBlock c ext)) where
-  arbitrary = getHeader <$> arbitrary
+  arbitrary = getHeader <$> (arbitrary :: Gen (SimpleBlock c ext))
 
 instance (HashAlgorithm (SimpleHash c), Arbitrary ext, Serialise ext)
       => Arbitrary (SimpleStdHeader c ext) where

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

@@ -2,14 +2,13 @@
 
 module Test.ThreadNet.Util.SimpleBlock (prop_validSimpleBlock) where
 
-import           Data.Typeable
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Mock.Ledger
 import           Ouroboros.Consensus.Util.Condense (condense)
 import           Test.QuickCheck
 
 prop_validSimpleBlock
-  :: (SimpleCrypto c, Typeable ext, Typeable ext')
+  :: (GetPrevHash (SimpleBlock' c ext ext'))
   => SimpleBlock' c ext ext' -> Property
 prop_validSimpleBlock blk = conjoin $ map each $ simpleTxs $ simpleBody blk
   where