Also instantiate HasBlockIO

jasagredo · jasagredo · commit 15ce0ca7ab98 · 2025-07-02T16:28:06.000+02:00
diff --git a/cabal.project b/cabal.project
@@ -118,7 +118,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/jasagredo/lsm-tree
-  tag: 55c4b99e3e569c168de38f6d351507236d027f49
+  tag: 2491d82e325be54dfa3525175f3382b56404404c
   subdir:
     .
     blockio
diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs
@@ -36,7 +36,7 @@ import Control.Monad (guard)
 import Data.Coerce (coerce)
 import Data.Maybe
 import Data.Text (Text)
-import Data.Void (Void)
+import Data.Void (Void, absurd)
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.BlockchainTime (SystemStart (..))
 import Ouroboros.Consensus.Byron.Crypto.DSIGN
@@ -61,11 +61,18 @@ import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..))
 import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo)
 import Ouroboros.Consensus.Util ((....:))
 import Ouroboros.Network.Magic (NetworkMagic (..))
+import qualified Database.LSMTree as LSM
 
 {-------------------------------------------------------------------------------
   Credentials
 -------------------------------------------------------------------------------}
 
+instance LSM.SerialiseKey Void where
+  serialiseKey = absurd
+  deserialiseKey = error "deserialiseKey: Void"
+
+deriving via LSM.ResolveAsFirst Void instance LSM.ResolveValue Void
+
 -- | Credentials needed to produce blocks in the Byron era.
 data ByronLeaderCredentials = ByronLeaderCredentials
   { blcSignKey :: Crypto.SigningKey
diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
@@ -83,6 +83,8 @@ library
     contra-tracer,
     deepseq,
     filepath,
+    blockio,
+    lsm-tree,
     fs-api ^>=0.4,
     hashable,
     io-classes:{io-classes, si-timers, strict-stm} ^>=1.8,
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
@@ -128,6 +128,8 @@ import Ouroboros.Consensus.Storage.LedgerDB.Args
 import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.IOLike
+import System.FS.BlockIO.API
+import System.FS.BlockIO.IO
 import Ouroboros.Consensus.Util.Orphans ()
 import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime)
 import Ouroboros.Network.BlockFetch
@@ -176,7 +178,8 @@ import System.FS.API (SomeHasFS (..))
 import System.FS.API.Types (MountPoint (..))
 import System.FS.IO (ioHasFS)
 import System.FilePath ((</>))
-import System.Random (StdGen, newStdGen, randomIO, split)
+import System.Random (StdGen, newStdGen, randomIO, split, genWord64, initStdGen)
+import qualified Database.LSMTree as LSM
 
 {-------------------------------------------------------------------------------
   The arguments to the Consensus Layer node functionality
@@ -266,6 +269,8 @@ 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
@@ -526,6 +531,8 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
               initLedger
               llrnMkImmutableHasFS
               llrnMkVolatileHasFS
+              llrnMkLSMFS
+              llrnGenSalt
               llrnLdbFlavorArgs
               llrnChainDbArgsDefaults
               ( setLoEinChainDbArgs
@@ -814,13 +821,15 @@ 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 flavorArgs defArgs customiseArgs =
+openChainDB registry cfg initLedger fsImm fsVol fsLSM genSalt flavorArgs defArgs customiseArgs =
   let args =
         customiseArgs $
           ChainDB.completeChainDbArgs
@@ -831,6 +840,8 @@ openChainDB registry cfg initLedger fsImm fsVol flavorArgs defArgs customiseArgs
             (nodeCheckIntegrity (configStorage cfg))
             fsImm
             fsVol
+            fsLSM
+            genSalt
             flavorArgs
             defArgs
    in (,args) <$> ChainDB.openDB args
@@ -1025,6 +1036,9 @@ stdLowLevelRunNodeArgsIO
         , llrnPeerSelectionRng
         , 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
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
@@ -45,6 +45,7 @@ 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
@@ -169,6 +170,10 @@ 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 ->
@@ -181,6 +186,8 @@ completeChainDbArgs
   checkIntegrity
   mkImmFS
   mkVolFS
+  mkLSMFS
+  genSalt
   flavorArgs
   defArgs =
     defArgs
@@ -208,6 +215,8 @@ completeChainDbArgs
                   (LedgerDB.ledgerDbCfgComputeLedgerEvents $ LedgerDB.lgrConfig (cdbLgrDbArgs defArgs))
             , LedgerDB.lgrFlavorArgs = flavorArgs
             , LedgerDB.lgrRegistry = registry
+            , LedgerDB.lgrGenSalt = genSalt
+            , LedgerDB.lgrMkLSMFS = mkLSMFS
             }
       , cdbsArgs =
           (cdbsArgs defArgs)
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
@@ -723,12 +723,6 @@ data TraceEvent blk
   | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk)
   deriving Generic
 
-deriving instance
-  ( Eq (Header blk)
-  , LedgerSupportsProtocol blk
-  , InspectLedger blk
-  ) =>
-  Eq (TraceEvent blk)
 deriving instance
   ( Show (Header blk)
   , LedgerSupportsProtocol blk
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs
@@ -91,12 +91,12 @@ openDB
               <$> allocate
                 (lgrRegistry args)
                 ( \_ -> do
-                    hasBlockIO <- ioHasBlockIO (lgrHasFS args) defaultIOCtxParams
-                    salt <- fst . genWord64 <$> initStdGen
+                    SomeHasFSAndBlockIO fs blockio <- lgrMkLSMFS args "lsm"
+                    salt <- lgrGenSalt args
                     LSM.openSession
                       (LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args)
-                      (lgrHasFS args)
-                      hasBlockIO
+                      fs
+                      blockio
                       salt
                       (mkFsPath [path])
                 )
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs
@@ -22,6 +22,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.Args
   , QueryBatchSize (..)
   , defaultArgs
   , defaultQueryBatchSize
+  , SomeHasFSAndBlockIO (..)
   ) where
 
 import Control.ResourceRegistry
@@ -39,6 +40,9 @@ 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
 
 {-------------------------------------------------------------------------------
   Arguments
@@ -63,8 +67,13 @@ 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 =>
@@ -82,6 +91,8 @@ defaultArgs =
       lgrFlavorArgs = LedgerDbFlavorArgsV2 (V2.V2Args V2.InMemoryHandleArgs)
     , lgrRegistry = NoDefault
     , lgrStartSnapshot = Nothing
+    , lgrGenSalt = NoDefault
+    , lgrMkLSMFS = NoDefault
     }
 
 data LedgerDbFlavorArgs f m

Original file line number	Diff line number	Diff line change
`@@ -118,7 +118,7 @@ source-repository-package`
`118`	`118`	`source-repository-package`
`119`	`119`	`type: git`
`120`	`120`	`location: https://github.com/jasagredo/lsm-tree`
`121`		`- tag: 55c4b99e3e569c168de38f6d351507236d027f49`
	`121`	`+ tag: 2491d82e325be54dfa3525175f3382b56404404c`
`122`	`122`	`subdir:`
`123`	`123`	`.`
`124`	`124`	`blockio`