wip

hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Class.hs

@@ -21,6 +21,7 @@ instance MonadUnliftIO m => Storage NCQStorage HbSync LBS.ByteString m where
   hasBlock     sto h   = ncqStorageHasBlock sto (coerce h)
 
   putBlock     sto lbs = fmap coerce <$> ncqPutBlock sto lbs
+
   enqueueBlock sto lbs = fmap coerce <$> ncqPutBlock sto lbs
 
   getBlock sto h = runMaybeT $ do

hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs

@@ -89,7 +89,7 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
     ema <- readTVarIO ncqWriteEMA
     debug $ "EMA" <+> pretty (realToFrac @_ @(Fixed E3) ema)
 
-  spawnActivity $ postponed 10 $ forever do
+  spawnActivity $ postponed 60 $ forever do
     lsInit <- ncqLiveKeys ncq <&> HS.size
     void $ race (pause @'Seconds 60) do
       flip fix lsInit $ \next ls0 -> do
@@ -110,7 +110,7 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
   spawnActivity $ postponed 10 $ compactLoop 10 300 do
     ncqIndexCompactStep ncq
 
-  spawnActivity $ postponed 15 $ compactLoop 10 600 do
+  spawnActivity $ postponed 20 $ compactLoop 10 600 do
     ncqFossilMergeStep ncq
 
 

hbs2-tests/test/NCQ3.hs

@@ -52,6 +52,7 @@ import System.Random.MWC as MWC
 import Control.Concurrent.STM qualified as STM
 import Data.List qualified as List
 import Control.Monad.Trans.Cont
+import Control.Monad.Except
 import System.IO.Temp qualified as Temp
 import System.Environment (getExecutablePath)
 import System.Process.Typed as PT
@@ -61,6 +62,8 @@ import UnliftIO.IO.File
 import UnliftIO.IO as IO
 import UnliftIO.Directory
 
+import Streaming.Prelude qualified as S
+
 {-HLINT ignore "Functor law"-}
 
 
@@ -587,6 +590,55 @@ ncq3Tests = do
     notice $ "second must fail" <+> pretty wx <+> "=>" <+> viaShow r
 
 
+  entry $ bindMatch "test:ncq3:merkle" $ nil_ $ \e -> runTest $ \TestEnv{..} -> do
+
+    let (opts,args) = splitOpts [] e
+    let n  = headDef (1 * gigabytes) [ fromIntegral x | LitIntVal x <- args ]
+
+    g <- liftIO MWC.createSystemRandom
+    ncqWithStorage testEnvDir $ \ncq -> do
+
+      fn <- liftIO $ Temp.emptyTempFile (ncqGetWorkDir ncq) "wtf"
+
+      debug $ "generate file" <+> pretty n <+> pretty fn
+
+      flip fix n $ \loop rest -> when (rest > 0) do
+          let size = min (1 * megabytes) rest
+          block <- liftIO $ genRandomBS g size
+          liftIO (BS.appendFile fn block)
+          loop (rest - size)
+
+
+      debug $ "done file" <+> pretty fn
+
+      debug $ "make merkle from" <+> pretty fn
+
+      let sto = AnyStorage ncq
+
+      lbs <- liftIO $ LBS.readFile fn
+
+      t0 <- getTimeCoarse
+
+      tree <- createTreeWithMetadata sto Nothing mempty lbs
+                >>= orThrowUser "can't create tree"
+
+      t2 <- getTimeCoarse
+
+      let s = sec2 (1e-9 * realToFrac (toNanoSecs (t2 - t0)))
+
+      notice $ "merkle hash" <+> pretty s <+> pretty tree
+
+      h0 <- liftIO (LBS.readFile fn) <&> HashRef . hashObject @HbSync
+
+      lbs1 <- runExceptT (getTreeContents sto tree)
+                >>= orThrowPassIO
+                <&> HashRef . hashObject @HbSync
+
+      notice $ "found" <+> pretty tree <+> pretty lbs1 <+> pretty h0
+
+      liftIO $ assertBool (show $ "hash eq" <+> pretty h0 <+> pretty lbs1) (h0 == lbs1)
+
+
   entry $ bindMatch "test:ncq3:storage:basic" $ nil_ $ \e -> do
     let (opts,args) = splitOpts [] e
     let n  = headDef 100000 [ fromIntegral x | LitIntVal x <- args ]