diff --git a/ouroboros-consensus-cardano/changelog.d/utxo-hd-javier.md b/ouroboros-consensus-cardano/changelog.d/utxo-hd-javier.md new file mode 100644 index 0000000000..e295ba9218 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/utxo-hd-javier.md @@ -0,0 +1,3 @@ +### Non-Breaking + +- Adapt `QueryLedger` instances to the renaming to `BlockSupportsLedgerQuery`. diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index 338503359c..ac5062ceed 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/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) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs index 0a17eefca1..f8e9ffbcad 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Ouroboros.Consensus.Cardano.Block ( @@ -9,6 +10,7 @@ module Ouroboros.Consensus.Cardano.Block ( 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) = _ diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index c90dd6ec86..50c8731923 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ 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 diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index 7b5daad9f6..def3c190a1 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/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 -> diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index 9dc848d0f8..5f45c342d6 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/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) diff --git a/ouroboros-consensus-diffusion/changelog.d/utxo-hd-javier.md b/ouroboros-consensus-diffusion/changelog.d/utxo-hd-javier.md new file mode 100644 index 0000000000..174795fb82 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/utxo-hd-javier.md @@ -0,0 +1,3 @@ +### Breaking + +- Removed `llrnRunDataDiffusion`'s unused `ResourceRegistry` argument. diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs index ebf4babd2e..5ccf59049a 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs +++ b/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))) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index ea295b551f..f42484a59f 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/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 diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 74d023bb16..ea1ebf96fe 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/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 diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 2604836127..6c37dc2c84 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/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 diff --git a/ouroboros-consensus/changelog.d/utxo-hd-javier.md b/ouroboros-consensus/changelog.d/utxo-hd-javier.md new file mode 100644 index 0000000000..94d86dd990 --- /dev/null +++ b/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. diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index bf9ce1a1a2..a4596fbf15 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/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, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs index b802ca90c1..cb264a732c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs +++ b/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 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs index e0a949448a..1fe146150a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs +++ b/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 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs index 1ce3e5f6c5..4e404949e5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs +++ b/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 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Instances.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Instances.hs index 382f4a665d..00b58f0b17 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Instances.hs +++ b/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 -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs index 51708f2d60..25bb3d7f9a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/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 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs index 84f0a6d728..d4e2975cd6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs @@ -45,7 +45,7 @@ import Ouroboros.Consensus.Util ((..:)) class GetTip l where -- | Point of the most recently applied block -- - -- Should be 'genesisPoint' when no blocks have been applied yet + -- Should be 'GenesisPoint' when no blocks have been applied yet getTip :: l -> Point l type instance HeaderHash (Ticked l) = HeaderHash l @@ -98,6 +98,8 @@ pureLedgerResult a = LedgerResult { -------------------------------------------------------------------------------} -- | Static environment required for the ledger +-- +-- Types that inhabit this family will come from the Ledger code. type family LedgerCfg l :: Type class ( -- Requirements on the ledger state itself @@ -172,6 +174,17 @@ applyChainTick = lrResult ..: applyChainTickLedgerResult -------------------------------------------------------------------------------} -- | Ledger state associated with a block +-- +-- This is the Consensus notion of a /ledger state/. Each block type is +-- associated with one of the Ledger types for the /ledger state/. Virtually +-- every concept in this codebase revolves around this type, or the referenced +-- @blk@. Whenever we use the type variable @l@, we intend to denote that the +-- expected instantiation is either a 'LedgerState' or some wrapper over it +-- (like the 'Ouroboros.Consensus.Ledger.Extended.ExtLedgerState'). +-- +-- The main operations we can do with a 'LedgerState' are /ticking/ (defined in +-- 'IsLedger'), and /applying a block/ (defined in +-- 'Ouroboros.Consensus.Ledger.Abstract.ApplyBlock'). data family LedgerState blk :: Type type instance HeaderHash (LedgerState blk) = HeaderHash blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index 9d1e4a7ef8..ffd59bbbcd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -502,7 +502,7 @@ instance (Typeable m, Typeable a) => ShowProxy (BlockQuery (DualBlock m a)) where -- | Not used in the tests: no constructors -instance Bridge m a => QueryLedger (DualBlock m a) where +instance Bridge m a => BlockSupportsLedgerQuery (DualBlock m a) where answerBlockQuery _ = \case {} instance SameDepIndex (BlockQuery (DualBlock m a)) where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 69a6361498..d234790221 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -20,7 +20,9 @@ module Ouroboros.Consensus.Ledger.Extended ( , ExtLedgerState (..) , ExtValidationError (..) -- * Serialisation + , decodeDiskExtLedgerState , decodeExtLedgerState + , encodeDiskExtLedgerState , encodeExtLedgerState -- * Casts , castExtLedgerState @@ -43,6 +45,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Storage.Serialisation {------------------------------------------------------------------------------- Extended ledger state @@ -194,6 +197,19 @@ encodeExtLedgerState encodeLedgerState encodeChainDepState encodeAnnTip +encodeDiskExtLedgerState :: + forall blk. + (EncodeDisk blk (LedgerState blk), + EncodeDisk blk (ChainDepState (BlockProtocol blk)), + EncodeDisk blk (AnnTip blk) + ) + => (CodecConfig blk -> ExtLedgerState blk -> Encoding) +encodeDiskExtLedgerState cfg = + encodeExtLedgerState + (encodeDisk cfg) + (encodeDisk cfg) + (encodeDisk cfg) + decodeExtLedgerState :: (forall s. Decoder s (LedgerState blk)) -> (forall s. Decoder s (ChainDepState (BlockProtocol blk))) -> (forall s. Decoder s (AnnTip blk)) @@ -210,6 +226,19 @@ decodeExtLedgerState decodeLedgerState decodeChainDepState decodeAnnTip +decodeDiskExtLedgerState :: + forall blk. + (DecodeDisk blk (LedgerState blk), + DecodeDisk blk (ChainDepState (BlockProtocol blk)), + DecodeDisk blk (AnnTip blk) + ) + => (CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk)) +decodeDiskExtLedgerState cfg = + decodeExtLedgerState + (decodeDisk cfg) + (decodeDisk cfg) + (decodeDisk cfg) + {------------------------------------------------------------------------------- Casts -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query.hs index 3a2dba894e..fb75facca0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query.hs @@ -11,9 +11,9 @@ {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Ledger.Query ( BlockQuery + , BlockSupportsLedgerQuery (..) , ConfigSupportsNode (..) , Query (..) - , QueryLedger (..) , QueryVersion (..) , ShowQuery (..) , answerQuery @@ -124,8 +124,10 @@ data QueryEncoderException blk = (SomeSecond Query blk) QueryVersion -deriving instance Show (SomeSecond BlockQuery blk) => Show (QueryEncoderException blk) -instance (Typeable blk, Show (SomeSecond BlockQuery blk)) => Exception (QueryEncoderException blk) +deriving instance Show (SomeSecond BlockQuery blk) + => Show (QueryEncoderException blk) +instance (Typeable blk, Show (SomeSecond BlockQuery blk)) + => Exception (QueryEncoderException blk) queryEncodeNodeToClient :: forall blk. @@ -202,7 +204,10 @@ queryDecodeNodeToClient codecConfig queryVersion blockVersion (1, 3) -> requireVersion QueryVersion2 $ SomeSecond GetChainPoint _ -> fail $ "Query: invalid size and tag" <> show (size, tag) - requireVersion :: QueryVersion -> SomeSecond Query blk -> Decoder s (SomeSecond Query blk) + requireVersion :: + QueryVersion + -> SomeSecond Query blk + -> Decoder s (SomeSecond Query blk) requireVersion expectedVersion someSecondQuery = if queryVersion >= expectedVersion then return someSecondQuery @@ -261,7 +266,7 @@ deriving instance Show (BlockQuery blk result) => Show (Query blk result) -- | Answer the given query about the extended ledger state. answerQuery :: - (QueryLedger blk, ConfigSupportsNode blk, HasAnnTip blk) + (BlockSupportsLedgerQuery blk, ConfigSupportsNode blk, HasAnnTip blk) => ExtLedgerCfg blk -> Query blk result -> ExtLedgerState blk @@ -279,12 +284,18 @@ data family BlockQuery blk :: Type -> Type -- -- Used by the LocalStateQuery protocol to allow clients to query the extended -- ledger state. -class (ShowQuery (BlockQuery blk), SameDepIndex (BlockQuery blk)) => QueryLedger blk where +class (ShowQuery (BlockQuery blk), SameDepIndex (BlockQuery blk)) + => BlockSupportsLedgerQuery blk where -- | Answer the given query about the extended ledger state. - answerBlockQuery :: ExtLedgerCfg blk -> BlockQuery blk result -> ExtLedgerState blk -> result + answerBlockQuery :: + ExtLedgerCfg blk + -> BlockQuery blk result + -> ExtLedgerState blk + -> result instance SameDepIndex (BlockQuery blk) => Eq (SomeSecond BlockQuery blk) where SomeSecond qry == SomeSecond qry' = isJust (sameDepIndex qry qry') -deriving instance (forall result. Show (BlockQuery blk result)) => Show (SomeSecond BlockQuery blk) +deriving instance (forall result. Show (BlockQuery blk result)) + => Show (SomeSecond BlockQuery blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs index 528b25d717..19d32a08bd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs @@ -98,7 +98,11 @@ data InternalState blk = IS { -- | The most recent 'SlotNo' that 'isTxs' was validated against -- - -- This comes from 'applyChainTick' ('tickedSlotNo'). + -- Note in particular that if the mempool is revalidated against a state S + -- at slot s, then the state will be ticked (for now to the successor + -- slot, see 'tickLedgerState') and 'isSlotNo' will be set to @succ s@, + -- which is different from the slot of the original ledger state, which + -- will remain in 'isTip'. , isSlotNo :: !SlotNo -- | The mempool 'TicketNo' counter. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs index 6a52fca90b..f71cca3543 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs @@ -235,7 +235,9 @@ implRemoveTxs :: => MempoolEnv m blk -> [GenTxId blk] -> m () -implRemoveTxs menv txs = do +implRemoveTxs menv txs + | null txs = pure () + | otherwise = do tr <- atomically $ do is <- readTVar istate ls <- getCurrentLedgerState ldgrInterface diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalStateQuery/Server.hs index c4ab3ce2d3..21fbbe6b31 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -13,7 +13,7 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..), Target (..)) localStateQueryServer :: - forall m blk. (IOLike m, QueryLedger blk, ConfigSupportsNode blk, HasAnnTip blk) + forall m blk. (IOLike m, BlockSupportsLedgerQuery blk, ConfigSupportsNode blk, HasAnnTip blk) => ExtLedgerCfg blk -> STM m (Point blk) -- ^ Get tip point diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs index aa006e21f9..97c2eba210 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs @@ -80,7 +80,7 @@ class ( LedgerSupportsProtocol blk , HasHardForkHistory blk , LedgerSupportsMempool blk , HasTxId (GenTx blk) - , QueryLedger blk + , BlockSupportsLedgerQuery blk , SupportedNetworkProtocolVersion blk , ConfigSupportsNode blk , ConvertRawHash blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 30d97ec3a7..b89fbc255a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -130,8 +130,9 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do lift $ traceWith tracer $ TraceOpenEvent StartedOpeningVolatileDB volatileDB <- VolatileDB.openDB argsVolatileDb $ innerOpenCont VolatileDB.closeDB + maxSlot <- lift $ atomically $ VolatileDB.getMaxSlotNo volatileDB (chainDB, testing, env) <- lift $ do - traceWith tracer $ TraceOpenEvent OpenedVolatileDB + traceWith tracer $ TraceOpenEvent (OpenedVolatileDB maxSlot) let lgrReplayTracer = LgrDB.decorateReplayTracerWithGoal immutableDbTipPoint diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs index 3d0be05f05..9c897020ed 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs @@ -48,8 +48,6 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB ( , mkLgrDB ) where -import Codec.CBOR.Decoding (Decoder) -import Codec.CBOR.Encoding (Encoding) import Codec.Serialise (Serialise (decode)) import Control.Monad.Trans.Class import Control.Tracer @@ -71,15 +69,13 @@ import Ouroboros.Consensus.Storage.ChainDB.API (ChainDbFailure (..)) import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache (BlockCache) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache -import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) -import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB +import Ouroboros.Consensus.Storage.ImmutableDB.Stream import Ouroboros.Consensus.Storage.LedgerDB (LedgerDB') import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API (SomeHasFS (..), createDirectoryIfMissing) import System.FS.API.Types (FsError, mkFsPath) @@ -236,7 +232,7 @@ initFromDisk LgrDbArgs { lgrHasFS = hasFS, .. } replayTracer lgrTracer hasFS - decodeExtLedgerState' + (decodeDiskExtLedgerState ccfg) decode (LedgerDB.configLedgerDb lgrTopLevelConfig) lgrGenesis @@ -245,12 +241,6 @@ initFromDisk LgrDbArgs { lgrHasFS = hasFS, .. } where ccfg = configCodec lgrTopLevelConfig - decodeExtLedgerState' :: forall s. Decoder s (ExtLedgerState blk) - decodeExtLedgerState' = decodeExtLedgerState - (decodeDisk ccfg) - (decodeDisk ccfg) - (decodeDisk ccfg) - -- | For testing purposes mkLgrDB :: StrictTVar m (LedgerDB' blk) -> StrictTVar m (Set (RealPoint blk)) @@ -300,17 +290,11 @@ takeSnapshot lgrDB@LgrDB{ cfg, tracer, hasFS } = wrapFailure (Proxy @blk) $ do LedgerDB.takeSnapshot tracer hasFS - encodeExtLedgerState' + (encodeDiskExtLedgerState ccfg) ledgerDB where ccfg = configCodec cfg - encodeExtLedgerState' :: ExtLedgerState blk -> Encoding - encodeExtLedgerState' = encodeExtLedgerState - (encodeDisk ccfg) - (encodeDisk ccfg) - (encodeDisk ccfg) - trimSnapshots :: forall m blk. (MonadCatch m, HasHeader blk) => LgrDB m blk @@ -388,37 +372,6 @@ validate LgrDB{..} ledgerDB blockCache numRollbacks trace = \hdrs -> do -> Set (RealPoint blk) -> Set (RealPoint blk) addPoints hs set = foldl' (flip Set.insert) set hs -{------------------------------------------------------------------------------- - Stream API to the immutable DB --------------------------------------------------------------------------------} - -streamAPI :: - forall m blk. - (IOLike m, HasHeader blk) - => ImmutableDB m blk -> LedgerDB.StreamAPI m blk -streamAPI immutableDB = LedgerDB.StreamAPI streamAfter - where - streamAfter :: HasCallStack - => Point blk - -> (Either (RealPoint blk) (m (LedgerDB.NextBlock blk)) -> m a) - -> m a - streamAfter tip k = withRegistry $ \registry -> do - eItr <- - ImmutableDB.streamAfterPoint - immutableDB - registry - GetBlock - tip - case eItr of - -- Snapshot is too recent - Left err -> k $ Left $ ImmutableDB.missingBlockPoint err - Right itr -> k $ Right $ streamUsing itr - - streamUsing :: ImmutableDB.Iterator m blk blk -> m (LedgerDB.NextBlock blk) - streamUsing itr = ImmutableDB.iteratorNext itr >>= \case - ImmutableDB.IteratorExhausted -> return $ LedgerDB.NoMoreBlocks - ImmutableDB.IteratorResult blk -> return $ LedgerDB.NextBlock blk - {------------------------------------------------------------------------------- Previously applied blocks -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 1b2dce3cf5..5044ec6d18 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -106,6 +106,7 @@ import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (WithFingerprint) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import Ouroboros.Network.Block (MaxSlotNo) -- | All the serialisation related constraints needed by the ChainDB. class ( ImmutableDbSerialiseConstraints blk @@ -584,8 +585,9 @@ data TraceOpenEvent blk = -- | The VolatileDB started opening. | StartedOpeningVolatileDB - -- | The VolatileDB was opened. - | OpenedVolatileDB + -- | The VolatileDB was opened, with the highest seen slot number for any + -- block currently in the DB. + | OpenedVolatileDB MaxSlotNo -- | The LedgerDB started opening. | StartedOpeningLgrDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs new file mode 100644 index 0000000000..f290033acb --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.Storage.ImmutableDB.Stream ( + NextItem (..) + , StreamAPI (..) + , streamAPI + , streamAPI' + , streamAll + ) where + +import Control.Monad.Except +import GHC.Stack +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Storage.Common +import Ouroboros.Consensus.Storage.ImmutableDB hiding (streamAll) +import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.ResourceRegistry + +{------------------------------------------------------------------------------- + Abstraction over the streaming API provided by the Chain DB +-------------------------------------------------------------------------------} + +-- | Next item returned during streaming +data NextItem blk = NoMoreItems | NextItem blk + +-- | Stream items from the immutable DB +-- +-- When we initialize the ledger DB, we try to find a snapshot close to the +-- tip of the immutable DB, and then stream blocks from the immutable DB to its +-- tip to bring the ledger up to date with the tip of the immutable DB. +-- +-- In CPS form to enable the use of 'withXYZ' style iterator init functions. +newtype StreamAPI m blk a = StreamAPI { + -- | Start streaming after the specified block + streamAfter :: forall b. HasCallStack + => Point blk + -- Reference to the block corresponding to the snapshot we found + -- (or 'GenesisPoint' if we didn't find any) + + -> (Either (RealPoint blk) (m (NextItem a)) -> m b) + -- Get the next item + -- + -- Should be @Left pt@ if the snapshot we found is more recent than the + -- tip of the immutable DB. Since we only store snapshots to disk for + -- blocks in the immutable DB, this can only happen if the immutable DB + -- got truncated due to disk corruption. The returned @pt@ is a + -- 'RealPoint', not a 'Point', since it must always be possible to + -- stream after genesis. + -> m b + } + +-- | Stream all items +streamAll :: + forall m blk e b a. (Monad m, HasCallStack) + => StreamAPI m blk b + -> Point blk -- ^ Starting point for streaming + -> (RealPoint blk -> e) -- ^ Error when tip not found + -> a -- ^ Starting point when tip /is/ found + -> (b -> a -> m a) -- ^ Update function for each item + -> ExceptT e m a +streamAll StreamAPI{..} tip notFound e f = ExceptT $ + streamAfter tip $ \case + Left tip' -> return $ Left (notFound tip') + + Right getNext -> do + let go :: a -> m a + go a = do mNext <- getNext + case mNext of + NoMoreItems -> return a + NextItem b -> go =<< f b a + Right <$> go e + + +streamAPI :: + (IOLike m, HasHeader blk) + => ImmutableDB m blk -> StreamAPI m blk blk +streamAPI = streamAPI' (return . NextItem) GetBlock + +streamAPI' :: + forall m blk a. + (IOLike m, HasHeader blk) + => (a -> m (NextItem a)) -- ^ Stop condition + -> BlockComponent blk a + -> ImmutableDB m blk + -> StreamAPI m blk a +streamAPI' shouldStop blockComponent immutableDB = StreamAPI streamAfter + where + streamAfter :: Point blk + -> (Either (RealPoint blk) (m (NextItem a)) -> m b) + -> m b + streamAfter tip k = withRegistry $ \registry -> do + eItr <- + ImmutableDB.streamAfterPoint + immutableDB + registry + blockComponent + tip + case eItr of + -- Snapshot is too recent + Left err -> k $ Left $ ImmutableDB.missingBlockPoint err + Right itr -> k $ Right $ streamUsing itr + + streamUsing :: ImmutableDB.Iterator m blk a + -> m (NextItem a) + streamUsing itr = do + itrResult <- ImmutableDB.iteratorNext itr + case itrResult of + ImmutableDB.IteratorExhausted -> return NoMoreItems + ImmutableDB.IteratorResult b -> shouldStop b diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index 104a412a0f..7e970703d9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -128,10 +128,6 @@ module Ouroboros.Consensus.Storage.LedgerDB ( , PushStart (..) , Pushing (..) , UpdateLedgerDbTraceEvent (..) - -- * Streaming - , NextBlock (..) - , StreamAPI (..) - , streamAll -- * Snapshots , DiskSnapshot (..) -- ** Read from disk @@ -180,8 +176,6 @@ import Ouroboros.Consensus.Storage.LedgerDB.Snapshots deleteSnapshot, diskSnapshotIsTemporary, encodeSnapshot, listSnapshots, readSnapshot, snapshotToFileName, snapshotToPath, takeSnapshot, trimSnapshots, writeSnapshot) -import Ouroboros.Consensus.Storage.LedgerDB.Stream (NextBlock (..), - StreamAPI (..), streamAll) import Ouroboros.Consensus.Storage.LedgerDB.Update (AnnLedgerError (..), AnnLedgerError', Ap (..), ExceededRollback (..), PushGoal (..), PushStart (..), diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs index 273289ca5a..ba6d0f08e4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs @@ -32,10 +32,10 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Storage.ImmutableDB.Stream import Ouroboros.Consensus.Storage.LedgerDB.LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.Query import Ouroboros.Consensus.Storage.LedgerDB.Snapshots -import Ouroboros.Consensus.Storage.LedgerDB.Stream import Ouroboros.Consensus.Storage.LedgerDB.Update import Ouroboros.Consensus.Util.IOLike import Ouroboros.Network.Block (Point (Point)) @@ -103,7 +103,7 @@ initLedgerDB :: -> (forall s. Decoder s (HeaderHash blk)) -> LedgerDbCfg (ExtLedgerState blk) -> m (ExtLedgerState blk) -- ^ Genesis ledger state - -> StreamAPI m blk + -> StreamAPI m blk blk -> m (InitLog blk, LedgerDB' blk, Word64) initLedgerDB replayTracer tracer @@ -112,7 +112,7 @@ initLedgerDB replayTracer decHash cfg getGenesisLedger - streamAPI = do + stream = do snapshots <- listSnapshots hasFS tryNewestFirst id snapshots where @@ -124,7 +124,7 @@ initLedgerDB replayTracer traceWith replayTracer ReplayFromGenesis initDb <- ledgerDbWithAnchor <$> getGenesisLedger let replayTracer' = decorateReplayTracerWithStart (Point Origin) replayTracer - ml <- runExceptT $ initStartingWith replayTracer' cfg streamAPI initDb + ml <- runExceptT $ initStartingWith replayTracer' cfg stream initDb case ml of Left _ -> error "invariant violation: invalid current chain" Right (l, replayed) -> return (acc InitFromGenesis, l, replayed) @@ -136,7 +136,7 @@ initLedgerDB replayTracer decLedger decHash cfg - streamAPI + stream s case ml of Left err -> do @@ -170,10 +170,10 @@ initFromSnapshot :: -> (forall s. Decoder s (ExtLedgerState blk)) -> (forall s. Decoder s (HeaderHash blk)) -> LedgerDbCfg (ExtLedgerState blk) - -> StreamAPI m blk + -> StreamAPI m blk blk -> DiskSnapshot -> ExceptT (SnapshotFailure blk) m (RealPoint blk, LedgerDB' blk, Word64) -initFromSnapshot tracer hasFS decLedger decHash cfg streamAPI ss = do +initFromSnapshot tracer hasFS decLedger decHash cfg stream ss = do initSS <- withExceptT InitFailureRead $ readSnapshot hasFS decLedger decHash ss let initialPoint = withOrigin (Point Origin) annTipPoint $ headerStateTip $ headerState $ initSS @@ -186,7 +186,7 @@ initFromSnapshot tracer hasFS decLedger decHash cfg streamAPI ss = do initStartingWith tracer' cfg - streamAPI + stream (ledgerDbWithAnchor initSS) return (tip, initDB, replayed) @@ -200,11 +200,11 @@ initStartingWith :: ) => Tracer m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk) -> LedgerDbCfg (ExtLedgerState blk) - -> StreamAPI m blk + -> StreamAPI m blk blk -> LedgerDB' blk -> ExceptT (SnapshotFailure blk) m (LedgerDB' blk, Word64) -initStartingWith tracer cfg streamAPI initDb = do - streamAll streamAPI (castPoint (ledgerDbTip initDb)) +initStartingWith tracer cfg stream initDb = do + streamAll stream (castPoint (ledgerDbTip initDb)) InitFailureTooRecent (initDb, 0) push diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Stream.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Stream.hs deleted file mode 100644 index c40a95da03..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Stream.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Ouroboros.Consensus.Storage.LedgerDB.Stream ( - NextBlock (..) - , StreamAPI (..) - , streamAll - ) where - -import Control.Monad.Except -import GHC.Stack -import Ouroboros.Consensus.Block - -{------------------------------------------------------------------------------- - Abstraction over the streaming API provided by the Chain DB --------------------------------------------------------------------------------} - --- | Next block returned during streaming -data NextBlock blk = NoMoreBlocks | NextBlock blk - --- | Stream blocks from the immutable DB --- --- When we initialize the ledger DB, we try to find a snapshot close to the --- tip of the immutable DB, and then stream blocks from the immutable DB to its --- tip to bring the ledger up to date with the tip of the immutable DB. --- --- In CPS form to enable the use of 'withXYZ' style iterator init functions. -data StreamAPI m blk = StreamAPI { - -- | Start streaming after the specified block - streamAfter :: forall a. HasCallStack - => Point blk - -- Reference to the block corresponding to the snapshot we found - -- (or 'GenesisPoint' if we didn't find any) - - -> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) - -- Get the next block (by value) - -- - -- Should be @Left pt@ if the snapshot we found is more recent than the - -- tip of the immutable DB. Since we only store snapshots to disk for - -- blocks in the immutable DB, this can only happen if the immutable DB - -- got truncated due to disk corruption. The returned @pt@ is a - -- 'RealPoint', not a 'Point', since it must always be possible to - -- stream after genesis. - -> m a - } - --- | Stream all blocks -streamAll :: - forall m blk e a. (Monad m, HasCallStack) - => StreamAPI m blk - -> Point blk -- ^ Starting point for streaming - -> (RealPoint blk -> e) -- ^ Error when tip not found - -> a -- ^ Starting point when tip /is/ found - -> (blk -> a -> m a) -- ^ Update function for each block - -> ExceptT e m a -streamAll StreamAPI{..} tip notFound e f = ExceptT $ - streamAfter tip $ \case - Left tip' -> return $ Left (notFound tip') - - Right getNext -> do - let go :: a -> m a - go a = do mNext <- getNext - case mNext of - NoMoreBlocks -> return a - NextBlock b -> go =<< f b a - Right <$> go e diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs index 55e24e922d..c0a582d3c8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs @@ -233,8 +233,9 @@ closeDBImpl VolatileDBEnv { varInternalState, tracer, hasFS } = do RAWLock.withWriteAccess varInternalState $ \st -> return (DbClosed, st) case mbInternalState of DbClosed -> traceWith tracer DBAlreadyClosed - DbOpen ost -> + DbOpen ost -> do wrapFsError (Proxy @blk) $ closeOpenHandles hasFS ost + traceWith tracer DBClosed getBlockComponentImpl :: forall m blk b. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Types.hs index 81ca5897df..e1ded2dac8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Types.hs @@ -93,6 +93,7 @@ data TraceEvent blk | BlockAlreadyHere (HeaderHash blk) | Truncate (ParseError blk) FsPath BlockOffset | InvalidFileNames [FsPath] + | DBClosed deriving (Eq, Generic, Show) {------------------------------------------------------------------------------ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs index 5b39d84a31..e4c86e42d6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs @@ -12,6 +12,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- | Miscellaneous utilities @@ -102,6 +103,7 @@ import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..)) import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) {------------------------------------------------------------------------------- @@ -111,9 +113,6 @@ import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) class Empty a instance Empty a -data Some (f :: k -> Type) where - Some :: f a -> Some f - -- | Pair of functors instantiated to the /same/ existential data SomePair (f :: k -> Type) (g :: k -> Type) where SomePair :: f a -> g a -> SomePair f g @@ -122,7 +121,8 @@ data SomePair (f :: k -> Type) (g :: k -> Type) where -- -- @SomeSecond f a@ is isomorphic to @Some (f a)@, but is more convenient in -- partial applications. -data SomeSecond (f :: Type -> Type -> Type) a where +type SomeSecond :: (k1 -> k2 -> Type) -> k1 -> Type +data SomeSecond f a where SomeSecond :: !(f a b) -> SomeSecond f a mustBeRight :: Either Void a -> a @@ -368,6 +368,7 @@ allDisjoint = go Set.empty (......:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> y) -> (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> z) (f ......: g) x0 x1 x2 x3 x4 x5 x6 = f (g x0 x1 x2 x3 x4 x5 x6) + {------------------------------------------------------------------------------- Product -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Args.hs index 63df7d3c0a..2352ae1b70 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Args.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} -- | Utilities for arguments record with defaults -- @@ -33,10 +34,13 @@ module Ouroboros.Consensus.Util.Args ( , HKD , MapHKD (..) -- * Re-exported for convenience + , Complete , Identity (..) + , Incomplete ) where import Data.Functor.Identity (Identity (..)) +import Data.Kind data Defaults t = NoDefault deriving (Functor) @@ -45,6 +49,9 @@ type family HKD f a where HKD Identity a = a HKD f a = f a +type Incomplete (args :: (Type -> Type) -> k) = args Defaults +type Complete (args :: (Type -> Type) -> k) = args Identity + class MapHKD f where mapHKD :: proxy (f b) -> (a -> b) -> HKD f a -> HKD f b @@ -53,5 +60,3 @@ instance MapHKD Identity where instance MapHKD Defaults where mapHKD _ _ = const NoDefault - - diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Assert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Assert.hs index ce269e49b9..ebeb5d2360 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Assert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Assert.hs @@ -1,9 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} -module Ouroboros.Consensus.Util.Assert ( - assertEqWithMsg - , assertWithMsg - ) where +module Ouroboros.Consensus.Util.Assert (assertWithMsg) where import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Util.RedundantConstraints @@ -15,10 +12,3 @@ assertWithMsg (Left msg) _ = error msg assertWithMsg _ a = a where _ = keepRedundantConstraint (Proxy @HasCallStack) - -assertEqWithMsg :: (Eq b, Show b, HasCallStack) => (b, b) -> a -> a -assertEqWithMsg (x, y) = assertWithMsg msg - where - msg :: Either String () - msg | x == y = Right () - | otherwise = Left $ show x ++ " /= " ++ show y diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs index 6a7817cf5f..c9901b2e0b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -38,7 +39,7 @@ import Data.Proxy import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Util ((.:)) import Ouroboros.Consensus.Util.IOLike (IOLike (..), PrimMonad (..), - StrictSVar, StrictTVar) + StrictSVar, StrictTVar, castStrictSVar, castStrictTVar) import Ouroboros.Consensus.Util.NormalForm.StrictMVar (StrictMVar) {------------------------------------------------------------------------------- @@ -56,6 +57,18 @@ newtype WithEarlyExit m a = WithEarlyExit { , MonadPlus ) +instance NoThunks (StrictTVar m a) + => NoThunks (StrictTVar (WithEarlyExit m) a) where + showTypeOf _ = "StrictTVar (WithEarlyExit m)" + wNoThunks ctxt tv = do + wNoThunks ctxt (castStrictTVar tv :: StrictTVar m a) + +instance NoThunks (StrictSVar m a) + => NoThunks (StrictSVar (WithEarlyExit m) a) where + showTypeOf _ = "StrictSVar (WithEarlyExit m)" + wNoThunks ctxt tv = do + wNoThunks ctxt (castStrictSVar tv :: StrictSVar m a) + -- | Internal only earlyExit :: m (Maybe a) -> WithEarlyExit m a earlyExit = WithEarlyExit . MaybeT diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/RAWLock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/RAWLock.hs index 4863ab8dab..7fc8dd0ce0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/RAWLock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/RAWLock.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} --- | A Read-Append-Write (RAW) lock +{-# LANGUAGE StandaloneDeriving #-} +-- | A writer-biased Read-Append-Write (RAW) lock -- -- Intended for qualified import module Ouroboros.Consensus.Util.MonadSTM.RAWLock ( @@ -144,6 +146,8 @@ import Prelude hiding (read) -- * All public functions are exception-safe. -- newtype RAWLock m st = RAWLock (StrictTVar m (RAWState st)) +deriving newtype instance (IOLike m, NoThunks st) + => NoThunks (RAWLock m st) -- | Create a new 'RAWLock' new :: (IOLike m, NoThunks st) => st -> m (RAWLock m st) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 3a8795efaf..5d77ffab6b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -22,6 +22,7 @@ import Data.Bimap (Bimap) import qualified Data.Bimap as Bimap import Data.IntPSQ (IntPSQ) import qualified Data.IntPSQ as PSQ +import Data.Monoid import Data.SOP.BasicFunctors import NoThunks.Class (InspectHeap (..), InspectHeapNamed (..), NoThunks (..), OnlyCheckWhnfNamed (..), allNoThunks, @@ -98,6 +99,8 @@ instance NoThunks a => NoThunks (K a b) where showTypeOf _ = showTypeOf (Proxy @a) wNoThunks ctxt (K a) = wNoThunks ("K":ctxt) a +instance NoThunks a => NoThunks (Sum a) + {------------------------------------------------------------------------------- fs-api -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/TraceSize.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/TraceSize.hs deleted file mode 100644 index 1e30a964bd..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/TraceSize.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Ouroboros.Consensus.Util.TraceSize ( - -- * Generic - traceSize - -- * Ledger DB specific - , LedgerDbSize (..) - , traceLedgerDbSize - ) where - -import Cardano.Prelude (CountFailure, computeHeapSize) -import Control.Monad (when) -import Control.Monad.IO.Class -import Control.Tracer -import Data.Word -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Ledger.Basics -import Ouroboros.Consensus.Storage.LedgerDB (LedgerDB, - ledgerDbCurrent) - -{------------------------------------------------------------------------------- - Generic --------------------------------------------------------------------------------} - --- | Generic helper to trace a value and its size -traceSize :: MonadIO m - => Tracer m (a, Either CountFailure Word64) - -> Tracer m a -traceSize (Tracer f) = Tracer $ \a -> do - sz <- liftIO $ computeHeapSize a - f (a, sz) - -{------------------------------------------------------------------------------- - Ledger DB specific --------------------------------------------------------------------------------} - -data LedgerDbSize l = LedgerDbSize { - -- | The tip of the ledger DB - ledgerDbTip :: Point l - - -- | Size of the ledger at the tip of the DB - , ledgerDbSizeTip :: Either CountFailure Word64 - - -- | Size of the entire (in-memory) ledger DB - , ledgerDbSizeTotal :: Either CountFailure Word64 - } - deriving (Show) - --- | Trace the size of the ledger --- --- Only traces slots for which the predicate results true (genesis will be --- considered to be slot 0). -traceLedgerDbSize :: forall m l. (MonadIO m, GetTip l) - => (Word64 -> Bool) - -> Tracer m (LedgerDbSize l) - -> Tracer m (LedgerDB l) -traceLedgerDbSize p (Tracer f) = Tracer $ \(!db) -> do - let !ledger = ledgerDbCurrent db - !tip = getTip ledger - - when (shouldTrace tip) $ do - sizeTip <- liftIO $ computeHeapSize ledger - sizeTotal <- liftIO $ computeHeapSize db - f $ LedgerDbSize { - ledgerDbTip = tip - , ledgerDbSizeTip = sizeTip - , ledgerDbSizeTotal = sizeTotal - } - where - shouldTrace :: Point l -> Bool - shouldTrace GenesisPoint = p 0 - shouldTrace (BlockPoint s _) = p (unSlotNo s) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 8d919ceb05..23384b9d7a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -652,7 +652,7 @@ instance HasHardForkHistory TestBlock where data instance BlockQuery TestBlock result where QueryLedgerTip :: BlockQuery TestBlock (Point TestBlock) -instance QueryLedger TestBlock where +instance BlockSupportsLedgerQuery TestBlock where answerBlockQuery _cfg QueryLedgerTip (ExtLedgerState TestLedger { lastAppliedPoint } _) = lastAppliedPoint diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Address.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Address.hs index 1f0f40b30c..b946df94a0 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Address.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Address.hs @@ -6,11 +6,13 @@ module Ouroboros.Consensus.Mock.Ledger.Address ( , mkAddrDist ) where +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.String +import Data.Text (pack, unpack) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId (NodeId (..)) @@ -28,6 +30,12 @@ newtype Addr = Addr String , NoThunks ) +instance ToCBOR Addr where + toCBOR (Addr a) = toCBOR $ pack a + +instance FromCBOR Addr where + fromCBOR = Addr . unpack <$> fromCBOR + instance Condense Addr where condense (Addr addr) = addr diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index b855a6bb14..a82a7f3361 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -494,7 +494,7 @@ txSize = fromIntegral . Lazy.length . serialise data instance BlockQuery (SimpleBlock c ext) result where QueryLedgerTip :: BlockQuery (SimpleBlock c ext) (Point (SimpleBlock c ext)) -instance MockProtocolSpecific c ext => QueryLedger (SimpleBlock c ext) where +instance MockProtocolSpecific c ext => BlockSupportsLedgerQuery (SimpleBlock c ext) where answerBlockQuery _cfg QueryLedgerTip = castPoint . ledgerTipPoint diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs index b7cb812dda..9cda7820a5 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs @@ -68,6 +68,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Storage.ImmutableDB.Stream import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.IOLike @@ -665,12 +666,12 @@ initStandaloneDB dbEnv@DbEnv{..} = do , "or LedgerDB not re-initialized after chain truncation" ] -dbStreamAPI :: forall m. IOLike m => StandaloneDB m -> StreamAPI m TestBlock +dbStreamAPI :: forall m. IOLike m => StandaloneDB m -> StreamAPI m TestBlock TestBlock dbStreamAPI DB{..} = StreamAPI {..} where streamAfter :: Point TestBlock - -> (Either (RealPoint TestBlock) (m (NextBlock TestBlock)) -> m a) + -> (Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a) -> m a streamAfter tip k = do pts <- atomically $ reverse . fst <$> readTVar dbState @@ -693,7 +694,7 @@ dbStreamAPI DB{..} = StreamAPI {..} blocksToStream Origin = id blocksToStream (NotOrigin r) = tail . dropWhile (/= r) - getNext :: StrictTVar m [RealPoint TestBlock] -> m (NextBlock TestBlock) + getNext :: StrictTVar m [RealPoint TestBlock] -> m (NextItem TestBlock) getNext toStream = do mr <- atomically $ do rs <- readTVar toStream @@ -701,10 +702,10 @@ dbStreamAPI DB{..} = StreamAPI {..} [] -> return Nothing r:rs' -> writeTVar toStream rs' >> return (Just r) case mr of - Nothing -> return NoMoreBlocks + Nothing -> return NoMoreItems Just r -> do mb <- atomically $ Map.lookup r <$> readTVar dbBlocks case mb of - Just b -> return $ NextBlock b + Just b -> return $ NextItem b Nothing -> error blockNotFound blockNotFound :: String @@ -721,7 +722,7 @@ runDB standalone@DB{..} cmd = case dbEnv of DbEnv{dbHasFS} -> Resp <$> go dbHasFS cmd where - streamAPI = dbStreamAPI standalone + stream = dbStreamAPI standalone annLedgerErr' :: AnnLedgerError (ExtLedgerState TestBlock) TestBlock @@ -771,7 +772,7 @@ runDB standalone@DB{..} cmd = S.decode dbLedgerDbCfg (return (testInitExtLedgerWithState initialTestLedgerState)) - streamAPI + stream atomically $ modifyTVar dbState (\(rs, _) -> (rs, db)) return $ Restored (fromInitLog initLog, ledgerDbCurrent db) go hasFS (Corrupt c ss) = diff --git a/sop-extras/changelog.d/utxo-hd-javier.md b/sop-extras/changelog.d/utxo-hd-javier.md new file mode 100644 index 0000000000..355ffe91e0 --- /dev/null +++ b/sop-extras/changelog.d/utxo-hd-javier.md @@ -0,0 +1,9 @@ +### Breaking + +- `Index` became poly-kinded. + +### Non-Breaking + +- Added `K1` and `Flip` basic functors (poly-kinded). +- Provide `hczipWith` for `InPairs`. +- Added `HTrans` instances to `OptNP`, `Match`, `Telescope`. diff --git a/sop-extras/sop-extras.cabal b/sop-extras/sop-extras.cabal index 0e51d9adf4..35f253a20f 100644 --- a/sop-extras/sop-extras.cabal +++ b/sop-extras/sop-extras.cabal @@ -3,7 +3,7 @@ name: sop-extras synopsis: Type-level and data utilities that build upon SOP. description: This package provides some more constructs that are not present on the - @sop-core@ package but build upon the same foundations. + @sop-core@ package but built upon the same foundations. version: 0.1.0.0 license: Apache-2.0 @@ -48,6 +48,7 @@ library build-depends: base >=4.14 && <4.20, + constraints ^>=0.14, nothunks ^>=0.1, sop-core ^>=0.5, strict-sop-core ^>=0.1, diff --git a/sop-extras/src/Data/SOP/Functors.hs b/sop-extras/src/Data/SOP/Functors.hs index cfa13aad1b..826e65d43d 100644 --- a/sop-extras/src/Data/SOP/Functors.hs +++ b/sop-extras/src/Data/SOP/Functors.hs @@ -1,13 +1,31 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Data.SOP.Functors (Product2 (..)) where +module Data.SOP.Functors ( + Flip (..) + , K2 (..) + , Product2 (..) + , snd2 + ) where import Data.Kind (Type) import GHC.Generics (Generic) +import NoThunks.Class type Product2 :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type data Product2 f g x y = Pair2 (f x y) (g x y) deriving (Eq, Generic, Show) + +snd2 :: Product2 f g x y -> g x y +snd2 (Pair2 _ g) = g + +type Flip :: (x -> y -> Type) -> y -> x -> Type +newtype Flip f x y = Flip {unFlip :: f y x} + deriving (Eq, Generic, NoThunks, Show) + +type K2 :: Type -> x -> y -> Type +newtype K2 a b c = K2 a diff --git a/sop-extras/src/Data/SOP/InPairs.hs b/sop-extras/src/Data/SOP/InPairs.hs index 938b70f88e..6baa26b689 100644 --- a/sop-extras/src/Data/SOP/InPairs.hs +++ b/sop-extras/src/Data/SOP/InPairs.hs @@ -23,6 +23,7 @@ module Data.SOP.InPairs ( -- * SOP-like operators , hcmap , hcpure + , hczipWith , hmap , hpure -- * Requiring @@ -39,7 +40,7 @@ import Data.Proxy import Data.SOP.Constraint import Data.SOP.NonEmpty import Data.SOP.Sing -import Data.SOP.Strict hiding (hcmap, hcpure, hmap, hpure) +import Data.SOP.Strict hiding (hcmap, hcpure, hczipWith, hmap, hpure) {------------------------------------------------------------------------------- InPairs @@ -95,6 +96,19 @@ hcpure _ f = go SNil = PNil go SCons = PCons f (go sList) +hczipWith :: + forall proxy c f f' f'' xs. All c xs + => proxy c + -> (forall x y. (c x, c y) => f x y -> f' x y -> f'' x y) + -> InPairs f xs + -> InPairs f' xs + -> InPairs f'' xs +hczipWith _ f = go + where + go :: All c xs' => InPairs f xs' -> InPairs f' xs' -> InPairs f'' xs' + go PNil PNil = PNil + go (PCons x xs) (PCons y ys) = PCons (f x y) (go xs ys) + {------------------------------------------------------------------------------- RequiringBoth -------------------------------------------------------------------------------} diff --git a/sop-extras/src/Data/SOP/Index.hs b/sop-extras/src/Data/SOP/Index.hs index a7c2779297..647f43c503 100644 --- a/sop-extras/src/Data/SOP/Index.hs +++ b/sop-extras/src/Data/SOP/Index.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} @@ -31,6 +32,7 @@ module Data.SOP.Index ( , npWithIndices , nsFromIndex , nsToIndex + , toWord8 ) where import Data.Coerce @@ -43,7 +45,7 @@ import Data.SOP.Sing import Data.SOP.Strict import Data.Word -type Index :: [Type] -> Type -> Type +type Index :: [k] -> k -> Type data Index xs x where IZ :: Index (x ': xs) x IS :: Index xs x -> Index (y ': xs) x @@ -194,3 +196,11 @@ nsFromIndex n = go 0 sList | i == n = Just $ Z $ K () | otherwise = S <$> go (i + 1) sList go !_ SNil = Nothing + +toWord8 :: Index xs x -> Word8 +toWord8 = go 0 + where + go :: Word8 -> Index ys y -> Word8 + go !n = \case + IZ -> n + IS idx' -> go (n + 1) idx' diff --git a/sop-extras/src/Data/SOP/Match.hs b/sop-extras/src/Data/SOP/Match.hs index b54eb66e98..a1624ecf70 100644 --- a/sop-extras/src/Data/SOP/Match.hs +++ b/sop-extras/src/Data/SOP/Match.hs @@ -4,9 +4,13 @@ {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} @@ -38,10 +42,13 @@ module Data.SOP.Match ( ) where import Data.Bifunctor +import Data.Coerce (coerce) +import Data.Constraint (Dict (..)) import Data.Functor.Product import Data.Kind (Type) import Data.Proxy import Data.SOP.Constraint +import Data.SOP.Sing import Data.SOP.Strict import Data.SOP.Telescope (Telescope (..)) import qualified Data.SOP.Telescope as Telescope @@ -113,6 +120,46 @@ instance HAp (Mismatch f) where go (f :* _) (MR fy gx) = MR fy (apFn f gx) go Nil m = case m of {} +type instance Same (Mismatch f) = Mismatch f + +instance (forall x y. LiftedCoercible p p x y) + => HTrans (Mismatch p) (Mismatch p) where + htrans :: + forall proxy c f g xs ys. AllZipN (Prod (Mismatch p)) c xs ys + => proxy c + -> (forall x y. c x y => f x -> g y) + -> Mismatch p f xs + -> Mismatch p g ys + htrans p t = \case + ML fx gy -> ML (coerce fx) $ htrans p t gy + MR fy gx | Dict <- tailDict -> MR (hcoerce fy) $ t gx + where + tailDict :: Dict (AllZip (LiftedCoercible p p) (Tail xs) (Tail ys)) + tailDict = impliesAllZip (Proxy @c) + MS m -> MS $ htrans p t m + + -- NOTE(jdral): this code could be replaced by 'unsafeCoerce' (see 'trans_NP' + -- or 'trans_NS' for examples), but this would technically sacrifice type + -- safety. For now, this version should be sufficient. + hcoerce :: + forall f g xs ys. AllZipN (Prod (Mismatch p)) (LiftedCoercible f g) xs ys + => Mismatch p f xs + -> Mismatch p g ys + hcoerce = htrans (Proxy @(LiftedCoercible f g)) coerce + +impliesAllZip :: + forall c c' xs ys. + (AllZip c xs ys, forall x y. c x y => c' x y) + => Proxy c -> Dict (AllZip c' xs ys) +impliesAllZip _ = go sList sList + where + go :: + forall as bs. AllZip c as bs + => SList as -> SList bs + -> Dict (AllZip c' as bs) + go SNil SNil = Dict + go SCons SCons = case go (sList @(Tail as)) (sList @(Tail bs)) of Dict -> Dict + {------------------------------------------------------------------------------- Utilities -------------------------------------------------------------------------------} diff --git a/sop-extras/src/Data/SOP/OptNP.hs b/sop-extras/src/Data/SOP/OptNP.hs index 361142c38a..38e6f08b56 100644 --- a/sop-extras/src/Data/SOP/OptNP.hs +++ b/sop-extras/src/Data/SOP/OptNP.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -38,6 +39,7 @@ module Data.SOP.OptNP ( ) where import Control.Monad (guard) +import Data.Coerce (coerce) import Data.Functor.These (These1 (..)) import Data.Kind (Type) import Data.Maybe (isJust) @@ -147,6 +149,33 @@ instance HSequence (OptNP empty) where htraverse' = hctraverse' (Proxy @Top) hsequence' = htraverse' unComp +type instance Same (OptNP empty) = OptNP empty + +instance HTrans (OptNP empty) (OptNP empty) where + htrans = trans_OptNP + -- NOTE(jdral): this code could be replaced by 'unsafeCoerce' (see 'trans_NP' + -- or 'trans_NS' for examples), but this would technically sacrifice type + -- safety. For now, this version should be sufficient. + hcoerce = coerce_OptNP + +trans_OptNP :: + AllZipN (Prod (OptNP empty)) c xs ys + => proxy c + -> (forall x y. c x y => f x -> g y) + -> OptNP empty f xs + -> OptNP empty g ys +trans_OptNP p t = \case + OptNil -> OptNil + OptCons fx fxs -> OptCons (t fx) (trans_OptNP p t fxs) + OptSkip fxs -> OptSkip (trans_OptNP p t fxs) + +coerce_OptNP :: + forall empty f g xs ys. + AllZipN (Prod (OptNP empty)) (LiftedCoercible f g) xs ys + => OptNP empty f xs + -> OptNP empty g ys +coerce_OptNP = trans_OptNP (Proxy @(LiftedCoercible f g)) coerce + {------------------------------------------------------------------------------- View -------------------------------------------------------------------------------} diff --git a/sop-extras/src/Data/SOP/Telescope.hs b/sop-extras/src/Data/SOP/Telescope.hs index 7c56e1dd02..52d412af49 100644 --- a/sop-extras/src/Data/SOP/Telescope.hs +++ b/sop-extras/src/Data/SOP/Telescope.hs @@ -1,9 +1,12 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -50,6 +53,7 @@ module Data.SOP.Telescope ( , scanl ) where +import Data.Coerce (coerce) import Data.Functor.Product import Data.Kind import Data.Proxy @@ -133,6 +137,17 @@ sequence = go go (TZ (Comp fx)) = TZ <$> fx go (TS gx t) = TS gx <$> go t +instance (forall x y. LiftedCoercible g g x y) + => HTrans (Telescope g) (Telescope g) where + htrans p transf = \case + TZ fx -> TZ $ transf fx + TS gx t -> TS (coerce gx) $ htrans p transf t + hcoerce = \case + TZ fx -> TZ $ coerce fx + TS gx t -> TS (coerce gx) $ hcoerce t + +type instance Same (Telescope g) = Telescope g + {------------------------------------------------------------------------------- Bifunctor analogues of class methods -------------------------------------------------------------------------------} diff --git a/strict-sop-core/changelog.d/utxo-hd-javier.md b/strict-sop-core/changelog.d/utxo-hd-javier.md new file mode 100644 index 0000000000..23a97f713a --- /dev/null +++ b/strict-sop-core/changelog.d/utxo-hd-javier.md @@ -0,0 +1,3 @@ +### Non-Breaking + +- Add `PolyKinds` to the `Data.SOP.Strict` module. diff --git a/strict-sop-core/src/Data/SOP/Strict.hs b/strict-sop-core/src/Data/SOP/Strict.hs index 1005352384..cdc1d496dd 100644 --- a/strict-sop-core/src/Data/SOP/Strict.hs +++ b/strict-sop-core/src/Data/SOP/Strict.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} -- | Strict variant of SOP