First integration of LSM trees

Author: jasagredo

cabal.project

@@ -25,6 +25,7 @@ packages:
   ouroboros-consensus-diffusion
   sop-extras
   strict-sop-core
+  ../lsm-tree
 
 -- We want to always build the test-suites and benchmarks
 tests: true
@@ -57,6 +58,9 @@ if impl (ghc >= 9.12)
     -- https://github.com/kapralVV/Unique/issues/11
     , Unique:hashable
 
+    -- https://github.com/phadej/regression-simple/pull/14
+    , regression-simple:base
+
 source-repository-package
    type: git
    location: https://github.com/IntersectMBO/cardano-ledger
@@ -95,7 +99,7 @@ source-repository-package
   location: https://github.com/IntersectMBO/ouroboros-network
   tag: dd45510b6c5a935e0f330d7b180800a27ebe2fd8
   --sha256: sha256-Xk+DbtqQwadtmRoZNVzDUWM8tnV+RECXYRe74IOkL0s=
-  subdir: 
+  subdir:
           network-mux
           ouroboros-network
           ouroboros-network-api
@@ -111,3 +115,11 @@ source-repository-package
   --sha256: 0ss4n302khl13fj5f4l6cxfj5vn558s2wk533ikmxhgigf9qas0q
   subdir: fs-api
           fs-sim
+
+source-repository-package
+  type: git
+  location: https://github.com/jasagredo/lsm-tree
+  tag: fa0d862b7a609473538a0007bd0df314cd2fa635
+  subdir:
+
+    blockio

ouroboros-consensus/ouroboros-consensus.cabal

@@ -253,6 +253,7 @@ library
     Ouroboros.Consensus.Storage.LedgerDB.V2.Args
     Ouroboros.Consensus.Storage.LedgerDB.V2.Forker
     Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
+    Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
     Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
     Ouroboros.Consensus.Storage.Serialisation
     Ouroboros.Consensus.Storage.VolatileDB
@@ -350,6 +351,7 @@ library
     transformers-base,
     typed-protocols ^>=1.0,
     vector ^>=0.13,
+    lsm-tree,
 
   x-docspec-extra-packages:
     directory
@@ -542,7 +544,6 @@ library unstable-mempool-test-utils
     io-classes:strict-stm,
     ouroboros-consensus,
     resource-registry,
-    strict-stm,
 
 library unstable-tutorials
   import: common-lib

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

@@ -38,6 +38,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl
   , openDBInternal
   ) where
 
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
 import Control.Monad (void, when)
 import Control.Monad.Trans.Class (lift)
 import Control.ResourceRegistry
@@ -60,6 +61,7 @@ import Ouroboros.Consensus.HardFork.Abstract
 import Ouroboros.Consensus.HeaderValidation (mkHeaderWithTime)
 import Ouroboros.Consensus.Ledger.Extended (ledgerState)
 import Ouroboros.Consensus.Ledger.Inspect
+import Ouroboros.Consensus.Ledger.Basics
 import Ouroboros.Consensus.Ledger.SupportsProtocol
 import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
 import qualified Ouroboros.Consensus.Storage.ChainDB.API as API
@@ -105,6 +107,7 @@ withDB ::
   , ConvertRawHash blk
   , SerialiseDiskConstraints blk
   , LedgerSupportsLedgerDB blk
+  , LSM.GoodForLSM (LedgerState blk)
   ) =>
   Complete Args.ChainDbArgs m blk ->
   (ChainDB m blk -> m a) ->
@@ -121,6 +124,7 @@ openDB ::
   , ConvertRawHash blk
   , SerialiseDiskConstraints blk
   , LedgerSupportsLedgerDB blk
+  , LSM.GoodForLSM (LedgerState blk)
   ) =>
   Complete Args.ChainDbArgs m blk ->
   m (ChainDB m blk)
@@ -137,6 +141,7 @@ openDBInternal ::
   , SerialiseDiskConstraints blk
   , HasCallStack
   , LedgerSupportsLedgerDB blk
+  , LSM.GoodForLSM (LedgerState blk)
   ) =>
   Complete Args.ChainDbArgs m blk ->
   -- | 'True' = Launch background tasks

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

@@ -22,6 +22,7 @@ import Data.Word
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.HardFork.Abstract
 import Ouroboros.Consensus.Ledger.Inspect
+import Ouroboros.Consensus.Ledger.Basics
 import Ouroboros.Consensus.Ledger.SupportsProtocol
 import Ouroboros.Consensus.Storage.ImmutableDB.Stream
 import Ouroboros.Consensus.Storage.LedgerDB.API
@@ -30,6 +31,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.Forker
 import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as V2
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.CallStack
 import Ouroboros.Consensus.Util.IOLike
@@ -44,6 +46,8 @@ openDB ::
   , HasCallStack
   , HasHardForkHistory blk
   , LedgerSupportsLedgerDB blk
+  , LSM.GoodForLSM (LedgerState blk)
+
   ) =>
   -- | Stateless initializaton arguments
   Complete LedgerDbArgs m blk ->

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

@@ -183,17 +183,20 @@ instance FromJSON SnapshotMetadata where
 data SnapshotBackend
   = UTxOHDMemSnapshot
   | UTxOHDLMDBSnapshot
+  | UTxOHDLSMSnapshot
   deriving (Eq, Show)
 
 instance ToJSON SnapshotBackend where
   toJSON = \case
     UTxOHDMemSnapshot -> "utxohd-mem"
     UTxOHDLMDBSnapshot -> "utxohd-lmdb"
