Some more cleanup

Author: jasagredo

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -84,7 +84,6 @@ library
     deepseq,
     filepath,
     blockio,
-    lsm-tree,
     fs-api ^>=0.4,
     hashable,
     io-classes:{io-classes, si-timers, strict-stm} ^>=1.8,

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

@@ -53,6 +53,7 @@ module Ouroboros.Consensus.Node
   , pattern DoDiskSnapshotChecksum
   , pattern NoDoDiskSnapshotChecksum
   , ChainSyncIdleTimeout (..)
+  , LedgerDbBackendArgs (..)
 
     -- * Internal helpers
   , mkNodeKernelArgs
@@ -126,9 +127,9 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
 import Ouroboros.Consensus.Storage.LedgerDB.Args
 import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.IOLike
-import System.FS.BlockIO.IO
 import Ouroboros.Consensus.Util.Orphans ()
 import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime)
 import Ouroboros.Network.BlockFetch
@@ -176,10 +177,10 @@ import qualified SafeWildCards
 import System.Exit (ExitCode (..))
 import System.FS.API (SomeHasFS (..))
 import System.FS.API.Types (MountPoint (..))
+import System.FS.BlockIO.IO
 import System.FS.IO (ioHasFS)
 import System.FilePath ((</>))
-import System.Random (StdGen, newStdGen, randomIO, split, genWord64, initStdGen)
-import qualified Database.LSMTree as LSM
+import System.Random (StdGen, genWord64, initStdGen, newStdGen, randomIO, split)
 
 {-------------------------------------------------------------------------------
   The arguments to the Consensus Layer node functionality
@@ -269,8 +270,6 @@ data LowLevelRunNodeArgs m addrNTN addrNTC blk
   , llrnMkVolatileHasFS :: ChainDB.RelativeMountPoint -> SomeHasFS m
   -- ^ File-system on which the directories for databases other than the ImmutableDB will
   -- be created.
-  , llrnMkLSMFS :: FilePath -> m (SomeHasFSAndBlockIO m)
-  , llrnGenSalt :: m LSM.Salt
   , llrnCustomiseChainDbArgs ::
       Complete ChainDbArgs m blk ->
       Complete ChainDbArgs m blk
@@ -379,7 +378,7 @@ data
   , -- Ad hoc values to replace default ChainDB configurations
     srnSnapshotPolicyArgs :: SnapshotPolicyArgs
   , srnQueryBatchSize :: QueryBatchSize
-  , srnLdbFlavorArgs :: Complete LedgerDbFlavorArgs m
+  , srnLdbFlavorArgs :: LedgerDbBackendArgs m
   }
 
 {-------------------------------------------------------------------------------
@@ -527,8 +526,6 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
               initLedger
               llrnMkImmutableHasFS
               llrnMkVolatileHasFS
-              llrnMkLSMFS
-              llrnGenSalt
               llrnLdbFlavorArgs
               llrnChainDbArgsDefaults
               ( setLoEinChainDbArgs
@@ -822,15 +819,13 @@ openChainDB ::
   (ChainDB.RelativeMountPoint -> SomeHasFS m) ->
   -- | Volatile FS, see 'NodeDatabasePaths'
   (ChainDB.RelativeMountPoint -> SomeHasFS m) ->
-  (FilePath -> m (SomeHasFSAndBlockIO m)) ->
-  (m LSM.Salt) ->
   Complete LedgerDbFlavorArgs m ->
   -- | A set of default arguments (possibly modified from 'defaultArgs')
   Incomplete ChainDbArgs m blk ->
   -- | Customise the 'ChainDbArgs'
   (Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk) ->
   m (ChainDB m blk, Complete ChainDbArgs m blk)
-openChainDB registry cfg initLedger fsImm fsVol fsLSM genSalt flavorArgs defArgs customiseArgs =
+openChainDB registry cfg initLedger fsImm fsVol flavorArgs defArgs customiseArgs =
   let args =
         customiseArgs $
           ChainDB.completeChainDbArgs
@@ -841,8 +836,6 @@ openChainDB registry cfg initLedger fsImm fsVol fsLSM genSalt flavorArgs defArgs
             (nodeCheckIntegrity (configStorage cfg))
             fsImm
             fsVol
-            fsLSM
-            genSalt
             flavorArgs
             defArgs
    in (,args) <$> ChainDB.openDB args
@@ -1024,9 +1017,6 @@ stdLowLevelRunNodeArgsIO
         , llrnRng
         , llrnMkImmutableHasFS = stdMkChainDbHasFS $ immutableDbPath srnDatabasePath
         , llrnMkVolatileHasFS = stdMkChainDbHasFS $ nonImmutableDbPath srnDatabasePath
-        , llrnMkLSMFS = \s ->
-            uncurry SomeHasFSAndBlockIO <$> ioHasBlockIO (MountPoint $ nonImmutableDbPath srnDatabasePath </> s) defaultIOCtxParams
-        , llrnGenSalt = fst . genWord64 <$> initStdGen
         , llrnChainDbArgsDefaults = updateChainDbDefaults ChainDB.defaultArgs
         , llrnCustomiseChainDbArgs = id
         , llrnCustomiseNodeKernelArgs
@@ -1063,7 +1053,17 @@ stdLowLevelRunNodeArgsIO
         , llrnPublicPeerSelectionStateVar =
             Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration
         , llrnLdbFlavorArgs =
-            srnLdbFlavorArgs
+            case srnLdbFlavorArgs of
+              V1LMDB args -> LedgerDbFlavorArgsV1 args
+              V2InMemory -> LedgerDbFlavorArgsV2 (V2.V2Args V2.InMemoryHandleArgs)
+              V2LSM path ->
+                let
+                  mkFS = \s ->
+                    uncurry V2.SomeHasFSAndBlockIO
+                      <$> ioHasBlockIO (MountPoint $ nonImmutableDbPath srnDatabasePath </> s) defaultIOCtxParams
+                  genSalt = fst . genWord64 <$> initStdGen
+                 in
+                  LedgerDbFlavorArgsV2 (V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)))
         }
    where
     networkMagic :: NetworkMagic

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs

