wip

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

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

hbs2/Main.hs

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