mirror of https://github.com/voidlizard/hbs2
wip, ncq3 fixes + storage update
This commit is contained in:
voidlizard
parent
70e7639dcf
commit
ccc2154f1e
|
|
@ -67,17 +67,26 @@ ncqFossilMergeStep me@NCQStorage{..} = flip runContT pure $ callCC \exit -> do
|
|||
|
||||
debug "ncqFossilMergeStep"
|
||||
|
||||
files0 <- atomically do
|
||||
NCQState{..} <- readTVar ncqState
|
||||
cur <- readTVar ncqCurrentFossils
|
||||
pure (fmap DataFile $ HS.toList $ ncqStateFiles `HS.difference` cur)
|
||||
|
||||
files1 <- for files0 $ \fd -> do
|
||||
let fn = ncqGetFileName me fd
|
||||
ts1 <- liftIO (PFS.getFileStatus fn) <&> PFS.modificationTimeHiRes
|
||||
pure (ts1, fd)
|
||||
|
||||
-- TODO: consider-sort-by-timestamps
|
||||
files <- readTVarIO ncqState
|
||||
<&> fmap DataFile . HS.toList . ncqStateFiles
|
||||
<&> List.sortOn Down
|
||||
let files = List.sortOn Down files1 & fmap snd
|
||||
|
||||
NCQState{..} <- readTVarIO ncqState
|
||||
|
||||
-- cur <- ncqCurrentFossils
|
||||
|
||||
let tss = ncqStateIndex & fmap (\(Down x, y) -> (y, realToFrac x :: POSIXTime)) & HM.fromList
|
||||
|
||||
cur <- readTVarIO ncqCurrentFossils
|
||||
r' <- lift $ ncqFindMinPairOfBy me (\x -> not (HS.member (coerce x) cur)) files
|
||||
r' <- lift $ ncqFindMinPairOf me files
|
||||
|
||||
r@(sumSize, f1, f2) <- ContT $ maybe1 r' (pure False)
|
||||
|
||||
|
|
@ -131,6 +140,10 @@ ncqFossilMergeStep me@NCQStorage{..} = flip runContT pure $ callCC \exit -> do
|
|||
debug $ "MOVED" <+> pretty outFile <+> pretty newFile
|
||||
moveFile outFile newFile
|
||||
|
||||
let f1p = ncqGetFileName me f1
|
||||
ts1 <- liftIO (PFS.getFileStatus f1p) <&> PFS.modificationTimeHiRes
|
||||
liftIO $ PFS.setFileTimesHiRes newFile ts1 ts1
|
||||
|
||||
ss <- liftIO (PFS.getFileStatus newFile) <&> fromIntegral . PFS.fileSize
|
||||
|
||||
ncqStateUpdate me do
|
||||
|
|
|
|||
|
|
@ -396,7 +396,12 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
|
|||
|
||||
ncqStateUpdate ncq do
|
||||
ncqStateAddFact (P (PData (DataFile fk) 0))
|
||||
ncqStateAddDataFile fk
|
||||
-- FIXM: asap-remove-this
|
||||
-- это неправильно. из-за этого файл
|
||||
-- болтается в current и мешает при мерже
|
||||
-- хотя это еще не настоящий файл (до индексации).
|
||||
-- почему мы вообще его сюда засунули?
|
||||
-- ncqStateAddDataFile fk
|
||||
|
||||
let fname = ncqGetFileName ncq (DataFile fk)
|
||||
-- touch fname
|
||||
|
|
|
|||
|
|
@ -91,7 +91,9 @@ data EnduranceFSM =
|
|||
| EnduranceStorm
|
||||
| EnduranceCalm
|
||||
| EnduranceKill
|
||||
| EnduranceExit
|
||||
| EnduranceMerge
|
||||
| EnduranceCompact
|
||||
| EnduranceSweep
|
||||
| EnduranceStop
|
||||
|
||||
|
|
@ -280,8 +282,10 @@ ncq3EnduranceTest = do
|
|||
wStormMax <- dbl <$> lookupValueDef (mkDouble 60.00) "w:stormmax"
|
||||
wCalm <- dbl <$> lookupValueDef (mkDouble 0.001) "w:calm"
|
||||
wKill <- dbl <$> lookupValueDef (mkDouble 0.00) "w:kill"
|
||||
wMerge <- dbl <$> lookupValueDef (mkDouble 0.001) "w:merge"
|
||||
wSweep <- dbl <$> lookupValueDef (mkDouble 0.001) "w:sweep"
|
||||
wExit <- dbl <$> lookupValueDef (mkDouble 0.001) "w:exit"
|
||||
wMerge <- dbl <$> lookupValueDef (mkDouble 0.005) "w:merge"
|
||||
wCompact <- dbl <$> lookupValueDef (mkDouble 0.005) "w:compact"
|
||||
wSweep <- dbl <$> lookupValueDef (mkDouble 0.005) "w:sweep"
|
||||
wNum <- int <$> lookupValueDef (mkInt 10000) "w:num"
|
||||
|
||||
|
||||
|
|
@ -292,11 +296,15 @@ ncq3EnduranceTest = do
|
|||
|
||||
let n = headDef wNum [ fromIntegral x | LitIntVal x <- args ]
|
||||
|
||||
rest <- newTVarIO n
|
||||
blocks <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () )
|
||||
seed <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () )
|
||||
refs <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double HashRef )
|
||||
killed <- newTVarIO 0
|
||||
rest <- newTVarIO n
|
||||
blocks <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () )
|
||||
seed <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () )
|
||||
refs <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double HashRef )
|
||||
killed <- newTVarIO 0
|
||||
stopped <- newTVarIO 0
|
||||
merged <- newTVarIO 0
|
||||
sweeped <- newTVarIO 0
|
||||
compacted <- newTVarIO 0
|
||||
|
||||
let getRandomBlock = liftIO $ getRandomFromPSQ g blocks
|
||||
let getRandomSeedBlock = liftIO $ getRandomFromPSQ g seed
|
||||
|
|
@ -336,20 +344,22 @@ ncq3EnduranceTest = do
|
|||
--
|
||||
debug $ red "pKill" <+> pretty wKill
|
||||
|
||||
let actions = [ (EnduranceIdle, wIdle)
|
||||
, (EndurancePutBlk, wPutBlk)
|
||||
, (EnduranceGetBlk, wGetBlk)
|
||||
let actions = [ (EnduranceIdle, wIdle)
|
||||
, (EndurancePutBlk, wPutBlk)
|
||||
, (EnduranceGetBlk, wGetBlk)
|
||||
, (EnduranceHasSeedBlk, wHasBlk)
|
||||
, (EnduranceHasBlk, wHasBlk)
|
||||
, (EnduranceDelBlk, wDelBlk)
|
||||
, (EndurancePutRef, wPutRef)
|
||||
, (EnduranceGetRef, wGetRef)
|
||||
, (EnduranceDelRef, wDelRef)
|
||||
, (EnduranceStorm, wStorm)
|
||||
, (EnduranceCalm, wCalm)
|
||||
, (EnduranceMerge, wMerge)
|
||||
, (EnduranceSweep, wSweep)
|
||||
, (EnduranceKill, wKill)
|
||||
, (EnduranceHasBlk, wHasBlk)
|
||||
, (EnduranceDelBlk, wDelBlk)
|
||||
, (EndurancePutRef, wPutRef)
|
||||
, (EnduranceGetRef, wGetRef)
|
||||
, (EnduranceDelRef, wDelRef)
|
||||
, (EnduranceStorm, wStorm)
|
||||
, (EnduranceCalm, wCalm)
|
||||
, (EnduranceMerge, wMerge)
|
||||
, (EnduranceCompact, wCompact)
|
||||
, (EnduranceSweep, wSweep)
|
||||
, (EnduranceKill, wKill)
|
||||
, (EnduranceExit, wExit)
|
||||
]
|
||||
|
||||
let dist = buildCDF actions -- ← подготовили один раз
|
||||
|
|
@ -406,12 +416,20 @@ ncq3EnduranceTest = do
|
|||
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"
|
||||
<+> "rest:" <+> pretty rest
|
||||
<+> "b:" <+> pretty b
|
||||
<+> "r:" <+> pretty r
|
||||
<+> "k:" <+> pretty k
|
||||
<+> "b:" <+> pretty b
|
||||
<+> "r:" <+> pretty r
|
||||
<+> "m:" <+> pretty m
|
||||
<+> "sw:" <+> pretty sw
|
||||
<+> "c:" <+> pretty c
|
||||
<+> "k:" <+> pretty k
|
||||
<+> "s:" <+> pretty s
|
||||
|
||||
pause @'Seconds 1
|
||||
|
||||
|
|
@ -493,12 +511,30 @@ ncq3EnduranceTest = do
|
|||
|
||||
EnduranceMerge -> do
|
||||
liftIO $ IO.hPrint inp "merge"
|
||||
atomically $ modifyTVar merged succ
|
||||
getNextState >>= loop
|
||||
|
||||
EnduranceCompact -> do
|
||||
liftIO $ IO.hPrint inp "compact"
|
||||
atomically $ modifyTVar compacted succ
|
||||
getNextState >>= loop
|
||||
|
||||
EnduranceSweep -> do
|
||||
liftIO $ IO.hPrint inp "sweep"
|
||||
atomically $ modifyTVar sweeped succ
|
||||
getNextState >>= loop
|
||||
|
||||
EnduranceExit -> do
|
||||
liftIO $ IO.hPrint inp "exit"
|
||||
debug $ yellow "inner process stopped?"
|
||||
liftIO $ race (pause @'Seconds 1) (waitExitCode p) >>= \case
|
||||
Right{} -> none
|
||||
Left{} -> do
|
||||
debug $ red "force inner process to stop"
|
||||
stopProcess p
|
||||
atomically $ modifyTVar stopped succ
|
||||
lift recover
|
||||
|
||||
EnduranceKill -> do
|
||||
debug $ red "KILL" <+> viaShow pid
|
||||
cancel pread
|
||||
|
|
@ -508,6 +544,7 @@ ncq3EnduranceTest = do
|
|||
void $ runProcess (proc "kill" ["-9", show pid])
|
||||
notice $ red "Killed" <+> viaShow pid
|
||||
atomically $ modifyTVar killed succ
|
||||
pause @'Seconds 0.5
|
||||
lift recover
|
||||
|
||||
EnduranceStop -> do
|
||||
|
|
@ -575,7 +612,10 @@ testEnduranceInner path = flip runContT pure $ callCC \exit -> do
|
|||
|
||||
lift (try @_ @SomeException (run @c (dict g sto) s')) >>= \case
|
||||
Left e -> err (viaShow e)
|
||||
Right (StringLike "done") -> exit ()
|
||||
Right (StringLike "done") -> do
|
||||
liftIO $ IO.hPutStrLn stderr $ "INNER PROCESS TO EXIT"
|
||||
exit ()
|
||||
|
||||
Right _ -> none
|
||||
|
||||
where
|
||||
|
|
@ -646,6 +686,10 @@ testEnduranceInner path = flip runContT pure $ callCC \exit -> do
|
|||
ncqSetFlag ncqMergeReq
|
||||
liftIO $ print $ "merge"
|
||||
|
||||
entry $ bindMatch "compact" $ nil_ $ const do
|
||||
ncqSetFlag ncqCompactReq
|
||||
liftIO $ print $ "compact"
|
||||
|
||||
entry $ bindMatch "sweep" $ nil_ $ const do
|
||||
ncqSetFlag ncqSweepReq
|
||||
liftIO $ print $ "sweep"
|
||||
|
|
|
|||
|
|
@ -609,89 +609,6 @@ main = do
|
|||
[] -> SC.bind "test:dir:keep" (mkBool True)
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:fuckup-recovery1" $ nil_ $ \_ -> do
|
||||
debug $ "test:ncq:fuckup-recovery1"
|
||||
runTest testNCQFuckupRecovery1
|
||||
|
||||
entry $ bindMatch "test:ncq:long-write" $ nil_ $ \case
|
||||
[ LitIntVal n ] -> runTest $ testNCQLongWrite (fromIntegral n)
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:long-write-read" $ nil_ $ \case
|
||||
[ LitIntVal n ] -> runTest $ testNCQLongWriteRead (fromIntegral n)
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:test-simple1" $ nil_ $ \case
|
||||
[] -> runTest $ testNCQSimple1
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:test-simple2" $ nil_ $ \case
|
||||
[ LitIntVal n ] -> runTest $ testNCQSimple2 (fromIntegral n)
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:test1" $ nil_ $ \case
|
||||
[ LitIntVal n ] -> do
|
||||
debug $ "ncq:test1" <+> pretty n
|
||||
runTest $ testNCQ1 (fromIntegral n)
|
||||
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:refs1" $ nil_ $ \case
|
||||
[ LitIntVal n ] -> do
|
||||
debug $ "ncq:refs1" <+> pretty n
|
||||
runTest $ testNCQRefs1 (fromIntegral n)
|
||||
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:tree1" $ nil_ $ \case
|
||||
[ LitIntVal n ] -> do
|
||||
debug $ "ncq:tree1" <+> pretty n
|
||||
runTest $ testNCQTree1 (fromIntegral n)
|
||||
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:concurrent1" $ nil_ $ \case
|
||||
[ LitIntVal tn, LitIntVal n ] -> do
|
||||
debug $ "ncq:concurrent1" <+> pretty tn <+> pretty n
|
||||
runTest $ testNCQConcurrent1 False ( fromIntegral tn) (fromIntegral n)
|
||||
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:concurrent1:wo" $ nil_ $ \case
|
||||
[ LitIntVal tn, LitIntVal n ] -> do
|
||||
debug $ "ncq:concurrent1" <+> pretty tn <+> pretty n
|
||||
runTest $ testNCQConcurrent1 True ( fromIntegral tn) (fromIntegral n)
|
||||
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
entry $ bindMatch "test:ncq:test-lock" $ nil_ $ \case
|
||||
[ ] -> do
|
||||
runTest $ \TestEnv{..} -> do
|
||||
debug $ "test:ncq:test-lock" <+> pretty testEnvDir
|
||||
|
||||
let ncq1 = testEnvDir </> "ncq1"
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
pause @'Seconds 2
|
||||
r1 <- ContT $ withAsync do
|
||||
withNCQ id ncq1 $ \_ -> do
|
||||
forever $ pause @'Seconds 1
|
||||
|
||||
-- link r1
|
||||
|
||||
sto2 <- ContT $ withNCQ id ncq1
|
||||
|
||||
result <- poll r1
|
||||
|
||||
notice $ viaShow result
|
||||
|
||||
case result of
|
||||
Just Left{} -> none
|
||||
_ -> liftIO $ assertBool "must be (Left _)" False
|
||||
|
||||
e -> throwIO $ BadFormException @C (mkList e)
|
||||
|
||||
-- NCQ3 tests
|
||||
|
||||
ncq3Tests
|
||||
|
|
|
|||
Loading…
Reference in New Issue