@@ -45,7 +45,6 @@ import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.IOLike
 import System.FS.API
-import qualified Database.LSMTree as LSM
 
 {-------------------------------------------------------------------------------
   Arguments
@@ -170,10 +169,6 @@ completeChainDbArgs ::
   (RelativeMountPoint -> SomeHasFS m) ->
   -- | Volatile  FS, see 'NodeDatabasePaths'
   (RelativeMountPoint -> SomeHasFS m) ->
-  -- | Make LSM fs
-  (FilePath -> m (LedgerDB.SomeHasFSAndBlockIO m)) ->
-  -- | Make LSM Salt
-  (m LSM.Salt) ->
   Complete LedgerDbFlavorArgs m ->
   -- | A set of incomplete arguments, possibly modified wrt @defaultArgs@
   Incomplete ChainDbArgs m blk ->
@@ -186,8 +181,6 @@ completeChainDbArgs
   checkIntegrity
   mkImmFS
   mkVolFS
-  mkLSMFS
-  genSalt
   flavorArgs
   defArgs =
     defArgs
@@ -215,8 +208,6 @@ completeChainDbArgs
                   (LedgerDB.ledgerDbCfgComputeLedgerEvents $ LedgerDB.lgrConfig (cdbLgrDbArgs defArgs))
             , LedgerDB.lgrFlavorArgs = flavorArgs
             , LedgerDB.lgrRegistry = registry
-            , LedgerDB.lgrGenSalt = genSalt
-            , LedgerDB.lgrMkLSMFS = mkLSMFS
             }
       , cdbsArgs =
           (cdbsArgs defArgs)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs

