voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2023-01-11 15:52:09 +03:00
parent 412a3191a5
commit 521f4c67c2
2 changed files with 12 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
hbs2-storage-simple/lib/HBS2/Storage/Simple.hs
View File

@ -79,7 +79,7 @@ storageBlocks = to f
simpleStorageInit :: (MonadIO m, Data opts) => opts -> m (SimpleStorage h) simpleStorageInit :: (MonadIO m, Data opts) => opts -> m (SimpleStorage h)
simpleStorageInit opts = liftIO $ do simpleStorageInit opts = liftIO $ do
let prefix = uniLastDef "." opts :: StoragePrefix let prefix = uniLastDef "." opts :: StoragePrefix
let qSize = uniLastDef 100 opts :: StorageQueueSize let qSize = uniLastDef 500 opts :: StorageQueueSize
pdir <- canonicalizePath (fromPrefix prefix) pdir <- canonicalizePath (fromPrefix prefix)
@ -119,7 +119,8 @@ simpleStorageStop ss = do
atomically $ TV.writeTVar ( ss ^. storageStopWriting ) True atomically $ TV.writeTVar ( ss ^. storageStopWriting ) True
fix \next -> do fix \next -> do
mt <- atomically $ TBMQ.isEmptyTBMQueue ( ss ^. storageOpQ ) mt <- atomically $ TBMQ.isEmptyTBMQueue ( ss ^. storageOpQ )
if mt then if mt then do
atomically $ TBMQ.closeTBMQueue ( ss ^. storageOpQ )
pure () pure ()
else else
pause ( 0.01 :: Timeout 'Seconds ) >> next pause ( 0.01 :: Timeout 'Seconds ) >> next
@ -127,12 +128,11 @@ simpleStorageStop ss = do
simpleStorageWorker :: SimpleStorage h -> IO () simpleStorageWorker :: SimpleStorage h -> IO ()
simpleStorageWorker ss = do simpleStorageWorker ss = do
ops <- async $ forever $ do ops <- async $ fix \next -> do
s <- atomically $ do TBMQ.readTBMQueue ( ss ^. storageOpQ ) s <- atomically $ do TBMQ.readTBMQueue ( ss ^. storageOpQ )
case s of case s of
Nothing -> pure () Nothing -> pure ()
Just a -> a Just a -> a >> next
killer <- async $ forever $ do killer <- async $ forever $ do
pause ( 30 :: Timeout 'Seconds ) -- FIXME: setting pause ( 30 :: Timeout 'Seconds ) -- FIXME: setting

13
hbs2/Main.hs
View File

@ -27,7 +27,9 @@ import HBS2.Defaults
newtype HashRef = HashRef (Hash HbSync) newtype HashRef = HashRef (Hash HbSync)
deriving newtype (Eq,Ord,IsString,Pretty) deriving newtype (Eq,Ord,IsString,Pretty)
deriving stock (Data) deriving stock (Data,Generic)
instance Serialise HashRef
newtype OptInputFile = OptInputFile { unOptFile :: FilePath } newtype OptInputFile = OptInputFile { unOptFile :: FilePath }
deriving newtype (Eq,Ord,IsString) deriving newtype (Eq,Ord,IsString)
@ -64,10 +66,9 @@ runStore opts ss = do
let pt = toPTree (MaxSize 2048) (MaxNum 2048) hashes let pt = toPTree (MaxSize 2048) (MaxNum 2048) hashes
-- mapM_ (print . pretty) hashes root <- makeMerkle 0 pt $ \(h,_,bs) -> void $ putBlock ss bs
pure ()
print $ "merkle-root: " <+> pretty root
withStore :: Data opts => opts -> ( SimpleStorage HbSync -> IO () ) -> IO () withStore :: Data opts => opts -> ( SimpleStorage HbSync -> IO () ) -> IO ()
withStore opts f = do withStore opts f = do
@ -76,13 +77,13 @@ withStore opts f = do
let pref = uniLastDef xdg opts :: StoragePrefix let pref = uniLastDef xdg opts :: StoragePrefix
s <- simpleStorageInit (Just pref) s <- simpleStorageInit (Just pref)
storage <- async $ simpleStorageWorker s w <- replicateM 4 $ async $ simpleStorageWorker s
f s f s
simpleStorageStop s simpleStorageStop s
_ <- waitAnyCatch [storage] _ <- waitAnyCatch w
pure () pure ()