before switch to ncq3

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

@@ -36,6 +36,18 @@ ncqStorageStop NCQStorage{..} = do
   atomically $ writeTVar ncqStopReq True
 
 
+ncqRemoveGarbage :: forall m. MonadIO m
+                => NCQStorage
+                -> m ()
+
+ncqRemoveGarbage me = do
+  let wd = ncqGetWorkDir me
+  let garb x = List.isSuffixOf ".part" x
+                || List.isSuffixOf ".cq$" x
+                || List.isSuffixOf ".merge" x
+
+  dirFiles wd <&> filter garb >>= mapM_ rm
+
 ncqTryLoadState :: forall m. MonadUnliftIO m
                 => NCQStorage
                 -> m ()
@@ -156,6 +168,8 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
   ContT $ bracket none $ const $ liftIO do
     debug "storage done"
 
+  ncqRemoveGarbage ncq
+
   liftIO (ncqTryLoadState ncq)
 
   closeQ <- liftIO newTQueueIO

hbs2-tests/test/NCQ3/Endurance.hs

@@ -163,7 +163,7 @@ validateTestResult logFile = do
 
         entry $ bindMatch "has-seed-block-result" $ nil_ \case
           [ HashLike _, LitIntVal _ ] -> none
-          [ HashLike h]  -> err $ red "missed seed block" <+> pretty h
+          [ HashLike h]  -> err $ red "missed seed block (2)" <+> pretty h
           _ -> none
 
         -- has-block-result
@@ -374,33 +374,30 @@ ncq3EnduranceTest = do
         for_ seeds $ \(h,_,_) -> do
           here <- hasBlock (AnyStorage sto) (coerce h)
           unless (isJust here) do
-            err $ "missed seed block" <+> pretty h
+            err $ "missed seed block (1)" <+> pretty h
 
-      fix \recover -> handle (\(e :: IOException) -> err (viaShow e) >> pause @'Seconds 1 >> recover) do
+      let handler e = err (viaShow e) >> debug "RECOVERING" >> pause @'Seconds 3
+      fix \recover -> handleAny (\e -> handler e >> recover) do
 
         flip runContT pure do
           p <- startProcess conf -- ContT $ withProcessWait conf
-
           storms <- newTQueueIO
-
           let inp  = getStdin p
-          let outp = getStdout p
-
           let logFile = testEnvDir </> "op.log"
 
-          pread <- ContT $ withAsync $ fix \loop -> do
-            liftIO (try @_ @IOException (IO.hGetLine outp)) >>= \case
-              Left e | isEOFError e -> none
-              Left e -> err (viaShow e) >> throwIO e
-              Right s -> do
+          pread <- ContT $ withAsync $ flip runContT pure $ callCC \stop -> do
+            let outp = getStdout p
+            fix \loop -> do
+              s <- liftIO (try @_ @IOException (IO.hGetLine outp)) >>= \case
+                     Left  e -> err (red "pread:" <+> viaShow e) >> stop ()
+                     Right s -> pure s
+
               liftIO do
                 appendFile logFile (s <> "\n")
                 void $ try @_ @SomeException (parseTop s & either (err.viaShow) (void . run d))
                 putStrLn s
               loop
 
-          link pread
-
           ContT $ withAsync $ forever do
             join $ atomically (readTQueue storms)
 
@@ -506,8 +503,8 @@ ncq3EnduranceTest = do
               debug $ red "KILL" <+> viaShow pid
               cancel pread
               hFlush inp
-              hClose outp
-              pause @'Seconds 0.1
+              liftIO $ appendFile logFile "; killed"
+              pause @'Seconds 0.25
               void $ runProcess (proc "kill" ["-9", show pid])
               notice $ red "Killed" <+> viaShow pid
               atomically $ modifyTVar killed succ