Port some code from the UTXO-HD branch to main (#1054)

This is a collection of small tweaks from the UTXO-HD branch. Best
reviewed commit by commit, they are independent.

ouroboros-consensus-cardano/changelog.d/utxo-hd-javier.md

@@ -0,0 +1,3 @@
+### Non-Breaking
+
+- Adapt `QueryLedger` instances to the renaming to `BlockSupportsLedgerQuery`.

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

@@ -200,7 +200,7 @@ instance ApplyBlock (LedgerState ByronBlock) ByronBlock where
 data instance BlockQuery ByronBlock :: Type -> Type where
   GetUpdateInterfaceState :: BlockQuery ByronBlock UPI.State
 
-instance QueryLedger ByronBlock where
+instance BlockSupportsLedgerQuery ByronBlock where
   answerBlockQuery _cfg GetUpdateInterfaceState (ExtLedgerState ledgerState _) =
     CC.cvsUpdateState (byronLedgerState ledgerState)
 

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

@@ -2,13 +2,15 @@
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE GADTs                    #-}
 {-# LANGUAGE PatternSynonyms          #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TypeOperators            #-}
 {-# LANGUAGE ViewPatterns             #-}
 module Ouroboros.Consensus.Cardano.Block (
     -- * Eras
     CardanoEras
   , CardanoShelleyEras
   , module Ouroboros.Consensus.Shelley.Eras
+  , ShelleyBasedLedgerEras
     -- * Block
   , CardanoBlock
     -- Note: by exporting the pattern synonyms as part of the matching data
@@ -66,6 +68,7 @@ module Ouroboros.Consensus.Cardano.Block (
   , EraMismatch (..)
   ) where
 
+import           Data.Kind
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Strict
 import           Ouroboros.Consensus.Block (BlockProtocol)
@@ -94,8 +97,10 @@ import           Ouroboros.Consensus.TypeFamilyWrappers
 -- We parameterise over the crypto used in the post-Byron eras: @c@.
 --
 -- TODO: parameterise ByronBlock over crypto too
+type CardanoEras :: Type -> [Type]
 type CardanoEras c = ByronBlock ': CardanoShelleyEras c
 
+type CardanoShelleyEras :: Type -> [Type]
 type CardanoShelleyEras c =
   '[ ShelleyBlock (TPraos c) (ShelleyEra c)
    , ShelleyBlock (TPraos c) (AllegraEra c)
@@ -105,6 +110,16 @@ type CardanoShelleyEras c =
    , ShelleyBlock (Praos c)  (ConwayEra c)
    ]
 
+type ShelleyBasedLedgerEras :: Type -> [Type]
+type ShelleyBasedLedgerEras c =
+  '[ ShelleyEra c
+   , AllegraEra c
+   , MaryEra c
+   , AlonzoEra c
+   , BabbageEra c
+   , ConwayEra c
+   ]
+
 {-------------------------------------------------------------------------------
   INTERNAL A tag function for each era
 -------------------------------------------------------------------------------}
@@ -200,7 +215,7 @@ pattern TeleConway  byron shelley allegra mary alonzo babbage x = TS byron (TS s
 -- | /The/ Cardano block.
 --
 -- Thanks to the pattern synonyms, you can treat this as a sum type with
--- constructors 'BlockByron' and 'BlockShelley'.
+-- constructors 'BlockByron', 'BlockShelley', etc.
 --
 -- > f :: CardanoBlock c -> _
 -- > f (BlockByron   b) = _

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

@@ -544,7 +544,7 @@ translateValidatedTxShelleyToAllegraWrapper = InjectValidatedTx $
     fmap unComp . eitherToMaybe . runExcept . SL.translateEra () . Comp
 
 {-------------------------------------------------------------------------------
-  Translation from Shelley to Allegra
+  Translation from Allegra to Mary
 -------------------------------------------------------------------------------}
 
 translateLedgerStateAllegraToMaryWrapper ::
@@ -559,10 +559,6 @@ translateLedgerStateAllegraToMaryWrapper =
       Translate $ \_epochNo ->
         unComp . SL.translateEra' () . Comp
 
-{-------------------------------------------------------------------------------
-  Translation from Allegra to Mary
--------------------------------------------------------------------------------}
-
 translateTxAllegraToMaryWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => InjectTx

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

@@ -300,7 +300,8 @@ data instance BlockQuery (ShelleyBlock proto era) :: Type -> Type where
 instance (Typeable era, Typeable proto)
   => ShowProxy (BlockQuery (ShelleyBlock proto era)) where
 
-instance (ShelleyCompatible proto era, ProtoCrypto proto ~ crypto) => QueryLedger (ShelleyBlock proto era) where
+instance (ShelleyCompatible proto era, ProtoCrypto proto ~ crypto)
+      => BlockSupportsLedgerQuery (ShelleyBlock proto era) where
   answerBlockQuery cfg query ext =
       case query of
         GetLedgerTip ->

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

@@ -8,7 +8,6 @@ module Cardano.Tools.DBAnalyser.Run (analyse) where
 import           Cardano.Tools.DBAnalyser.Analysis
 import           Cardano.Tools.DBAnalyser.HasAnalysis
 import           Cardano.Tools.DBAnalyser.Types
-import           Codec.CBOR.Decoding (Decoder)
 import           Codec.Serialise (Serialise (decode))
 import           Control.Monad.Except (runExceptT)
 import           Control.Tracer (Tracer (..), nullTracer)
@@ -26,7 +25,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import           Ouroboros.Consensus.Storage.ChainDB.Impl.Args (fromChainDbArgs)
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import           Ouroboros.Consensus.Storage.LedgerDB (readSnapshot)
-import           Ouroboros.Consensus.Storage.Serialisation (DecodeDisk (..))
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Consensus.Util.Orphans ()
@@ -76,7 +74,7 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
           -- how to do it.
           initLedgerErr <- runExceptT $ case initializeFrom of
             Nothing       -> pure genesisLedger
-            Just snapshot -> readSnapshot ledgerDbFS (decodeExtLedgerState' cfg) decode snapshot
+            Just snapshot -> readSnapshot ledgerDbFS (decodeDiskExtLedgerState $ configCodec cfg) decode snapshot
               -- TODO @readSnapshot@ has type @ExceptT ReadIncrementalErr m
               -- (ExtLedgerState blk)@ but it also throws exceptions! This makes
               -- error handling more challenging than it ought to be. Maybe we
@@ -138,11 +136,3 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
       (_, Just MinimumBlockValidation) -> VolatileDB.NoValidation
       (OnlyValidation, _ )             -> VolatileDB.ValidateAll
       _                                -> VolatileDB.NoValidation
-
-    decodeExtLedgerState' :: forall s . TopLevelConfig blk -> Decoder s (ExtLedgerState blk)
-    decodeExtLedgerState' cfg =
-      let ccfg = configCodec cfg
-      in decodeExtLedgerState
-           (decodeDisk ccfg)
-           (decodeDisk ccfg)
-           (decodeDisk ccfg)

ouroboros-consensus-diffusion/changelog.d/utxo-hd-javier.md

@@ -0,0 +1,3 @@
+### Breaking
+
+- Removed `llrnRunDataDiffusion`'s unused `ResourceRegistry` argument.

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

@@ -109,7 +109,7 @@ mkHandlers ::
      ( IOLike m
      , LedgerSupportsMempool blk
      , LedgerSupportsProtocol blk
-     , QueryLedger blk
+     , BlockSupportsLedgerQuery blk
      , ConfigSupportsNode blk
      )
   => NodeKernelArgs m addrNTN addrNTC blk
@@ -290,7 +290,7 @@ clientCodecs ccfg version networkVersion = Codecs {
     dec = decodeNodeToClient ccfg version
 
 -- | Identity codecs used in tests.
-identityCodecs :: (Monad m, QueryLedger blk)
+identityCodecs :: (Monad m, BlockSupportsLedgerQuery blk)
                => Codecs blk CodecFailure m
                     (AnyMessage (ChainSync (Serialised blk) (Point blk) (Tip blk)))
                     (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))

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

@@ -256,8 +256,7 @@ data LowLevelRunNodeArgs m addrNTN addrNTC versionDataNTN versionDataNTC blk
       --
       -- 'run' will not return before this does.
     , llrnRunDataDiffusion ::
-           ResourceRegistry m
-        -> Diffusion.Applications
+           Diffusion.Applications
              addrNTN NodeToNodeVersion   versionDataNTN
              addrNTC NodeToClientVersion versionDataNTC
              m NodeToNodeInitiatorResult
@@ -491,7 +490,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                                         nodeKernel
                                         peerMetrics
 
-          llrnRunDataDiffusion registry apps appsExtra
+          llrnRunDataDiffusion apps appsExtra
   where
     ProtocolInfo
       { pInfoConfig       = cfg
@@ -937,7 +936,7 @@ stdLowLevelRunNodeArgsIO RunNodeArgs{ rnProtocolInfo
       , llrnCustomiseChainDbArgs = id
       , llrnCustomiseNodeKernelArgs
       , llrnRunDataDiffusion =
-          \_reg apps extraApps ->
+          \apps extraApps ->
             stdRunDataDiffusion srnDiffusionTracers
                                 srnDiffusionTracersExtra
                                 srnDiffusionArguments

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs

@@ -348,7 +348,7 @@ instance ShowQuery (BlockQuery BlockA) where
 data instance BlockQuery BlockA result
   deriving (Show)
 
-instance QueryLedger BlockA where
+instance BlockSupportsLedgerQuery BlockA where
   answerBlockQuery _ qry = case qry of {}
 
 instance SameDepIndex (BlockQuery BlockA) where

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs

@@ -284,7 +284,7 @@ instance ShowQuery (BlockQuery BlockB) where
 data instance BlockQuery BlockB result
   deriving (Show)
 
-instance QueryLedger BlockB where
+instance BlockSupportsLedgerQuery BlockB where
   answerBlockQuery _ qry = case qry of {}
 
 instance SameDepIndex (BlockQuery BlockB) where

ouroboros-consensus/changelog.d/utxo-hd-javier.md

@@ -0,0 +1,24 @@
+### Breaking
+
+- Renamed `QueryLedger` class to `BlockSupportsLedgerQuery`.
+- `StreamAPI` was moved to the new `Ouroboros.Consensus.Storage.ImmutableDB.Stream` module.
+   - A `StreamAPI` now can stream specific block components.
+   - `NextBlock` was renamed to `NextItem`.
+- Removed unused `Ouroboros.Consensus.Util.TraceSize`.
+- Removed unused `assertEqWithMessage` function.
+- `Mempool.removeTxs` now expects a `NonEmpty (GenTxId blk)` as an argument.
+- VolatileDB traces were tweaked
+    - `VolatileDB.OpenedVolatileDB` trace message now includes the maximum slot seen.
+    - Added `VolatileDB.ClosedDB`.
+- Deleted `Ouroboros.Consensus.Util.Some` in favour of `Ouroboros.Network.Protocol.LocalStateQuery.Codec.Some`.
+
+### Non-Breaking
+
+- Provide `NoThunks` instances for:
+  - `Sum a`,
+  - `RAWLock m st`,
+  - `StrictTVar (WithEarlyExit m) a`,
+  - `StrictSVar (WithEarlyExit m) a`
+- Added `Complete` and `Incomplete` type aliases for arguments.
+- Implement `HTrans` instance for `HardForkState`
+- `SomeSecond` became poly-kinded.

ouroboros-consensus/ouroboros-consensus.cabal

@@ -220,13 +220,13 @@ library
     Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types
     Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util
     Ouroboros.Consensus.Storage.ImmutableDB.Impl.Validation
+    Ouroboros.Consensus.Storage.ImmutableDB.Stream
     Ouroboros.Consensus.Storage.LedgerDB
     Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
     Ouroboros.Consensus.Storage.LedgerDB.Init
     Ouroboros.Consensus.Storage.LedgerDB.LedgerDB
     Ouroboros.Consensus.Storage.LedgerDB.Query
     Ouroboros.Consensus.Storage.LedgerDB.Snapshots
-    Ouroboros.Consensus.Storage.LedgerDB.Stream
     Ouroboros.Consensus.Storage.LedgerDB.Update
     Ouroboros.Consensus.Storage.Serialisation
     Ouroboros.Consensus.Storage.VolatileDB
@@ -264,7 +264,6 @@ library
     Ouroboros.Consensus.Util.ResourceRegistry
     Ouroboros.Consensus.Util.STM
     Ouroboros.Consensus.Util.Time
-    Ouroboros.Consensus.Util.TraceSize
     Ouroboros.Consensus.Util.Versioned
 
   build-depends:
@@ -468,6 +467,7 @@ library unstable-mock-block
     ouroboros-network-api,
     ouroboros-network-mock,
     serialise,
+    text,
     time,
     unstable-consensus-testlib,
 

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs

@@ -86,12 +86,15 @@ blockRealPoint blk = RealPoint s h
   where
     HeaderFields { headerFieldSlot = s, headerFieldHash = h } = getHeaderFields blk
 
-#if __GLASGOW_HASKELL__ >= 906
-headerRealPoint :: (HasHeader blk, HasHeader (Header blk)) => Header blk -> RealPoint blk
-#else
--- GHC 9.6 considiers these constraints insufficient.
-headerRealPoint :: HasHeader (Header blk) => Header blk -> RealPoint blk
+headerRealPoint ::
+    ( HasHeader (Header blk)
+#if __GLASGOW_HASKELL__ >= 904
+-- GHC 9.4+ considers these constraints insufficient.
+    , HasHeader blk
 #endif
+    )
+    => Header blk
+    -> RealPoint blk
 headerRealPoint hdr = RealPoint s h
   where
     HeaderFields { headerFieldSlot = s, headerFieldHash = h } = getHeaderFields hdr

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs

@@ -57,7 +57,7 @@ class ( LedgerSupportsProtocol blk
       , InspectLedger blk
       , LedgerSupportsMempool blk
       , ConvertRawTxId (GenTx blk)
-      , QueryLedger blk
+      , BlockSupportsLedgerQuery blk
       , HasPartialConsensusConfig (BlockProtocol blk)
       , HasPartialLedgerConfig blk
       , ConvertRawHash blk

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs

@@ -112,7 +112,7 @@ data instance BlockQuery (HardForkBlock xs) :: Type -> Type where
     => QueryHardFork (x ': xs) result
     -> BlockQuery (HardForkBlock (x ': xs)) result
 
-instance All SingleEraBlock xs => QueryLedger (HardForkBlock xs) where
+instance All SingleEraBlock xs => BlockSupportsLedgerQuery (HardForkBlock xs) where
   answerBlockQuery
     (ExtLedgerCfg cfg)
     query

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Instances.hs

@@ -2,11 +2,14 @@
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE InstanceSigs          #-}
 {-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE StandaloneDeriving    #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
@@ -25,6 +28,7 @@ import           Cardano.Binary (enforceSize)
 import           Codec.CBOR.Decoding (Decoder)
 import           Codec.CBOR.Encoding (Encoding, encodeListLen)
 import           Codec.Serialise
+import           Data.Coerce
 import           Data.Proxy
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Constraint
@@ -62,6 +66,22 @@ instance HSequence HardForkState where
 instance HCollapse HardForkState where
   hcollapse = hcollapse . hmap currentState . Telescope.tip . getHardForkState
 
+instance HTrans HardForkState HardForkState where
+  htrans p t (HardForkState st) = HardForkState $
+      htrans p (\(Current b fx) -> Current b $ t fx) st
+
+  hcoerce ::
+       forall f g xs ys. AllZipN (Prod HardForkState) (LiftedCoercible f g) xs ys
+    => HardForkState f xs
+    -> HardForkState g ys
+  hcoerce (HardForkState st) = HardForkState $
+      htrans
+        (Proxy @(LiftedCoercible f g))
+        (\(Current b fx) -> Current b $ coerce fx)
+        st
+
+type instance Same HardForkState = HardForkState
+
 {-------------------------------------------------------------------------------
   Eq, Show, NoThunks
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs

@@ -10,6 +10,10 @@
 {-# LANGUAGE UndecidableInstances  #-}
 
 -- | Interface to the ledger layer
+--
+-- This module defines how to apply blocks to a ledger state, and re-exports
+-- (from "Ouroboros.Consensus.Ledger.Basics") how to tick ledger states. These
+-- are the two main operations we can do with a 'LedgerState'.
 module Ouroboros.Consensus.Ledger.Abstract (
     -- * Type-level validation marker
     Validated
@@ -79,7 +83,7 @@ class ( IsLedger l
 
   -- | Apply a block to the ledger state.
   --
-  -- This is passed the ledger state ticked with the slot of the given block, so
+  -- This is passed the ledger state ticked to the slot of the given block, so
   -- 'applyChainTickLedgerResult' has already been called.
   applyBlockLedgerResult ::
        HasCallStack