diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index 05842ad1..59aa71ec 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -128,6 +128,7 @@ test-suite test , random , safe , serialise + , streaming , tasty , tasty-hunit , temporary diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs b/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs index 33da73de..57ed6505 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs +++ b/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 diff --git a/hbs2-storage-simple/test/TestCompactStorage.hs b/hbs2-storage-simple/test/TestCompactStorage.hs index 431f9e59..81546855 100644 --- a/hbs2-storage-simple/test/TestCompactStorage.hs +++ b/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 - pure () + let elems = [ 0 .. 10_000 :: Int ] - 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