wip

hbs2-peer/app/PeerMain.hs

@@ -31,8 +31,8 @@ import HBS2.Net.Proto.Notify
 import HBS2.Peer.Proto.Mailbox
 import HBS2.OrDie
 import HBS2.Storage.Simple
--- import HBS2.Storage.NCQ3
+import HBS2.Storage.NCQ3
-import HBS2.Storage.NCQ
+-- import HBS2.Storage.NCQ
 import HBS2.Storage.Operations.Missed
 import HBS2.Data.Detect
 
@@ -822,13 +822,13 @@ runPeer opts = respawnOnError opts $ flip runContT pure do
 
   -- error "STOP"
 
-  -- let ncqPath = coerce pref </> "ncq3"
+  let ncqPath = coerce pref </> "ncq3"
-  let ncqPath = coerce pref </> "ncq"
+  -- let ncqPath = coerce pref </> "ncq"
 
   debug $ "storage prefix:" <+> pretty ncqPath
 
   -- s <- ContT $ ncqWithStorage ncqPath
-  s <- lift $ ncqStorageOpen ncqPath
+  s <- lift $ ncqStorageOpen ncqPath id
 
   -- simpleStorageInit @HbSync (Just pref)
   let blk = liftIO . hasBlock s
@@ -1380,7 +1380,7 @@ runPeer opts = respawnOnError opts $ flip runContT pure do
                                , monkeys
                                ]
 
-  -- liftIO $ ncqStorageStop s
+  liftIO $ ncqStorageStop s
   pause @'Seconds 1
 
   -- we want to clean up all resources
@@ -1399,7 +1399,7 @@ checkMigration prefix  = flip runContT pure $ callCC \exit -> do
   already <- Sy.doesDirectoryExist migration
 
   when (L.null blocks && not already) do
-    -- checkNCQ1
+    checkNCQ1
     exit ()
 
   let reason = if already then
@@ -1417,14 +1417,15 @@ checkMigration prefix  = flip runContT pure $ callCC \exit -> do
 
 
   where
-    -- checkNCQ1 = do
+    checkNCQ1 :: ContT () m ()
-    --   let ncq1Dir =  prefix </> "ncq"
+    checkNCQ1 = do
-    --   ncq1Here <- Sy.doesDirectoryExist ncq1Dir
+      let ncq1Dir =  prefix </> "ncq"
-    --   when ncq1Here do
+      ncq1Here <- Sy.doesDirectoryExist ncq1Dir
-    --     notice $ yellow "found NCQv1 storage"
+      when ncq1Here do
-    --     notice $ red "Run" <+> "hbs2-peer migrate" <+> pretty prefix
+        notice $ yellow "found NCQv1 storage"
-    --              <> line
+        notice $ red "Run" <+> "hbs2-peer migrate" <+> pretty prefix
-    --              <> "to migrate the storage to a new version"
+                 <> line
-    --     notice $ "You may also: backup" <+> pretty ncq1Dir <+> "or move it or remove permanently"
+                 <> "to migrate the storage to a new version"
-    --     liftIO exitFailure
+        notice $ "You may also: backup" <+> pretty ncq1Dir <+> "or move it or remove permanently"
+        liftIO exitFailure
 

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

@@ -204,7 +204,7 @@ ncqTryLoadState :: forall m. MonadUnliftIO m
                 => NCQStorage
                 -> m ()
 
-ncqTryLoadState me@NCQStorage{..} = do
+ncqTryLoadState me@NCQStorage{..} = withSem ncqServiceSem do
 
   stateFiles <- ncqListFilesBy me ( List.isPrefixOf "s-" )
 

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

@@ -86,7 +86,7 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
       -- debug $ "NOT FOUND SHIT" <+> pretty h
       answer Nothing >> exit ()
 
-  spawnActivity measureWPS
+  -- spawnActivity measureWPS
 
   spawnActivity (ncqStateUpdateLoop ncq)
 
