wip

hbs2-core/lib/HBS2/Storage.hs

@@ -31,6 +31,8 @@ class ( Monad m
 
   putBlock :: a -> Block block -> m (Maybe (Key block))
 
+  enqueueBlock :: a -> Block block -> m (Maybe (Key block))
+
   getBlock :: a -> Key block -> m (Maybe (Block block))
 
   getChunk :: a -> Key block -> Offset -> Size -> m (Maybe (Block block))

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

@@ -264,11 +264,12 @@ simpleGetChunkLazy s key off size = do
 
   atomically $ TBMQ.readTBMQueue resQ >>= maybe (pure Nothing) pure
 
-simplePutBlockLazy :: SimpleStorage h
+simplePutBlockLazy :: Bool -- | wait
+                   -> SimpleStorage h
                    -> LBS.ByteString
                    -> IO (Maybe (Key (Raw LBS.ByteString)))
 
-simplePutBlockLazy  s lbs = do
+simplePutBlockLazy doWait s lbs = do
 
   let hash = hashObject lbs :: Key (Raw LBS.ByteString)
   let fn = simpleBlockFileName s hash
@@ -290,9 +291,11 @@ simplePutBlockLazy  s lbs = do
 
     simpleAddTask s action
 
-    ok <- atomically $ TBQ.readTBQueue waits
-
-    pure $! if ok then Just hash else Nothing
+    if doWait then do
+      ok <- atomically $ TBQ.readTBQueue waits
+      pure $! if ok then Just hash else Nothing
+    else
+      pure $ Just hash
 
 
 simpleBlockExists :: SimpleStorage h
@@ -309,7 +312,9 @@ instance (MonadIO m, (Hashed hash (Raw LBS.ByteString)))
 
   type instance StorageHash (SimpleStorage hash) (Raw LBS.ByteString) = hash
 
-  putBlock s lbs = liftIO $ simplePutBlockLazy s lbs
+  putBlock s lbs = liftIO $ simplePutBlockLazy True s lbs
+
+  enqueueBlock s lbs = liftIO $ simplePutBlockLazy False s  lbs
 
   getBlock s key = liftIO $ simpleGetBlockLazy s key
 

hbs2/Main.hs

@@ -59,12 +59,12 @@ runStore opts ss = do
   handle <- maybe (pure stdin) (flip openFile ReadMode . unOptFile) fname
 
   hashes <- readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings!
-                & S.mapM (\blk -> putBlock ss (LBS.fromStrict blk) >> pure blk)
+                & S.mapM (\blk -> enqueueBlock ss (LBS.fromStrict blk) >> pure blk)
                 & S.map hashObject
                 & S.map HashRef
                 & S.toList_
 
-  let pt = toPTree (MaxSize 2048) (MaxNum 2048) hashes
+  let pt = toPTree (MaxSize 2048) (MaxNum 2048) hashes -- FIXME: settings
 
   root <- makeMerkle 0 pt $ \(h,_,bs) -> void $ putBlock ss bs