diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Class.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Class.hs index f821078b..f461377e 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Class.hs +++ b/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 diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs index e97eb0c3..dde9bce7 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs +++ b/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 diff --git a/hbs2-tests/test/NCQ3.hs b/hbs2-tests/test/NCQ3.hs index b6662355..da36c0d2 100644 --- a/hbs2-tests/test/NCQ3.hs +++ b/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 ]