diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs index b47157a3..d9ec1f4c 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs @@ -67,17 +67,26 @@ ncqFossilMergeStep me@NCQStorage{..} = flip runContT pure $ callCC \exit -> do debug "ncqFossilMergeStep" + files0 <- atomically do + NCQState{..} <- readTVar ncqState + cur <- readTVar ncqCurrentFossils + pure (fmap DataFile $ HS.toList $ ncqStateFiles `HS.difference` cur) + + files1 <- for files0 $ \fd -> do + let fn = ncqGetFileName me fd + ts1 <- liftIO (PFS.getFileStatus fn) <&> PFS.modificationTimeHiRes + pure (ts1, fd) + -- TODO: consider-sort-by-timestamps - files <- readTVarIO ncqState - <&> fmap DataFile . HS.toList . ncqStateFiles - <&> List.sortOn Down + let files = List.sortOn Down files1 & fmap snd NCQState{..} <- readTVarIO ncqState + -- cur <- ncqCurrentFossils + let tss = ncqStateIndex & fmap (\(Down x, y) -> (y, realToFrac x :: POSIXTime)) & HM.fromList - cur <- readTVarIO ncqCurrentFossils - r' <- lift $ ncqFindMinPairOfBy me (\x -> not (HS.member (coerce x) cur)) files + r' <- lift $ ncqFindMinPairOf me files r@(sumSize, f1, f2) <- ContT $ maybe1 r' (pure False) @@ -131,6 +140,10 @@ ncqFossilMergeStep me@NCQStorage{..} = flip runContT pure $ callCC \exit -> do debug $ "MOVED" <+> pretty outFile <+> pretty newFile moveFile outFile newFile + let f1p = ncqGetFileName me f1 + ts1 <- liftIO (PFS.getFileStatus f1p) <&> PFS.modificationTimeHiRes + liftIO $ PFS.setFileTimesHiRes newFile ts1 ts1 + ss <- liftIO (PFS.getFileStatus newFile) <&> fromIntegral . PFS.fileSize ncqStateUpdate me 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 49f1cd87..66aa02cf 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs @@ -396,7 +396,12 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do ncqStateUpdate ncq do ncqStateAddFact (P (PData (DataFile fk) 0)) - ncqStateAddDataFile fk + -- FIXM: asap-remove-this + -- это неправильно. из-за этого файл + -- болтается в current и мешает при мерже + -- хотя это еще не настоящий файл (до индексации). + -- почему мы вообще его сюда засунули? + -- ncqStateAddDataFile fk let fname = ncqGetFileName ncq (DataFile fk) -- touch fname diff --git a/hbs2-tests/test/NCQ3/Endurance.hs b/hbs2-tests/test/NCQ3/Endurance.hs index 4d4dfb54..329ee28d 100644 --- a/hbs2-tests/test/NCQ3/Endurance.hs +++ b/hbs2-tests/test/NCQ3/Endurance.hs @@ -91,7 +91,9 @@ data EnduranceFSM = | EnduranceStorm | EnduranceCalm | EnduranceKill + | EnduranceExit | EnduranceMerge + | EnduranceCompact | EnduranceSweep | EnduranceStop @@ -280,8 +282,10 @@ ncq3EnduranceTest = do wStormMax <- dbl <$> lookupValueDef (mkDouble 60.00) "w:stormmax" wCalm <- dbl <$> lookupValueDef (mkDouble 0.001) "w:calm" wKill <- dbl <$> lookupValueDef (mkDouble 0.00) "w:kill" - wMerge <- dbl <$> lookupValueDef (mkDouble 0.001) "w:merge" - wSweep <- dbl <$> lookupValueDef (mkDouble 0.001) "w:sweep" + wExit <- dbl <$> lookupValueDef (mkDouble 0.001) "w:exit" + wMerge <- dbl <$> lookupValueDef (mkDouble 0.005) "w:merge" + wCompact <- dbl <$> lookupValueDef (mkDouble 0.005) "w:compact" + wSweep <- dbl <$> lookupValueDef (mkDouble 0.005) "w:sweep" wNum <- int <$> lookupValueDef (mkInt 10000) "w:num" @@ -292,11 +296,15 @@ ncq3EnduranceTest = do let n = headDef wNum [ fromIntegral x | LitIntVal x <- args ] - rest <- newTVarIO n - blocks <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () ) - seed <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () ) - refs <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double HashRef ) - killed <- newTVarIO 0 + rest <- newTVarIO n + blocks <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () ) + seed <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () ) + refs <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double HashRef ) + killed <- newTVarIO 0 + stopped <- newTVarIO 0 + merged <- newTVarIO 0 + sweeped <- newTVarIO 0 + compacted <- newTVarIO 0 let getRandomBlock = liftIO $ getRandomFromPSQ g blocks let getRandomSeedBlock = liftIO $ getRandomFromPSQ g seed @@ -336,20 +344,22 @@ ncq3EnduranceTest = do -- debug $ red "pKill" <+> pretty wKill - let actions = [ (EnduranceIdle, wIdle) - , (EndurancePutBlk, wPutBlk) - , (EnduranceGetBlk, wGetBlk) + let actions = [ (EnduranceIdle, wIdle) + , (EndurancePutBlk, wPutBlk) + , (EnduranceGetBlk, wGetBlk) , (EnduranceHasSeedBlk, wHasBlk) - , (EnduranceHasBlk, wHasBlk) - , (EnduranceDelBlk, wDelBlk) - , (EndurancePutRef, wPutRef) - , (EnduranceGetRef, wGetRef) - , (EnduranceDelRef, wDelRef) - , (EnduranceStorm, wStorm) - , (EnduranceCalm, wCalm) - , (EnduranceMerge, wMerge) - , (EnduranceSweep, wSweep) - , (EnduranceKill, wKill) + , (EnduranceHasBlk, wHasBlk) + , (EnduranceDelBlk, wDelBlk) + , (EndurancePutRef, wPutRef) + , (EnduranceGetRef, wGetRef) + , (EnduranceDelRef, wDelRef) + , (EnduranceStorm, wStorm) + , (EnduranceCalm, wCalm) + , (EnduranceMerge, wMerge) + , (EnduranceCompact, wCompact) + , (EnduranceSweep, wSweep) + , (EnduranceKill, wKill) + , (EnduranceExit, wExit) ] let dist = buildCDF actions -- ← подготовили один раз @@ -406,12 +416,20 @@ ncq3EnduranceTest = do b <- readTVarIO blocks <&> HPSQ.size r <- readTVarIO refs <&> HPSQ.size k <- readTVarIO killed + s <- readTVarIO stopped + c <- readTVarIO compacted + m <- readTVarIO merged + sw <- readTVarIO sweeped notice $ green "status" <+> "rest:" <+> pretty rest - <+> "b:" <+> pretty b - <+> "r:" <+> pretty r - <+> "k:" <+> pretty k + <+> "b:" <+> pretty b + <+> "r:" <+> pretty r + <+> "m:" <+> pretty m + <+> "sw:" <+> pretty sw + <+> "c:" <+> pretty c + <+> "k:" <+> pretty k + <+> "s:" <+> pretty s pause @'Seconds 1 @@ -493,12 +511,30 @@ ncq3EnduranceTest = do EnduranceMerge -> do liftIO $ IO.hPrint inp "merge" + atomically $ modifyTVar merged succ + getNextState >>= loop + + EnduranceCompact -> do + liftIO $ IO.hPrint inp "compact" + atomically $ modifyTVar compacted succ getNextState >>= loop EnduranceSweep -> do liftIO $ IO.hPrint inp "sweep" + atomically $ modifyTVar sweeped succ getNextState >>= loop + EnduranceExit -> do + liftIO $ IO.hPrint inp "exit" + debug $ yellow "inner process stopped?" + liftIO $ race (pause @'Seconds 1) (waitExitCode p) >>= \case + Right{} -> none + Left{} -> do + debug $ red "force inner process to stop" + stopProcess p + atomically $ modifyTVar stopped succ + lift recover + EnduranceKill -> do debug $ red "KILL" <+> viaShow pid cancel pread @@ -508,6 +544,7 @@ ncq3EnduranceTest = do void $ runProcess (proc "kill" ["-9", show pid]) notice $ red "Killed" <+> viaShow pid atomically $ modifyTVar killed succ + pause @'Seconds 0.5 lift recover EnduranceStop -> do @@ -575,7 +612,10 @@ testEnduranceInner path = flip runContT pure $ callCC \exit -> do lift (try @_ @SomeException (run @c (dict g sto) s')) >>= \case Left e -> err (viaShow e) - Right (StringLike "done") -> exit () + Right (StringLike "done") -> do + liftIO $ IO.hPutStrLn stderr $ "INNER PROCESS TO EXIT" + exit () + Right _ -> none where @@ -646,6 +686,10 @@ testEnduranceInner path = flip runContT pure $ callCC \exit -> do ncqSetFlag ncqMergeReq liftIO $ print $ "merge" + entry $ bindMatch "compact" $ nil_ $ const do + ncqSetFlag ncqCompactReq + liftIO $ print $ "compact" + entry $ bindMatch "sweep" $ nil_ $ const do ncqSetFlag ncqSweepReq liftIO $ print $ "sweep" diff --git a/hbs2-tests/test/TestNCQ.hs b/hbs2-tests/test/TestNCQ.hs index f4aa7256..425f244b 100644 --- a/hbs2-tests/test/TestNCQ.hs +++ b/hbs2-tests/test/TestNCQ.hs @@ -609,89 +609,6 @@ main = do [] -> SC.bind "test:dir:keep" (mkBool True) e -> throwIO $ BadFormException @C (mkList e) - entry $ bindMatch "test:ncq:fuckup-recovery1" $ nil_ $ \_ -> do - debug $ "test:ncq:fuckup-recovery1" - runTest testNCQFuckupRecovery1 - - entry $ bindMatch "test:ncq:long-write" $ nil_ $ \case - [ LitIntVal n ] -> runTest $ testNCQLongWrite (fromIntegral n) - e -> throwIO $ BadFormException @C (mkList e) - - entry $ bindMatch "test:ncq:long-write-read" $ nil_ $ \case - [ LitIntVal n ] -> runTest $ testNCQLongWriteRead (fromIntegral n) - e -> throwIO $ BadFormException @C (mkList e) - - entry $ bindMatch "test:ncq:test-simple1" $ nil_ $ \case - [] -> runTest $ testNCQSimple1 - e -> throwIO $ BadFormException @C (mkList e) - - entry $ bindMatch "test:ncq:test-simple2" $ nil_ $ \case - [ LitIntVal n ] -> runTest $ testNCQSimple2 (fromIntegral n) - e -> throwIO $ BadFormException @C (mkList e) - - entry $ bindMatch "test:ncq:test1" $ nil_ $ \case - [ LitIntVal n ] -> do - debug $ "ncq:test1" <+> pretty n - runTest $ testNCQ1 (fromIntegral n) - - e -> throwIO $ BadFormException @C (mkList e) - - entry $ bindMatch "test:ncq:refs1" $ nil_ $ \case - [ LitIntVal n ] -> do - debug $ "ncq:refs1" <+> pretty n - runTest $ testNCQRefs1 (fromIntegral n) - - e -> throwIO $ BadFormException @C (mkList e) - - entry $ bindMatch "test:ncq:tree1" $ nil_ $ \case - [ LitIntVal n ] -> do - debug $ "ncq:tree1" <+> pretty n - runTest $ testNCQTree1 (fromIntegral n) - - e -> throwIO $ BadFormException @C (mkList e) - - entry $ bindMatch "test:ncq:concurrent1" $ nil_ $ \case - [ LitIntVal tn, LitIntVal n ] -> do - debug $ "ncq:concurrent1" <+> pretty tn <+> pretty n - runTest $ testNCQConcurrent1 False ( fromIntegral tn) (fromIntegral n) - - e -> throwIO $ BadFormException @C (mkList e) - - entry $ bindMatch "test:ncq:concurrent1:wo" $ nil_ $ \case - [ LitIntVal tn, LitIntVal n ] -> do - debug $ "ncq:concurrent1" <+> pretty tn <+> pretty n - runTest $ testNCQConcurrent1 True ( fromIntegral tn) (fromIntegral n) - - e -> throwIO $ BadFormException @C (mkList e) - - entry $ bindMatch "test:ncq:test-lock" $ nil_ $ \case - [ ] -> do - runTest $ \TestEnv{..} -> do - debug $ "test:ncq:test-lock" <+> pretty testEnvDir - - let ncq1 = testEnvDir "ncq1" - - flip runContT pure do - - pause @'Seconds 2 - r1 <- ContT $ withAsync do - withNCQ id ncq1 $ \_ -> do - forever $ pause @'Seconds 1 - - -- link r1 - - sto2 <- ContT $ withNCQ id ncq1 - - result <- poll r1 - - notice $ viaShow result - - case result of - Just Left{} -> none - _ -> liftIO $ assertBool "must be (Left _)" False - - e -> throwIO $ BadFormException @C (mkList e) - -- NCQ3 tests ncq3Tests