voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

fixing wrong state on crash exit

This commit is contained in:
voidlizard 2025-08-22 09:23:52 +03:00
parent ac629634c0
commit 7a357dd8c4
15 changed files with 410 additions and 215 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
hbs2-cli/lib/HBS2/CLI/NCQ3/Migrate.hs
View File

@ -33,10 +33,6 @@ migrateEntries = do
$ entry $ bindMatch "ncq3:migrate:ncq" $ nil_ $ \case $ entry $ bindMatch "ncq3:migrate:ncq" $ nil_ $ \case
[ StringLike src, StringLike dst] -> do [ StringLike src, StringLike dst] -> do
sto <- getStorage
api <- getClientAPI @PeerAPI @UNIX api <- getClientAPI @PeerAPI @UNIX
refs <- callRpcWaitMay @RpcPollList2 (1.0 :: Timeout 'Seconds) api (Nothing, Nothing) refs <- callRpcWaitMay @RpcPollList2 (1.0 :: Timeout 'Seconds) api (Nothing, Nothing)
@ -44,7 +40,11 @@ migrateEntries = do
rrefs <- S.toList_ <$> for refs $ \(pk, s, _) -> case s of rrefs <- S.toList_ <$> for refs $ \(pk, s, _) -> case s of
"reflog" -> S.yield (WrapRef $ RefLogKey @'HBS2Basic pk) "reflog" -> S.yield (WrapRef $ RefLogKey @'HBS2Basic pk)
"refchan" -> S.yield (WrapRef $ RefChanLogKey @'HBS2Basic pk)
"refchan" -> do
S.yield (WrapRef $ RefChanLogKey @'HBS2Basic pk)
S.yield (WrapRef $ RefChanHeadKey @'HBS2Basic pk)
"lwwref" -> S.yield (WrapRef $ LWWRefKey @'HBS2Basic pk) "lwwref" -> S.yield (WrapRef $ LWWRefKey @'HBS2Basic pk)
_ -> none _ -> none

4
hbs2-peer/app/Migrate.hs
View File

@ -101,7 +101,9 @@ migrate syn = flip runContT pure $ callCC \exit -> do
rrefs <- S.toList_ <$> for refs $ \(pk, s, _) -> case s of rrefs <- S.toList_ <$> for refs $ \(pk, s, _) -> case s of
"reflog" -> S.yield (WrapRef $ RefLogKey @'HBS2Basic pk) "reflog" -> S.yield (WrapRef $ RefLogKey @'HBS2Basic pk)
"refchan" -> S.yield (WrapRef $ RefChanLogKey @'HBS2Basic pk) "refchan" -> do
S.yield (WrapRef $ RefChanLogKey @'HBS2Basic pk)
S.yield (WrapRef $ RefChanHeadKey @'HBS2Basic pk)
"lwwref" -> S.yield (WrapRef $ LWWRefKey @'HBS2Basic pk) "lwwref" -> S.yield (WrapRef $ LWWRefKey @'HBS2Basic pk)
_ -> none _ -> none

13
hbs2-peer/app/PeerMain.hs
View File

@ -31,8 +31,8 @@ import HBS2.Net.Proto.Notify
import HBS2.Peer.Proto.Mailbox import HBS2.Peer.Proto.Mailbox
import HBS2.OrDie import HBS2.OrDie
import HBS2.Storage.Simple import HBS2.Storage.Simple
import HBS2.Storage.NCQ3 -- import HBS2.Storage.NCQ3
-- import HBS2.Storage.NCQ import HBS2.Storage.NCQ
import HBS2.Storage.Operations.Missed import HBS2.Storage.Operations.Missed
import HBS2.Data.Detect import HBS2.Data.Detect
@ -822,13 +822,14 @@ runPeer opts = respawnOnError opts $ flip runContT pure do
-- error "STOP" -- error "STOP"
let ncqPath = coerce pref </> "ncq3" -- let ncqPath = coerce pref </> "ncq3"
-- let ncqPath = coerce pref </> "ncq" let ncqPath = coerce pref </> "ncq"
debug $ "storage prefix:" <+> pretty ncqPath debug $ "storage prefix:" <+> pretty ncqPath
-- s <- ContT $ ncqWithStorage ncqPath -- s <- ContT $ ncqWithStorage ncqPath
s <- lift $ ncqStorageOpen ncqPath id -- s <- lift $ ncqStorageOpen ncqPath id
s <- lift $ ncqStorageOpen ncqPath
-- simpleStorageInit @HbSync (Just pref) -- simpleStorageInit @HbSync (Just pref)
let blk = liftIO . hasBlock s let blk = liftIO . hasBlock s
@ -1399,7 +1400,7 @@ checkMigration prefix = flip runContT pure $ callCC \exit -> do
already <- Sy.doesDirectoryExist migration already <- Sy.doesDirectoryExist migration
when (L.null blocks && not already) do when (L.null blocks && not already) do
checkNCQ1 -- checkNCQ1
exit () exit ()
let reason = if already then let reason = if already then

1
hbs2-storage-ncq/hbs2-storage-ncq.cabal
View File

@ -73,6 +73,7 @@ library
HBS2.Storage.NCQ3.Internal.MMapCache HBS2.Storage.NCQ3.Internal.MMapCache
HBS2.Storage.NCQ3.Internal.Files HBS2.Storage.NCQ3.Internal.Files
HBS2.Storage.NCQ3.Internal.Fossil HBS2.Storage.NCQ3.Internal.Fossil
HBS2.Storage.NCQ3.Internal.Flags
HBS2.Storage.NCQ HBS2.Storage.NCQ
HBS2.Storage.NCQ.Types HBS2.Storage.NCQ.Types
-- other-modules: -- other-modules:

1
hbs2-storage-ncq/lib/HBS2/Storage/NCQ3.hs
View File

@ -25,6 +25,7 @@ import HBS2.Storage.NCQ3.Internal.State
import HBS2.Storage.NCQ3.Internal.Memtable import HBS2.Storage.NCQ3.Internal.Memtable
import HBS2.Storage.NCQ3.Internal.Index import HBS2.Storage.NCQ3.Internal.Index
import HBS2.Storage.NCQ3.Internal.Fossil import HBS2.Storage.NCQ3.Internal.Fossil
import HBS2.Storage.NCQ3.Internal.Flags as Exported

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

@ -27,20 +27,22 @@ import System.FileLock as FL
ncqStorageOpen :: MonadIO m => FilePath -> (NCQStorage -> NCQStorage) -> m NCQStorage ncqStorageOpen :: MonadIO m => FilePath -> (NCQStorage -> NCQStorage) -> m NCQStorage
ncqStorageOpen fp upd = do ncqStorageOpen fp upd = do
let ncqRoot = fp let ncqRoot = fp
let ncqGen = 0 let ncqGen = 0
-- let ncqFsync = 16 * megabytes -- let ncqFsync = 16 * megabytes
let ncqFsync = 16 * megabytes let ncqFsync = 16 * megabytes
let ncqWriteQLen = 1024 * 4 let ncqWriteQLen = 1024 * 4
let ncqMinLog = 512 * megabytes let ncqMinLog = 512 * megabytes
let ncqMaxLog = 32 * gigabytes let ncqMaxLog = 32 * gigabytes
let ncqWriteBlock = max 256 $ ncqWriteQLen `div` 2 let ncqWriteBlock = max 256 $ ncqWriteQLen `div` 2
let ncqMaxCachedIndex = 64 let ncqMaxCachedIndex = 64
let ncqMaxCachedData = 64 let ncqMaxCachedData = 64
let ncqIdleThrsh = 50.0 let ncqIdleThrsh = 50.0
let ncqPostponeMerge = 300.0 let ncqPostponeService = 20
let ncqPostponeSweep = 2 * ncqPostponeMerge let ncqSweepTime = 30.00
let ncqSalt = "EstEFasxrCFqsGDxcY4haFcha9e4ZHRzsPbGUmDfdxLk" let ncqMergeTimeA = 10.00
let ncqMergeTimeB = 60.00
let ncqSalt = "EstEFasxrCFqsGDxcY4haFcha9e4ZHRzsPbGUmDfdxLk"
cap <- getNumCapabilities cap <- getNumCapabilities
@ -61,10 +63,12 @@ ncqStorageOpen fp upd = do
ncqAlive <- newTVarIO False ncqAlive <- newTVarIO False
ncqStopReq <- newTVarIO False ncqStopReq <- newTVarIO False
ncqSyncReq <- newTVarIO False ncqSyncReq <- newTVarIO False
ncqSweepReq <- newTVarIO False
ncqMergeReq <- newTVarIO False
ncqOnRunWriteIdle <- newTVarIO none ncqOnRunWriteIdle <- newTVarIO none
ncqSyncNo <- newTVarIO 0 ncqSyncNo <- newTVarIO 0
ncqState <- newTVarIO mempty ncqState <- newTVarIO mempty
ncqStateKey <- newTVarIO (FileKey maxBound) ncqStateKey <- newTVarIO ncqNullStateKey
ncqStateUse <- newTVarIO mempty ncqStateUse <- newTVarIO mempty
ncqServiceSem <- atomically $ newTSem 1 ncqServiceSem <- atomically $ newTSem 1
ncqRunSem <- atomically $ newTSem 1 ncqRunSem <- atomically $ newTSem 1
@ -75,17 +79,21 @@ ncqStorageOpen fp upd = do
mkdir (ncqGetWorkDir ncq) mkdir (ncqGetWorkDir ncq)
liftIO (FL.tryLockFile (ncqGetFileName ncq ".lock") Exclusive)
>>= orThrow NCQStorageCurrentAlreadyOpen
>>= atomically . writeTVar ncqFileLock . Just
liftIO (ncqTryLoadState ncq)
pure ncq pure ncq
ncqWithStorage :: MonadUnliftIO m => FilePath -> (NCQStorage -> m a) -> m a {- HLINT ignore "Eta reduce" -}
ncqWithStorage fp action = flip runContT pure do
sto <- lift (ncqStorageOpen fp id) ncqWithStorage :: MonadUnliftIO m
=> FilePath
-> (NCQStorage -> m a) -> m a
ncqWithStorage fp action = ncqWithStorage0 fp id action
ncqWithStorage0 :: MonadUnliftIO m
=> FilePath
-> (NCQStorage -> NCQStorage)
-> (NCQStorage -> m a) -> m a
ncqWithStorage0 fp tune action = flip runContT pure do
sto <- lift (ncqStorageOpen fp tune)
w <- ContT $ withAsync (ncqStorageRun sto) w <- ContT $ withAsync (ncqStorageRun sto)
link w link w
r <- lift (action sto) r <- lift (action sto)
@ -200,86 +208,6 @@ ncqPutBS0 wait ncq@NCQStorage{..} mtp mhref bs' = ncqOperation ncq (pure $ fromM
where hash0 = HashRef (hashObject @HbSync bs') where hash0 = HashRef (hashObject @HbSync bs')
ncqTryLoadState :: forall m. MonadUnliftIO m
=> NCQStorage
-> m ()
ncqTryLoadState me@NCQStorage{..} = withSem ncqServiceSem do
stateFiles <- ncqListFilesBy me ( List.isPrefixOf "s-" )
r <- flip fix ([], ncqState0, stateFiles) $ \next -> \case
(r, s, []) -> pure (r,s,[])
(l, s0, (_,s):ss) -> do
readStateMay me s >>= \case
Nothing -> next (s : l, s0, ss)
Just ns -> do
ok <- checkState ns
if ok then
pure (l <> fmap snd ss, ns, ss)
else
next (s : l, s0, ss)
let (bad, new@NCQState{..}, rest) = r
atomically $ modifyTVar ncqState (<> new)
for_ [ (d,s) | P (PData d s) <- Set.toList ncqStateFacts ] $ \(dataFile,s) -> do
let path = ncqGetFileName me dataFile
realSize <- fileSize path
let sizewtf = realSize /= fromIntegral s
flip fix 0 $ \again i -> do
good <- try @_ @NCQFsckException (ncqFileFastCheck path)
let corrupted = isLeft good
if not corrupted then do
debug $ yellow "indexing" <+> pretty dataFile
ncqIndexFile me Nothing dataFile
else do
o <- ncqFileTryRecover path
warn $ "ncqFileTryRecover" <+> pretty path <+> pretty o <+> parens (pretty realSize)
let best = if i < 1 then max s o else s
warn $ red "trim" <+> pretty s <+> pretty best <+> red (pretty (fromIntegral best - realSize)) <+> pretty (takeFileName path)
liftIO $ PFS.setFileSize path (fromIntegral best)
if i <= 1 then again (succ i) else pure Nothing
for_ (bad <> fmap snd rest) $ \f -> do
let old = ncqGetFileName me (StateFile f)
rm old
where
-- TODO: created-but-not-indexed-file?
checkState NCQState{..} = flip runContT pure $ callCC \exit -> do
for_ ncqStateFiles $ \fk -> do
let dataFile = ncqGetFileName me (DataFile fk)
here <- doesFileExist dataFile
unless here $ exit False
lift (try @_ @SomeException (ncqFileFastCheck dataFile)) >>= \case
Left e -> err (viaShow e) >> exit False
Right () -> none
pure True
class IsTomb a where class IsTomb a where

32
hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Flags.hs Normal file
View File

@ -0,0 +1,32 @@
module HBS2.Storage.NCQ3.Internal.Flags where
import HBS2.Storage.NCQ3.Internal.Prelude
import HBS2.Storage.NCQ3.Internal.Types
import Control.Concurrent.STM qualified as STM
ncqSetFlagSTM :: TVar Bool -> STM ()
ncqSetFlagSTM t = writeTVar t True
ncqSetFlag :: MonadIO m => TVar Bool -> m ()
ncqSetFlag t = atomically $ writeTVar t True
ncqClearFlagSTM :: TVar Bool -> STM ()
ncqClearFlagSTM t = writeTVar t False
ncqClearFlag :: MonadIO m => TVar Bool -> m ()
ncqClearFlag t = liftIO (atomically $ ncqClearFlagSTM t)
ncqWaitFlagSTM :: TVar Bool -> STM Bool
ncqWaitFlagSTM t = do
val <- readTVar t
unless val STM.retry
writeTVar t False
pure val
ncqGetFlagSTM :: TVar Bool -> STM Bool
ncqGetFlagSTM = readTVar
ncqGetFlag :: MonadIO m => TVar Bool -> m Bool
ncqGetFlag = liftIO . readTVarIO

2
hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs
View File

@ -62,7 +62,7 @@ ncqFossilMergeStep :: forall m . MonadUnliftIO m
=> NCQStorage => NCQStorage
-> m Bool -> m Bool
ncqFossilMergeStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pure $ callCC \exit -> do ncqFossilMergeStep me@NCQStorage{..} = flip runContT pure $ callCC \exit -> do
tmax <- liftIO getPOSIXTime >>= newTVarIO tmax <- liftIO getPOSIXTime >>= newTVarIO
debug "ncqFossilMergeStep" debug "ncqFossilMergeStep"

3
hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs
View File

@ -156,7 +156,7 @@ ncqIndexCompactFull ncq = fix \again ->
ncqIndexCompactStep :: MonadUnliftIO m ncqIndexCompactStep :: MonadUnliftIO m
=> NCQStorage => NCQStorage
-> m Bool -> m Bool
ncqIndexCompactStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pure $ callCC \exit -> do ncqIndexCompactStep me@NCQStorage{..} = flip runContT pure $ callCC \exit -> do
debug "ncqIndexCompactStep" debug "ncqIndexCompactStep"
@ -198,6 +198,7 @@ ncqIndexCompactStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pu
liftIO $ PFS.setFileTimesHiRes result ts ts liftIO $ PFS.setFileTimesHiRes result ts ts
fki <- ncqGetNewFileKey me IndexFile fki <- ncqGetNewFileKey me IndexFile
moveFile result (ncqGetFileName me (IndexFile fki)) moveFile result (ncqGetFileName me (IndexFile fki))
debug $ "state update" <+> pretty a <+> pretty b <+> "=>" <+> pretty fki debug $ "state update" <+> pretty a <+> pretty b <+> "=>" <+> pretty fki

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

@ -11,28 +11,143 @@ import HBS2.Storage.NCQ3.Internal.State
import HBS2.Storage.NCQ3.Internal.Sweep import HBS2.Storage.NCQ3.Internal.Sweep
import HBS2.Storage.NCQ3.Internal.MMapCache import HBS2.Storage.NCQ3.Internal.MMapCache
import HBS2.Storage.NCQ3.Internal.Fossil import HBS2.Storage.NCQ3.Internal.Fossil
import HBS2.Storage.NCQ3.Internal.Flags
import Control.Concurrent.STM qualified as STM
import Control.Monad.Trans.Cont import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.HashSet qualified as HS import Data.Either
import Data.Vector qualified as V
import Data.Sequence qualified as Seq
import Data.Fixed import Data.Fixed
import Data.HashSet qualified as HS
import Data.HashMap.Strict qualified as HM
import Data.List qualified as List
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Data.Vector qualified as V
import System.FileLock as FL
import System.Posix.Files qualified as PFS
import System.Posix.IO as PosixBase import System.Posix.IO as PosixBase
import System.Posix.IO.ByteString as Posix
import System.Posix.Types as Posix import System.Posix.Types as Posix
import System.Posix.Unistd import System.Posix.Unistd
import System.Posix.IO.ByteString as Posix
import Control.Concurrent.STM qualified as STM
import System.FileLock as FL
ncqStorageStop :: forall m . MonadUnliftIO m => NCQStorage -> m () ncqStorageStop :: forall m . MonadUnliftIO m => NCQStorage -> m ()
ncqStorageStop NCQStorage{..} = do ncqStorageStop NCQStorage{..} = do
atomically $ writeTVar ncqStopReq True atomically $ writeTVar ncqStopReq True
ncqTryLoadState :: forall m. MonadUnliftIO m
=> NCQStorage
-> m ()
ncqTryLoadState me@NCQStorage{..} = do
debug "ncqTryLoadState"
stateFiles <- ncqListFilesBy me ( List.isPrefixOf "s-" )
<&> List.sortOn ( Down . snd )
r <- flip fix ([], ncqState0, stateFiles) $ \next -> \case
(r, s, []) -> pure (r,s,[])
(l, s0, (_,s):ss) -> do
readStateMay me s >>= \case
Nothing -> next (s : l, s0, ss)
Just ns -> do
ok <- checkState ns
debug $ "state status" <+> pretty s <+> pretty ok
if ok then
pure (l <> fmap snd ss, ns, ss)
else
next (s : l, s0, ss)
let (bad, new@NCQState{..}, rest) = r
atomically $ modifyTVar ncqState (<> new)
for_ [ (d,s) | P (PData d s) <- Set.toList ncqStateFacts ] $ \(dataFile,s) -> do
let path = ncqGetFileName me dataFile
realSize <- fileSize path
let sizewtf = realSize /= fromIntegral s
flip fix 0 $ \again i -> do
good <- try @_ @NCQFsckException (ncqFileFastCheck path)
let corrupted = isLeft good
if not corrupted then do
debug $ yellow "indexing" <+> pretty dataFile
ncqIndexFile me Nothing dataFile
else do
o <- ncqFileTryRecover path
warn $ "ncqFileTryRecover" <+> pretty path <+> pretty o <+> parens (pretty realSize)
let best = if i < 1 then max s o else s
warn $ red "trim" <+> pretty s <+> pretty best <+> red (pretty (fromIntegral best - realSize)) <+> pretty (takeFileName path)
liftIO $ PFS.setFileSize path (fromIntegral best)
if i <= 1 then again (succ i) else pure Nothing
for_ (bad <> fmap snd rest) $ \f -> do
let old = ncqGetFileName me (StateFile f)
rm old
where
-- TODO: created-but-not-indexed-file?
checkState NCQState{..} = flip runContT pure $ callCC \exit -> do
for_ ncqStateFiles $ \fk -> do
let dataFile = ncqGetFileName me (DataFile fk)
here <- doesFileExist dataFile
unless here $ exit False
-- lift (try @_ @SomeException (ncqFileFastCheck dataFile)) >>= \case
-- Right () -> none
-- Left e -> do
-- warn (viaShow e)
-- let known = HM.lookup fk facts
-- fs <- fileSize dataFile
-- warn $ "file is incomplete (or damaged)"
-- <+> pretty dataFile
-- <+> "actual:" <+> pretty fs
-- <+> "known:" <+> pretty known
-- let ok = isJust known && Just (fromIntegral fs) >= known
-- unless ok $ exit False
for_ ncqStateIndex $ \(_,fk) -> do
let idxFile = ncqGetFileName me (IndexFile fk)
here <- doesFileExist idxFile
unless here do
err $ red "missed index in state" <+> pretty idxFile
exit False
pure True
ncqStorageRun :: forall m . MonadUnliftIO m ncqStorageRun :: forall m . MonadUnliftIO m
=> NCQStorage => NCQStorage
-> m () -> m ()
ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
debug "ncqStorageRun"
liftIO (FL.tryLockFile (ncqGetFileName ncq ".lock") Exclusive)
>>= orThrow NCQStorageCurrentAlreadyOpen
>>= atomically . writeTVar ncqFileLock . Just
ContT $ bracket setAlive (const unsetAlive) ContT $ bracket setAlive (const unsetAlive)
ContT $ bracket none $ const $ liftIO do ContT $ bracket none $ const $ liftIO do
@ -41,6 +156,8 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
ContT $ bracket none $ const $ liftIO do ContT $ bracket none $ const $ liftIO do
debug "storage done" debug "storage done"
liftIO (ncqTryLoadState ncq)
closeQ <- liftIO newTQueueIO closeQ <- liftIO newTQueueIO
closer <- spawnActivity $ liftIO $ fix \loop -> do closer <- spawnActivity $ liftIO $ fix \loop -> do
@ -86,7 +203,7 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
-- debug $ "NOT FOUND SHIT" <+> pretty h -- debug $ "NOT FOUND SHIT" <+> pretty h
answer Nothing >> exit () answer Nothing >> exit ()
-- spawnActivity measureWPS spawnActivity measureWPS
spawnActivity (ncqStateUpdateLoop ncq) spawnActivity (ncqStateUpdateLoop ncq)
@ -95,29 +212,17 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
ema <- readTVarIO ncqWriteEMA ema <- readTVarIO ncqWriteEMA
debug $ "EMA" <+> pretty (realToFrac @_ @(Fixed E3) ema) debug $ "EMA" <+> pretty (realToFrac @_ @(Fixed E3) ema)
spawnActivity $ postponed 30 $ forever do spawnActivity $ postponed ncqPostponeService $ forever do
lsInit <- ncqLiveKeys ncq <&> HS.size ncqSweepObsoleteStates ncq
void $ race (pause @'Seconds 30) do ncqSweepFiles ncq
flip fix lsInit $ \next ls0 -> do void $ race (pause @'Seconds ncqSweepTime) do
(lsA,lsB) <- atomically do atomically (ncqWaitFlagSTM ncqSweepReq)
ema <- readTVar ncqWriteEMA
ls1 <- ncqLiveKeysSTM ncq <&> HS.size
if ls1 /= ls0 && ema < ncqIdleThrsh then spawnActivity $ postponed ncqPostponeService
pure (ls0,ls1) $ compactLoop ncqMergeReq ncqMergeTimeA ncqMergeTimeB $ withSem ncqServiceSem do
else a <- ncqFossilMergeStep ncq
STM.retry b <- ncqIndexCompactStep ncq
pure $ a || b
debug $ "do sweep" <+> pretty lsA <+> pretty lsB
ncqSweepObsoleteStates ncq
ncqSweepFiles ncq
next lsB
spawnActivity $ postponed 20 $ compactLoop 10 30 do
ncqIndexCompactStep ncq
spawnActivity $ postponed 20 $ compactLoop 10 60 do
ncqFossilMergeStep ncq
flip fix RunNew $ \loop -> \case flip fix RunNew $ \loop -> \case
RunFin -> do RunFin -> do
@ -255,12 +360,18 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
postponed n m = liftIO (pause @'Seconds n) >> m postponed n m = liftIO (pause @'Seconds n) >> m
compactLoop :: Timeout 'Seconds -> Timeout 'Seconds -> m Bool -> m () compactLoop :: TVar Bool
compactLoop t1 t2 what = forever $ void $ runMaybeT do -> Timeout 'Seconds
ema <- readTVarIO ncqWriteEMA -> Timeout 'Seconds
-> m Bool
-> m ()
compactLoop flag t1 t2 what = forever $ void $ runMaybeT do
ema <- readTVarIO ncqWriteEMA
fired <- ncqGetFlag flag
when (ema > ncqIdleThrsh) $ pause @'Seconds t1 >> mzero when (ema > ncqIdleThrsh && not fired) $ pause @'Seconds t1 >> mzero
ncqClearFlag flag
compacted <- lift what compacted <- lift what
when compacted mzero when compacted mzero

2
hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/State.hs
View File

@ -108,7 +108,7 @@ ncqStateDelIndexFile fk = do
where f (_,b) = b /= fk where f (_,b) = b /= fk
sortIndexes :: NCQState -> NCQState sortIndexes :: NCQState -> NCQState
sortIndexes = over #ncqStateIndex (List.sortOn fst) sortIndexes = over #ncqStateIndex sortIndexes0
ncqStateCapture :: forall m . MonadUnliftIO m ncqStateCapture :: forall m . MonadUnliftIO m

35
hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Sweep.hs
View File

@ -4,13 +4,15 @@ module HBS2.Storage.NCQ3.Internal.Sweep where
import HBS2.Storage.NCQ3.Internal.Prelude import HBS2.Storage.NCQ3.Internal.Prelude
import HBS2.Storage.NCQ3.Internal.Types import HBS2.Storage.NCQ3.Internal.Types
import HBS2.Storage.NCQ3.Internal.Files import HBS2.Storage.NCQ3.Internal.Files
import HBS2.Storage.NCQ3.Internal.State
import Data.Generics.Uniplate.Operations import Control.Monad.Trans.Cont
import Data.Generics.Uniplate.Data() import Data.Generics.Uniplate.Data()
import Data.List qualified as List import Data.Generics.Uniplate.Operations
import Data.HashSet qualified as HS
import System.Posix.Files qualified as PFS
import Data.HashMap.Strict qualified as HM import Data.HashMap.Strict qualified as HM
import Data.HashSet qualified as HS
import Data.List qualified as List
import System.Posix.Files qualified as PFS
ncqLiveKeysSTM :: NCQStorage -> STM (HashSet FileKey) ncqLiveKeysSTM :: NCQStorage -> STM (HashSet FileKey)
ncqLiveKeysSTM NCQStorage{..} = do ncqLiveKeysSTM NCQStorage{..} = do
@ -24,19 +26,26 @@ ncqLiveKeysSTM NCQStorage{..} = do
ncqLiveKeys :: forall m . MonadIO m => NCQStorage -> m (HashSet FileKey) ncqLiveKeys :: forall m . MonadIO m => NCQStorage -> m (HashSet FileKey)
ncqLiveKeys ncq = atomically $ ncqLiveKeysSTM ncq ncqLiveKeys ncq = atomically $ ncqLiveKeysSTM ncq
{- HLINT ignore "Functor law"-}
ncqSweepFiles :: forall m . MonadUnliftIO m => NCQStorage -> m () ncqSweepFiles :: forall m . MonadUnliftIO m => NCQStorage -> m ()
ncqSweepFiles me@NCQStorage{..} = withSem ncqServiceSem do ncqSweepFiles me@NCQStorage{..} = do
debug "ncqSweepFiles" debug "ncqSweepFiles"
live <- ncqLiveKeys me
debug $ "ALIVE" <+> pretty (HS.toList live)
fossils <- ncqListFilesBy me (List.isPrefixOf "f-") fossils <- ncqListFilesBy me (List.isPrefixOf "f-")
indexes <- ncqListFilesBy me (List.isPrefixOf "i-") indexes <- ncqListFilesBy me (List.isPrefixOf "i-")
stateFiles <- ncqListFilesBy me (List.isPrefixOf "s-") <&> fmap snd
liveOnDisk <- for stateFiles (readStateMay me)
<&> mconcat . catMaybes
<&> HS.fromList . universeBi @_ @FileKey
live <- ncqLiveKeys me <&> (<> liveOnDisk)
debug $ "ALIVE" <+> pretty (HS.toList live)
for_ indexes $ \(_, k) -> unless (HS.member k live) do for_ indexes $ \(_, k) -> unless (HS.member k live) do
let fn = ncqGetFileName me (IndexFile k) let fn = ncqGetFileName me (IndexFile k)
debug $ yellow "REMOVING" <+> pretty (takeFileName fn) debug $ yellow "REMOVING" <+> pretty (takeFileName fn)
@ -49,14 +58,18 @@ ncqSweepFiles me@NCQStorage{..} = withSem ncqServiceSem do
ncqSweepObsoleteStates :: forall m . MonadUnliftIO m => NCQStorage -> m () ncqSweepObsoleteStates :: forall m . MonadUnliftIO m => NCQStorage -> m ()
ncqSweepObsoleteStates me@NCQStorage{..} = withSem ncqServiceSem do ncqSweepObsoleteStates me@NCQStorage{..} = flip runContT pure $ callCC \exit -> do
debug $ "ncqSweepObsoleteStates" debug $ "ncqSweepObsoleteStates"
k <- readTVarIO ncqStateKey k <- readTVarIO ncqStateKey
when (k == ncqNullStateKey) $ exit ()
r <- liftIO $ try @_ @SomeException do r <- liftIO $ try @_ @SomeException do
ts <- PFS.getFileStatus (ncqGetFileName me (StateFile k)) <&> PFS.modificationTimeHiRes ts <- PFS.getFileStatus (ncqGetFileName me (StateFile k)) <&> PFS.modificationTimeHiRes
filez <- ncqListFilesBy me (List.isPrefixOf "s-") filez <- ncqListFilesBy me (List.isPrefixOf "s-")
<&> List.drop 1 . List.sortOn (Down . snd) -- delete old 10 states
for_ filez $ \(t,f) -> do for_ filez $ \(t,f) -> do

83
hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs
View File

@ -7,6 +7,7 @@ import Numeric (readHex)
import Data.Data import Data.Data
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.HashSet qualified as HS import Data.HashSet qualified as HS
import Data.List qualified as List
import Text.Printf import Text.Printf
import Control.Concurrent.STM.TSem (TSem,waitTSem,signalTSem) import Control.Concurrent.STM.TSem (TSem,waitTSem,signalTSem)
import System.FileLock (FileLock) import System.FileLock (FileLock)
@ -83,42 +84,47 @@ data NCQState =
data NCQStorage = data NCQStorage =
NCQStorage NCQStorage
{ ncqRoot :: FilePath { ncqRoot :: FilePath
, ncqGen :: Int , ncqGen :: Int
, ncqSalt :: HashRef , ncqSalt :: HashRef
, ncqPostponeMerge :: Timeout 'Seconds , ncqPostponeService :: Timeout 'Seconds
, ncqPostponeSweep :: Timeout 'Seconds , ncqSweepTime :: Timeout 'Seconds
, ncqFsync :: Int , ncqMergeTimeA :: Timeout 'Seconds
, ncqWriteQLen :: Int , ncqMergeTimeB :: Timeout 'Seconds
, ncqWriteBlock :: Int , ncqFsync :: Int
, ncqMinLog :: Int , ncqWriteQLen :: Int
, ncqMaxLog :: Int , ncqWriteBlock :: Int
, ncqMaxCachedIndex :: Int , ncqMinLog :: Int
, ncqMaxCachedData :: Int , ncqMaxLog :: Int
, ncqReadThreads :: Int , ncqMaxCachedIndex :: Int
, ncqIdleThrsh :: Double , ncqMaxCachedData :: Int
, ncqMMapCachedIdx :: TVar (HashPSQ FileKey CachePrio CachedIndex) , ncqReadThreads :: Int
, ncqMMapCachedData :: TVar (HashPSQ FileKey CachePrio CachedData) , ncqIdleThrsh :: Double
, ncqMemTable :: Vector Shard , ncqMMapCachedIdx :: TVar (HashPSQ FileKey CachePrio CachedIndex)
, ncqState :: TVar NCQState , ncqMMapCachedData :: TVar (HashPSQ FileKey CachePrio CachedData)
, ncqStateKey :: TVar FileKey , ncqMemTable :: Vector Shard
, ncqStateUse :: TVar (HashMap FileKey (NCQState, TVar Int)) , ncqState :: TVar NCQState
, ncqCurrentFossils :: TVar (HashSet FileKey) , ncqStateKey :: TVar FileKey
, ncqWrites :: TVar Int , ncqStateUse :: TVar (HashMap FileKey (NCQState, TVar Int))
, ncqWriteEMA :: TVar Double -- for writes-per-seconds , ncqCurrentFossils :: TVar (HashSet FileKey)
, ncqWriteQ :: TVar (Seq HashRef) , ncqWrites :: TVar Int
, ncqWriteOps :: Vector (TQueue (IO ())) , ncqWriteEMA :: TVar Double -- for writes-per-seconds
, ncqSyncOps :: TQueue (IO ()) , ncqWriteQ :: TVar (Seq HashRef)
, ncqReadReq :: TQueue (HashRef, TMVar (Maybe Location)) , ncqWriteOps :: Vector (TQueue (IO ()))
, ncqAlive :: TVar Bool , ncqSyncOps :: TQueue (IO ())
, ncqStopReq :: TVar Bool , ncqReadReq :: TQueue (HashRef, TMVar (Maybe Location))
, ncqSyncReq :: TVar Bool , ncqAlive :: TVar Bool
, ncqOnRunWriteIdle :: TVar (IO ()) , ncqStopReq :: TVar Bool
, ncqSyncNo :: TVar Int , ncqSyncReq :: TVar Bool
, ncqServiceSem :: TSem , ncqSweepReq :: TVar Bool
, ncqRunSem :: TSem , ncqMergeReq :: TVar Bool
, ncqFileLock :: TVar (Maybe FileLock) , ncqOnRunWriteIdle :: TVar (IO ())
, ncqSyncNo :: TVar Int
, ncqServiceSem :: TSem
, ncqRunSem :: TSem
, ncqFileLock :: TVar (Maybe FileLock)
} }
deriving stock (Generic)
instance Monoid FileKey where instance Monoid FileKey where
@ -147,7 +153,7 @@ instance Semigroup NCQState where
(<>) a b = NCQState files index seqq version facts (<>) a b = NCQState files index seqq version facts
where where
files = ncqStateFiles a <> ncqStateFiles b files = ncqStateFiles a <> ncqStateFiles b
index = ncqStateIndex a <> ncqStateIndex b index = sortIndexes0 (ncqStateIndex a <> ncqStateIndex b)
seqq = max (ncqStateFileSeq a) (ncqStateFileSeq b) seqq = max (ncqStateFileSeq a) (ncqStateFileSeq b)
version = max (ncqStateVersion a) (ncqStateVersion b) version = max (ncqStateVersion a) (ncqStateVersion b)
facts = ncqStateFacts a <> ncqStateFacts b facts = ncqStateFacts a <> ncqStateFacts b
@ -208,6 +214,8 @@ instance Pretty NCQState where
pf (P (PData (DataFile a) s)) = "fp" <+> pretty a <+> pretty s pf (P (PData (DataFile a) s)) = "fp" <+> pretty a <+> pretty s
sortIndexes0 :: [(Down POSIXTime, b)] -> [(Down POSIXTime, b)]
sortIndexes0 = List.sortOn fst
ncqTombEntrySize :: NCQSize ncqTombEntrySize :: NCQSize
ncqTombEntrySize = ncqSLen + ncqKeyLen + ncqPrefixLen ncqTombEntrySize = ncqSLen + ncqKeyLen + ncqPrefixLen
@ -226,5 +234,6 @@ ncqDeferredWriteOpSTM NCQStorage{..} work = do
logErr :: forall x a m . (Pretty x, MonadUnliftIO m) => x -> m a -> m a logErr :: forall x a m . (Pretty x, MonadUnliftIO m) => x -> m a -> m a
logErr loc m = handle (\(e::SomeException) -> err (pretty loc <> ":" <> viaShow e) >> throwIO e) m logErr loc m = handle (\(e::SomeException) -> err (pretty loc <> ":" <> viaShow e) >> throwIO e) m
ncqNullStateKey :: FileKey
ncqNullStateKey = FileKey maxBound

21
hbs2-tests/test/NCQ3.hs
View File

@ -868,6 +868,27 @@ ncq3Tests = do
notice "re-opened storage test done" notice "re-opened storage test done"
entry $ bindMatch "test:ncq3:wrong-state" $ nil_ $ \e -> do
g <- liftIO MWC.createSystemRandom
let (opts,args) = splitOpts [] e
let path = headDef "." [x | StringLike x <- args ]
notice $ "root path" <+> pretty path
let params = set #ncqPostponeService 1
ncqWithStorage0 path params $ \sto -> do
void $ race (pause @'Seconds 600) $ forever do
p <- liftIO $ uniformRM (0,3.00) g
pause @'Seconds (realToFrac p)
n <- liftIO $ uniformRM (1,256*1024) g
s <- liftIO $ genRandomBS g n
h <- putBlock (AnyStorage sto) (LBS.fromStrict s)
debug $ "block written" <+> pretty h <+> pretty n
none
ncq3EnduranceTest ncq3EnduranceTest
ncq3EnduranceTestInProc ncq3EnduranceTestInProc

107
hbs2-tests/test/NCQ3/Endurance.hs
View File

@ -83,12 +83,16 @@ data EnduranceFSM =
| EndurancePutBlk | EndurancePutBlk
| EnduranceHasBlk | EnduranceHasBlk
| EnduranceGetBlk | EnduranceGetBlk
| EnduranceHasSeedBlk
| EnduranceDelBlk | EnduranceDelBlk
| EndurancePutRef | EndurancePutRef
| EnduranceGetRef | EnduranceGetRef
| EnduranceDelRef | EnduranceDelRef
| EnduranceStorm | EnduranceStorm
| EnduranceCalm
| EnduranceKill | EnduranceKill
| EnduranceMerge
| EnduranceSweep
| EnduranceStop | EnduranceStop
buildCDF :: [(s, Double)] -> (V.Vector s, U.Vector Double) buildCDF :: [(s, Double)] -> (V.Vector s, U.Vector Double)
@ -157,6 +161,11 @@ validateTestResult logFile = do
atomically $ modifyTVar blocks (HM.insert h (Left ())) atomically $ modifyTVar blocks (HM.insert h (Left ()))
_ -> none _ -> none
entry $ bindMatch "has-seed-block-result" $ nil_ \case
[ HashLike _, LitIntVal _ ] -> none
[ HashLike h] -> err $ red "missed seed block" <+> pretty h
_ -> none
-- has-block-result -- has-block-result
entry $ bindMatch "has-block-result" $ nil_ \case entry $ bindMatch "has-block-result" $ nil_ \case
[ HashLike h, LitIntVal n ] -> do [ HashLike h, LitIntVal n ] -> do
@ -255,18 +264,25 @@ ncq3EnduranceTest = do
LitIntVal x -> fromIntegral x LitIntVal x -> fromIntegral x
_ -> 0 _ -> 0
wIdle <- dbl <$> lookupValueDef (mkDouble 200.00) "w:idle" wSeed <- int <$> lookupValueDef (mkInt 1000) "w:seed"
wIdleDef <- dbl <$> lookupValueDef (mkDouble 0.25) "w:idle:def" wIdle <- dbl <$> lookupValueDef (mkDouble 200.00) "w:idle"
wPutBlk <- dbl <$> lookupValueDef (mkDouble 30.00) "w:putblk" wIdleDef <- dbl <$> lookupValueDef (mkDouble 0.25) "w:idle:def"
wGetBlk <- dbl <$> lookupValueDef (mkDouble 30.00) "w:getblk" wMaxBlk <- int <$> lookupValueDef (mkInt 65536) "w:maxblk"
wHasBlk <- dbl <$> lookupValueDef (mkDouble 30.00) "w:hasblk" wPutBlk <- dbl <$> lookupValueDef (mkDouble 30.00) "w:putblk"
wDelBlk <- dbl <$> lookupValueDef (mkDouble 3.00) "w:delblk" wGetBlk <- dbl <$> lookupValueDef (mkDouble 30.00) "w:getblk"
wPutRef <- dbl <$> lookupValueDef (mkDouble 5.00) "w:putref" wHasBlk <- dbl <$> lookupValueDef (mkDouble 30.00) "w:hasblk"
wGetRef <- dbl <$> lookupValueDef (mkDouble 10.00) "w:getref" wDelBlk <- dbl <$> lookupValueDef (mkDouble 3.00) "w:delblk"
wDelRef <- dbl <$> lookupValueDef (mkDouble 1.00) "w:delref" wPutRef <- dbl <$> lookupValueDef (mkDouble 5.00) "w:putref"
wStorm <- dbl <$> lookupValueDef (mkDouble 0.80) "w:storm" wGetRef <- dbl <$> lookupValueDef (mkDouble 10.00) "w:getref"
wKill <- dbl <$> lookupValueDef (mkDouble 0.0004) "w:kill" wDelRef <- dbl <$> lookupValueDef (mkDouble 1.00) "w:delref"
wNum <- int <$> lookupValueDef (mkInt 10000) "w:num" wStorm <- dbl <$> lookupValueDef (mkDouble 0.80) "w:storm"
wStormMin <- dbl <$> lookupValueDef (mkDouble 1.00) "w:stormmin"
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"
wNum <- int <$> lookupValueDef (mkInt 10000) "w:num"
runTest \TestEnv{..} -> do runTest \TestEnv{..} -> do
@ -278,10 +294,12 @@ ncq3EnduranceTest = do
rest <- newTVarIO n rest <- newTVarIO n
blocks <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double () ) 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 ) refs <- newTVarIO ( HPSQ.empty :: HPSQ.HashPSQ HashRef Double HashRef )
killed <- newTVarIO 0 killed <- newTVarIO 0
let getRandomBlock = liftIO $ getRandomFromPSQ g blocks let getRandomBlock = liftIO $ getRandomFromPSQ g blocks
let getRandomSeedBlock = liftIO $ getRandomFromPSQ g seed
let getRandomRef = liftIO $ getRandomFromPSQ g refs let getRandomRef = liftIO $ getRandomFromPSQ g refs
let d = makeDict do let d = makeDict do
@ -321,12 +339,16 @@ ncq3EnduranceTest = do
let actions = [ (EnduranceIdle, wIdle) let actions = [ (EnduranceIdle, wIdle)
, (EndurancePutBlk, wPutBlk) , (EndurancePutBlk, wPutBlk)
, (EnduranceGetBlk, wGetBlk) , (EnduranceGetBlk, wGetBlk)
, (EnduranceHasSeedBlk, wHasBlk)
, (EnduranceHasBlk, wHasBlk) , (EnduranceHasBlk, wHasBlk)
, (EnduranceDelBlk, wDelBlk) , (EnduranceDelBlk, wDelBlk)
, (EndurancePutRef, wPutRef) , (EndurancePutRef, wPutRef)
, (EnduranceGetRef, wGetRef) , (EnduranceGetRef, wGetRef)
, (EnduranceDelRef, wDelRef) , (EnduranceDelRef, wDelRef)
, (EnduranceStorm, wStorm) , (EnduranceStorm, wStorm)
, (EnduranceCalm, wCalm)
, (EnduranceMerge, wMerge)
, (EnduranceSweep, wSweep)
, (EnduranceKill, wKill) , (EnduranceKill, wKill)
] ]
@ -339,6 +361,21 @@ ncq3EnduranceTest = do
, "test:ncq3:endurance:inner", testEnvDir , "test:ncq3:endurance:inner", testEnvDir
] & setStdin createPipe & setStdout createPipe ] & setStdin createPipe & setStdout createPipe
ncqWithStorage testEnvDir $ \sto -> 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
seeds <- readTVarIO seed <&> HPSQ.toList
for_ seeds $ \(h,_,_) -> do
here <- hasBlock (AnyStorage sto) (coerce h)
unless (isJust here) do
err $ "missed seed block" <+> pretty h
fix \recover -> handle (\(e :: IOException) -> err (viaShow e) >> pause @'Seconds 1 >> recover) do fix \recover -> handle (\(e :: IOException) -> err (viaShow e) >> pause @'Seconds 1 >> recover) do
flip runContT pure do flip runContT pure do
@ -354,7 +391,7 @@ ncq3EnduranceTest = do
pread <- ContT $ withAsync $ fix \loop -> do pread <- ContT $ withAsync $ fix \loop -> do
liftIO (try @_ @IOException (IO.hGetLine outp)) >>= \case liftIO (try @_ @IOException (IO.hGetLine outp)) >>= \case
Left e | isEOFError e -> none Left e | isEOFError e -> none
Left e -> err (viaShow e) Left e -> err (viaShow e) >> throwIO e
Right s -> do Right s -> do
liftIO do liftIO do
appendFile logFile (s <> "\n") appendFile logFile (s <> "\n")
@ -362,6 +399,8 @@ ncq3EnduranceTest = do
putStrLn s putStrLn s
loop loop
link pread
ContT $ withAsync $ forever do ContT $ withAsync $ forever do
join $ atomically (readTQueue storms) join $ atomically (readTQueue storms)
@ -403,7 +442,7 @@ ncq3EnduranceTest = do
getNextState >>= loop getNextState >>= loop
EndurancePutBlk -> do EndurancePutBlk -> do
bsize <- liftIO $ uniformRM (1, 256*1024) g bsize <- liftIO $ uniformRM (1, wMaxBlk) g
liftIO $ IO.hPrint inp ("write-random-block" <+> viaShow bsize) liftIO $ IO.hPrint inp ("write-random-block" <+> viaShow bsize)
atomically $ modifyTVar rest pred atomically $ modifyTVar rest pred
getNextState >>= loop getNextState >>= loop
@ -422,6 +461,13 @@ ncq3EnduranceTest = do
getNextState >>= loop getNextState >>= loop
EnduranceHasSeedBlk -> do
blk <- getRandomSeedBlock
for_ blk $ \h -> do
liftIO $ IO.hPrint inp ("has-seed-block" <+> pretty h)
getNextState >>= loop
EnduranceGetBlk -> do EnduranceGetBlk -> do
blk <- getRandomBlock blk <- getRandomBlock
for_ blk $ \h -> do for_ blk $ \h -> do
@ -448,6 +494,14 @@ ncq3EnduranceTest = do
liftIO $ IO.hPrint inp ("del-ref" <+> pretty h) liftIO $ IO.hPrint inp ("del-ref" <+> pretty h)
getNextState >>= loop getNextState >>= loop
EnduranceMerge -> do
liftIO $ IO.hPrint inp "merge"
getNextState >>= loop
EnduranceSweep -> do
liftIO $ IO.hPrint inp "sweep"
getNextState >>= loop
EnduranceKill -> do EnduranceKill -> do
debug $ red "KILL" <+> viaShow pid debug $ red "KILL" <+> viaShow pid
cancel pread cancel pread
@ -467,6 +521,12 @@ ncq3EnduranceTest = do
notice $ "validate" <+> pretty logFile notice $ "validate" <+> pretty logFile
liftIO $ validateTestResult logFile liftIO $ validateTestResult logFile
EnduranceCalm -> do
n <- liftIO $ uniformRM (0.5,10.00) g
debug $ "CALM" <+> pretty n
pause @'Seconds (realToFrac n)
getNextState >>= loop
EnduranceStorm -> do EnduranceStorm -> do
now <- getTimeCoarse now <- getTimeCoarse
@ -482,7 +542,7 @@ ncq3EnduranceTest = do
loop EnduranceIdle loop EnduranceIdle
| otherwise -> do | otherwise -> do
t0 <- liftIO $ uniformRM (0,10.00) g t0 <- liftIO $ uniformRM (wStormMin,wStormMax) g
debug $ red "FIRE IN DA HOLE!" <+> pretty t0 debug $ red "FIRE IN DA HOLE!" <+> pretty t0
atomically $ writeTQueue storms do atomically $ writeTQueue storms do
atomically $ writeTVar idleTime 0 atomically $ writeTVar idleTime 0
@ -522,7 +582,7 @@ testEnduranceInner path = flip runContT pure $ callCC \exit -> do
Right _ -> none Right _ -> none
where where
dict g sto = makeDict @c @m do dict g sto@NCQStorage{..} = makeDict @c @m do
entry $ bindMatch "exit" $ const do entry $ bindMatch "exit" $ const do
pure $ mkSym "done" pure $ mkSym "done"
@ -542,6 +602,13 @@ testEnduranceInner path = flip runContT pure $ callCC \exit -> do
e -> throwIO (BadFormException @c (mkList e)) e -> throwIO (BadFormException @c (mkList e))
entry $ bindMatch "has-seed-block" $ nil_ \case
[ HashLike h ] -> do
s <- hasBlock (AnyStorage sto) (coerce h)
liftIO $ print $ "has-seed-block-result" <+> pretty h <+> pretty s
e -> throwIO (BadFormException @c (mkList e))
entry $ bindMatch "get-block" $ nil_ \case entry $ bindMatch "get-block" $ nil_ \case
[ HashLike h ] -> do [ HashLike h ] -> do
s <- getBlock (AnyStorage sto) (coerce h) s <- getBlock (AnyStorage sto) (coerce h)
@ -578,4 +645,12 @@ testEnduranceInner path = flip runContT pure $ callCC \exit -> do
e -> throwIO (BadFormException @c (mkList e)) e -> throwIO (BadFormException @c (mkList e))
entry $ bindMatch "merge" $ nil_ $ const do
ncqSetFlag ncqMergeReq
liftIO $ print $ "merge"
entry $ bindMatch "sweep" $ nil_ $ const do
ncqSetFlag ncqSweepReq
liftIO $ print $ "sweep"