wip

hbs2-storage-simple/hbs2-storage-simple.cabal

@@ -128,6 +128,7 @@ test-suite test
         , random
         , safe
         , serialise
+        , streaming
         , tasty
         , tasty-hunit
         , temporary

hbs2-storage-simple/lib/HBS2/Storage/Compact.hs

@@ -1,7 +1,23 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# Language ViewPatterns #-}
 {-# Language UndecidableInstances #-}
-module HBS2.Storage.Compact where
+module HBS2.Storage.Compact
+  ( Storage(..)
+  , CompactStorage
+  , compactStorageOpen
+  , compactStorageClose
+  , compactStorageCommit
+  , compactStoragePut
+  , compactStorageGet
+  , compactStorageDel
+  , compactStorageFindLiveHeads
+  , compactStorageRun
+  , HBS2.Storage.Compact.keys
+  , HBS2.Storage.Compact.member
+  , HBS2.Storage.Compact.put
+  , HBS2.Storage.Compact.get
+  , HBS2.Storage.Compact.del
+  ) where
 
 import HBS2.Clock
 import HBS2.Hash
@@ -18,16 +34,14 @@ import Data.Coerce
 import Data.Function
 import Data.List qualified as List
 import Data.Maybe
-import Data.Map (Map)
-import Data.Map qualified as Map
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.Foldable
+import Data.Traversable
 import Data.Vector (Vector,(!))
 import Data.Vector qualified as V
 import Codec.Serialise
 import GHC.Generics
--- import System.IO
 import Lens.Micro.Platform
 import Control.Monad.Except
 import Control.Monad.Trans.Maybe
@@ -99,6 +113,12 @@ pattern Fresh e <- e@(Entry _ ( isFresh -> True ))
 pattern Tomb :: Entry -> Entry
 pattern Tomb e <- e@(Entry _ ( isTomb -> True ))
 
+isAlive :: Entry -> Bool
+isAlive = \case
+  Entry _ New{}     -> True
+  Entry _ e@(Off{}) -> not (isTomb e)
+  _                 -> False
+
 isTomb :: E -> Bool
 isTomb (Off e) = idxEntryTomb e
 isTomb _ = False
@@ -502,6 +522,43 @@ headerSize 1 = fromIntegral (32 :: Integer)
 headerSize _ = error "unsupported header version"
 
 
+-- Map-like interface
+
+keys :: ForCompactStorage m => CompactStorage k -> m [ ByteString ]
+keys sto = do
+  what <- atomically $ mapM readTVar (csKeys sto)
+  let w = foldMap HM.toList (V.toList what)
+  pure [ k | (k,x) <- w, isAlive x ]
+
+member :: ForCompactStorage m
+       => CompactStorage k
+       -> ByteString
+       -> m Bool
+member s k = isJust <$> compactStorageExists s k
+
+put :: ForCompactStorage m
+     => CompactStorage k
+     -> ByteString
+     -> ByteString
+     -> m ()
+
+put = compactStoragePut
+
+get  :: ForCompactStorage m
+     => CompactStorage k
+     -> ByteString
+     -> m (Maybe ByteString)
+
+get = compactStorageGet
+
+del :: ForCompactStorage m
+     => CompactStorage k
+     -> ByteString
+     -> m ()
+
+del = compactStorageDel
+
+
 -- Storage instance
 
 translateKey :: Coercible (Hash hash) ByteString

hbs2-storage-simple/test/TestCompactStorage.hs

@@ -1,6 +1,8 @@
+{-# LANGUAGE NumericUnderscores #-}
 module TestCompactStorage where
 
 import HBS2.Prelude.Plated
+import HBS2.Merkle
 import HBS2.OrDie
 import HBS2.Hash
 import HBS2.Clock
@@ -11,8 +13,6 @@ import HBS2.Data.Bundle
 
 import Control.Monad.Except
 import Control.Monad
-import Data.Traversable
-import Data.Foldable
 import Control.Concurrent.Async
 import Control.Concurrent
 import Data.ByteString.Lazy qualified as LBS
@@ -27,14 +27,32 @@ import Test.QuickCheck
 import System.TimeIt
 import System.IO
 
+import Streaming.Prelude qualified as S
+
 import Test.Tasty.HUnit
 
 
 testCompactStorageBasic :: IO ()
 testCompactStorageBasic = do
 
-  withSystemTempFile "simpleStorageTest1" $ \fn ha -> do
+  let elems = [ 0 .. 10_000 :: Int ]
-    pure ()
 
-  pure ()
+  let pt = toPTree (MaxSize 1000) (MaxNum 256) elems
+
+  withSystemTempDirectory "simpleStorageTest1" $ \dir -> do
+    let db = "storage"
+    sto <- compactStorageOpen @HbSync mempty db
+
+    root <- makeMerkle 0 pt $ \(_,_,bss) -> do
+      void $ putBlock sto bss
+
+    compactStorageClose sto
+
+    sto2 <- compactStorageOpen @HbSync mempty db
+
+    elems2 <- S.toList_ $ walkMerkle @[Int] root ( getBlock sto2 ) $ \case
+      Left{}   -> error "missed block"
+      Right xs -> mapM_ S.yield  xs
+
+    assertEqual "elems-read-from-storage" elems elems2