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`.

ouroboros-consensus-cardano/changelog.d/chaindb-args-javier.md

@@ -0,0 +1 @@
+<!-- Empty to satisfy CI, only unstable libraries changed -->

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

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

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

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

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`

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