endurance test skeleton

hbs2-tests/hbs2-tests.cabal

@@ -1211,7 +1211,7 @@ executable test-ncq
     ghc-options:
     hs-source-dirs:   test
     main-is:          TestNCQ.hs
-    other-modules:    NCQTestCommon NCQ3
+    other-modules:    NCQTestCommon NCQ3 NCQ3.Endurance
     build-depends:
           base, hbs2-core, hbs2-log-structured, hbs2-storage-ncq
         , network

hbs2-tests/test/NCQ3.hs

@@ -1,3 +1,4 @@
+{-# Language AllowAmbiguousTypes #-}
 {-# Language RecordWildCards #-}
 {-# Language MultiWayIf #-}
 module NCQ3 where
@@ -35,6 +36,7 @@ import Data.Config.Suckless.Script as SC
 import Data.Config.Suckless.System
 
 import NCQTestCommon
+import NCQ3.Endurance
 
 import Data.Generics.Labels
 import Lens.Micro.Platform
@@ -42,6 +44,7 @@ import Network.ByteOrder qualified as N
 import System.TimeIt
 import Data.Fixed
 import Data.HashSet qualified as HS
+import Data.HashPSQ qualified as HPSQ
 import Data.HashMap.Strict qualified as HM
 import Test.Tasty.HUnit
 import Data.ByteString qualified as BS
@@ -56,6 +59,9 @@ import Control.Monad.Except
 import System.IO.Temp qualified as Temp
 import System.Environment (getExecutablePath)
 import System.Process.Typed as PT
+import System.IO qualified as IO
+import System.Posix.IO qualified as Posix
+import GHC.IO.Handle qualified as GHC
 import System.Random.Stateful
 import UnliftIO
 import UnliftIO.IO.File
@@ -829,6 +835,9 @@ ncq3Tests = do
 
       notice "re-opened storage test done"
 
+
+  ncq3EnduranceTest
+
 testNCQ3Concurrent1 :: MonadUnliftIO m
          => Bool
          -> Int
@@ -1000,6 +1009,3 @@ testNCQ3Lookup1 syn TestEnv{..} = do
 
 
 
-
-
-

hbs2-tests/test/NCQ3/Endurance.hs

@@ -0,0 +1,578 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language RecordWildCards #-}
+{-# Language MultiWayIf #-}
+module NCQ3.Endurance where
+
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.Hash
+import HBS2.Data.Types.Refs
+import HBS2.Misc.PrettyStuff
+import HBS2.Clock
+import HBS2.Merkle
+import HBS2.Polling
+import HBS2.Peer.Proto.AnyRef
+
+import HBS2.Storage
+import HBS2.Storage.Simple
+import HBS2.Storage.Operations.ByteString
+import HBS2.Storage.NCQ3
+import HBS2.Storage.NCQ3.Internal.Files
+import HBS2.Storage.NCQ3.Internal.Index
+import HBS2.Storage.NCQ3.Internal.Fossil
+import HBS2.Storage.NCQ3.Internal.State
+import HBS2.Storage.NCQ3.Internal.Sweep
+import HBS2.Storage.NCQ3.Internal
+
+import HBS2.System.Logger.Simple.ANSI
+
+import HBS2.Data.Log.Structured.SD
+import HBS2.Data.Log.Structured.NCQ
+
+import HBS2.CLI.Run.Internal.Merkle
+
+import Data.Config.Suckless.Syntax
+import Data.Config.Suckless.Script as SC
+import Data.Config.Suckless.System
+
+import NCQTestCommon
+
+import Data.Generics.Labels
+import Lens.Micro.Platform
+import Network.ByteOrder qualified as N
+import System.TimeIt
+import Data.Fixed
+import Data.HashSet qualified as HS
+import Data.Either
+import Data.HashPSQ qualified as HPSQ
+import Data.HashMap.Strict qualified as HM
+import Test.Tasty.HUnit
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
+import Data.Ord
+import Data.Set qualified as Set
+import System.Random.MWC as MWC
+import Control.Concurrent.STM qualified as STM
+import Data.List qualified as List
+import Control.Monad.Trans.Cont
+import Control.Monad.Except
+import System.IO.Temp qualified as Temp
+import System.Environment (getExecutablePath)
+import System.Process.Typed as PT
+import System.IO qualified as IO
+import System.IO.Error
+import System.Posix.IO qualified as Posix
+import GHC.IO.Handle qualified as GHC
+import System.Random.Stateful
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as U
+import UnliftIO
+import UnliftIO.IO.File
+import UnliftIO.IO as IO
+import UnliftIO.Directory
+
+import Streaming.Prelude qualified as S
+
+{-HLINT ignore "Functor law"-}
+
+
+data EnduranceFSM =
+    EnduranceIdle
+  | EndurancePutBlk
+  | EnduranceHasBlk
+  | EnduranceGetBlk
+  | EnduranceDelBlk
+  | EndurancePutRef
+  | EnduranceGetRef
+  | EnduranceDelRef
+  | EnduranceStorm
+  | EnduranceKill
+  | EnduranceStop
+
+buildCDF :: [(s, Double)] -> (V.Vector s, U.Vector Double)
+buildCDF xs =
+  let states = V.fromList (map fst xs)
+      cdf    = U.fromList (scanl1 (+) (map snd xs))
+  in (states, cdf)
+
+-- выборка по бинарному поиску
+sampleState :: MonadIO m => GenIO -> (V.Vector s, U.Vector Double) -> m s
+sampleState g (states,cdf) = do
+  let total = U.last cdf
+  r <- liftIO $ uniformRM (0,total) g
+  pure $ states V.! binarySearch cdf r
+
+binarySearch :: U.Vector Double -> Double -> Int
+binarySearch vec x = go 0 (U.length vec - 1)
+  where
+    go l r
+      | l >= r    = l
+      | otherwise =
+          let mid = (l+r) `div` 2
+          in if x <= vec U.! mid
+               then go l mid
+               else go (mid+1) r
+
+-- | Pick a random key from a HashPSQ
+getRandomFromPSQ :: forall k p v m . (MonadIO m, Hashable k, Ord k, Ord p)
+                 => MWC.GenIO
+                 -> TVar (HPSQ.HashPSQ k p v)
+                 -> m (Maybe k)
+getRandomFromPSQ g tvar = do
+  psq <- readTVarIO tvar
+  let n = HPSQ.size psq
+  if n == 0
+    then pure Nothing
+    else do
+      dropn <- liftIO $ uniformRM (0, n-1) g
+      let e = fmap (view _1) . headMay $ drop dropn $ HPSQ.toList psq
+      pure e
+
+
+-- | Deleted = Left (), Alive = Right size
+type BlockState = Either () Integer
+
+-- | Deleted = Left (), Alive = Right destination
+type RefState   = Either () HashRef
+
+validateTestResult :: forall m . MonadUnliftIO m => FilePath -> m ()
+validateTestResult logFile = do
+
+  blocks <- newTVarIO (mempty :: HM.HashMap HashRef BlockState)
+  refs   <- newTVarIO (mempty :: HM.HashMap HashRef RefState)
+
+  let dict = makeDict @C do
+
+        -- block-written: remember size
+        entry $ bindMatch "block-written" $ nil_ \case
+          [ HashLike h, LitIntVal n ] ->
+            atomically $ modifyTVar blocks (HM.insert h (Right n))
+          _ -> none
+
+        -- block-deleted: mark deleted
+        entry $ bindMatch "block-deleted" $ nil_ \case
+          [ HashLike h ] ->
+            atomically $ modifyTVar blocks (HM.insert h (Left ()))
+          _ -> none
+
+        -- has-block-result
+        entry $ bindMatch "has-block-result" $ nil_ \case
+          [ HashLike h, LitIntVal n ] -> do
+            really <- readTVarIO blocks <&> HM.lookup h
+            case really of
+              Just (Right n0) | n0 == n -> none
+              Just (Left ())             -> err $ red "has-block says present, but deleted" <+> pretty h
+              _                          -> err $ red "has-block mismatch" <+> pretty h
+
+          [ HashLike h ] -> do
+            really <- readTVarIO blocks <&> HM.lookup h
+            case really of
+              Just (Left ()) -> none
+              Nothing        -> none
+              Just (Right _) -> err $ red "has-block says missing, but we have" <+> pretty h
+          _ -> none
+
+        -- get-block-result
+        entry $ bindMatch "get-block-result" $ nil_ \case
+          [ HashLike h, HashLike _hx ] -> do
+            really <- readTVarIO blocks <&> HM.lookup h
+            case really of
+              Just (Right _) -> none
+              Just (Left ()) -> err $ red "get-block returned data for deleted block" <+> pretty h
+              Nothing        -> err $ red "get-block returned data for unknown block" <+> pretty h
+
+          [ HashLike h ] -> do
+            really <- readTVarIO blocks <&> HM.lookup h
+            case really of
+              Just (Right _) -> err $ red "get-block missing, but expected present" <+> pretty h
+              _              -> none
+          _ -> none
+
+        -- ref-updated
+        entry $ bindMatch "ref-updated" $ nil_ \case
+          [ HashLike h, HashLike hdest ] ->
+            atomically $ modifyTVar refs (HM.insert h (Right hdest))
+          _ -> none
+
+        -- get-ref-result
+        entry $ bindMatch "get-ref-result" $ nil_ \case
+          [ HashLike h, HashLike hdest ] -> do
+            really <- readTVarIO refs <&> HM.lookup h
+            case really of
+              Just (Right h0) | h0 == hdest -> none
+              Just (Left ()) -> err $ red "get-ref returned value for deleted ref" <+> pretty h
+              _ -> err $ red "get-ref mismatch" <+> pretty h <+> "got" <+> pretty hdest
+
+          [ HashLike h ] -> do
+            really <- readTVarIO refs <&> HM.lookup h
+            case really of
+              Just (Left ()) -> none
+              Nothing        -> none
+              Just (Right _) -> err $ red "get-ref says missing, but we have" <+> pretty h
+          _ -> none
+
+        -- ref-deleted
+        entry $ bindMatch "ref-deleted" $ nil_ \case
+          [ HashLike h ] ->
+            atomically $ modifyTVar refs (HM.insert h (Left ()))
+          _ -> none
+
+  -- читаем лог построчно и скармливаем dict
+  rs <- lines <$> liftIO (IO.readFile logFile)
+  for_ rs $ \s -> case parseTop s of
+    Left{}  -> none
+    Right syn -> void $ run dict syn
+
+  -- финальная статистика
+  bs <- readTVarIO blocks
+  rs' <- readTVarIO refs
+  notice $ green "validate done"
+         <+> "blocks:" <+> pretty (length [() | Right _ <- HM.elems bs])
+         <+> "deleted-blocks:" <+> pretty (length [() | Left () <- HM.elems bs])
+         <+> "refs:" <+> pretty (length [() | Right _ <- HM.elems rs'])
+         <+> "deleted-refs:" <+> pretty (length [() | Left () <- HM.elems rs'])
+
+
+ncq3EnduranceTest :: forall m . MonadUnliftIO m => MakeDictM C m ()
+ncq3EnduranceTest = do
+
+  entry $ bindMatch "test:ncq3:endurance:inner" $ nil_ $ \syn -> do
+    let (opts,args) = splitOpts [] syn
+    path <- orThrowUser "path not set" $ headMay [ x | StringLike x <- args ]
+    testEnduranceInner @C path
+
+  entry $ bindMatch "test:ncq3:endurance" $ nil_ $ \syn -> do
+
+    let dbl = \case
+                 LitScientificVal x -> realToFrac x
+                 LitIntVal x        -> realToFrac x
+                 _ -> 0.00
+
+    let int = \case
+                 LitScientificVal x -> floor x
+                 LitIntVal x        -> fromIntegral  x
+                 _ -> 0
+
+    wIdle    <-  dbl <$> lookupValueDef (mkDouble 100.00) "w:idle"
+    wIdleDef <-  dbl <$> lookupValueDef (mkDouble  0.25) "w:idle:def"
+    wPutBlk  <-  dbl <$> lookupValueDef (mkDouble  20.00) "w:putblk"
+    wGetBlk  <-  dbl <$> lookupValueDef (mkDouble  30.00) "w:getblk"
+    wHasBlk  <-  dbl <$> lookupValueDef (mkDouble  40.00) "w:hasblk"
+    wDelBlk  <-  dbl <$> lookupValueDef (mkDouble   3.00) "w:delblk"
+    wPutRef  <-  dbl <$> lookupValueDef (mkDouble   5.00) "w:putref"
+    wGetRef  <-  dbl <$> lookupValueDef (mkDouble  10.00) "w:getref"
+    wDelRef  <-  dbl <$> lookupValueDef (mkDouble   1.00) "w:delref"
+    wStorm   <-  dbl <$> lookupValueDef (mkDouble   0.50) "w:storm"
+    wKill    <-  dbl <$> lookupValueDef (mkDouble 0.0004) "w:kill"
+    wNum     <-  int <$> lookupValueDef (mkInt 10000)     "w:num"
+
+
+    runTest \TestEnv{..} -> do
+      g <- liftIO $ MWC.createSystemRandom
+
+      let (opts,args) = splitOpts [] syn
+
+      let n = headDef wNum [ fromIntegral x | LitIntVal x <- args ]
+
+      rest   <- newTVarIO n
+      blocks <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () )
+      refs   <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double HashRef )
+      killed <- newTVarIO 0
+
+      let getRandomBlock = liftIO $ getRandomFromPSQ g blocks
+      let getRandomRef = liftIO $ getRandomFromPSQ g refs
+
+      let d = makeDict do
+
+               entry $ bindMatch "ref-updated" $ nil_ \case
+                         [HashLike h, HashLike r] -> do
+
+                          w <- liftIO $ uniformRM (0,1.0) g
+
+                          atomically do
+                            modifyTVar refs (HPSQ.insert h w r)
+                            size <- readTVar refs <&> HPSQ.size
+                            when (size > 100000 ) do
+                              modifyTVar refs HPSQ.deleteMin
+
+                         _ -> none
+
+
+               entry $ bindMatch "block-written" $ nil_ \case
+                         [HashLike h, _] -> do
+
+                          w <- liftIO $ uniformRM (0,1.0) g
+
+                          atomically do
+                            modifyTVar blocks (HPSQ.insert h w ())
+                            size <- readTVar blocks <&> HPSQ.size
+                            when (size > 100000 ) do
+                              modifyTVar blocks HPSQ.deleteMin
+
+                         _ -> none
+
+
+      -- pI <- rublookupValue "endurance:idle"
+      --
+      debug $ red "pKill" <+> pretty wKill
+
+      let actions = [ (EnduranceIdle,   wIdle)
+                    , (EndurancePutBlk, wPutBlk)
+                    , (EnduranceGetBlk, wGetBlk)
+                    , (EnduranceHasBlk, wHasBlk)
+                    , (EnduranceDelBlk, wDelBlk)
+                    , (EndurancePutRef, wPutRef)
+                    , (EnduranceGetRef, wGetRef)
+                    , (EnduranceDelRef, wDelRef)
+                    , (EnduranceStorm,  wStorm)
+                    , (EnduranceKill,   wKill)
+                    ]
+
+      let dist = buildCDF actions   -- ← подготовили один раз
+
+      let inner =  "test:ncq3:endurance:inner"
+      self <- liftIO getExecutablePath
+      let conf = proc self [ "debug on"
+                           , "and"
+                           , "test:ncq3:endurance:inner", testEnvDir
+                           ] & setStdin createPipe & setStdout createPipe
+
+      fix \recover -> handle (\(e :: IOException) -> err (viaShow e) >> pause @'Seconds 1 >> 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)
+              Right s -> do
+                liftIO do
+                  appendFile logFile (s <> "\n")
+                  void $ try @_ @SomeException (parseTop s & either (err.viaShow) (void . run d))
+                  putStrLn s
+                loop
+
+          ContT $ withAsync $ forever do
+            join $ atomically (readTQueue storms)
+
+          ContT $ withAsync $ forever do
+            rest <- readTVarIO rest
+            b    <- readTVarIO blocks <&> HPSQ.size
+            r    <- readTVarIO refs <&> HPSQ.size
+            k    <- readTVarIO killed
+
+            notice $ green "status"
+                       <+> "rest:" <+> pretty rest
+                       <+> "b:" <+> pretty b
+                       <+> "r:" <+> pretty r
+                       <+> "k:" <+> pretty k
+
+            pause @'Seconds 1
+
+          liftIO $ hSetBuffering inp  LineBuffering
+
+          pid <- liftIO (PT.getPid p) `orDie` "oopsie!"
+          info $ "spawned" <+> pretty inner <+> viaShow pid
+
+          let getNextState = sampleState g dist
+
+          let defaultIdle = 0.25 :: Timeout 'Seconds
+
+          idleTime  <- newTVarIO defaultIdle
+          trelaxTill <- newTVarIO 0
+
+          flip fix EnduranceIdle \loop -> \case
+            EnduranceIdle -> do
+              readTVarIO idleTime >>= pause
+
+              r <- readTVarIO rest
+
+              if r <= 0 then do
+                loop EnduranceStop
+              else do
+                getNextState >>= loop
+
+            EndurancePutBlk -> do
+              bsize <- liftIO $ uniformRM (1, 65536) g
+              liftIO $ IO.hPrint inp ("write-random-block" <+> viaShow bsize)
+              atomically $ modifyTVar rest pred
+              getNextState >>= loop
+
+            EnduranceDelBlk -> do
+              blk <- getRandomBlock
+              for_ blk $ \h -> do
+                liftIO $ IO.hPrint inp ("del-block" <+> pretty h)
+
+              getNextState >>= loop
+
+            EnduranceHasBlk -> do
+              blk <- getRandomBlock
+              for_ blk $ \h -> do
+                liftIO $ IO.hPrint inp ("has-block" <+> pretty h)
+
+              getNextState >>= loop
+
+            EnduranceGetBlk -> do
+              blk <- getRandomBlock
+              for_ blk $ \h -> do
+                liftIO $ IO.hPrint inp ("get-block" <+> pretty h)
+              getNextState >>= loop
+
+            EndurancePutRef -> do
+              href <- liftIO (genRandomBS g 32) <&> HashRef . coerce
+              blk  <- getRandomBlock
+              for_ blk $ \val -> do
+                liftIO $ IO.hPrint inp ("set-ref" <+> pretty href <+> pretty val)
+              atomically $ modifyTVar rest pred
+              getNextState >>= loop
+
+            EnduranceGetRef -> do
+              e <- getRandomRef
+              for_ e $ \h ->
+                liftIO $ IO.hPrint inp ("get-ref" <+> pretty h)
+              getNextState >>= loop
+
+            EnduranceDelRef -> do
+              e <- getRandomRef
+              for_ e $ \h ->
+                liftIO $ IO.hPrint inp ("del-ref" <+> pretty h)
+              getNextState >>= loop
+
+            EnduranceKill -> do
+              debug $ red "KILL" <+> viaShow pid
+              cancel pread
+              hFlush inp
+              hClose outp
+              pause @'Seconds 0.1
+              void $ runProcess (proc "kill" ["-9", show pid])
+              notice $ red "Killed" <+> viaShow pid
+              atomically $ modifyTVar killed succ
+              lift recover
+
+            EnduranceStop -> do
+              liftIO $ hClose inp
+              wait pread
+              stopProcess p
+              notice $ green "done"
+              notice $ "validate" <+> pretty logFile
+              liftIO $ validateTestResult logFile
+
+            EnduranceStorm -> do
+
+              now <- getTimeCoarse
+              relaxTill <- readTVarIO trelaxTill
+
+              itn <- readTVarIO idleTime
+
+              if | itn < defaultIdle -> do
+                     loop EnduranceIdle
+
+                 | now < relaxTill -> do
+                    debug $ yellow "storm on cooldown"
+                    loop EnduranceIdle
+
+                 | otherwise -> do
+                    t0 <- liftIO $ uniformRM (0,10.00) g
+                    debug $ red "FIRE IN DA HOLE!" <+> pretty t0
+                    atomically $ writeTQueue storms do
+                      atomically $ writeTVar idleTime 0
+                      pause @'Seconds (realToFrac t0)
+                      atomically $ writeTVar idleTime defaultIdle
+                      t1 <- getTimeCoarse
+                      -- add 10 sec cooldown
+                      atomically $ writeTVar trelaxTill (t1 + ceiling 10e9)
+
+                    getNextState >>= loop
+
+testEnduranceInner :: forall c m . (MonadUnliftIO m, IsContext c, Exception (BadFormException c))
+                   => FilePath
+                   -> m ()
+
+testEnduranceInner path = flip runContT pure $ callCC \exit -> do
+
+  g <- liftIO $ MWC.createSystemRandom
+
+  debug $ red "storage path" <+> pretty path
+
+  sto <- ContT $ ncqWithStorage path
+
+  forever $ callCC \again -> do
+
+     s' <- liftIO (try @_ @IOException getLine)
+            <&> fromRight "exit"
+            <&> parseTop >>= \case
+                  Left  e  -> err (viaShow e) >> again ()
+                  Right s  -> pure (fmap (fixContext @C @c) s)
+
+     lift (try @_ @SomeException (run @c (dict g sto) s')) >>= \case
+        Left e -> err (viaShow e)
+        Right (StringLike "done") -> exit ()
+        Right _ -> none
+
+  where
+    dict g sto = makeDict @c @m do
+
+      entry $ bindMatch "exit" $ const do
+        pure $ mkSym "done"
+
+      entry $ bindMatch "write-random-block" $ nil_ \case
+        [ LitIntVal n ] -> do
+          s <- liftIO $ genRandomBS g (fromIntegral n)
+          h <- putBlock (AnyStorage sto) (LBS.fromStrict s) >>= orThrowUser "block-not-written"
+          notice $ "block-written" <+> pretty h <+> pretty (BS.length s)
+
+        e -> throwIO (BadFormException @c (mkList e))
+
+      entry $ bindMatch "has-block" $ nil_ \case
+        [ HashLike h ] -> do
+          s <- hasBlock (AnyStorage sto) (coerce h)
+          notice $ "has-block-result" <+> pretty h <+> pretty s
+
+        e -> throwIO (BadFormException @c (mkList e))
+
+      entry $ bindMatch "get-block" $ nil_ \case
+        [ HashLike h ] -> do
+          s <- getBlock (AnyStorage sto) (coerce h)
+          let hx = fmap (hashObject @HbSync) s
+          notice $ "get-block-result" <+> pretty h <+> pretty hx
+
+        e -> throwIO (BadFormException @c (mkList e))
+
+      entry $ bindMatch "del-block" $ nil_ \case
+        [ HashLike h ] -> do
+          delBlock (AnyStorage sto) (coerce h)
+          notice $ "block-deleted" <+> pretty h
+
+        e -> throwIO (BadFormException @c (mkList e))
+
+      entry $ bindMatch "set-ref" $ nil_ \case
+        [ HashLike h, HashLike hdest ] -> lift do
+          updateRef (AnyStorage sto) (RefAlias2 mempty h) (coerce hdest)
+          notice $ "ref-updated" <+> pretty h <+> pretty hdest
+
+        e -> throwIO (BadFormException @c (mkList e))
+
+      entry $ bindMatch "get-ref" $ nil_ \case
+        [ HashLike h ] -> lift do
+          what <- getRef (AnyStorage sto) (RefAlias2 mempty h)
+          notice $ "get-ref-result" <+> pretty h <+> pretty what
+
+        e -> throwIO (BadFormException @c (mkList e))
+
+      entry $ bindMatch "del-ref" $ nil_ \case
+        [ HashLike h ] -> lift do
+          delRef (AnyStorage sto) (RefAlias2 mempty h)
+          notice $ "ref-deleted" <+> pretty h
+
+        e -> throwIO (BadFormException @c (mkList e))
+
+