+    UTxOHDLSMSnapshot -> "utxohd-lsm"
 
 instance FromJSON SnapshotBackend where
   parseJSON = Aeson.withText "SnapshotBackend" $ \case
     "utxohd-mem" -> pure UTxOHDMemSnapshot
     "utxohd-lmdb" -> pure UTxOHDLMDBSnapshot
+    "utxohd-lsm" -> pure UTxOHDLSMSnapshot
     _ -> fail "unknown SnapshotBackend"
 
 data MetadataErr

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

@@ -56,6 +56,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
 import Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
 import Ouroboros.Consensus.Storage.LedgerDB.V2.Forker
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
 import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.CallStack
@@ -72,6 +73,7 @@ mkInitDb ::
   , IOLike m
   , LedgerDbSerialiseConstraints blk
   , HasHardForkHistory blk
+  , LSM.GoodForLSM (LedgerState blk)
   , LedgerSupportsInMemoryLedgerDB blk
   ) =>
   Complete LedgerDbArgs m blk ->
@@ -138,7 +140,10 @@ mkInitDb args flavArgs getBlock =
   emptyF st =
     empty' st $ case bss of
       InMemoryHandleArgs -> InMemory.newInMemoryLedgerTablesHandle v2Tracer lgrHasFS
-      LSMHandleArgs x -> absurd x
+      LSMHandleArgs session ->
+        \values -> do
+          table <- LSM.tableFromValuesMK lgrRegistry session values
+          LSM.newLSMLedgerTablesHandle v2Tracer lgrRegistry session table
 
   loadSnapshot ::
     CodecConfig blk ->
@@ -147,7 +152,7 @@ mkInitDb args flavArgs getBlock =
     m (Either (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
   loadSnapshot ccfg fs ds = case bss of
     InMemoryHandleArgs -> runExceptT $ InMemory.loadSnapshot v2Tracer lgrRegistry ccfg fs ds
-    LSMHandleArgs x -> absurd x
+    LSMHandleArgs session -> runExceptT $ LSM.loadSnapshot v2Tracer lgrRegistry ccfg fs session ds
 
 implMkLedgerDb ::
   forall m l blk.
@@ -162,7 +167,7 @@ implMkLedgerDb ::
   , HasHardForkHistory blk
   ) =>
   LedgerDBHandle m l blk ->
-  HandleArgs ->
+  HandleArgs m ->
   (LedgerDB m l blk, TestInternals m l blk)
 implMkLedgerDb h bss =
   ( LedgerDB
@@ -188,7 +193,7 @@ mkInternals ::
   , LedgerSupportsProtocol blk
   , ApplyBlock (ExtLedgerState blk) blk
   ) =>
-  HandleArgs ->
+  HandleArgs m ->
   LedgerDBHandle m (ExtLedgerState blk) blk ->
   TestInternals' m blk
 mkInternals bss h =
@@ -245,7 +250,7 @@ mkInternals bss h =
     m (Maybe (DiskSnapshot, RealPoint blk))
   takeSnapshot = case bss of
     InMemoryHandleArgs -> InMemory.takeSnapshot
-    LSMHandleArgs x -> absurd x
+    LSMHandleArgs{} -> LSM.takeSnapshot
 
 -- | Testing only! Truncate all snapshots in the DB.
 implIntTruncateSnapshots :: MonadThrow m => SomeHasFS m -> m ()
@@ -359,7 +364,7 @@ implTryTakeSnapshot ::
   , LedgerSupportsProtocol blk
   , LedgerDbSerialiseConstraints blk
   ) =>
-  HandleArgs ->
+  HandleArgs m ->
   LedgerDBEnv m l blk ->
   Maybe (Time, Time) ->
   Word64 ->
@@ -397,7 +402,13 @@ implTryTakeSnapshot bss env mTime nrBlocks =
         fs
         Nothing
         ref
-    LSMHandleArgs x -> absurd x
+    LSMHandleArgs{} ->
+      LSM.takeSnapshot
+        config
+        trcr
+        fs
+        Nothing
+        ref
 
 -- In the first version of the LedgerDB for UTxO-HD, there is a need to
 -- periodically flush the accumulated differences to the disk. However, in the

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

@@ -17,13 +17,13 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.Args
 import Data.Void (Void)
 import GHC.Generics
 import NoThunks.Class
+import Database.LSMTree (Session)
 
-data LedgerDbFlavorArgs f m = V2Args HandleArgs
+data LedgerDbFlavorArgs f m = V2Args (HandleArgs m)
 
-data HandleArgs
+data HandleArgs m
   = InMemoryHandleArgs
-  | LSMHandleArgs Void
-  deriving (Generic, NoThunks)
+  | LSMHandleArgs (Session m)
 
 data FlavorImplSpecificTrace
   = -- | Created a new 'LedgerTablesHandle', potentially by duplicating an

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

@@ -137,7 +137,7 @@ newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do
           guardClosed h $
             \values ->
               withFile hasFS (mkFsPath [snapshotName, "tables", "tvar"]) (WriteMode MustBeNew) $ \hf ->
-                fmap snd $
+                fmap (Just . snd) $
                   hPutAllCRC hasFS hf $
                     CBOR.toLazyByteString $
                       valuesMKEncoder hint values
@@ -172,7 +172,7 @@ writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do
   writeSnapshotMetadata fs ds $
     SnapshotMetadata
       { snapshotBackend = UTxOHDMemSnapshot
-      , snapshotChecksum = crcOfConcat crc1 crc2
+      , snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2
       }
 
 takeSnapshot ::