@@ -77,14 +77,14 @@ openDB
     LedgerDbFlavorArgsV2 bss -> do
       (ds, bss') <- case bss of
         V2.V2Args V2.InMemoryHandleArgs -> pure (defaultDeleteSnapshot, V2.InMemoryHandleEnv)
-        V2.V2Args (V2.LSMHandleArgs path) -> do
+        V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)) -> do
           session <-
             snd
               <$> allocate
                 (lgrRegistry args)
                 ( \_ -> do
-                    SomeHasFSAndBlockIO fs blockio <- lgrMkLSMFS args "lsm"
-                    salt <- lgrGenSalt args
+                    V2.SomeHasFSAndBlockIO fs blockio <- mkFS "lsm"
+                    salt <- genSalt
                     LSM.openSession
                       (LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args)
                       fs

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs

@@ -18,11 +18,11 @@
 -- | Arguments for LedgerDB initialization.
 module Ouroboros.Consensus.Storage.LedgerDB.Args
   ( LedgerDbArgs (..)
+  , LedgerDbBackendArgs (..)
   , LedgerDbFlavorArgs (..)
   , QueryBatchSize (..)
   , defaultArgs
   , defaultQueryBatchSize
-  , SomeHasFSAndBlockIO (..)
   ) where
 
 import Control.ResourceRegistry
@@ -40,9 +40,8 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
 import Ouroboros.Consensus.Util.Args
 import System.FS.API
-import qualified Database.LSMTree as LSM
-import System.FS.BlockIO.API
-import Data.Typeable
+
+data LedgerDbBackendArgs m = V1LMDB (Complete V1.LedgerDbFlavorArgs m) | V2InMemory | V2LSM FilePath
 
 {-------------------------------------------------------------------------------
   Arguments
@@ -67,13 +66,8 @@ data LedgerDbArgs f m blk = LedgerDbArgs
   -- ^ If provided, the ledgerdb will start using said snapshot and fallback
   -- to genesis. It will ignore any other existing snapshots. Useful for
   -- db-analyser.
-  , lgrGenSalt :: HKD f (m LSM.Salt)
-  , lgrMkLSMFS :: HKD f (FilePath -> m (SomeHasFSAndBlockIO m))
   }
 
-data SomeHasFSAndBlockIO m where
-  SomeHasFSAndBlockIO :: (Eq h, Typeable h) => HasFS m h -> HasBlockIO m h -> SomeHasFSAndBlockIO m
-
 -- | Default arguments
 defaultArgs ::
   Applicative m =>
@@ -91,13 +85,11 @@ defaultArgs =
       lgrFlavorArgs = LedgerDbFlavorArgsV2 (V2.V2Args V2.InMemoryHandleArgs)
     , lgrRegistry = NoDefault
     , lgrStartSnapshot = Nothing
-    , lgrGenSalt = NoDefault
-    , lgrMkLSMFS = NoDefault
     }
 
 data LedgerDbFlavorArgs f m
   = LedgerDbFlavorArgsV1 (V1.LedgerDbFlavorArgs f m)
-  | LedgerDbFlavorArgsV2 (V2.LedgerDbFlavorArgs f)
+  | LedgerDbFlavorArgsV2 (V2.LedgerDbFlavorArgs f m)
 
 {-------------------------------------------------------------------------------
   QueryBatchSize

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs

@@ -13,7 +13,6 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.Args
   ( BackingStoreArgs (..)
   , FlushFrequency (..)
   , LedgerDbFlavorArgs (..)
-  , defaultLedgerDbFlavorArgs
   , shouldFlush
   ) where
 
@@ -55,9 +54,3 @@ data BackingStoreArgs f m
 
 class (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m
 instance (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m
-
-defaultLedgerDbFlavorArgs :: Incomplete LedgerDbFlavorArgs m
-defaultLedgerDbFlavorArgs = V1Args DefaultFlushFrequency defaultBackingStoreArgs
-
-defaultBackingStoreArgs :: Incomplete BackingStoreArgs m
-defaultBackingStoreArgs = InMemoryBackingStoreArgs

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs

@@ -1,28 +1,35 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Ouroboros.Consensus.Storage.LedgerDB.V2.Args
   ( FlavorImplSpecificTrace (..)
   , HandleArgs (..)
   , HandleEnv (..)
   , LedgerDbFlavorArgs (..)
+  , SomeHasFSAndBlockIO (..)
+  , LSMHandleArgs (..)
   ) where
 
-import Database.LSMTree (LSMTreeTrace (..), Session)
+import Data.Typeable
+import Database.LSMTree (LSMTreeTrace (..), Salt, Session)
+import Ouroboros.Consensus.Util.Args
+import System.FS.API
+import System.FS.BlockIO.API
 
-data LedgerDbFlavorArgs f = V2Args HandleArgs
+data LedgerDbFlavorArgs f m = V2Args (HandleArgs f m)
 
-data HandleArgs
+data HandleArgs f m
   = InMemoryHandleArgs
-  | LSMHandleArgs FilePath
+  | LSMHandleArgs (LSMHandleArgs f m)
+
+data LSMHandleArgs f m = LSMArgs
+  { lsmFilePath :: HKD f FilePath
+  , lsmGenSalt :: HKD f (m Salt)
+  , lsmMkFS :: HKD f (FilePath -> m (SomeHasFSAndBlockIO m))
+  }
+
+data SomeHasFSAndBlockIO m where
+  SomeHasFSAndBlockIO :: (Eq h, Typeable h) => HasFS m h -> HasBlockIO m h -> SomeHasFSAndBlockIO m
 
 data HandleEnv m
   = InMemoryHandleEnv