diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs index 9c1cb61a..92abdc8c 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs @@ -403,7 +403,16 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do makeMerge = do me <- ContT $ withAsync $ untilStopped do micropause @'Seconds 10 - debug "MERGE THREAD" + req <- readTVarIO ncqMergeReq + + when (req > 0) do + debug $ "STARTED MERGE" <+> pretty req + + try @_ @SomeException (ncqStorageMergeStep ncq) >>= \case + Right{} -> none + Left e -> err ("MERGE ERROR:" <+> viaShow e) + + atomically $ writeTVar ncqMergeReq 0 link me pure me diff --git a/hbs2-tests/test/TCQ.hs b/hbs2-tests/test/TCQ.hs index 5666ba66..a0414ba7 100644 --- a/hbs2-tests/test/TCQ.hs +++ b/hbs2-tests/test/TCQ.hs @@ -221,6 +221,19 @@ main = do pure nil + entry $ bindMatch "ncq:merge" $ \syn -> lift do + + tcq <- case syn of + [ isOpaqueOf @TCQ -> Just tcq ] -> do + pure tcq + + e -> throwIO $ BadFormException @C (mkList e) + + ncq <- getNCQ tcq + ncqStorageMerge ncq + + pure nil + entry $ bindMatch "ncq:close" $ nil_ \case [ isOpaqueOf @TCQ -> Just tcq ] -> lift do ncq <- getNCQ tcq