wip, ncq3 crash test

cabal.project

@@ -8,6 +8,7 @@ constraints:
     pandoc >=3.1.11
   , suckless-conf >= 0.1.2.7
   , http-client >=0.7.16 && <0.8
+  , typed-process >= 0.2.13.0
 
 
 debug-info: True

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

@@ -172,7 +172,7 @@ ncqTryLoadState me@NCQStorage3{..} = do
     let corrupted = isLeft good
 
     when corrupted $ liftIO do
-      warn $ red "trim" <+> pretty s <+> pretty (takeFileName path)
+      warn $ red "trim" <+> pretty s  <+> red (pretty (fromIntegral s - realSize)) <+> pretty (takeFileName path)
       PFS.setFileSize path (fromIntegral s)
 
     debug $ yellow "indexing" <+> pretty dataFile <+> pretty s <+> color (pretty realSize)

hbs2-tests/hbs2-tests.cabal

@@ -21,21 +21,23 @@ common common-deps
           base, hbs2-core, hbs2-storage-simple, hbs2-peer, hbs2-cli
         , fuzzy-parse
         , async
-        , bytestring
         , bloomfilter
+        , bytestring
         , cache
         , containers
         , data-default
         , deepseq
         , directory
         , filepath
-        , hashable
         , generic-lens
+        , hashable
+        , interpolatedstring-perl6
         , microlens-platform
         , mtl
         , mwc-random
-        , psqueues
         , prettyprinter
+        , prettyprinter-ansi-terminal
+        , psqueues
         , QuickCheck
         , random
         , random-shuffle
@@ -45,6 +47,7 @@ common common-deps
         , split
         , stm
         , streaming
+        , string-conversions
         , suckless-conf
         , tasty
         , tasty-hunit
@@ -52,13 +55,11 @@ common common-deps
         , temporary
         , timeit
         , transformers
+        , typed-process
         , uniplate
+        , unliftio
         , unordered-containers
         , vector
-        , prettyprinter-ansi-terminal
-        , interpolatedstring-perl6
-        , string-conversions
-        , unliftio
 
 common shared-properties
   ghc-options:

hbs2-tests/test/NCQ3.hs

@@ -49,6 +49,8 @@ import Control.Concurrent.STM qualified as STM
 import Data.List qualified as List
 import Control.Monad.Trans.Cont
 import System.IO.Temp qualified as Temp
+import System.Environment (getExecutablePath)
+import System.Process.Typed as PT
 import System.Random.Stateful
 import UnliftIO
 import UnliftIO.IO.File
@@ -290,6 +292,72 @@ ncq3Tests = do
               found <- ncqLocate sto h <&> isJust
               liftIO $ assertBool (show $ "found" <+> pretty h) found
 
+  entry $ bindMatch "test:ncq3:long-write" $ nil_ $ \e -> lift do
+    g <- liftIO MWC.createSystemRandom
+    let (opts,args) = splitOpts [] e
+
+    let seconds = headDef 10 [ t0 | LitScientificVal t0 <- args ]
+
+    let path' = headMay [ p | StringLike p  <- drop 1 $ args ]
+
+    path <- case path' of
+              Just p -> pure p
+              Nothing -> liftIO $ Temp.createTempDirectory "." "ncq-long-write-test"
+
+    let writtenLog = path </> "written.log"
+    touch writtenLog
+
+    ncqWithStorage3 path $ \sto -> do
+
+      race (pause @'Seconds (realToFrac seconds) >> ncqStorageStop3 sto) $ forever do
+        n <- liftIO  $ uniformRM (1, 256*1024) g
+        s <- liftIO $ genRandomBS g n
+        h <- ncqPutBS sto (Just B) Nothing s
+        liftIO $ appendFile writtenLog (show (pretty h <> line))
+        none
+
+
+  entry $ bindMatch "test:ncq3:crash-test1" $ nil_ \e -> runTest \TestEnv{..} -> do
+    g <- liftIO MWC.createSystemRandom
+    let (opts,args) = splitOpts [] e
+
+    let (s,seconds) = headDef (5.00,mkDouble 5) [ (realToFrac t0,s) | s@(LitScientificVal t0) <- args ]
+
+    let path0 = testEnvDir
+
+    self <- liftIO getExecutablePath
+
+    flip runContT pure do
+
+      p <- liftIO $ uniformM @Word32 g
+
+      let path = path0 </> show p
+
+      notice $ "Run" <+> pretty testEnvDir <+> pretty (sec2 s)
+
+      p <- ContT $ withProcessWait (proc self ["test:ncq3:long-write", show (pretty seconds), path])
+
+      pid <- liftIO (PT.getPid p) `orDie` "oopsie!"
+
+      delta <- liftIO $ uniformRM (0.25, s - 0.10) g
+      notice $ green "PID" <+> viaShow pid <+>  "wait" <+> pretty delta
+
+      pause @'Seconds (realToFrac delta)
+
+      void $ runProcess (proc "kill" ["-9", show pid])
+
+      notice $ "Killed" <+> viaShow pid <+> pretty testEnvDir <+> "at" <+> pretty (sec2 delta)
+
+      pause @'Seconds 2
+
+      notice "Try open storage"
+
+      lift $ ncqWithStorage3 path $ \sto -> do
+        notice "okay?"
+        pause @'Seconds 5
+
+    none
+
   entry $ bindMatch "test:ncq3:concurrent1" $ nil_ $ \case
     [ LitIntVal tn, LitIntVal n ] -> do
       debug $ "ncq2:concurrent1" <+> pretty tn <+> pretty n