wip, ncq3 fixes + storage update

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
+  let files = List.sortOn Down files1 & fmap snd
-           <&> fmap DataFile .  HS.toList . ncqStateFiles
-           <&> List.sortOn Down
 
   NCQState{..}  <- readTVarIO ncqState
 
+  -- cur <- ncqCurrentFossils
+
   let tss = ncqStateIndex & fmap (\(Down x, y) -> (y, realToFrac x :: POSIXTime)) & HM.fromList
 
-  cur <- readTVarIO ncqCurrentFossils
+  r' <- lift $ ncqFindMinPairOf me files
-  r' <- lift $ ncqFindMinPairOfBy me (\x -> not (HS.member (coerce x) cur)) 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

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

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"
+    wExit     <-  dbl <$> lookupValueDef (mkDouble  0.001) "w:exit"
-    wSweep    <-  dbl <$> lookupValueDef (mkDouble  0.001) "w:sweep"
+    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"
 
 
@@ -297,6 +301,10 @@ ncq3EnduranceTest = do
       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
@@ -348,8 +356,10 @@ ncq3EnduranceTest = do
                     , (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
+                       <+> "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"

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