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

wip

This commit is contained in:
Dmitry Zuykov 2025-05-13 07:59:12 +03:00
parent bb9df9c25b
commit 7196fcc54c
2 changed files with 23 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs
View File

@ -141,8 +141,8 @@ data Location =
instance Pretty Location where instance Pretty Location where
pretty = \case pretty = \case
InWriteQueue{} -> "write-queue" InWriteQueue{} -> "write-queue"
InCurrent (o,l) -> pretty $ mkForm @C "current" [mkInt o, mkInt l] InCurrent (o,l) -> pretty $ mkForm @C "current" [mkInt o, mkInt l]
InFossil _ (o,l) -> pretty $ mkForm @C "fossil " [mkList [mkInt o, mkInt l]] InFossil _ (o,l) -> pretty $ mkForm @C "fossil " [mkList [mkInt o, mkInt l]]
type IsHCQKey h = ( Eq (Key h) type IsHCQKey h = ( Eq (Key h)
@ -214,17 +214,18 @@ ncqAddCachedSTM now limit tv k v = do
writeTVar tv (HPSQ.insert k now v dst) writeTVar tv (HPSQ.insert k now v dst)
ncqAddTrackedFilesIO :: MonadIO m => NCQStorage -> [FilePath] -> m () ncqAddTrackedFilesIO :: MonadIO m => NCQStorage -> [FilePath] -> m ()
ncqAddTrackedFilesIO ncq fps = do ncqAddTrackedFilesIO ncq fps = do
tsFiles <- catMaybes <$> forM fps \fp -> liftIO $ do tsFiles <- catMaybes <$> forM fps \fp' -> liftIO $ do
catchIOError catchIOError
(do (do
stat <- getFileStatus fp let fp = fromString fp'
let dataFile = ncqGetDataFileName ncq fp
stat <- getFileStatus dataFile
let ts = modificationTimeHiRes stat let ts = modificationTimeHiRes stat
pure $ Just (FileKey (fromString fp), TimeSpec (floor ts) 0)) pure $ Just (fp, TimeSpec (floor ts) 0))
(\e -> do (\e -> do
err $ "ncqAddTrackedFilesIO: failed to stat " <+> pretty fp <+> pretty (displayException e) err $ "ncqAddTrackedFilesIO: failed to stat " <+> viaShow e
pure Nothing) pure Nothing)
atomically $ ncqAddTrackedFilesSTM ncq tsFiles atomically $ ncqAddTrackedFilesSTM ncq tsFiles
@ -239,13 +240,16 @@ ncqAddTrackedFilesSTM NCQStorage{..} keys = do
writeTVar ncqTrackedFiles new writeTVar ncqTrackedFiles new
ncqListTrackedFiles :: MonadIO m => NCQStorage -> m [FilePath]
ncqListTrackedFiles ncq = do
let wd = ncqGetCurrentDir ncq
dirFiles wd
>>= mapM (pure . takeBaseName)
<&> List.filter (List.isPrefixOf "fossil-")
ncqReadTrackedFiles :: MonadIO m => NCQStorage -> m () ncqReadTrackedFiles :: MonadIO m => NCQStorage -> m ()
ncqReadTrackedFiles ncq@NCQStorage{} = do ncqReadTrackedFiles ncq@NCQStorage{} = do
files <- ncqListTrackedFiles ncq
files <- dirFiles (ncqGetCurrentDir ncq)
>>= mapM (pure . takeBaseName)
<&> List.filter (List.isPrefixOf "fossil-")
ncqAddTrackedFilesIO ncq files ncqAddTrackedFilesIO ncq files
ncqWriteError :: MonadIO m => NCQStorage -> Text -> m () ncqWriteError :: MonadIO m => NCQStorage -> Text -> m ()
@ -943,6 +947,7 @@ ncqStorageInit_ check path = do
when (lastSz /= currSz ) do when (lastSz /= currSz ) do
fossilized <- ncqGetNewFossilName ncq0 fossilized <- ncqGetNewFossilName ncq0
debug $ "NEW FOSSIL FILE" <+> pretty fossilized
let fn = takeFileName fossilized let fn = takeFileName fossilized
let msg = fromString $ show $ "wrong-size" <+> pretty lastSz <+> pretty fn let msg = fromString $ show $ "wrong-size" <+> pretty lastSz <+> pretty fn
err $ pretty msg err $ pretty msg
@ -979,5 +984,6 @@ withNCQ setopts p action = flip runContT pure do
link writer link writer
e <- lift (action ncq) e <- lift (action ncq)
lift (ncqStorageStop ncq) lift (ncqStorageStop ncq)
wait writer
pure e pure e

5
hbs2-tests/test/TestCQ.hs
View File

@ -249,6 +249,11 @@ main = do
e -> throwIO $ BadFormException @C (mkList e) e -> throwIO $ BadFormException @C (mkList e)
entry $ bindMatch "test:ncq:raw:list-tracked-files" $ nil_ \case
[StringLike fn] -> lift $ withNCQ id fn $ \ncq -> do
ncqListTrackedFiles ncq >>= mapM_ display_
e -> throwIO $ BadFormException @C (mkList e)
entry $ bindMatch "test:ncq:raw:get:stdout" $ nil_ \case entry $ bindMatch "test:ncq:raw:get:stdout" $ nil_ \case