@@ -113,7 +113,7 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
         ncqSweepFiles ncq
         next lsB
 
-  spawnActivity $ postponed 10 $ compactLoop 10 30 do
+  spawnActivity $ postponed 20 $ compactLoop 10 30 do
     ncqIndexCompactStep ncq
 
   spawnActivity $ postponed 20 $ compactLoop 10 60 do
@@ -234,6 +234,7 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
       link a
       pure a
 
+    measureWPS :: m ()
     measureWPS = void $ flip fix Nothing \loop -> \case
       Nothing      -> do
         w <- readTVarIO ncqWrites

hbs2-tests/test/NCQ3.hs

@@ -331,6 +331,12 @@ ncq3Tests = do
 
       race (pause @'Seconds (realToFrac seconds) >> ncqStorageStop sto) $ forever do
         n <- liftIO  $ uniformRM (1, 256*1024) g
+
+        p <- liftIO  $ uniformRM (0.00, 1.00) g
+
+        when (p < 0.11 ) do
+          none
+
         s <- liftIO $ genRandomBS g n
         h <- ncqPutBS sto (Just B) Nothing s
         liftIO $ appendFile writtenLog (show (pretty h <+> pretty n <> line))
@@ -347,11 +353,11 @@ ncq3Tests = do
 
     self <- liftIO getExecutablePath
 
+    replicateM_ 5 do
+
       flip runContT pure do
 
-      p <- liftIO $ uniformM @Word32 g
+        let path = path0
-
-      let path = path0 </> show p
 
         p <- ContT $ withProcessWait (proc self ["debug off"
                                                 , "and"

hbs2-tests/test/NCQ3/EnduranceInProc.hs

@@ -77,6 +77,10 @@ import Streaming.Prelude qualified as S
 
 {-HLINT ignore "Functor law"-}
 
+data AbortException = AbortException
+                      deriving stock (Show, Typeable)
+
+instance Exception AbortException
 
 data EnduranceFSM =
     EnduranceIdle
@@ -89,6 +93,7 @@ data EnduranceFSM =
   | EnduranceDelRef
   | EnduranceStorm
   | EnduranceCalm
+  | EnduranceAbort
   | EnduranceStop
 
 buildCDF :: [(s, Double)] -> (V.Vector s, U.Vector Double)
@@ -274,6 +279,7 @@ ncq3EnduranceTestInProc = do
     wMaxBlk   <-  int <$> lookupValueDef (mkInt 262144)    "w:blk"
     wStormMin <-  dbl <$> lookupValueDef (mkDouble 1.00)   "w:stormmin"
     wStormMax <-  dbl <$> lookupValueDef (mkDouble 60.00)  "w:stormmax"
+    wAbort    <-  dbl <$> lookupValueDef (mkDouble 0.001)  "w:abort"
 
     runTest \TestEnv{..} -> do
       g <- liftIO $ MWC.createSystemRandom
@@ -302,11 +308,12 @@ ncq3EnduranceTestInProc = do
                     , (EnduranceDelRef, wDelRef)
                     , (EnduranceStorm,  wStorm)
                     , (EnduranceCalm,   wCalm)
+                    , (EnduranceAbort,  wAbort)
                     ]
 
       let dist = buildCDF actions   -- ← подготовили один раз
 
-      fix \recover -> handle (\(e :: IOException) -> err (viaShow e) >> pause @'Seconds 1 >> recover) do
+      fix \recover -> handleAny (\e -> err (viaShow e) >> pause @'Seconds 1 >> recover) do
 
         flip runContT pure do
 
@@ -437,6 +444,11 @@ ncq3EnduranceTestInProc = do
               pause @'Seconds (realToFrac n)
               getNextState >>= loop
 
+            EnduranceAbort -> do
+              debug $ red "EnduranceAbort"
+              pause @'Seconds 0.01
+              throwIO AbortException
+
             EnduranceStorm -> do
               now <- getTimeCoarse
               relaxTill <- readTVarIO trelaxTill