From e99363f94543cd7b7e6b1a44941cad5f7b9d70c1 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 12 Apr 2024 17:51:46 +0200 Subject: [PATCH] Rework the arguments for the DBs - Tweak the ChainDB arguments: - Remove unused fields in `CDB`: - `cdbTraceLedger` this was *always* set to nullTracer, furthermore it would trace the whole LedgerDB. - `cdbChunkInfo` was never accessed from the ChainDB. - `cdbCheckIntegrity` was never accessed from the ChainDB. - Transform `ChainDbArgs` into an isomorphic product of the different arguments of the inner databases. - Define most common operations on `ChainDbArgs` as separate functions: `ensureValidateAll`, `updateTracer` and `updateDiskPolicyArgs` - Tweak the LgrDB arguments: - `LgrDB.cfg` and `LgrDbArgs.lgrConfig` are now `LedgerDbCfg (ExtLedgerState blk)` instead of `TopLevelConfig blk`. - `defaultArgs` no longer expects a filesystem. - Tweak the ImmutableDB arguments: - `defaultArgs` no longer expects a filesystem. - Tweak the VolatileDB arguments: - `defaultArgs` no longer expects a filesystem. - Hide the `Identity`/`Defaults` types in `Ouroboros.Consensus.Util.Args` in favor of `Complete`/`Incomplete`. - Expose `noDefault` to replace `NoDefault`. --- .../changelog.d/chaindb-args-javier.md | 1 + .../Cardano/Tools/DBAnalyser/Run.hs | 41 ++- .../Cardano/Tools/DBSynthesizer/Run.hs | 22 +- .../Cardano/Tools/DBTruncater/Run.hs | 4 +- .../Cardano/Tools/ImmDBServer/Diffusion.hs | 6 +- .../changelog.d/chaindb-args-javier.md | 5 + .../Ouroboros/Consensus/Node.hs | 145 +++------ .../Test/ThreadNet/Network.hs | 30 +- .../Test/Consensus/PeerSimulator/Run.hs | 31 +- .../changelog.d/chaindb-args-javier.md | 18 ++ .../Consensus/Storage/ChainDB/Impl.hs | 32 +- .../Consensus/Storage/ChainDB/Impl/Args.hs | 299 ++++++++---------- .../Storage/ChainDB/Impl/ChainSel.hs | 1 - .../Consensus/Storage/ChainDB/Impl/LgrDB.hs | 41 ++- .../Consensus/Storage/ChainDB/Impl/Types.hs | 7 +- .../Consensus/Storage/ImmutableDB/Impl.hs | 25 +- .../Consensus/Storage/VolatileDB/Impl.hs | 19 +- .../Ouroboros/Consensus/Util/Args.hs | 15 +- .../Test/Util/ChainDB.hs | 97 +++--- .../Test/Util/Orphans/NoThunks.hs | 22 +- .../MiniProtocol/BlockFetch/Client.hs | 4 +- .../MiniProtocol/LocalStateQuery/Server.hs | 8 +- .../Storage/ChainDB/FollowerPromptness.hs | 4 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 31 +- .../Test/Ouroboros/Storage/ChainDB/Unit.hs | 5 +- 25 files changed, 462 insertions(+), 451 deletions(-) create mode 100644 ouroboros-consensus-cardano/changelog.d/chaindb-args-javier.md create mode 100644 ouroboros-consensus-diffusion/changelog.d/chaindb-args-javier.md create mode 100644 ouroboros-consensus/changelog.d/chaindb-args-javier.md diff --git a/ouroboros-consensus-cardano/changelog.d/chaindb-args-javier.md b/ouroboros-consensus-cardano/changelog.d/chaindb-args-javier.md new file mode 100644 index 0000000000..9335854816 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/chaindb-args-javier.md @@ -0,0 +1 @@ + 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 5f45c342d6..4322a421bc 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 @@ -22,10 +22,10 @@ import qualified Ouroboros.Consensus.Node as Node import qualified Ouroboros.Consensus.Node.InitStorage as Node import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB -import Ouroboros.Consensus.Storage.ChainDB.Impl.Args (fromChainDbArgs) +import Ouroboros.Consensus.Storage.ChainDB.Impl.Args +import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (lgrHasFS) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB (readSnapshot) -import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.ResourceRegistry @@ -56,16 +56,17 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo mkProtocolInfo args let chunkInfo = Node.nodeImmutableDbChunkInfo (configStorage cfg) args' = - Node.mkChainDbArgs - registry InFuture.dontCheck cfg genesisLedger chunkInfo $ - ChainDB.defaultArgs (Node.stdMkChainDbHasFS dbDir) - chainDbArgs = args' { - ChainDB.cdbImmutableDbValidation = immValidationPolicy - , ChainDB.cdbVolatileDbValidation = volValidationPolicy - , ChainDB.cdbTracer = chainDBTracer - } - (immutableDbArgs, _, _, _) = fromChainDbArgs chainDbArgs - ledgerDbFS = ChainDB.cdbHasFSLgrDB chainDbArgs + completeChainDbArgs + registry + InFuture.dontCheck + cfg + genesisLedger + chunkInfo + (const True) + (Node.stdMkChainDbHasFS dbDir) $ defaultArgs + chainDbArgs = maybeValidateAll $ updateTracer chainDBTracer args' + immutableDbArgs = ChainDB.cdbImmDbArgs chainDbArgs + ledgerDbFS = lgrHasFS $ ChainDB.cdbLgrDbArgs chainDbArgs case selectDB of SelectImmutableDB initializeFrom -> do @@ -125,14 +126,8 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo where withLock = bracket_ (takeMVar lock) (putMVar lock ()) - immValidationPolicy = case (analysis, validation) of - (_, Just ValidateAllBlocks) -> ImmutableDB.ValidateAllChunks - (_, Just MinimumBlockValidation) -> ImmutableDB.ValidateMostRecentChunk - (OnlyValidation, _ ) -> ImmutableDB.ValidateAllChunks - _ -> ImmutableDB.ValidateMostRecentChunk - - volValidationPolicy = case (analysis, validation) of - (_, Just ValidateAllBlocks) -> VolatileDB.ValidateAll - (_, Just MinimumBlockValidation) -> VolatileDB.NoValidation - (OnlyValidation, _ ) -> VolatileDB.ValidateAll - _ -> VolatileDB.NoValidation + maybeValidateAll = case (analysis, validation) of + (_, Just ValidateAllBlocks) -> ensureValidateAll + (_, Just MinimumBlockValidation) -> id + (OnlyValidation, _ ) -> ensureValidateAll + _ -> id diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index f13d870162..2d32cfc5ae 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -23,16 +23,15 @@ import Data.Bool (bool) import Data.ByteString as BS (ByteString, readFile) import Ouroboros.Consensus.Config (configStorage) import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture (dontCheck) -import qualified Ouroboros.Consensus.Node as Node (mkChainDbArgs, - stdMkChainDbHasFS) +import qualified Ouroboros.Consensus.Node as Node (stdMkChainDbHasFS) import qualified Ouroboros.Consensus.Node.InitStorage as Node (nodeImmutableDbChunkInfo) import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) import Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..), validateGenesis) -import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB - (ChainDbArgs (..), defaultArgs, getTipPoint) +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB (getTipPoint) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB (withDB) +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.IOLike (atomically) import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block @@ -114,9 +113,16 @@ synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} (Some let epochSize = sgEpochLength confShelleyGenesis chunkInfo = Node.nodeImmutableDbChunkInfo (configStorage pInfoConfig) - dbArgs = Node.mkChainDbArgs - registry InFuture.dontCheck pInfoConfig pInfoInitLedger chunkInfo $ - ChainDB.defaultArgs (Node.stdMkChainDbHasFS confDbDir) + dbArgs = + ChainDB.completeChainDbArgs + registry + InFuture.dontCheck + pInfoConfig + pInfoInitLedger + chunkInfo + (const True) + (Node.stdMkChainDbHasFS confDbDir) + $ ChainDB.defaultArgs forgers <- blockForging let fCount = length forgers @@ -126,7 +132,7 @@ synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} (Some putStrLn $ "--> opening ChainDB on file system with mode: " ++ show synthOpenMode preOpenChainDB synthOpenMode confDbDir let dbTracer = nullTracer - ChainDB.withDB dbArgs {ChainDB.cdbTracer = dbTracer} $ \chainDB -> do + ChainDB.withDB (ChainDB.updateTracer dbTracer dbArgs) $ \chainDB -> do slotNo <- do tip <- atomically (ChainDB.getTipPoint chainDB) pure $ case pointSlot tip of diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs index 990a27b7eb..1fd310d1ed 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Cardano.Tools.DBTruncater.Run (truncate) where @@ -46,12 +47,13 @@ truncate DBTruncaterConfig{ dbDir, truncateAfter, verbose } args = do chunkInfo = Node.nodeImmutableDbChunkInfo (configStorage config) immutableDBArgs :: ImmutableDbArgs Identity IO block immutableDBArgs = - (ImmutableDB.defaultArgs fs) + (ImmutableDB.defaultArgs @IO) { immTracer = immutableDBTracer , immRegistry = registry , immCheckIntegrity = nodeCheckIntegrity (configStorage config) , immCodecConfig = configCodec config , immChunkInfo = chunkInfo + , immHasFS = fs } withDB immutableDBArgs $ \(immutableDB, internal) -> do diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs index edcf89e551..fbf747f1f7 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs @@ -93,15 +93,13 @@ run immDBDir sockAddr cfg = withRegistry \registry -> immDB networkMagic where - immDBArgs registry = defaultImmDBArgs { + immDBArgs registry = ImmutableDB.defaultArgs { immCheckIntegrity = nodeCheckIntegrity storageCfg , immChunkInfo = nodeImmutableDbChunkInfo storageCfg , immCodecConfig = codecCfg , immRegistry = registry + , immHasFS = SomeHasFS $ ioHasFS $ MountPoint immDBDir } - where - defaultImmDBArgs = - ImmutableDB.defaultArgs $ SomeHasFS $ ioHasFS $ MountPoint immDBDir codecCfg = configCodec cfg storageCfg = configStorage cfg diff --git a/ouroboros-consensus-diffusion/changelog.d/chaindb-args-javier.md b/ouroboros-consensus-diffusion/changelog.d/chaindb-args-javier.md new file mode 100644 index 0000000000..16358e1fdf --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/chaindb-args-javier.md @@ -0,0 +1,5 @@ +### Breaking + +- `ChainDbArgs` re-exported by `Ouroboros.Consensus.Node` had breaking changes upstream. See `ouroboros-consensus`' changelog for details. +- Removed `mkChainDbArgs`. +- New `llrnMkHasFS` field in `LowLevelRunNodeArgs` 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 f42484a59f..558df2fd59 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 @@ -10,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | Run the whole Node -- @@ -49,7 +50,6 @@ module Ouroboros.Consensus.Node ( , Tracers , Tracers' (..) -- * Internal helpers - , mkChainDbArgs , mkNodeKernelArgs , nodeKernelArgsEnforceInvariants , openChainDB @@ -100,13 +100,9 @@ import Ouroboros.Consensus.Node.Tracers import Ouroboros.Consensus.NodeKernel import Ouroboros.Consensus.Storage.ChainDB (ChainDB, ChainDbArgs) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB -import Ouroboros.Consensus.Storage.ChainDB.API (LoE (LoEDisabled)) -import Ouroboros.Consensus.Storage.ImmutableDB (ChunkInfo, - ValidationPolicy (..)) +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (DiskPolicyArgs (..)) -import Ouroboros.Consensus.Storage.VolatileDB - (BlockValidationPolicy (..)) import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () @@ -220,12 +216,16 @@ data LowLevelRunNodeArgs m addrNTN addrNTC versionDataNTN versionDataNTC blk -> m a -- | The " static " ChainDB arguments - , llrnChainDbArgsDefaults :: ChainDbArgs Defaults m blk + , llrnChainDbArgsDefaults :: Incomplete ChainDbArgs m blk + + -- | FS on which the directories for the different databases will be + -- created. + , llrnMkHasFS :: ChainDB.RelativeMountPoint -> SomeHasFS m -- | Customise the 'ChainDbArgs' , llrnCustomiseChainDbArgs :: - ChainDbArgs Identity m blk - -> ChainDbArgs Identity m blk + Complete ChainDbArgs m blk + -> Complete ChainDbArgs m blk -- | Customise the 'NodeArgs' , llrnCustomiseNodeKernelArgs :: @@ -410,29 +410,24 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = llrnMaxClockSkew systemTime - let customiseChainDbArgs' args + let maybeValidateAll | lastShutDownWasClean - = llrnCustomiseChainDbArgs args + = id | otherwise -- When the last shutdown was not clean, validate the complete - -- ChainDB to detect and recover from any corruptions. This will - -- override the default value /and/ the user-customised value of - -- the 'ChainDB.cdbImmValidation' and the - -- 'ChainDB.cdbVolValidation' fields. - = (llrnCustomiseChainDbArgs args) { - ChainDB.cdbImmutableDbValidation = ValidateAllChunks - , ChainDB.cdbVolatileDbValidation = ValidateAll - } - - let finalChainDbArgs = - mkFinalChainDbArgs - registry - inFuture - cfg - initLedger - llrnChainDbArgsDefaults - customiseChainDbArgs' - chainDB <- ChainDB.openDB finalChainDbArgs + -- ChainDB to detect and recover from any corruptions. + = ChainDB.ensureValidateAll + + (chainDB, finalArgs) <- openChainDB + registry + inFuture + cfg + initLedger + llrnMkHasFS + llrnChainDbArgsDefaults + ( maybeValidateAll + . llrnCustomiseChainDbArgs + ) continueWithCleanChainDB chainDB $ do btime <- @@ -458,7 +453,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = llrnMaxCaughtUpAge systemTime let gsmMarkerFileView = - case ChainDB.cdbHasFSGsmDB finalChainDbArgs of + case ChainDB.cdbsHasFSGsmDB $ ChainDB.cdbsArgs finalArgs of SomeHasFS x -> GSM.realMarkerFileView chainDB x fmap (nodeKernelArgsEnforceInvariants . llrnCustomiseNodeKernelArgs) $ mkNodeKernelArgs @@ -674,57 +669,23 @@ openChainDB :: -> TopLevelConfig blk -> ExtLedgerState blk -- ^ Initial ledger - -> ChainDbArgs Defaults m blk - -> (ChainDbArgs Identity m blk -> ChainDbArgs Identity m blk) + -> (ChainDB.RelativeMountPoint -> SomeHasFS m) + -> Incomplete ChainDbArgs m blk + -- ^ A set of default arguments (possibly modified from 'defaultArgs') + -> (Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk) -- ^ Customise the 'ChainDbArgs' - -> m (ChainDB m blk) -openChainDB registry inFuture cfg initLedger defArgs customiseArgs = - ChainDB.openDB - $ mkFinalChainDbArgs registry inFuture cfg initLedger defArgs customiseArgs - -mkFinalChainDbArgs - :: forall m blk. (RunNode blk, IOLike m) - => ResourceRegistry m - -> CheckInFuture m blk - -> TopLevelConfig blk - -> ExtLedgerState blk - -- ^ Initial ledger - -> ChainDbArgs Defaults m blk - -> (ChainDbArgs Identity m blk -> ChainDbArgs Identity m blk) - -- ^ Customise the 'ChainDbArgs' - -> ChainDbArgs Identity m blk -mkFinalChainDbArgs registry inFuture cfg initLedger defArgs customiseArgs = - customiseArgs $ - mkChainDbArgs registry inFuture cfg initLedger - (nodeImmutableDbChunkInfo (configStorage cfg)) - defArgs - -mkChainDbArgs :: - forall m blk. (RunNode blk, IOLike m) - => ResourceRegistry m - -> CheckInFuture m blk - -> TopLevelConfig blk - -> ExtLedgerState blk - -- ^ Initial ledger - -> ChunkInfo - -> ChainDbArgs Defaults m blk - -> ChainDbArgs Identity m blk -mkChainDbArgs - registry - inFuture - cfg - initLedger - chunkInfo - defArgs - = defArgs { - ChainDB.cdbTopLevelConfig = cfg - , ChainDB.cdbChunkInfo = chunkInfo - , ChainDB.cdbCheckIntegrity = nodeCheckIntegrity (configStorage cfg) - , ChainDB.cdbGenesis = return initLedger - , ChainDB.cdbCheckInFuture = inFuture - , ChainDB.cdbLoE = LoEDisabled - , ChainDB.cdbRegistry = registry - } + -> m (ChainDB m blk, Complete ChainDbArgs m blk) +openChainDB registry inFuture cfg initLedger fs defArgs customiseArgs = + let args = customiseArgs $ ChainDB.completeChainDbArgs + registry + inFuture + cfg + initLedger + (nodeImmutableDbChunkInfo (configStorage cfg)) + (nodeCheckIntegrity (configStorage cfg)) + fs + defArgs + in (,args) <$> ChainDB.openDB args mkNodeKernelArgs :: forall m addrNTN addrNTC blk. (RunNode blk, IOLike m) @@ -931,8 +892,8 @@ stdLowLevelRunNodeArgsIO RunNodeArgs{ rnProtocolInfo , llrnCustomiseHardForkBlockchainTimeArgs = id , llrnGsmAntiThunderingHerd , llrnKeepAliveRng - , llrnChainDbArgsDefaults = - updateChainDbDefaults $ ChainDB.defaultArgs mkHasFS + , llrnMkHasFS = stdMkChainDbHasFS srnDatabasePath + , llrnChainDbArgsDefaults = updateChainDbDefaults ChainDB.defaultArgs , llrnCustomiseChainDbArgs = id , llrnCustomiseNodeKernelArgs , llrnRunDataDiffusion = @@ -973,23 +934,19 @@ stdLowLevelRunNodeArgsIO RunNodeArgs{ rnProtocolInfo Diffusion.daPublicPeerSelectionVar srnDiffusionArguments } where - mkHasFS :: ChainDB.RelativeMountPoint -> SomeHasFS IO - mkHasFS = stdMkChainDbHasFS srnDatabasePath - networkMagic :: NetworkMagic networkMagic = getNetworkMagic $ configBlock $ pInfoConfig rnProtocolInfo updateChainDbDefaults :: - ChainDbArgs Defaults IO blk - -> ChainDbArgs Defaults IO blk + Incomplete ChainDbArgs IO blk + -> Incomplete ChainDbArgs IO blk updateChainDbDefaults = - (\x -> x { ChainDB.cdbTracer = srnTraceChainDB - , ChainDB.cdbDiskPolicyArgs = srnDiskPolicyArgs - }) . - (if not srnChainDbValidateOverride then id else \x -> x - { ChainDB.cdbImmutableDbValidation = ValidateAllChunks - , ChainDB.cdbVolatileDbValidation = ValidateAll - }) + ChainDB.updateDiskPolicyArgs srnDiskPolicyArgs + . ChainDB.updateTracer srnTraceChainDB + . (if not srnChainDbValidateOverride + then id + else ChainDB.ensureValidateAll) + llrnCustomiseNodeKernelArgs :: NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 7ebd333fff..929826cc80 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -46,6 +46,7 @@ import qualified Control.Monad.Except as Exc import Control.Tracer import qualified Data.ByteString.Lazy as Lazy import Data.Either (isRight) +import Data.Functor.Contravariant ((>$<)) import Data.Functor.Identity (Identity) import qualified Data.List as List import qualified Data.List.NonEmpty as NE @@ -84,8 +85,11 @@ import Ouroboros.Consensus.NodeKernel as NodeKernel import Ouroboros.Consensus.Protocol.Abstract import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment -import Ouroboros.Consensus.Storage.ChainDB.Impl (ChainDbArgs (..)) +import Ouroboros.Consensus.Storage.ChainDB.Impl +import Ouroboros.Consensus.Storage.ChainDB.Impl.Args +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LedgerDB import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB +import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Assert import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Enclose (pattern FallingEdge) @@ -719,14 +723,26 @@ runThreadNetwork systemTime ThreadNetworkArgs , mcdbRegistry = registry , mcdbNodeDBs = nodeDBs } - in args { cdbCheckIntegrity = nodeCheckIntegrity (configStorage cfg) - , cdbCheckInFuture = InFuture.reference (configLedger cfg) + tr = instrumentationTracer <> nullDebugTracer + in args { cdbImmDbArgs = (cdbImmDbArgs args) { + ImmutableDB.immCheckIntegrity = nodeCheckIntegrity (configStorage cfg) + , ImmutableDB.immTracer = TraceImmutableDBEvent >$< tr + } + , cdbVolDbArgs = (cdbVolDbArgs args) { + VolatileDB.volCheckIntegrity = nodeCheckIntegrity (configStorage cfg) + , VolatileDB.volTracer = TraceVolatileDBEvent >$< tr + } + , cdbLgrDbArgs = (cdbLgrDbArgs args) { + LedgerDB.lgrTracer = TraceSnapshotEvent >$< tr + } + , cdbsArgs = (cdbsArgs args) { + cdbsCheckInFuture = InFuture.reference (configLedger cfg) InFuture.defaultClockSkew (OracularClock.finiteSystemTime clock) - , cdbTracer = instrumentationTracer <> nullDebugTracer - , cdbTraceLedger = nullDebugTracer - -- TODO: Vary cdbGcDelay, cdbGcInterval, cdbBlockToAddSize - , cdbGcDelay = 0 + -- TODO: Vary cdbsGcDelay, cdbsGcInterval, cdbsBlockToAddSize + , cdbsGcDelay = 0 + , cdbsTracer = instrumentationTracer <> nullDebugTracer + } } where prj af = case AF.headBlockNo af of diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index a44c301c90..2e2433e19d 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -31,9 +31,9 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainDbView, import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB -import Ouroboros.Consensus.Storage.ChainDB.Impl - (ChainDbArgs (cdbTracer), cdbLoE) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB.Impl +import Ouroboros.Consensus.Storage.ChainDB.Impl.Args + (ChainDbSpecificArgs (cdbsLoE), updateTracer) import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike (IOLike, MonadDelay (threadDelay), MonadSTM (atomically), @@ -288,19 +288,18 @@ mkChainDb :: m (ChainDB m TestBlock) mkChainDb schedulerConfig tracer nodeCfg registry updateLoEFrag = do chainDbArgs <- do - mcdbNodeDBs <- emptyNodeDBs - pure $ ( - fromMinimalChainDbArgs MinimalChainDbArgs { - mcdbTopLevelConfig = nodeCfg - , mcdbChunkInfo = mkTestChunkInfo nodeCfg - , mcdbInitLedger = testInitExtLedger - , mcdbRegistry = registry - , mcdbNodeDBs - } - ) { - cdbTracer = Tracer (traceWith tracer . TraceChainDBEvent), - cdbLoE - } + mcdbNodeDBs <- emptyNodeDBs + let args = updateTracer + (Tracer (traceWith tracer . TraceChainDBEvent)) + (fromMinimalChainDbArgs MinimalChainDbArgs { + mcdbTopLevelConfig = nodeCfg + , mcdbChunkInfo = mkTestChunkInfo nodeCfg + , mcdbInitLedger = testInitExtLedger + , mcdbRegistry = registry + , mcdbNodeDBs + } + ) + pure $ args { ChainDB.Impl.cdbsArgs = (ChainDB.Impl.cdbsArgs args) { cdbsLoE } } (_, (chainDB, ChainDB.Impl.Internal{intAddBlockRunner})) <- allocate registry @@ -309,6 +308,6 @@ mkChainDb schedulerConfig tracer nodeCfg registry updateLoEFrag = do _ <- forkLinkedThread registry "AddBlockRunner" intAddBlockRunner pure chainDB where - cdbLoE + cdbsLoE | scEnableLoE schedulerConfig = LoEEnabled updateLoEFrag | otherwise = LoEDisabled diff --git a/ouroboros-consensus/changelog.d/chaindb-args-javier.md b/ouroboros-consensus/changelog.d/chaindb-args-javier.md new file mode 100644 index 0000000000..1272ab5321 --- /dev/null +++ b/ouroboros-consensus/changelog.d/chaindb-args-javier.md @@ -0,0 +1,18 @@ +### Breaking + +- Tweak the ChainDB arguments: + - Remove unused fields in `CDB`: + - `cdbTraceLedger` this was *always* set to nullTracer, furthermore it would trace the whole LedgerDB. + - `cdbChunkInfo` was never accessed from the ChainDB. + - `cdbCheckIntegrity` was never accessed from the ChainDB. + - Transform `ChainDbArgs` into an isomorphic product of the different arguments of the inner databases. + - Define most common operations on `ChainDbArgs` as separate functions: `ensureValidateAll`, `updateTracer` and `updateDiskPolicyArgs` +- Tweak the LgrDB arguments: + - `LgrDB.cfg` and `LgrDbArgs.lgrConfig` are now `LedgerDbCfg (ExtLedgerState blk)` instead of `TopLevelConfig blk`. + - `defaultArgs` no longer expects a filesystem. +- Tweak the ImmutableDB arguments: + - `defaultArgs` no longer expects a filesystem. +- Tweak the VolatileDB arguments: + - `defaultArgs` no longer expects a filesystem. +- Hide the `Identity`/`Defaults` types in `Ouroboros.Consensus.Util.Args` in favor of `Complete`/`Incomplete`. +- Expose `noDefault` to replace `NoDefault`. 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 89e89f1d95..0f72980aa1 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 @@ -121,7 +121,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do immutableDB <- ImmutableDB.openDB argsImmutableDb $ innerOpenCont ImmutableDB.closeDB immutableDbTipPoint <- lift $ atomically $ ImmutableDB.getTipPoint immutableDB let immutableDbTipChunk = - chunkIndexOfPoint (Args.cdbChunkInfo args) immutableDbTipPoint + chunkIndexOfPoint (ImmutableDB.immChunkInfo argsImmutableDb) immutableDbTipPoint lift $ traceWith tracer $ TraceOpenEvent $ OpenedImmutableDB immutableDbTipPoint immutableDbTipChunk @@ -153,16 +153,15 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do volatileDB lgrDB initChainSelTracer - (Args.cdbTopLevelConfig args) + (Args.cdbsTopLevelConfig cdbSpecificArgs) varInvalid varFutureBlocks - (Args.cdbCheckInFuture args) - (Args.cdbLoE args) + (Args.cdbsCheckInFuture cdbSpecificArgs) + (Args.cdbsLoE cdbSpecificArgs) traceWith initChainSelTracer InitialChainSelected let chain = VF.validatedFragment chainAndLedger ledger = VF.validatedLedger chainAndLedger - cfg = Args.cdbTopLevelConfig args atomically $ LgrDB.setCurrent lgrDB ledger varChain <- newTVarIO chain @@ -175,7 +174,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do varKillBgThreads <- newTVarIO $ return () copyFuse <- newFuse "copy to immutable db" chainSelFuse <- newFuse "chain selection" - chainSelQueue <- newChainSelQueue (Args.cdbBlocksToAddSize args) + chainSelQueue <- newChainSelQueue (Args.cdbsBlocksToAddSize cdbSpecificArgs) let env = CDB { cdbImmutableDB = immutableDB , cdbVolatileDB = volatileDB @@ -185,24 +184,21 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , cdbTentativeHeader = varTentativeHeader , cdbIterators = varIterators , cdbFollowers = varFollowers - , cdbTopLevelConfig = cfg + , cdbTopLevelConfig = Args.cdbsTopLevelConfig cdbSpecificArgs , cdbInvalid = varInvalid , cdbNextIteratorKey = varNextIteratorKey , cdbNextFollowerKey = varNextFollowerKey , cdbCopyFuse = copyFuse , cdbChainSelFuse = chainSelFuse , cdbTracer = tracer - , cdbTraceLedger = Args.cdbTraceLedger args - , cdbRegistry = Args.cdbRegistry args - , cdbGcDelay = Args.cdbGcDelay args - , cdbGcInterval = Args.cdbGcInterval args + , cdbRegistry = Args.cdbsRegistry cdbSpecificArgs + , cdbGcDelay = Args.cdbsGcDelay cdbSpecificArgs + , cdbGcInterval = Args.cdbsGcInterval cdbSpecificArgs , cdbKillBgThreads = varKillBgThreads - , cdbChunkInfo = Args.cdbChunkInfo args - , cdbCheckIntegrity = Args.cdbCheckIntegrity args - , cdbCheckInFuture = Args.cdbCheckInFuture args + , cdbCheckInFuture = Args.cdbsCheckInFuture cdbSpecificArgs , cdbChainSelQueue = chainSelQueue , cdbFutureBlocks = varFutureBlocks - , cdbLoE = Args.cdbLoE args + , cdbLoE = Args.cdbsLoE cdbSpecificArgs } h <- fmap CDBHandle $ newTVarIO $ ChainDbOpen env let chainDB = API.ChainDB @@ -241,12 +237,12 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do return (chainDB, testing, env) - _ <- lift $ allocate (Args.cdbRegistry args) (\_ -> return $ chainDB) API.closeDB + _ <- lift $ allocate (Args.cdbsRegistry cdbSpecificArgs) (\_ -> return $ chainDB) API.closeDB return ((chainDB, testing), env) where - tracer = Args.cdbTracer args - (argsImmutableDb, argsVolatileDb, argsLgrDb, _) = Args.fromChainDbArgs args + tracer = Args.cdbsTracer cdbSpecificArgs + Args.ChainDbArgs argsImmutableDb argsVolatileDb argsLgrDb cdbSpecificArgs = args -- | We use 'runInnerWithTempRegistry' for the component databases. innerOpenCont :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index 1bcf7295e1..a13a2f0b0d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -1,34 +1,41 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} module Ouroboros.Consensus.Storage.ChainDB.Impl.Args ( ChainDbArgs (..) , ChainDbSpecificArgs (..) , RelativeMountPoint (..) + , completeChainDbArgs , defaultArgs - -- * Internal - , fromChainDbArgs + , ensureValidateAll + , updateDiskPolicyArgs + , updateTracer ) where -import Control.Tracer (Tracer, contramap, nullTracer) -import Data.Time.Clock (DiffTime, secondsToDiffTime) +import Control.Tracer (Tracer, nullTracer) +import Data.Functor.Contravariant ((>$<)) +import Data.Kind +import Data.Time.Clock (secondsToDiffTime) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Fragment.InFuture (CheckInFuture) import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API (LoE (LoEDisabled)) -import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (LedgerDB') -import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LgrDB +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LedgerDB import Ouroboros.Consensus.Storage.ChainDB.Impl.Types (TraceEvent (..)) -import Ouroboros.Consensus.Storage.ImmutableDB (ChunkInfo) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB -import Ouroboros.Consensus.Storage.LedgerDB (DiskPolicyArgs) +import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args +import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import System.FS.API @@ -37,55 +44,25 @@ import System.FS.API -------------------------------------------------------------------------------} data ChainDbArgs f m blk = ChainDbArgs { - - -- HasFS instances - cdbHasFSImmutableDB :: SomeHasFS m - , cdbHasFSVolatileDB :: SomeHasFS m - , cdbHasFSLgrDB :: SomeHasFS m - , cdbHasFSGsmDB :: SomeHasFS m - - -- Policy - , cdbImmutableDbValidation :: ImmutableDB.ValidationPolicy - -- ^ Which chunks of the ImmutableDB to validate on opening: all chunks, or - -- only the most recent chunk? - , cdbVolatileDbValidation :: VolatileDB.BlockValidationPolicy - -- ^ Should the parser for the VolatileDB fail when it encounters a - -- corrupt/invalid block? - , cdbMaxBlocksPerFile :: VolatileDB.BlocksPerFile - , cdbDiskPolicyArgs :: DiskPolicyArgs - - -- Integration - , cdbTopLevelConfig :: HKD f (TopLevelConfig blk) - , cdbChunkInfo :: HKD f ChunkInfo - , cdbCheckIntegrity :: HKD f (blk -> Bool) - -- ^ Predicate to check for integrity of - -- 'Ouroboros.Consensus.Storage.Common.GetVerifiedBlock' components when - -- extracting them from both the VolatileDB and the ImmutableDB. - , cdbGenesis :: HKD f (m (ExtLedgerState blk)) - , cdbCheckInFuture :: HKD f (CheckInFuture m blk) - , cdbImmutableDbCacheConfig :: ImmutableDB.CacheConfig - - -- Misc - , cdbTracer :: Tracer m (TraceEvent blk) - , cdbTraceLedger :: Tracer m (LedgerDB' blk) - , cdbRegistry :: HKD f (ResourceRegistry m) - , cdbGcDelay :: DiffTime - , cdbGcInterval :: DiffTime - , cdbBlocksToAddSize :: Word - -- ^ Size of the queue used to store asynchronously added blocks. This - -- is the maximum number of blocks that could be kept in memory at the - -- same time when the background thread processing the blocks can't keep - -- up. - - -- Limit on Eagerness - , cdbLoE :: LoE m blk - -- ^ The callback for advancing the LoE fragment, if enabled. - } + cdbImmDbArgs :: ImmutableDB.ImmutableDbArgs f m blk + , cdbVolDbArgs :: VolatileDB.VolatileDbArgs f m blk + , cdbLgrDbArgs :: LedgerDB.LgrDbArgs f m blk + , cdbsArgs :: ChainDbSpecificArgs f m blk + } -- | Arguments specific to the ChainDB, not to the ImmutableDB, VolatileDB, or -- LedgerDB. +type ChainDbSpecificArgs :: + (Type -> Type) + -> (Type -> Type) + -> Type + -> Type data ChainDbSpecificArgs f m blk = ChainDbSpecificArgs { cdbsBlocksToAddSize :: Word + -- ^ Size of the queue used to store asynchronously added blocks. This + -- is the maximum number of blocks that could be kept in memory at the + -- same time when the background thread processing the blocks can't keep + -- up. , cdbsCheckInFuture :: HKD f (CheckInFuture m blk) , cdbsGcDelay :: DiffTime -- ^ Delay between copying a block to the ImmutableDB and triggering a @@ -99,7 +76,8 @@ data ChainDbSpecificArgs f m blk = ChainDbSpecificArgs { -- 'cdbsGcInterval'. , cdbsRegistry :: HKD f (ResourceRegistry m) , cdbsTracer :: Tracer m (TraceEvent blk) - , cdbsHasFSGsmDB :: SomeHasFS m + , cdbsHasFSGsmDB :: HKD f (SomeHasFS m) + , cdbsTopLevelConfig :: HKD f (TopLevelConfig blk) , cdbsLoE :: LoE m blk } @@ -125,18 +103,16 @@ data ChainDbSpecificArgs f m blk = ChainDbSpecificArgs { -- have, because of batching) < the number of blocks sync in @gcInterval@. -- E.g., when syncing at 1k-2k blocks/s, this means 10k-20k blocks. During -- normal operation, we receive 1 block/20s, meaning at most 1 block. -defaultSpecificArgs :: - Monad m - => (RelativeMountPoint -> SomeHasFS m) - -> ChainDbSpecificArgs Defaults m blk -defaultSpecificArgs mkFS = ChainDbSpecificArgs { +defaultSpecificArgs :: Monad m => Incomplete ChainDbSpecificArgs m blk +defaultSpecificArgs = ChainDbSpecificArgs { cdbsBlocksToAddSize = 10 - , cdbsCheckInFuture = NoDefault + , cdbsCheckInFuture = noDefault , cdbsGcDelay = secondsToDiffTime 60 , cdbsGcInterval = secondsToDiffTime 10 - , cdbsRegistry = NoDefault + , cdbsRegistry = noDefault , cdbsTracer = nullTracer - , cdbsHasFSGsmDB = mkFS $ RelativeMountPoint "gsm" + , cdbsHasFSGsmDB = noDefault + , cdbsTopLevelConfig = noDefault , cdbsLoE = LoEDisabled } @@ -146,111 +122,94 @@ defaultSpecificArgs mkFS = ChainDbSpecificArgs { -- and 'defaultSpecificArgs' for a list of which fields are not given a default -- and must therefore be set explicitly. defaultArgs :: - forall m blk. + forall m blk . Monad m - => (RelativeMountPoint -> SomeHasFS m) - -> ChainDbArgs Defaults m blk -defaultArgs mkFS = - toChainDbArgs (ImmutableDB.defaultArgs immFS) - (VolatileDB.defaultArgs volFS) - (LgrDB.defaultArgs lgrFS) - (defaultSpecificArgs mkFS) - where - immFS, volFS, lgrFS :: SomeHasFS m - - immFS = mkFS $ RelativeMountPoint "immutable" - volFS = mkFS $ RelativeMountPoint "volatile" - lgrFS = mkFS $ RelativeMountPoint "ledger" - --- | Internal: split 'ChainDbArgs' into 'ImmutableDbArgs', 'VolatileDbArgs, --- 'LgrDbArgs', and 'ChainDbSpecificArgs'. -fromChainDbArgs :: - forall m blk f. MapHKD f - => ChainDbArgs f m blk - -> ( ImmutableDB.ImmutableDbArgs f m blk - , VolatileDB.VolatileDbArgs f m blk - , LgrDB.LgrDbArgs f m blk - , ChainDbSpecificArgs f m blk - ) -fromChainDbArgs ChainDbArgs{..} = ( - ImmutableDB.ImmutableDbArgs { - immCacheConfig = cdbImmutableDbCacheConfig - , immCheckIntegrity = cdbCheckIntegrity - , immChunkInfo = cdbChunkInfo - , immCodecConfig = mapHKD (Proxy @(f (CodecConfig blk))) configCodec cdbTopLevelConfig - , immHasFS = cdbHasFSImmutableDB - , immRegistry = cdbRegistry - , immTracer = contramap TraceImmutableDBEvent cdbTracer - , immValidationPolicy = cdbImmutableDbValidation - } - , VolatileDB.VolatileDbArgs { - volCheckIntegrity = cdbCheckIntegrity - , volCodecConfig = mapHKD (Proxy @(f (CodecConfig blk))) configCodec cdbTopLevelConfig - , volHasFS = cdbHasFSVolatileDB - , volMaxBlocksPerFile = cdbMaxBlocksPerFile - , volValidationPolicy = cdbVolatileDbValidation - , volTracer = contramap TraceVolatileDBEvent cdbTracer - } - , LgrDB.LgrDbArgs { - lgrTopLevelConfig = cdbTopLevelConfig - , lgrHasFS = cdbHasFSLgrDB - , lgrDiskPolicyArgs = cdbDiskPolicyArgs - , lgrGenesis = cdbGenesis - , lgrTracer = contramap TraceSnapshotEvent cdbTracer - , lgrTraceLedger = cdbTraceLedger - } - , ChainDbSpecificArgs { - cdbsTracer = cdbTracer - , cdbsRegistry = cdbRegistry - , cdbsGcDelay = cdbGcDelay - , cdbsGcInterval = cdbGcInterval - , cdbsCheckInFuture = cdbCheckInFuture - , cdbsBlocksToAddSize = cdbBlocksToAddSize - , cdbsHasFSGsmDB = cdbHasFSGsmDB - , cdbsLoE = cdbLoE - } - ) - --- | Internal: construct 'ChainDbArgs' from 'ImmutableDbArgs', 'VolatileDbArgs, --- 'LgrDbArgs', and 'ChainDbSpecificArgs'. --- --- Useful in 'defaultArgs' -toChainDbArgs :: - ImmutableDB.ImmutableDbArgs f m blk - -> VolatileDB.VolatileDbArgs f m blk - -> LgrDB.LgrDbArgs f m blk - -> ChainDbSpecificArgs f m blk - -> ChainDbArgs f m blk -toChainDbArgs ImmutableDB.ImmutableDbArgs {..} - VolatileDB.VolatileDbArgs {..} - LgrDB.LgrDbArgs {..} - ChainDbSpecificArgs {..} = ChainDbArgs{ - -- HasFS instances - cdbHasFSImmutableDB = immHasFS - , cdbHasFSVolatileDB = volHasFS - , cdbHasFSLgrDB = lgrHasFS - , cdbHasFSGsmDB = cdbsHasFSGsmDB - -- Policy - , cdbImmutableDbValidation = immValidationPolicy - , cdbVolatileDbValidation = volValidationPolicy - , cdbMaxBlocksPerFile = volMaxBlocksPerFile - , cdbDiskPolicyArgs = lgrDiskPolicyArgs - -- Integration - , cdbTopLevelConfig = lgrTopLevelConfig - , cdbChunkInfo = immChunkInfo - , cdbCheckIntegrity = immCheckIntegrity - , cdbGenesis = lgrGenesis - , cdbCheckInFuture = cdbsCheckInFuture - , cdbImmutableDbCacheConfig = immCacheConfig - -- Misc - , cdbTracer = cdbsTracer - , cdbTraceLedger = lgrTraceLedger - , cdbRegistry = cdbsRegistry - , cdbGcDelay = cdbsGcDelay - , cdbGcInterval = cdbsGcInterval - , cdbBlocksToAddSize = cdbsBlocksToAddSize - , cdbLoE = cdbsLoE - } + => Incomplete ChainDbArgs m blk +defaultArgs = + ChainDbArgs ImmutableDB.defaultArgs + VolatileDB.defaultArgs + LedgerDB.defaultArgs + defaultSpecificArgs + +ensureValidateAll :: + ChainDbArgs f m blk + -> ChainDbArgs f m blk +ensureValidateAll args = + args { cdbImmDbArgs = (cdbImmDbArgs args) { + ImmutableDB.immValidationPolicy = ImmutableDB.ValidateAllChunks + } + , cdbVolDbArgs = (cdbVolDbArgs args) { + VolatileDB.volValidationPolicy = VolatileDB.ValidateAll + } + } + +completeChainDbArgs :: + forall m blk. (ConsensusProtocol (BlockProtocol blk), IOLike m) + => ResourceRegistry m + -> CheckInFuture m blk + -> TopLevelConfig blk + -> ExtLedgerState blk + -- ^ Initial ledger + -> ImmutableDB.ChunkInfo + -> (blk -> Bool) + -- ^ Check integrity + -> (RelativeMountPoint -> SomeHasFS m) + -> Incomplete ChainDbArgs m blk + -- ^ A set of incomplete arguments, possibly modified wrt @defaultArgs@ + -> Complete ChainDbArgs m blk +completeChainDbArgs + registry + cdbsCheckInFuture + cdbsTopLevelConfig + initLedger + immChunkInfo + checkIntegrity + mkFS + defArgs + = defArgs { + cdbImmDbArgs = (cdbImmDbArgs defArgs) { + ImmutableDB.immChunkInfo + , ImmutableDB.immCheckIntegrity = checkIntegrity + , ImmutableDB.immRegistry = registry + , ImmutableDB.immCodecConfig = configCodec cdbsTopLevelConfig + , ImmutableDB.immHasFS = mkFS $ RelativeMountPoint "immutable" + } + , cdbVolDbArgs = (cdbVolDbArgs defArgs) { + VolatileDB.volHasFS = mkFS $ RelativeMountPoint "volatile" + , VolatileDB.volCheckIntegrity = checkIntegrity + , VolatileDB.volCodecConfig = configCodec cdbsTopLevelConfig + } + , cdbLgrDbArgs = (cdbLgrDbArgs defArgs) { + LedgerDB.lgrGenesis = pure initLedger + , LedgerDB.lgrHasFS = mkFS $ RelativeMountPoint "ledger" + , LedgerDB.lgrConfig = LedgerDB.configLedgerDb cdbsTopLevelConfig + } + , cdbsArgs = (cdbsArgs defArgs) { + cdbsCheckInFuture + , cdbsRegistry = registry + , cdbsTopLevelConfig + , cdbsHasFSGsmDB = mkFS $ RelativeMountPoint "gsm" + } + } + +updateTracer :: + Tracer m (TraceEvent blk) + -> ChainDbArgs f m blk + -> ChainDbArgs f m blk +updateTracer trcr args = + args { + cdbImmDbArgs = (cdbImmDbArgs args) { ImmutableDB.immTracer = TraceImmutableDBEvent >$< trcr } + , cdbVolDbArgs = (cdbVolDbArgs args) { VolatileDB.volTracer = TraceVolatileDBEvent >$< trcr } + , cdbLgrDbArgs = (cdbLgrDbArgs args) { LedgerDB.lgrTracer = TraceSnapshotEvent >$< trcr } + , cdbsArgs = (cdbsArgs args) { cdbsTracer = trcr } + } + +updateDiskPolicyArgs :: + DiskPolicyArgs + -> ChainDbArgs f m blk + -> ChainDbArgs f m blk +updateDiskPolicyArgs spa args = + args { cdbLgrDbArgs = (cdbLgrDbArgs args) { LedgerDB.lgrDiskPolicyArgs = spa } } {------------------------------------------------------------------------------- Relative mount points diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 9d0e5e8546..b00ea9ba97 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -911,7 +911,6 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ do mkTraceEvent events selChangedInfo curChain newChain whenJust (strictMaybeToMaybe prevTentativeHeader) $ traceWith $ PipeliningEvent . OutdatedTentativeHeader >$< addBlockTracer - traceWith cdbTraceLedger newLedger return $ castPoint $ AF.headPoint newChain where 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 9c897020ed..205715f589 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 @@ -98,7 +98,7 @@ data LgrDB m blk = LgrDB { -- this set. , resolveBlock :: !(RealPoint blk -> m blk) -- ^ Read a block from disk - , cfg :: !(TopLevelConfig blk) + , cfg :: !(LedgerDB.LedgerDbCfg (ExtLedgerState blk)) , diskPolicy :: !LedgerDB.DiskPolicy , hasFS :: !(SomeHasFS m) , tracer :: !(Tracer m (LedgerDB.TraceSnapshotEvent blk)) @@ -126,23 +126,18 @@ type LgrDbSerialiseConstraints blk = data LgrDbArgs f m blk = LgrDbArgs { lgrDiskPolicyArgs :: LedgerDB.DiskPolicyArgs , lgrGenesis :: HKD f (m (ExtLedgerState blk)) - , lgrHasFS :: SomeHasFS m - , lgrTopLevelConfig :: HKD f (TopLevelConfig blk) - , lgrTraceLedger :: Tracer m (LedgerDB' blk) + , lgrHasFS :: HKD f (SomeHasFS m) + , lgrConfig :: HKD f (LedgerDB.LedgerDbCfg (ExtLedgerState blk)) , lgrTracer :: Tracer m (LedgerDB.TraceSnapshotEvent blk) } -- | Default arguments -defaultArgs :: - Applicative m - => SomeHasFS m - -> LgrDbArgs Defaults m blk -defaultArgs lgrHasFS = LgrDbArgs { +defaultArgs :: Applicative m => Incomplete LgrDbArgs m blk +defaultArgs = LgrDbArgs { lgrDiskPolicyArgs = LedgerDB.defaultDiskPolicyArgs - , lgrGenesis = NoDefault - , lgrHasFS - , lgrTopLevelConfig = NoDefault - , lgrTraceLedger = nullTracer + , lgrGenesis = noDefault + , lgrHasFS = noDefault + , lgrConfig = noDefault , lgrTracer = nullTracer } @@ -157,7 +152,7 @@ openDB :: forall m blk. , InspectLedger blk , HasCallStack ) - => LgrDbArgs Identity m blk + => Complete LgrDbArgs m blk -- ^ Stateless initializaton arguments -> Tracer m (LedgerDB.ReplayGoal blk -> LedgerDB.TraceReplayEvent blk) -- ^ Used to trace the progress while replaying blocks against the @@ -203,8 +198,8 @@ openDB args@LgrDbArgs { lgrHasFS = lgrHasFS@(SomeHasFS hasFS), .. } replayTracer varDB = varDB , varPrevApplied = varPrevApplied , resolveBlock = getBlock - , cfg = lgrTopLevelConfig - , diskPolicy = let k = configSecurityParam lgrTopLevelConfig + , cfg = lgrConfig + , diskPolicy = let k = LedgerDB.ledgerDbCfgSecParam lgrConfig in LedgerDB.mkDiskPolicy k lgrDiskPolicyArgs , hasFS = lgrHasFS , tracer = lgrTracer @@ -220,7 +215,7 @@ initFromDisk :: , InspectLedger blk , HasCallStack ) - => LgrDbArgs Identity m blk + => Complete LgrDbArgs m blk -> Tracer m (LedgerDB.ReplayGoal blk -> LedgerDB.TraceReplayEvent blk) -> ImmutableDB m blk -> m (LedgerDB' blk, Word64) @@ -234,24 +229,24 @@ initFromDisk LgrDbArgs { lgrHasFS = hasFS, .. } hasFS (decodeDiskExtLedgerState ccfg) decode - (LedgerDB.configLedgerDb lgrTopLevelConfig) + lgrConfig lgrGenesis (streamAPI immutableDB) return (db, replayed) where - ccfg = configCodec lgrTopLevelConfig + ccfg = configCodec $ getExtLedgerCfg $ LedgerDB.ledgerDbCfg lgrConfig -- | For testing purposes mkLgrDB :: StrictTVar m (LedgerDB' blk) -> StrictTVar m (Set (RealPoint blk)) -> (RealPoint blk -> m blk) - -> LgrDbArgs Identity m blk + -> Complete LgrDbArgs m blk -> SecurityParam -> LgrDB m blk mkLgrDB varDB varPrevApplied resolveBlock args k = LgrDB {..} where LgrDbArgs { - lgrTopLevelConfig = cfg + lgrConfig = cfg , lgrDiskPolicyArgs = diskPolicyArgs , lgrHasFS = hasFS , lgrTracer = tracer @@ -293,7 +288,7 @@ takeSnapshot lgrDB@LgrDB{ cfg, tracer, hasFS } = wrapFailure (Proxy @blk) $ do (encodeDiskExtLedgerState ccfg) ledgerDB where - ccfg = configCodec cfg + ccfg = configCodec $ getExtLedgerCfg $ LedgerDB.ledgerDbCfg cfg trimSnapshots :: forall m blk. (MonadCatch m, HasHeader blk) @@ -328,7 +323,7 @@ validate LgrDB{..} ledgerDB blockCache numRollbacks trace = \hdrs -> do aps <- mkAps hdrs <$> atomically (readTVar varPrevApplied) res <- fmap rewrap $ LedgerDB.defaultResolveWithErrors resolveBlock $ LedgerDB.ledgerDbSwitch - (LedgerDB.configLedgerDb cfg) + cfg numRollbacks (lift . lift . trace) aps 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 bb8cc842b1..e781c1c5c0 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 @@ -88,8 +88,8 @@ import Ouroboros.Consensus.Storage.ChainDB.API (AddBlockPromise (..), UnknownRange) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment (InvalidBlockPunishment) -import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (LedgerDB', - LgrDB, LgrDbSerialiseConstraints) +import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (LgrDB, + LgrDbSerialiseConstraints) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LgrDB import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB, ImmutableDbSerialiseConstraints) @@ -237,7 +237,6 @@ data ChainDbEnv m blk = CDB , cdbCopyFuse :: !(Fuse m) , cdbChainSelFuse :: !(Fuse m) , cdbTracer :: !(Tracer m (TraceEvent blk)) - , cdbTraceLedger :: !(Tracer m (LedgerDB' blk)) , cdbRegistry :: !(ResourceRegistry m) -- ^ Resource registry that will be used to (re)start the background -- threads, see 'cdbBgThreads'. @@ -249,8 +248,6 @@ data ChainDbEnv m blk = CDB -- garbage collections. , cdbKillBgThreads :: !(StrictTVar m (m ())) -- ^ A handle to kill the background threads. - , cdbChunkInfo :: !ImmutableDB.ChunkInfo - , cdbCheckIntegrity :: !(blk -> Bool) , cdbCheckInFuture :: !(CheckInFuture m blk) , cdbChainSelQueue :: !(ChainSelQueue m blk) -- ^ Queue of blocks that still have to be added. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs index 3040555c05..337e95c64f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs @@ -138,24 +138,29 @@ import System.FS.CRC data ImmutableDbArgs f m blk = ImmutableDbArgs { immCacheConfig :: Index.CacheConfig + -- | Predicate to check for integrity of + -- 'Ouroboros.Consensus.Storage.Common.GetVerifiedBlock' components when + -- extracting them from the ImmutableDB. , immCheckIntegrity :: HKD f (blk -> Bool) , immChunkInfo :: HKD f ChunkInfo , immCodecConfig :: HKD f (CodecConfig blk) - , immHasFS :: SomeHasFS m + , immHasFS :: HKD f (SomeHasFS m) , immRegistry :: HKD f (ResourceRegistry m) , immTracer :: Tracer m (TraceEvent blk) + -- | Which chunks of the ImmutableDB to validate on opening: all chunks, or + -- only the most recent chunk? , immValidationPolicy :: ValidationPolicy } -- | Default arguments -defaultArgs :: Applicative m => SomeHasFS m -> ImmutableDbArgs Defaults m blk -defaultArgs immHasFS = ImmutableDbArgs { +defaultArgs :: Applicative m => Incomplete ImmutableDbArgs m blk +defaultArgs = ImmutableDbArgs { immCacheConfig = cacheConfig - , immCheckIntegrity = NoDefault - , immChunkInfo = NoDefault - , immCodecConfig = NoDefault - , immHasFS - , immRegistry = NoDefault + , immCheckIntegrity = noDefault + , immChunkInfo = noDefault + , immCodecConfig = noDefault + , immHasFS = noDefault + , immRegistry = noDefault , immTracer = nullTracer , immValidationPolicy = ValidateMostRecentChunk } @@ -216,7 +221,7 @@ openDB :: , ImmutableDbSerialiseConstraints blk , HasCallStack ) - => ImmutableDbArgs Identity m blk + => Complete ImmutableDbArgs m blk -> (forall st. WithTempRegistry st m (ImmutableDB m blk, st) -> ans) -> ans openDB args cont = @@ -235,7 +240,7 @@ openDBInternal :: , ImmutableDbSerialiseConstraints blk , HasCallStack ) - => ImmutableDbArgs Identity m blk + => Complete ImmutableDbArgs m blk -> (forall h. WithTempRegistry (OpenState m blk h) 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 c0a582d3c8..1a1378078e 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 @@ -153,20 +153,25 @@ import System.FS.API.Lazy ------------------------------------------------------------------------------} data VolatileDbArgs f m blk = VolatileDbArgs { + -- | Predicate to check for integrity of + -- 'Ouroboros.Consensus.Storage.Common.GetVerifiedBlock' components when + -- extracting them from the VolatileDB. volCheckIntegrity :: HKD f (blk -> Bool) , volCodecConfig :: HKD f (CodecConfig blk) - , volHasFS :: SomeHasFS m + , volHasFS :: HKD f (SomeHasFS m) , volMaxBlocksPerFile :: BlocksPerFile , volTracer :: Tracer m (TraceEvent blk) + -- | Should the parser for the VolatileDB fail when it encounters a + -- corrupt/invalid block? , volValidationPolicy :: BlockValidationPolicy } -- | Default arguments -defaultArgs :: Applicative m => SomeHasFS m -> VolatileDbArgs Defaults m blk -defaultArgs volHasFS = VolatileDbArgs { - volCheckIntegrity = NoDefault - , volCodecConfig = NoDefault - , volHasFS +defaultArgs :: Applicative m => Incomplete VolatileDbArgs m blk +defaultArgs = VolatileDbArgs { + volCheckIntegrity = noDefault + , volCodecConfig = noDefault + , volHasFS = noDefault , volMaxBlocksPerFile = mkBlocksPerFile 1000 , volTracer = nullTracer , volValidationPolicy = NoValidation @@ -188,7 +193,7 @@ openDB :: , GetPrevHash blk , VolatileDbSerialiseConstraints blk ) - => VolatileDbArgs Identity m blk + => Complete VolatileDbArgs m blk -> (forall st. WithTempRegistry st m (VolatileDB m blk, st) -> ans) -> ans openDB VolatileDbArgs { volHasFS = SomeHasFS hasFS, .. } cont = cont $ do 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 2352ae1b70..5b903a0515 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Args.hs @@ -13,18 +13,18 @@ -- > , hasDefault :: Bool -- > } -- > --- > defaultArgs :: Args Defaults +-- > defaultArgs :: Incomplete Args -- > defaultArgs = Args { --- > hasNoDefault = NoDefault +-- > hasNoDefault = noDefault -- > , hasDefault = False -- > } -- > --- > theArgs :: Args Identity +-- > theArgs :: Complete Args -- > theArgs = defaultArgs { -- > hasNoDefault = 0 -- > } -- > --- > useArgs :: Args Identity -> (Int, Bool) +-- > useArgs :: Complete Args -> (Int, Bool) -- > useArgs (Args a b) = (a, b) -- -- Leaving out the 'hasNoDefault' field from 'theArgs' will result in a type @@ -33,10 +33,10 @@ module Ouroboros.Consensus.Util.Args ( Defaults (..) , HKD , MapHKD (..) - -- * Re-exported for convenience + -- * Types , Complete - , Identity (..) , Incomplete + , noDefault ) where import Data.Functor.Identity (Identity (..)) @@ -45,6 +45,9 @@ import Data.Kind data Defaults t = NoDefault deriving (Functor) +noDefault :: Defaults t +noDefault = NoDefault + type family HKD f a where HKD Identity a = a HKD f a = f a diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index 23fc059b02..95181fdbb8 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -14,26 +14,32 @@ module Test.Util.ChainDB ( import Control.Tracer (nullTracer) -import Data.Functor.Identity (Identity) +import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config - (TopLevelConfig (topLevelConfigLedger)) + (TopLevelConfig (topLevelConfigLedger), configCodec) import Ouroboros.Consensus.Fragment.InFuture (CheckInFuture (..)) import qualified Ouroboros.Consensus.Fragment.Validated as VF import Ouroboros.Consensus.HardFork.History.EraParams (eraEpochSize) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) +import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB hiding (TraceFollowerEvent (..)) +import Ouroboros.Consensus.Storage.ChainDB.Impl.Args +import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB +import Ouroboros.Consensus.Storage.ImmutableDB import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB -import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal - (simpleChunkInfo) -import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB (configLedgerDb) +import qualified Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy as LedgerDB +import Ouroboros.Consensus.Storage.VolatileDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB +import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike hiding (invariant) import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import System.FS.API (SomeHasFS (..)) import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS import System.FS.Sim.STM (simHasFS) +import Test.Util.Orphans.NoThunks () import Test.Util.TestBlock (TestBlock, TestBlockLedgerConfig (..)) -- | A vector with an element for each database of a node @@ -77,38 +83,53 @@ mkTestChunkInfo = simpleChunkInfo . eraEpochSize . tblcHardForkParams . topLevel fromMinimalChainDbArgs :: ( MonadThrow m , MonadSTM m + , ConsensusProtocol (BlockProtocol blk) ) - => MinimalChainDbArgs m blk -> ChainDbArgs Identity m blk + => MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk fromMinimalChainDbArgs MinimalChainDbArgs {..} = ChainDbArgs { - cdbHasFSImmutableDB = SomeHasFS $ simHasFS (nodeDBsImm mcdbNodeDBs') - , cdbHasFSVolatileDB = SomeHasFS $ simHasFS (nodeDBsVol mcdbNodeDBs') - , cdbHasFSLgrDB = SomeHasFS $ simHasFS (nodeDBsLgr mcdbNodeDBs') - , cdbHasFSGsmDB = SomeHasFS $ simHasFS (nodeDBsGsm mcdbNodeDBs') - - , cdbImmutableDbValidation = ImmutableDB.ValidateAllChunks - , cdbVolatileDbValidation = VolatileDB.ValidateAll - , cdbMaxBlocksPerFile = VolatileDB.mkBlocksPerFile 4 - , cdbDiskPolicyArgs = LedgerDB.defaultDiskPolicyArgs - -- Keep 2 ledger snapshots, and take a new snapshot at least every 2 * k seconds, where k is the - -- security parameter. - , cdbTopLevelConfig = mcdbTopLevelConfig - , cdbChunkInfo = mcdbChunkInfo - , cdbCheckIntegrity = const True - -- Getting a verified block component does not do any integrity checking, both for the - -- ImmutableDB, as the VolatileDB. This is done in @extractBlockComponent@ in the iterator for the - -- ImmutableDB, and in @getBlockComponent@ for the VolatileDB. - , cdbGenesis = return mcdbInitLedger - , cdbCheckInFuture = CheckInFuture $ \vf -> pure (VF.validatedFragment vf, []) - -- Blocks are never in the future. - , cdbImmutableDbCacheConfig = ImmutableDB.CacheConfig 2 60 - -- Cache at most 2 chunks and expire each chunk after 60 seconds of being unused. - , cdbTracer = nullTracer - , cdbTraceLedger = nullTracer - , cdbRegistry = mcdbRegistry - , cdbGcDelay = 1 - , cdbGcInterval = 1 - , cdbBlocksToAddSize = 1 - , cdbLoE = LoEDisabled - } - where - mcdbNodeDBs' = unsafeToUncheckedStrictTVar <$> mcdbNodeDBs + cdbImmDbArgs = ImmutableDbArgs { + immCacheConfig = ImmutableDB.CacheConfig 2 60 + -- Cache at most 2 chunks and expire each chunk after 60 seconds of + -- being unused. + , immCheckIntegrity = const True + -- Getting a verified block component does not do any integrity + -- checking, both for the ImmutableDB, as the VolatileDB. This is + -- done in @extractBlockComponent@ in the iterator for the + -- ImmutableDB, and in @getBlockComponent@ for the VolatileDB. + , immChunkInfo = mcdbChunkInfo + , immHasFS = SomeHasFS $ simHasFS (unsafeToUncheckedStrictTVar $ nodeDBsImm mcdbNodeDBs) + , immRegistry = mcdbRegistry + , immTracer = nullTracer + , immCodecConfig = configCodec mcdbTopLevelConfig + , immValidationPolicy = ImmutableDB.ValidateAllChunks + } + , cdbVolDbArgs = VolatileDbArgs { + volCheckIntegrity = const True + , volCodecConfig = configCodec mcdbTopLevelConfig + , volHasFS = SomeHasFS $ simHasFS (unsafeToUncheckedStrictTVar $ nodeDBsVol mcdbNodeDBs) + , volMaxBlocksPerFile = VolatileDB.mkBlocksPerFile 4 + , volTracer = nullTracer + , volValidationPolicy = VolatileDB.ValidateAll + } + , cdbLgrDbArgs = LgrDbArgs { + lgrDiskPolicyArgs = LedgerDB.DiskPolicyArgs LedgerDB.DefaultSnapshotInterval LedgerDB.DefaultNumOfDiskSnapshots + -- Keep 2 ledger snapshots, and take a new snapshot at least every 2 * + -- k seconds, where k is the security parameter. + , lgrGenesis = return mcdbInitLedger + , lgrHasFS = SomeHasFS $ simHasFS (unsafeToUncheckedStrictTVar $ nodeDBsLgr mcdbNodeDBs) + , lgrTracer = nullTracer + , lgrConfig = configLedgerDb mcdbTopLevelConfig + } + , cdbsArgs = ChainDbSpecificArgs { + cdbsBlocksToAddSize = 1 + , cdbsCheckInFuture = CheckInFuture $ \vf -> pure (VF.validatedFragment vf, []) + -- Blocks are never in the future + , cdbsGcDelay = 1 + , cdbsHasFSGsmDB = SomeHasFS $ simHasFS (unsafeToUncheckedStrictTVar $ nodeDBsGsm mcdbNodeDBs) + , cdbsGcInterval = 1 + , cdbsRegistry = mcdbRegistry + , cdbsTracer = nullTracer + , cdbsTopLevelConfig = mcdbTopLevelConfig + , cdbsLoE = LoEDisabled + } + } diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs index ca38b8c57a..bb52023607 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Util.Orphans.NoThunks () where @@ -12,6 +14,9 @@ import Data.Proxy import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Util.MonadSTM.NormalForm import Ouroboros.Consensus.Util.NormalForm.StrictMVar +import System.FS.API.Types +import System.FS.Sim.FsTree +import System.FS.Sim.MockFS instance NoThunks a => NoThunks (StrictSVar (IOSim s) a) where showTypeOf _ = "StrictSVar IOSim" @@ -30,3 +35,16 @@ instance NoThunks a => NoThunks (StrictTVar (IOSim s) a) where wNoThunks ctxt tvar = do a <- unsafeSTToIO $ lazyToStrictST $ inspectTVar (Proxy :: Proxy (IOSim s)) $ toLazyTVar tvar noThunks ctxt a + +{------------------------------------------------------------------------------- + fs-sim +-------------------------------------------------------------------------------} + +deriving instance NoThunks FsPath +deriving instance NoThunks MockFS +deriving instance NoThunks a => NoThunks (FsTree a) +deriving instance NoThunks HandleMock +deriving instance NoThunks HandleState +deriving instance NoThunks OpenHandleState +deriving instance NoThunks ClosedHandleState +deriving instance NoThunks FilePtr diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index 663ba8e7f3..b3aa0efe1e 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -41,8 +41,8 @@ import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..)) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB -import Ouroboros.Consensus.Storage.ChainDB.Impl (ChainDbArgs (..)) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDBImpl +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry @@ -246,7 +246,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do , mcdbNodeDBs = nodeDBs } -- TODO: Test with more interesting behaviour for cdbCheckInFuture - pure $ args { cdbTracer = cdbTracer } + pure $ ChainDB.updateTracer cdbTracer args (_, (chainDB, ChainDBImpl.Internal{intAddBlockRunner})) <- allocate registry diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index a59cb53bc2..381c99c8b3 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -38,7 +38,8 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCac import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (LgrDB, LgrDbArgs (..), mkLgrDB) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LgrDB -import Ouroboros.Consensus.Storage.LedgerDB (defaultDiskPolicyArgs) +import Ouroboros.Consensus.Storage.LedgerDB (configLedgerDb, + defaultDiskPolicyArgs) import qualified Ouroboros.Consensus.Storage.LedgerDB as LgrDB (ledgerDbPast, ledgerDbTip, ledgerDbWithAnchor) import Ouroboros.Consensus.Util.IOLike @@ -213,7 +214,7 @@ initLgrDB k chain = do blockMapping = Map.fromList [(blockRealPoint b, b) | b <- Chain.toOldestFirst chain] - cfg = testCfg k + cfg = configLedgerDb $ testCfg k genesisLedgerDB = LgrDB.ledgerDbWithAnchor testInitExtLedger @@ -221,12 +222,11 @@ initLgrDB k chain = do noopTrace = const $ pure () args = LgrDbArgs - { lgrTopLevelConfig = cfg + { lgrConfig = cfg , lgrHasFS = SomeHasFS (error "lgrHasFS" :: HasFS m ()) , lgrDiskPolicyArgs = defaultDiskPolicyArgs , lgrGenesis = return testInitExtLedger , lgrTracer = nullTracer - , lgrTraceLedger = nullTracer } testCfg :: SecurityParam -> TopLevelConfig TestBlock diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs index bb8b346b41..15559363dc 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs @@ -33,8 +33,8 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment -import Ouroboros.Consensus.Storage.ChainDB.Impl (ChainDbArgs (..)) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDBImpl +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike @@ -174,7 +174,7 @@ runFollowerPromptnessTest FollowerPromptnessTestSetup{..} = withRegistry \regist mcdbRegistry = registry mcdbNodeDBs <- emptyNodeDBs let cdbArgs = fromMinimalChainDbArgs MinimalChainDbArgs{..} - pure $ cdbArgs { cdbTracer = cdbTracer } + pure $ ChainDB.updateTracer cdbTracer cdbArgs (_, (chainDB, ChainDBImpl.Internal{intAddBlockRunner})) <- allocate registry diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 2e2a094877..000709d5ea 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -81,7 +81,7 @@ module Test.Ouroboros.Storage.ChainDB.StateMachine ( import Codec.Serialise (Serialise) import Control.Monad (replicateM, void) -import Control.Tracer +import Control.Tracer as CT import Data.Bifoldable import Data.Bifunctor import qualified Data.Bifunctor.TH as TH @@ -117,6 +117,7 @@ import Ouroboros.Consensus.Storage.ChainDB hiding (TraceFollowerEvent (..)) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Storage.Common (SizeInBytes) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal @@ -1545,8 +1546,15 @@ runCmdsLockstep maxClockSkew (SmallChunkInfo chunkInfo) cmds = varCurSlot <- uncheckedNewTVarM 0 varNextId <- uncheckedNewTVarM 0 nodeDBs <- emptyNodeDBs - let args = mkArgs testCfg chunkInfo testInitExtLedger threadRegistry nodeDBs tracer - maxClockSkew varCurSlot + let args = mkArgs + testCfg + chunkInfo + testInitExtLedger + threadRegistry + nodeDBs + tracer + maxClockSkew + varCurSlot (hist, model, res, trace) <- bracket (open args >>= newTVarIO) @@ -1687,7 +1695,7 @@ mkArgs :: IOLike m -> ExtLedgerState Blk -> ResourceRegistry m -> NodeDBs (StrictTVar m MockFS) - -> Tracer m (TraceEvent Blk) + -> CT.Tracer m (TraceEvent Blk) -> MaxClockSkew -> StrictTVar m SlotNo -> ChainDbArgs Identity m Blk @@ -1699,10 +1707,17 @@ mkArgs cfg chunkInfo initLedger registry nodeDBs tracer (MaxClockSkew maxClockSk , mcdbRegistry = registry , mcdbNodeDBs = nodeDBs } - in args { cdbCheckInFuture = InFuture.miracle (readTVar varCurSlot) maxClockSkew - , cdbCheckIntegrity = testBlockIsValid - , cdbBlocksToAddSize = 2 - , cdbTracer = tracer + in ChainDB.updateTracer tracer $ + args { cdbsArgs = (cdbsArgs args) { + ChainDB.cdbsCheckInFuture = InFuture.miracle (readTVar varCurSlot) maxClockSkew + , ChainDB.cdbsBlocksToAddSize = 2 + } + , cdbImmDbArgs = (cdbImmDbArgs args) { + ImmutableDB.immCheckIntegrity = testBlockIsValid + } + , cdbVolDbArgs = (cdbVolDbArgs args) { + VolatileDB.volCheckIntegrity = testBlockIsValid + } } tests :: TestTree diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs index 7e05399610..a0922ef467 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs @@ -35,6 +35,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API as API import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as API import Ouroboros.Consensus.Storage.ChainDB.Impl (TraceEvent) import Ouroboros.Consensus.Storage.ChainDB.Impl.Args +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Storage.Common (StreamFrom (..), StreamTo (..)) import Ouroboros.Consensus.Storage.ImmutableDB.Chunks as ImmutableDB @@ -424,7 +425,7 @@ withTestChainDbEnv topLevelConfig chunkInfo extLedgerState cont closeChainDbEnv (env, _) = do readTVarIO (varDB env) >>= close closeRegistry (registry env) - closeRegistry (cdbRegistry $ args env) + closeRegistry (cdbsRegistry $ cdbsArgs $ args env) chainDbArgs registry nodeDbs tracer = let args = fromMinimalChainDbArgs MinimalChainDbArgs @@ -434,7 +435,7 @@ withTestChainDbEnv topLevelConfig chunkInfo extLedgerState cont , mcdbRegistry = registry , mcdbNodeDBs = nodeDbs } - in args { cdbTracer = tracer } + in ChainDB.updateTracer tracer args instance IOLike m => SupportsUnitTest (SystemM blk m) where