Final demo

.hlint.yaml

@@ -40,6 +40,7 @@
 - ignore: {name: "Use notElem"}
 - ignore: {name: "Use elem"}
 - ignore: {name: "Use infix"}
+- ignore: {name: "Redundant pure"}
 
 # Specify additional command line arguments
 #

app/Database/LSMTree/Demo.hs

@@ -0,0 +1,221 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
+
+{- HLINT ignore "Redundant pure" -}
+
+module Database.LSMTree.Demo (demo) where
+
+import           Control.Exception (SomeException, try)
+import           Control.Monad (when)
+import           Control.Monad.Class.MonadST (MonadST (..))
+import qualified Control.Monad.IOSim as IOSim
+import           Control.Monad.Primitive (RealWorld)
+import           Control.Monad.ST.Unsafe (unsafeIOToST)
+import           Control.Tracer (nullTracer)
+import           Data.Functor (void)
+import           Data.Primitive.PrimVar (PrimVar, newPrimVar, readPrimVar,
+                     writePrimVar)
+import           Data.Typeable (Typeable)
+import qualified Data.Vector as V
+import           Data.Word (Word64)
+import           Database.LSMTree as LSMT
+import qualified System.Directory as IO (createDirectoryIfMissing,
+                     doesDirectoryExist, removeDirectoryRecursive)
+import qualified System.FS.API as FS
+import qualified System.FS.BlockIO.API as FS
+import qualified System.FS.BlockIO.IO as FS
+import qualified System.FS.BlockIO.Sim as FSSim
+import qualified System.FS.IO as FS
+import qualified System.FS.Sim.MockFS as FSSim
+import           System.IO.Unsafe (unsafePerformIO)
+
+-- | Interactive demo showing functional requiremens for the @lsm-tree@ library
+-- are met.
+--
+-- The functional requirements are discussed in this document: "Storing the
+-- Cardano ledger state on disk: final report for high-performance backend"
+--
+-- Sections of the demo code are headed by the number of the corresponding
+-- functional requirement.
+demo :: IO ()
+demo = do
+  freshDirectory "_demo"
+  withOpenSessionIO tracer "_demo" $ \session -> do
+    withTableWith config session  $ \(table :: Table IO K V B) -> do
+      pause -- [0]
+
+      -- 2. basic key-value store operations
+
+      inserts table $ V.fromList [ (K i, V i, Just (B i)) | i <- [1 .. 10_000] ]
+      as <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4 ]
+      print (fmap getValue as)
+      pause -- [1]
+
+      deletes table $ V.fromList [ K i | i <- [1 .. 10_000], even i ]
+      bs <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4 ]
+      print (fmap getValue bs)
+      pause -- [2]
+
+      -- 2. Intermezzo: blob retrieval
+
+      cs <- try @SomeException $ retrieveBlobs session $ V.mapMaybe getBlob as
+      print cs
+      pause -- [3]
+
+      ds <- try @SomeException $ retrieveBlobs session $ V.mapMaybe getBlob bs
+      print ds
+      pause -- [4]
+
+      -- 3. range lookups and cursors
+
+      es <- rangeLookup table $ FromToIncluding (K 1) (K 4)
+      print (fmap getEntryValue es)
+      pause -- [5]
+
+      withCursorAtOffset table (K 1) $ \cursor -> do
+        fs <- LSMT.take 2 cursor
+        print (fmap getEntryValue fs)
+        pause -- [6]
+
+      -- 4. upserts (or monoidal updates)
+
+      -- better than lookup followed by insert
+      upserts table $ V.fromList [ (K i, V 1) | i <- [1 .. 10_000] ]
+      gs <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4 ]
+      print (fmap getValue gs)
+      pause -- [7]
+
+      -- 5. multiple independently writable references
+
+      withDuplicate table $ \dupliTable -> do
+        inserts dupliTable $ V.fromList [ (K i, V 1, Nothing) | i <- [1 .. 10_000] ]
+        hs <- lookups dupliTable $ V.fromList [ K 1, K 2, K 3, K 4 ]
+        print (fmap getValue hs)
+        pause -- [8]
+
+        is <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4]
+        print (fmap getValue is)
+        pause -- [9]
+
+        -- 6. snapshots
+
+        saveSnapshot "odds_evens" label table
+        saveSnapshot "all_ones" label dupliTable
+        js <- listSnapshots session
+        print js
+        pause -- [10]
+
+    -- 6. snapshots continued
+
+    withTableFromSnapshot session "odds_evens" label $ \(table :: Table IO K V B) -> do
+      withTableFromSnapshot session "all_ones" label $ \(dupliTable :: Table IO K V B) -> do
+        pause -- [11]
+
+        -- 7. table unions
+
+        withUnion table dupliTable $ \uniTable -> do
+          ks <- lookups uniTable $ V.fromList [ K 1, K 2, K 3, K 4]
+          print (fmap getValue ks)
+          pause -- [12]
+
+        withIncrementalUnion table dupliTable $ \uniTable -> do
+          ls <- lookups uniTable $ V.fromList [ K 1, K 2, K 3, K 4]
+          print (fmap getValue ls)
+          pause -- [13]
+
+          m@(UnionDebt m') <- remainingUnionDebt uniTable
+          supplyUnionCredits uniTable (UnionCredits (m' `div` 2))
+          print m
+          pause -- [14]
+
+          ns <- lookups uniTable $ V.fromList [ K 1, K 2, K 3, K 4]
+          print (fmap getValue ns)
+          pause -- [15]
+
+  -- 8. simulation
+
+  let
+    simpleAction ::
+         (LSMT.IOLike m, Typeable h)
+      => FS.HasFS m h -> FS.HasBlockIO m h -> m ()
+    simpleAction hasFS hasBlockIO = do
+      let sessionDir = FS.mkFsPath ["_demo"]
+      FS.createDirectoryIfMissing hasFS False sessionDir
+      withOpenSession tracer hasFS hasBlockIO 17 sessionDir $ \session -> do
+        withTableWith config session  $ \(table :: Table m K V B) -> do
+          inserts table $ V.fromList [ (K i, V i, Just (B i)) | i <- [1 .. 10_000] ]
+          os <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4 ]
+          print' (fmap getValue os)
+
+  do
+    let hasFS = FS.ioHasFS (FS.MountPoint "")
+    FS.withIOHasBlockIO hasFS FS.defaultIOCtxParams $ \hasBlockIO -> do
+      simpleAction hasFS hasBlockIO
+      pause -- [16]
+
+  do
+    pure $! IOSim.runSimOrThrow $ do
+      (hasFS, hasBlockIO) <- FSSim.simHasBlockIO' FSSim.empty
+      simpleAction hasFS hasBlockIO
+    pause -- [17]
+
+{-------------------------------------------------------------------------------
+  Types
+-------------------------------------------------------------------------------}
+
+newtype K = K Word64
+  deriving stock (Show, Eq)
+  deriving newtype SerialiseKey
+
+newtype V = V Word64
+  deriving stock (Show, Eq)
+  deriving newtype (Num, SerialiseValue)
+instance ResolveValue V where
+  resolve = (+)
+
+newtype B = B Word64
+  deriving stock (Show, Eq)
+  deriving newtype (Num, SerialiseValue)
+
+config :: TableConfig
+config = defaultTableConfig {
+      confWriteBufferAlloc = AllocNumEntries 172
+    }
+
+tracer :: Monad m => Tracer m LSMTreeTrace
+tracer = nullTracer
+
+label :: SnapshotLabel
+label = "KVB"
+
+{-------------------------------------------------------------------------------
+  Utils
+-------------------------------------------------------------------------------}
+
+{-# NOINLINE pauseRef #-}
+pauseRef :: PrimVar RealWorld Int
+pauseRef = unsafePerformIO $ newPrimVar 0
+
+incrPauseRef :: IO Int
+incrPauseRef = do
+    x <- readPrimVar pauseRef
+    writePrimVar pauseRef $! x + 1
+    pure x
+
+pause :: IO ()
+pause = do
+  x <- incrPauseRef
+  putStr ("[" <> show x <> "] " <> "press ENTER to continue...")
+  void $ getLine
+
+freshDirectory :: FilePath -> IO ()
+freshDirectory path = do
+    b <- IO.doesDirectoryExist path
+    when b $ IO.removeDirectoryRecursive path
+    IO.createDirectoryIfMissing False path
+
+print' :: (Show a, MonadST m) => a -> m ()
+print' x = stToIO $ unsafeIOToST $ print x

app/Main.hs

@@ -0,0 +1,9 @@
+module Main (main) where
+
+import           Database.LSMTree.Demo (demo)
+import           System.IO (BufferMode (..), hSetBuffering, stdout)
+
+main :: IO ()
+main = do
+  hSetBuffering stdout NoBuffering
+  demo

bench/macro/utxo-bench.hs

@@ -447,7 +447,7 @@ doSetup' gopts opts = do
 
     hasBlockIO <- FsIO.ioHasBlockIO hasFS FS.defaultIOCtxParams
 
-    let name = LSM.toSnapshotName "bench"
+    let name = LSM.toSnapshotName ("bench_" ++ show (initialSize gopts))
 
     LSM.withOpenSession (mkTracer gopts) hasFS hasBlockIO benchSalt (FS.mkFsPath []) $ \session -> do
         tbl <- LSM.newTableWith @IO @K @V @B (mkTableConfigSetup gopts opts benchTableConfig) session

lsm-tree.cabal

@@ -992,6 +992,7 @@ benchmark lsm-tree-bench-lookups
 
 library mcg
   import:          language, warnings, wno-x-partial
+  visibility:      private
   hs-source-dirs:  src-mcg
   exposed-modules: MCG
   build-depends:
@@ -1091,6 +1092,7 @@ benchmark utxo-rocksdb-bench
 
 library rocksdb
   import:          language, warnings
+  visibility:      private
   hs-source-dirs:  src-rocksdb
   exposed-modules: RocksDB
   other-modules:   RocksDB.FFI
@@ -1107,6 +1109,7 @@ library rocksdb
 
 library kmerge
   import:          language, warnings, wno-x-partial
+  visibility:      private
   hs-source-dirs:  src-kmerge
   exposed-modules:
     KMerge.Heap
@@ -1171,6 +1174,7 @@ test-suite map-range-test
 
 library prototypes
   import:          language, warnings, wno-x-partial
+  visibility:      private
   hs-source-dirs:  src-prototypes
   exposed-modules:
     FormatPage
@@ -1215,6 +1219,7 @@ test-suite prototypes-test
 
 library control
   import:          language, warnings
+  visibility:      private
   hs-source-dirs:  src-control
   exposed-modules:
     Control.ActionRegistry
@@ -1247,3 +1252,25 @@ test-suite control-test
     , QuickCheck
     , tasty
     , tasty-quickcheck
+
+executable demo
+  import:         language, warnings
+  scope:          private
+  hs-source-dirs: app
+  main-is:        Main.hs
+  other-modules:  Database.LSMTree.Demo
+  build-depends:
+    , base           <5
+    , blockio
+    , blockio:sim
+    , contra-tracer
+    , directory
+    , fs-api
+    , fs-sim
+    , io-classes
+    , io-sim
+    , lsm-tree
+    , primitive
+    , vector
+
+  ghc-options:    -threaded

src/Database/LSMTree.hs

@@ -45,6 +45,9 @@ module Database.LSMTree (
   lookup,
   lookups,
   Entry (..),
+  getEntryKey,
+  getEntryValue,
+  getEntryBlob,
   rangeLookup,
 
   -- ** Table Updates #table_updates#
@@ -1089,6 +1092,27 @@ data Entry k v b
   | EntryWithBlob !k !v !b
   deriving stock (Eq, Show, Functor, Foldable, Traversable)
 
+{- |
+Get the field of type @k@ from an @'Entry' k v b@.
+-}
+getEntryKey :: Entry k v b -> k
+getEntryKey (Entry !k !_v)             = k
+getEntryKey (EntryWithBlob !k !_v !_b) = k
+
+{- |
+Get the field of type @v@ from an @'Entry' k v b@.
+-}
+getEntryValue :: Entry k v b -> v
+getEntryValue (Entry !_k !v)             = v
+getEntryValue (EntryWithBlob !_k !v !_b) = v
+
+{- |
+Get the field of type @b@ from an @'Entry' k v b@, if any.
+-}
+getEntryBlob :: Entry k v b -> Maybe b
+getEntryBlob (Entry !_k !_v)            = Nothing
+getEntryBlob (EntryWithBlob !_k !_v !b) = Just b
+
 instance (NFData k, NFData v, NFData b) => NFData (Entry k v b) where
   rnf :: Entry k v b -> ()
   rnf = \case