mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
4b59cbceff
commit
82b2fa1770
|
|
@ -1,16 +1,6 @@
|
||||||
dist-newstyle
|
.fixme-new/refchan.local
|
||||||
.direnv/
|
dist-newstyle/
|
||||||
.fixme/state.db
|
|
||||||
result
|
|
||||||
# VS Code
|
|
||||||
settings.json
|
|
||||||
|
|
||||||
cabal.project.local
|
|
||||||
|
|
||||||
*.key
|
|
||||||
|
|
||||||
.backup/
|
|
||||||
.hbs2-git/
|
|
||||||
bin/
|
bin/
|
||||||
.fixme-new/current-stage.log
|
.direnv/
|
||||||
.hbs2-sync/
|
.hbs2-git3/
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -19,6 +19,7 @@ import Data.Config.Suckless.Script as SC
|
||||||
import Data.Config.Suckless.System
|
import Data.Config.Suckless.System
|
||||||
|
|
||||||
import NCQTestCommon
|
import NCQTestCommon
|
||||||
|
import Tee
|
||||||
|
|
||||||
import Lens.Micro.Platform
|
import Lens.Micro.Platform
|
||||||
import Data.Either
|
import Data.Either
|
||||||
|
|
@ -341,222 +342,224 @@ ncq3EnduranceTest = do
|
||||||
, "test:ncq3:endurance:inner", testEnvDir
|
, "test:ncq3:endurance:inner", testEnvDir
|
||||||
] & setStdin createPipe & setStdout createPipe
|
] & setStdin createPipe & setStdout createPipe
|
||||||
|
|
||||||
ncqWithStorage testEnvDir $ \sto -> do
|
withTeeLogging ( testEnvDir </> "test.log") do
|
||||||
replicateM_ wSeed do
|
|
||||||
n <- liftIO $ uniformRM (1, wMaxBlk) g
|
|
||||||
bs <- liftIO $ LBS.fromStrict <$> genRandomBS g n
|
|
||||||
putBlock (AnyStorage sto) bs >>= \case
|
|
||||||
Just h -> atomically $ modifyTVar seed (HPSQ.insert (HashRef h) 1.0 ())
|
|
||||||
Nothing -> err $ red "can't write seed block"
|
|
||||||
|
|
||||||
ncqWithStorage testEnvDir $ \sto -> do
|
ncqWithStorage testEnvDir $ \sto -> do
|
||||||
seeds <- readTVarIO seed <&> HPSQ.toList
|
replicateM_ wSeed do
|
||||||
for_ seeds $ \(h,_,_) -> do
|
n <- liftIO $ uniformRM (1, wMaxBlk) g
|
||||||
here <- hasBlock (AnyStorage sto) (coerce h)
|
bs <- liftIO $ LBS.fromStrict <$> genRandomBS g n
|
||||||
unless (isJust here) do
|
putBlock (AnyStorage sto) bs >>= \case
|
||||||
err $ "missed seed block (1)" <+> pretty h
|
Just h -> atomically $ modifyTVar seed (HPSQ.insert (HashRef h) 1.0 ())
|
||||||
|
Nothing -> err $ red "can't write seed block"
|
||||||
|
|
||||||
let handler e = err (viaShow e) >> debug "RECOVERING" >> pause @'Seconds 3
|
ncqWithStorage testEnvDir $ \sto -> do
|
||||||
fix \recover -> handleAny (\e -> handler e >> recover) do
|
seeds <- readTVarIO seed <&> HPSQ.toList
|
||||||
|
for_ seeds $ \(h,_,_) -> do
|
||||||
|
here <- hasBlock (AnyStorage sto) (coerce h)
|
||||||
|
unless (isJust here) do
|
||||||
|
err $ "missed seed block (1)" <+> pretty h
|
||||||
|
|
||||||
flip runContT pure do
|
let handler e = err (viaShow e) >> debug "RECOVERING" >> pause @'Seconds 3
|
||||||
p <- startProcess conf -- ContT $ withProcessWait conf
|
fix \recover -> handleAny (\e -> handler e >> recover) do
|
||||||
storms <- newTQueueIO
|
|
||||||
let inp = getStdin p
|
|
||||||
let logFile = testEnvDir </> "op.log"
|
|
||||||
|
|
||||||
pread <- ContT $ withAsync $ flip runContT pure $ callCC \stop -> do
|
flip runContT pure do
|
||||||
let outp = getStdout p
|
p <- startProcess conf -- ContT $ withProcessWait conf
|
||||||
fix \loop -> do
|
storms <- newTQueueIO
|
||||||
s <- liftIO (try @_ @IOException (IO.hGetLine outp)) >>= \case
|
let inp = getStdin p
|
||||||
Left e -> err (red "pread:" <+> viaShow e) >> stop ()
|
let logFile = testEnvDir </> "op.log"
|
||||||
Right s -> pure s
|
|
||||||
|
|
||||||
liftIO do
|
pread <- ContT $ withAsync $ flip runContT pure $ callCC \stop -> do
|
||||||
appendFile logFile (s <> "\n")
|
let outp = getStdout p
|
||||||
void $ try @_ @SomeException (parseTop s & either (err.viaShow) (void . run d))
|
fix \loop -> do
|
||||||
putStrLn s
|
s <- liftIO (try @_ @IOException (IO.hGetLine outp)) >>= \case
|
||||||
loop
|
Left e -> err (red "pread:" <+> viaShow e) >> stop ()
|
||||||
|
Right s -> pure s
|
||||||
|
|
||||||
ContT $ withAsync $ forever do
|
liftIO do
|
||||||
join $ atomically (readTQueue storms)
|
appendFile logFile (s <> "\n")
|
||||||
|
void $ try @_ @SomeException (parseTop s & either (err.viaShow) (void . run d))
|
||||||
|
putStrLn s
|
||||||
|
loop
|
||||||
|
|
||||||
ContT $ withAsync $ forever do
|
ContT $ withAsync $ forever do
|
||||||
rest <- readTVarIO rest
|
join $ atomically (readTQueue storms)
|
||||||
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"
|
ContT $ withAsync $ forever do
|
||||||
<+> "rest:" <+> pretty rest
|
rest <- readTVarIO rest
|
||||||
<+> "b:" <+> pretty b
|
b <- readTVarIO blocks <&> HPSQ.size
|
||||||
<+> "r:" <+> pretty r
|
r <- readTVarIO refs <&> HPSQ.size
|
||||||
<+> "m:" <+> pretty m
|
k <- readTVarIO killed
|
||||||
<+> "sw:" <+> pretty sw
|
s <- readTVarIO stopped
|
||||||
<+> "c:" <+> pretty c
|
c <- readTVarIO compacted
|
||||||
<+> "k:" <+> pretty k
|
m <- readTVarIO merged
|
||||||
<+> "s:" <+> pretty s
|
sw <- readTVarIO sweeped
|
||||||
|
|
||||||
pause @'Seconds 1
|
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
|
||||||
|
|
||||||
liftIO $ hSetBuffering inp LineBuffering
|
pause @'Seconds 1
|
||||||
|
|
||||||
pid <- liftIO (PT.getPid p) `orDie` "oopsie!"
|
liftIO $ hSetBuffering inp LineBuffering
|
||||||
info $ "spawned" <+> pretty inner <+> viaShow pid
|
|
||||||
|
|
||||||
let getNextState = sampleState g dist
|
pid <- liftIO (PT.getPid p) `orDie` "oopsie!"
|
||||||
|
info $ "spawned" <+> pretty inner <+> viaShow pid
|
||||||
|
|
||||||
let defaultIdle = realToFrac wIdleDef :: Timeout 'Seconds
|
let getNextState = sampleState g dist
|
||||||
|
|
||||||
idleTime <- newTVarIO defaultIdle
|
let defaultIdle = realToFrac wIdleDef :: Timeout 'Seconds
|
||||||
trelaxTill <- newTVarIO 0
|
|
||||||
|
|
||||||
flip fix EnduranceIdle \loop -> \case
|
idleTime <- newTVarIO defaultIdle
|
||||||
EnduranceIdle -> do
|
trelaxTill <- newTVarIO 0
|
||||||
readTVarIO idleTime >>= pause
|
|
||||||
|
|
||||||
r <- readTVarIO rest
|
flip fix EnduranceIdle \loop -> \case
|
||||||
|
EnduranceIdle -> do
|
||||||
|
readTVarIO idleTime >>= pause
|
||||||
|
|
||||||
if r <= 0 then do
|
r <- readTVarIO rest
|
||||||
loop EnduranceStop
|
|
||||||
else do
|
if r <= 0 then do
|
||||||
|
loop EnduranceStop
|
||||||
|
else do
|
||||||
|
getNextState >>= loop
|
||||||
|
|
||||||
|
EndurancePutBlk -> do
|
||||||
|
bsize <- liftIO $ uniformRM (1, wMaxBlk) g
|
||||||
|
toConsole inp ("write-random-block" <+> viaShow bsize)
|
||||||
|
atomically $ modifyTVar rest pred
|
||||||
getNextState >>= loop
|
getNextState >>= loop
|
||||||
|
|
||||||
EndurancePutBlk -> do
|
EnduranceDelBlk -> do
|
||||||
bsize <- liftIO $ uniformRM (1, wMaxBlk) g
|
blk <- getRandomBlock
|
||||||
toConsole inp ("write-random-block" <+> viaShow bsize)
|
for_ blk $ \h -> do
|
||||||
atomically $ modifyTVar rest pred
|
toConsole inp ("del-block" <+> pretty h)
|
||||||
getNextState >>= loop
|
|
||||||
|
|
||||||
EnduranceDelBlk -> do
|
getNextState >>= loop
|
||||||
blk <- getRandomBlock
|
|
||||||
for_ blk $ \h -> do
|
|
||||||
toConsole inp ("del-block" <+> pretty h)
|
|
||||||
|
|
||||||
getNextState >>= loop
|
EnduranceHasBlk -> do
|
||||||
|
blk <- getRandomBlock
|
||||||
|
for_ blk $ \h -> do
|
||||||
|
toConsole inp ("has-block" <+> pretty h)
|
||||||
|
|
||||||
EnduranceHasBlk -> do
|
getNextState >>= loop
|
||||||
blk <- getRandomBlock
|
|
||||||
for_ blk $ \h -> do
|
|
||||||
toConsole inp ("has-block" <+> pretty h)
|
|
||||||
|
|
||||||
getNextState >>= loop
|
EnduranceHasSeedBlk -> do
|
||||||
|
blk <- getRandomSeedBlock
|
||||||
|
for_ blk $ \h -> do
|
||||||
|
toConsole inp ("has-seed-block" <+> pretty h)
|
||||||
|
|
||||||
EnduranceHasSeedBlk -> do
|
getNextState >>= loop
|
||||||
blk <- getRandomSeedBlock
|
|
||||||
for_ blk $ \h -> do
|
|
||||||
toConsole inp ("has-seed-block" <+> pretty h)
|
|
||||||
|
|
||||||
getNextState >>= loop
|
EnduranceGetBlk -> do
|
||||||
|
blk <- getRandomBlock
|
||||||
|
for_ blk $ \h -> do
|
||||||
|
toConsole inp ("get-block" <+> pretty h)
|
||||||
|
getNextState >>= loop
|
||||||
|
|
||||||
EnduranceGetBlk -> do
|
EndurancePutRef -> do
|
||||||
blk <- getRandomBlock
|
href <- liftIO (genRandomBS g 32) <&> HashRef . coerce
|
||||||
for_ blk $ \h -> do
|
blk <- getRandomBlock
|
||||||
toConsole inp ("get-block" <+> pretty h)
|
for_ blk $ \val -> do
|
||||||
getNextState >>= loop
|
toConsole inp ("set-ref" <+> pretty href <+> pretty val)
|
||||||
|
atomically $ modifyTVar rest pred
|
||||||
|
getNextState >>= loop
|
||||||
|
|
||||||
EndurancePutRef -> do
|
EnduranceGetRef -> do
|
||||||
href <- liftIO (genRandomBS g 32) <&> HashRef . coerce
|
e <- getRandomRef
|
||||||
blk <- getRandomBlock
|
for_ e $ \h ->
|
||||||
for_ blk $ \val -> do
|
toConsole inp ("get-ref" <+> pretty h)
|
||||||
toConsole inp ("set-ref" <+> pretty href <+> pretty val)
|
getNextState >>= loop
|
||||||
atomically $ modifyTVar rest pred
|
|
||||||
getNextState >>= loop
|
|
||||||
|
|
||||||
EnduranceGetRef -> do
|
EnduranceDelRef -> do
|
||||||
e <- getRandomRef
|
e <- getRandomRef
|
||||||
for_ e $ \h ->
|
for_ e $ \h ->
|
||||||
toConsole inp ("get-ref" <+> pretty h)
|
toConsole inp ("del-ref" <+> pretty h)
|
||||||
getNextState >>= loop
|
getNextState >>= loop
|
||||||
|
|
||||||
EnduranceDelRef -> do
|
EnduranceMerge -> do
|
||||||
e <- getRandomRef
|
toConsole inp "merge"
|
||||||
for_ e $ \h ->
|
atomically $ modifyTVar merged succ
|
||||||
toConsole inp ("del-ref" <+> pretty h)
|
getNextState >>= loop
|
||||||
getNextState >>= loop
|
|
||||||
|
|
||||||
EnduranceMerge -> do
|
EnduranceCompact -> do
|
||||||
toConsole inp "merge"
|
toConsole inp "compact"
|
||||||
atomically $ modifyTVar merged succ
|
atomically $ modifyTVar compacted succ
|
||||||
getNextState >>= loop
|
getNextState >>= loop
|
||||||
|
|
||||||
EnduranceCompact -> do
|
EnduranceSweep -> do
|
||||||
toConsole inp "compact"
|
toConsole inp "sweep"
|
||||||
atomically $ modifyTVar compacted succ
|
atomically $ modifyTVar sweeped succ
|
||||||
getNextState >>= loop
|
getNextState >>= loop
|
||||||
|
|
||||||
EnduranceSweep -> do
|
EnduranceExit -> do
|
||||||
toConsole inp "sweep"
|
toConsole inp "exit"
|
||||||
atomically $ modifyTVar sweeped succ
|
debug $ yellow "inner process stopped?"
|
||||||
getNextState >>= loop
|
liftIO $ race (pause @'Seconds 30) (waitExitCode p) >>= \case
|
||||||
|
Right{} -> none
|
||||||
|
Left{} -> do
|
||||||
|
debug $ red "force inner process to stop"
|
||||||
|
stopProcess p
|
||||||
|
atomically $ modifyTVar stopped succ
|
||||||
|
lift recover
|
||||||
|
|
||||||
EnduranceExit -> do
|
EnduranceKill -> do
|
||||||
toConsole inp "exit"
|
debug $ red "KILL" <+> viaShow pid
|
||||||
debug $ yellow "inner process stopped?"
|
cancel pread
|
||||||
liftIO $ race (pause @'Seconds 1) (waitExitCode p) >>= \case
|
hFlush inp
|
||||||
Right{} -> none
|
liftIO $ appendFile logFile "; killed"
|
||||||
Left{} -> do
|
pause @'Seconds 0.25
|
||||||
debug $ red "force inner process to stop"
|
void $ runProcess (proc "kill" ["-9", show pid])
|
||||||
stopProcess p
|
notice $ red "Killed" <+> viaShow pid
|
||||||
atomically $ modifyTVar stopped succ
|
atomically $ modifyTVar killed succ
|
||||||
lift recover
|
pause @'Seconds 0.5
|
||||||
|
lift recover
|
||||||
|
|
||||||
EnduranceKill -> do
|
EnduranceStop -> do
|
||||||
debug $ red "KILL" <+> viaShow pid
|
liftIO $ hClose inp
|
||||||
cancel pread
|
wait pread
|
||||||
hFlush inp
|
stopProcess p
|
||||||
liftIO $ appendFile logFile "; killed"
|
notice $ green "done"
|
||||||
pause @'Seconds 0.25
|
notice $ "validate" <+> pretty logFile
|
||||||
void $ runProcess (proc "kill" ["-9", show pid])
|
liftIO $ validateTestResult logFile
|
||||||
notice $ red "Killed" <+> viaShow pid
|
|
||||||
atomically $ modifyTVar killed succ
|
|
||||||
pause @'Seconds 0.5
|
|
||||||
lift recover
|
|
||||||
|
|
||||||
EnduranceStop -> do
|
EnduranceCalm -> do
|
||||||
liftIO $ hClose inp
|
n <- liftIO $ uniformRM (0.5,10.00) g
|
||||||
wait pread
|
debug $ "CALM" <+> pretty n
|
||||||
stopProcess p
|
pause @'Seconds (realToFrac n)
|
||||||
notice $ green "done"
|
getNextState >>= loop
|
||||||
notice $ "validate" <+> pretty logFile
|
|
||||||
liftIO $ validateTestResult logFile
|
|
||||||
|
|
||||||
EnduranceCalm -> do
|
EnduranceStorm -> do
|
||||||
n <- liftIO $ uniformRM (0.5,10.00) g
|
|
||||||
debug $ "CALM" <+> pretty n
|
|
||||||
pause @'Seconds (realToFrac n)
|
|
||||||
getNextState >>= loop
|
|
||||||
|
|
||||||
EnduranceStorm -> do
|
now <- getTimeCoarse
|
||||||
|
relaxTill <- readTVarIO trelaxTill
|
||||||
|
|
||||||
now <- getTimeCoarse
|
itn <- readTVarIO idleTime
|
||||||
relaxTill <- readTVarIO trelaxTill
|
|
||||||
|
|
||||||
itn <- readTVarIO idleTime
|
if | itn < defaultIdle -> do
|
||||||
|
loop EnduranceIdle
|
||||||
|
|
||||||
if | itn < defaultIdle -> do
|
| now < relaxTill -> do
|
||||||
loop EnduranceIdle
|
debug $ yellow "storm on cooldown"
|
||||||
|
loop EnduranceIdle
|
||||||
|
|
||||||
| now < relaxTill -> do
|
| otherwise -> do
|
||||||
debug $ yellow "storm on cooldown"
|
t0 <- liftIO $ uniformRM (wStormMin,wStormMax) g
|
||||||
loop EnduranceIdle
|
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)
|
||||||
|
|
||||||
| otherwise -> do
|
getNextState >>= loop
|
||||||
t0 <- liftIO $ uniformRM (wStormMin,wStormMax) 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))
|
testEnduranceInner :: forall c m . (MonadUnliftIO m, IsContext c, Exception (BadFormException c))
|
||||||
=> FilePath
|
=> FilePath
|
||||||
|
|
|
||||||
|
|
@ -82,7 +82,7 @@ stripANSI = go
|
||||||
case BS.uncons s of
|
case BS.uncons s of
|
||||||
Nothing -> BS.empty
|
Nothing -> BS.empty
|
||||||
Just (c1, r1)
|
Just (c1, r1)
|
||||||
| c1 == lbr -> go (BS.drop1 $ dropCSI r1) -- ESC [
|
| c1 == lbr -> go (BS.drop 1 $ dropCSI r1) -- ESC [
|
||||||
| c1 == rbr -> go (dropOSC r1) -- ESC ]
|
| c1 == rbr -> go (dropOSC r1) -- ESC ]
|
||||||
| otherwise -> go r1 -- Прочие короткие ESC-послед.
|
| otherwise -> go r1 -- Прочие короткие ESC-послед.
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue