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

NCQStorage3 -> NCQStorage

This commit is contained in:
voidlizard 2025-08-01 14:39:29 +03:00
parent d71a66111a
commit 29ed5a7ecc
12 changed files with 106 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,10 +1,10 @@
module HBS2.Storage.NCQ3 module HBS2.Storage.NCQ3
( module Exported ( module Exported
, ncqWithStorage3 , ncqWithStorage
, ncqStorageSync3 , ncqStorageSync
, ncqStorageStop3 , ncqStorageStop
, ncqStorageOpen3 , ncqStorageOpen
, ncqStorageRun3 , ncqStorageRun
, ncqPutBS , ncqPutBS
, ncqGetEntryBS , ncqGetEntryBS
, IsTomb(..) , IsTomb(..)

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

@ -41,8 +41,8 @@ import Control.Concurrent.STM qualified as STM
import Control.Concurrent.STM.TSem import Control.Concurrent.STM.TSem
import System.FileLock as FL import System.FileLock as FL
ncqStorageOpen3 :: MonadIO m => FilePath -> (NCQStorage3 -> NCQStorage3) -> m NCQStorage3 ncqStorageOpen :: MonadIO m => FilePath -> (NCQStorage -> NCQStorage) -> m NCQStorage
ncqStorageOpen3 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
@ -83,7 +83,7 @@ ncqStorageOpen3 fp upd = do
ncqServiceSem <- atomically $ newTSem 1 ncqServiceSem <- atomically $ newTSem 1
ncqFileLock <- newTVarIO Nothing ncqFileLock <- newTVarIO Nothing
let ncq = NCQStorage3{..} & upd let ncq = NCQStorage{..} & upd
mkdir (ncqGetWorkDir ncq) mkdir (ncqGetWorkDir ncq)
@ -95,24 +95,24 @@ ncqStorageOpen3 fp upd = do
pure ncq pure ncq
ncqWithStorage3 :: MonadUnliftIO m => FilePath -> (NCQStorage3 -> m a) -> m a ncqWithStorage :: MonadUnliftIO m => FilePath -> (NCQStorage -> m a) -> m a
ncqWithStorage3 fp action = flip runContT pure do ncqWithStorage fp action = flip runContT pure do
sto <- lift (ncqStorageOpen3 fp id) sto <- lift (ncqStorageOpen fp id)
w <- ContT $ withAsync (ncqStorageRun3 sto) -- TODO: implement run w <- ContT $ withAsync (ncqStorageRun sto)
link w link w
r <- lift (action sto) r <- lift (action sto)
lift (ncqStorageStop3 sto) lift (ncqStorageStop sto)
wait w wait w
pure r pure r
-- FIXME: maybe-on-storage-closed -- FIXME: maybe-on-storage-closed
ncqPutBS :: MonadUnliftIO m ncqPutBS :: MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> Maybe NCQSectionType -> Maybe NCQSectionType
-> Maybe HashRef -> Maybe HashRef
-> ByteString -> ByteString
-> m HashRef -> m HashRef
ncqPutBS ncq@NCQStorage3{..} mtp mhref bs' = ncqOperation ncq (pure $ fromMaybe hash0 mhref) do ncqPutBS ncq@NCQStorage{..} mtp mhref bs' = ncqOperation ncq (pure $ fromMaybe hash0 mhref) do
waiter <- newEmptyTMVarIO waiter <- newEmptyTMVarIO
let work = do let work = do
@ -143,10 +143,10 @@ ncqPutBS ncq@NCQStorage3{..} mtp mhref bs' = ncqOperation ncq (pure $ fromMaybe
ncqTryLoadState :: forall m. MonadUnliftIO m ncqTryLoadState :: forall m. MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> m () -> m ()
ncqTryLoadState me@NCQStorage3{..} = do ncqTryLoadState me@NCQStorage{..} = do
stateFiles <- ncqListFilesBy me ( List.isPrefixOf "s-" ) stateFiles <- ncqListFilesBy me ( List.isPrefixOf "s-" )
@ -238,7 +238,7 @@ instance IsTomb Location where
(_, Right (T, _)) -> True (_, Right (T, _)) -> True
_ -> False _ -> False
ncqGetEntryBS :: MonadUnliftIO m => NCQStorage3 -> Location -> m (Maybe ByteString) ncqGetEntryBS :: MonadUnliftIO m => NCQStorage -> Location -> m (Maybe ByteString)
ncqGetEntryBS me = \case ncqGetEntryBS me = \case
InMemory bs -> pure $ Just bs InMemory bs -> pure $ Just bs
InFossil fk off size -> do InFossil fk off size -> do
@ -253,7 +253,7 @@ ncqEntrySize = \case
InMemory bs -> fromIntegral (BS.length bs) InMemory bs -> fromIntegral (BS.length bs)
ncqDelEntry :: MonadUnliftIO m ncqDelEntry :: MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> HashRef -> HashRef
-> m () -> m ()
ncqDelEntry me href = do ncqDelEntry me href = do

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

@ -8,28 +8,28 @@ import System.Posix.Files qualified as PFS
import Data.List qualified as List import Data.List qualified as List
ncqGetFileName :: forall f . ToFileName f => NCQStorage3 -> f -> FilePath ncqGetFileName :: forall f . ToFileName f => NCQStorage -> f -> FilePath
ncqGetFileName ncq fp = ncqGetWorkDir ncq </> takeFileName (toFileName fp) ncqGetFileName ncq fp = ncqGetWorkDir ncq </> takeFileName (toFileName fp)
ncqGetWorkDir :: NCQStorage3 -> FilePath ncqGetWorkDir :: NCQStorage -> FilePath
ncqGetWorkDir NCQStorage3{..} = ncqRoot </> show ncqGen ncqGetWorkDir NCQStorage{..} = ncqRoot </> show ncqGen
ncqGetLockFileName :: NCQStorage3 -> FilePath ncqGetLockFileName :: NCQStorage -> FilePath
ncqGetLockFileName ncq = ncqGetFileName ncq ".lock" ncqGetLockFileName ncq = ncqGetFileName ncq ".lock"
ncqGetNewFileKey :: forall f m . (ToFileName f, MonadIO m) ncqGetNewFileKey :: forall f m . (ToFileName f, MonadIO m)
=> NCQStorage3 => NCQStorage
-> ( FileKey -> f ) -> ( FileKey -> f )
-> m FileKey -> m FileKey
ncqGetNewFileKey me@NCQStorage3{..} fnameOf = fix \next -> do ncqGetNewFileKey me@NCQStorage{..} fnameOf = fix \next -> do
n <- atomically $ stateTVar ncqState (\e -> (e.ncqStateFileSeq , succSeq e)) n <- atomically $ stateTVar ncqState (\e -> (e.ncqStateFileSeq , succSeq e))
here <- doesFileExist (ncqGetFileName me (fnameOf n)) here <- doesFileExist (ncqGetFileName me (fnameOf n))
if here then next else pure n if here then next else pure n
where where
succSeq e = e { ncqStateFileSeq = succ e.ncqStateFileSeq } succSeq e = e { ncqStateFileSeq = succ e.ncqStateFileSeq }
ncqListFilesBy :: forall m . MonadUnliftIO m => NCQStorage3 -> (FilePath -> Bool) -> m [(POSIXTime, FileKey)] ncqListFilesBy :: forall m . MonadUnliftIO m => NCQStorage -> (FilePath -> Bool) -> m [(POSIXTime, FileKey)]
ncqListFilesBy me@NCQStorage3{..} filt = do ncqListFilesBy me@NCQStorage{..} filt = do
w <- dirFiles (ncqGetWorkDir me) w <- dirFiles (ncqGetWorkDir me)
<&> filter (filt . takeFileName) <&> filter (filt . takeFileName)
@ -40,7 +40,7 @@ ncqListFilesBy me@NCQStorage3{..} filt = do
pure $ List.sortOn ( Down . fst ) r pure $ List.sortOn ( Down . fst ) r
ncqFindMinPairOf :: forall fa m . (ToFileName fa, MonadUnliftIO m) ncqFindMinPairOf :: forall fa m . (ToFileName fa, MonadUnliftIO m)
=> NCQStorage3 => NCQStorage
-> [fa] -> [fa]
-> m (Maybe (NCQFileSize, fa, fa)) -> m (Maybe (NCQFileSize, fa, fa))
ncqFindMinPairOf sto lst = do ncqFindMinPairOf sto lst = do

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

@ -52,10 +52,10 @@ ncqEntryUnwrapValue v = case ncqIsMeta v of
ncqFossilMergeStep :: forall m . MonadUnliftIO m ncqFossilMergeStep :: forall m . MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> m Bool -> m Bool
ncqFossilMergeStep me@NCQStorage3{..} = withSem ncqServiceSem $ flip runContT pure $ callCC \exit -> do ncqFossilMergeStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pure $ callCC \exit -> do
debug "ncqFossilMergeStep" debug "ncqFossilMergeStep"
@ -188,7 +188,7 @@ ncqFileTryRecover fp = do
writeFiltered :: forall m . MonadIO m writeFiltered :: forall m . MonadIO m
=> NCQStorage3 => NCQStorage
-> FilePath -> FilePath
-> Fd -> Fd
-> ( Integer -> Integer -> HashRef -> ByteString -> m Bool) -> ( Integer -> Integer -> HashRef -> ByteString -> m Bool)

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

@ -72,8 +72,8 @@ ncqLookupIndex hx (mmaped, nway) = do
ncqLocate_ :: MonadUnliftIO m => Bool -> NCQStorage3 -> HashRef -> m (Maybe Location) ncqLocate_ :: MonadUnliftIO m => Bool -> NCQStorage -> HashRef -> m (Maybe Location)
ncqLocate_ f me@NCQStorage3{..} href = ncqOperation me (pure Nothing) do ncqLocate_ f me@NCQStorage{..} href = ncqOperation me (pure Nothing) do
answ <- newEmptyTMVarIO answ <- newEmptyTMVarIO
atomically do atomically do
@ -82,11 +82,11 @@ ncqLocate_ f me@NCQStorage3{..} href = ncqOperation me (pure Nothing) do
atomically $ takeTMVar answ atomically $ takeTMVar answ
ncqLocate :: MonadUnliftIO m => NCQStorage3 -> HashRef -> m (Maybe Location) ncqLocate :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe Location)
ncqLocate me href = ncqOperation me (pure Nothing) do ncqLocate me href = ncqOperation me (pure Nothing) do
ncqLocate_ True me href ncqLocate_ True me href
ncqIndexFile :: MonadUnliftIO m => NCQStorage3 -> DataFile FileKey -> m (Maybe FilePath) ncqIndexFile :: MonadUnliftIO m => NCQStorage -> DataFile FileKey -> m (Maybe FilePath)
ncqIndexFile n fk = runMaybeT do ncqIndexFile n fk = runMaybeT do
let fp = toFileName fk & ncqGetFileName n let fp = toFileName fk & ncqGetFileName n
@ -139,7 +139,7 @@ ncqIndexFile n fk = runMaybeT do
ncqIndexCompactFull :: MonadUnliftIO m ncqIndexCompactFull :: MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> m () -> m ()
ncqIndexCompactFull ncq = fix \again -> ncqIndexCompactFull ncq = fix \again ->
@ -148,9 +148,9 @@ ncqIndexCompactFull ncq = fix \again ->
False -> none False -> none
ncqIndexCompactStep :: MonadUnliftIO m ncqIndexCompactStep :: MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> m Bool -> m Bool
ncqIndexCompactStep me@NCQStorage3{..} = withSem ncqServiceSem $ flip runContT pure $ callCC \exit -> do ncqIndexCompactStep me@NCQStorage{..} = withSem ncqServiceSem $ flip runContT pure $ callCC \exit -> do
debug "ncqIndexCompactStep" debug "ncqIndexCompactStep"
@ -203,7 +203,7 @@ ncqIndexCompactStep me@NCQStorage3{..} = withSem ncqServiceSem $ flip runContT p
pure True pure True
ncqStorageScanDataFile :: MonadIO m ncqStorageScanDataFile :: MonadIO m
=> NCQStorage3 => NCQStorage
-> FilePath -> FilePath
-> ( Integer -> Integer -> HashRef -> ByteString -> m () ) -> ( Integer -> Integer -> HashRef -> ByteString -> m () )
-> m () -> m ()

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

@ -33,8 +33,8 @@ cacheLookupOrInsert maxSize load cacheTVar fk = do
writeTVar cacheTVar new writeTVar cacheTVar new
pure val pure val
ncqGetCachedData :: MonadUnliftIO m => NCQStorage3 -> FileKey -> m CachedData ncqGetCachedData :: MonadUnliftIO m => NCQStorage -> FileKey -> m CachedData
ncqGetCachedData ncq@NCQStorage3{..} = ncqGetCachedData ncq@NCQStorage{..} =
cacheLookupOrInsert ncqMaxCachedData load ncqMMapCachedData cacheLookupOrInsert ncqMaxCachedData load ncqMMapCachedData
where where
load fk = do load fk = do
@ -42,8 +42,8 @@ ncqGetCachedData ncq@NCQStorage3{..} =
bs <- liftIO (mmapFileByteString path Nothing) bs <- liftIO (mmapFileByteString path Nothing)
pure (CachedData bs) pure (CachedData bs)
ncqGetCachedIndex :: MonadUnliftIO m => NCQStorage3 -> FileKey -> m CachedIndex ncqGetCachedIndex :: MonadUnliftIO m => NCQStorage -> FileKey -> m CachedIndex
ncqGetCachedIndex ncq@NCQStorage3{..} = ncqGetCachedIndex ncq@NCQStorage{..} =
cacheLookupOrInsert ncqMaxCachedIndex load ncqMMapCachedIdx cacheLookupOrInsert ncqMaxCachedIndex load ncqMMapCachedIdx
where where
load fk = do load fk = do
@ -52,17 +52,17 @@ ncqGetCachedIndex ncq@NCQStorage3{..} =
Nothing -> throwIO $ NCQStorageCantMapFile path Nothing -> throwIO $ NCQStorageCantMapFile path
Just (bs, nway) -> pure (CachedIndex bs nway) Just (bs, nway) -> pure (CachedIndex bs nway)
ncqDelCachedIndexSTM :: NCQStorage3 ncqDelCachedIndexSTM :: NCQStorage
-> FileKey -> FileKey
-> STM () -> STM ()
ncqDelCachedIndexSTM NCQStorage3{..} fk = ncqDelCachedIndexSTM NCQStorage{..} fk =
modifyTVar ncqMMapCachedIdx$ HPSQ.delete fk modifyTVar ncqMMapCachedIdx$ HPSQ.delete fk
ncqDelCachedDataSTM :: NCQStorage3 ncqDelCachedDataSTM :: NCQStorage
-> FileKey -> FileKey
-> STM () -> STM ()
ncqDelCachedDataSTM NCQStorage3{..} fk = ncqDelCachedDataSTM NCQStorage{..} fk =
modifyTVar ncqMMapCachedData $ HPSQ.delete fk modifyTVar ncqMMapCachedData $ HPSQ.delete fk

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

@ -9,20 +9,20 @@ import Data.HashMap.Strict qualified as HM
import Data.Vector qualified as V import Data.Vector qualified as V
import Control.Concurrent.STM qualified as STM import Control.Concurrent.STM qualified as STM
ncqShardIdx :: NCQStorage3 -> HashRef -> Int ncqShardIdx :: NCQStorage -> HashRef -> Int
ncqShardIdx NCQStorage3{..} h = ncqShardIdx NCQStorage{..} h =
fromIntegral (BS.head (coerce h)) `mod` V.length ncqMemTable fromIntegral (BS.head (coerce h)) `mod` V.length ncqMemTable
{-# INLINE ncqShardIdx #-} {-# INLINE ncqShardIdx #-}
ncqGetShard :: NCQStorage3 -> HashRef -> Shard ncqGetShard :: NCQStorage -> HashRef -> Shard
ncqGetShard ncq@NCQStorage3{..} h = ncqMemTable ! ncqShardIdx ncq h ncqGetShard ncq@NCQStorage{..} h = ncqMemTable ! ncqShardIdx ncq h
{-# INLINE ncqGetShard #-} {-# INLINE ncqGetShard #-}
ncqLookupEntrySTM :: NCQStorage3 -> HashRef -> STM (Maybe NCQEntry) ncqLookupEntrySTM :: NCQStorage -> HashRef -> STM (Maybe NCQEntry)
ncqLookupEntrySTM ncq h = readTVar (ncqGetShard ncq h) <&> HM.lookup h ncqLookupEntrySTM ncq h = readTVar (ncqGetShard ncq h) <&> HM.lookup h
ncqAlterEntrySTM :: NCQStorage3 ncqAlterEntrySTM :: NCQStorage
-> HashRef -> HashRef
-> (Maybe NCQEntry -> Maybe NCQEntry) -> (Maybe NCQEntry -> Maybe NCQEntry)
-> STM () -> STM ()
@ -30,11 +30,11 @@ ncqAlterEntrySTM ncq h alterFn = do
let shard = ncqGetShard ncq h let shard = ncqGetShard ncq h
modifyTVar shard (HM.alter alterFn h) modifyTVar shard (HM.alter alterFn h)
ncqStorageSync3 :: forall m . MonadUnliftIO m => NCQStorage3 -> m () ncqStorageSync :: forall m . MonadUnliftIO m => NCQStorage -> m ()
ncqStorageSync3 NCQStorage3{..} = atomically $ writeTVar ncqSyncReq True ncqStorageSync NCQStorage{..} = atomically $ writeTVar ncqSyncReq True
ncqOperation :: MonadIO m => NCQStorage3 -> m a -> m a -> m a ncqOperation :: MonadIO m => NCQStorage -> m a -> m a -> m a
ncqOperation NCQStorage3{..} m0 m = do ncqOperation NCQStorage{..} m0 m = do
what <- atomically do what <- atomically do
alive <- readTVar ncqAlive alive <- readTVar ncqAlive
stop <- readTVar ncqStopReq stop <- readTVar ncqStopReq

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

@ -40,14 +40,14 @@ import System.IO.MMap as MMap
import Control.Concurrent.STM qualified as STM import Control.Concurrent.STM qualified as STM
import System.FileLock as FL import System.FileLock as FL
ncqStorageStop3 :: forall m . MonadUnliftIO m => NCQStorage3 -> m () ncqStorageStop :: forall m . MonadUnliftIO m => NCQStorage -> m ()
ncqStorageStop3 NCQStorage3{..} = do ncqStorageStop NCQStorage{..} = do
atomically $ writeTVar ncqStopReq True atomically $ writeTVar ncqStopReq True
ncqStorageRun3 :: forall m . MonadUnliftIO m ncqStorageRun :: forall m . MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> m () -> m ()
ncqStorageRun3 ncq@NCQStorage3{..} = flip runContT pure do ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
ContT $ bracket setAlive (const unsetAlive) ContT $ bracket setAlive (const unsetAlive)
ContT $ bracket none $ const $ liftIO do ContT $ bracket none $ const $ liftIO do

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

@ -26,16 +26,16 @@ import Lens.Micro.Platform
import Streaming.Prelude qualified as S import Streaming.Prelude qualified as S
newtype StateOP a = newtype StateOP a =
StateOP { fromStateOp :: ReaderT NCQStorage3 STM a } StateOP { fromStateOp :: ReaderT NCQStorage STM a }
deriving newtype (Functor,Applicative,Monad,MonadReader NCQStorage3) deriving newtype (Functor,Applicative,Monad,MonadReader NCQStorage)
{- HLINT ignore "Eta reduce"-} {- HLINT ignore "Eta reduce"-}
ncqStateUpdate :: MonadIO m ncqStateUpdate :: MonadIO m
=> NCQStorage3 => NCQStorage
-> StateOP a -> StateOP a
-> m () -> m ()
ncqStateUpdate ncq@NCQStorage3{..} action = do ncqStateUpdate ncq@NCQStorage{..} action = do
s0 <- readTVarIO ncqState s0 <- readTVarIO ncqState
s1 <- atomically do s1 <- atomically do
@ -52,26 +52,26 @@ ncqStateUpdate ncq@NCQStorage3{..} action = do
ncqStateAddDataFile :: FileKey -> StateOP () ncqStateAddDataFile :: FileKey -> StateOP ()
ncqStateAddDataFile fk = do ncqStateAddDataFile fk = do
NCQStorage3{..} <- ask NCQStorage{..} <- ask
StateOP $ lift do StateOP $ lift do
modifyTVar ncqState (over #ncqStateFiles (HS.insert fk)) modifyTVar ncqState (over #ncqStateFiles (HS.insert fk))
ncqStateDelDataFile :: FileKey -> StateOP () ncqStateDelDataFile :: FileKey -> StateOP ()
ncqStateDelDataFile fk = do ncqStateDelDataFile fk = do
sto@NCQStorage3{..} <- ask sto@NCQStorage{..} <- ask
StateOP $ lift do StateOP $ lift do
modifyTVar ncqState (over #ncqStateFiles (HS.delete fk)) modifyTVar ncqState (over #ncqStateFiles (HS.delete fk))
ncqDelCachedDataSTM sto fk ncqDelCachedDataSTM sto fk
ncqStateAddFact :: Fact -> StateOP () ncqStateAddFact :: Fact -> StateOP ()
ncqStateAddFact fact = do ncqStateAddFact fact = do
NCQStorage3{..} <- ask NCQStorage{..} <- ask
StateOP $ lift do StateOP $ lift do
modifyTVar ncqState (over #ncqStateFacts (Set.insert fact)) modifyTVar ncqState (over #ncqStateFacts (Set.insert fact))
ncqStateDelFact :: Fact -> StateOP () ncqStateDelFact :: Fact -> StateOP ()
ncqStateDelFact fact = do ncqStateDelFact fact = do
NCQStorage3{..} <- ask NCQStorage{..} <- ask
StateOP $ lift do StateOP $ lift do
modifyTVar ncqState (over #ncqStateFacts (Set.delete fact)) modifyTVar ncqState (over #ncqStateFacts (Set.delete fact))
@ -80,12 +80,12 @@ ncqStateAddIndexFile :: POSIXTime
-> StateOP () -> StateOP ()
ncqStateAddIndexFile ts fk = do ncqStateAddIndexFile ts fk = do
NCQStorage3{..} <- ask NCQStorage{..} <- ask
StateOP $ lift $ modifyTVar' ncqState (sortIndexes . over #ncqStateIndex ((Down ts, fk) :)) StateOP $ lift $ modifyTVar' ncqState (sortIndexes . over #ncqStateIndex ((Down ts, fk) :))
ncqStateDelIndexFile :: FileKey -> StateOP () ncqStateDelIndexFile :: FileKey -> StateOP ()
ncqStateDelIndexFile fk = do ncqStateDelIndexFile fk = do
sto@NCQStorage3{..} <- ask sto@NCQStorage{..} <- ask
StateOP $ lift do StateOP $ lift do
modifyTVar' ncqState (over #ncqStateIndex $ filter f) modifyTVar' ncqState (over #ncqStateIndex $ filter f)
ncqDelCachedIndexSTM sto fk ncqDelCachedIndexSTM sto fk
@ -97,10 +97,10 @@ sortIndexes = over #ncqStateIndex (List.sortOn fst)
ncqStateCapture :: forall m . MonadUnliftIO m ncqStateCapture :: forall m . MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> m FileKey -> m FileKey
ncqStateCapture me@NCQStorage3{..} = do ncqStateCapture me@NCQStorage{..} = do
atomically do atomically do
key <- readTVar ncqStateKey key <- readTVar ncqStateKey
stateUse <- readTVar ncqStateUse stateUse <- readTVar ncqStateUse
@ -113,10 +113,10 @@ ncqStateCapture me@NCQStorage3{..} = do
pure key pure key
ncqStateDismiss :: forall m . MonadUnliftIO m ncqStateDismiss :: forall m . MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> FileKey -> FileKey
-> m () -> m ()
ncqStateDismiss me@NCQStorage3{..} key = atomically do ncqStateDismiss me@NCQStorage{..} key = atomically do
useMap <- readTVar ncqStateUse useMap <- readTVar ncqStateUse
case HM.lookup key useMap of case HM.lookup key useMap of
Nothing -> pure () Nothing -> pure ()
@ -127,13 +127,13 @@ ncqStateDismiss me@NCQStorage3{..} key = atomically do
modifyTVar ncqStateUse (HM.delete key) modifyTVar ncqStateUse (HM.delete key)
ncqWithState :: forall a m . MonadUnliftIO m ncqWithState :: forall a m . MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> ( FileKey -> m a ) -> ( FileKey -> m a )
-> m a -> m a
ncqWithState sto = bracket (ncqStateCapture sto) (ncqStateDismiss sto) ncqWithState sto = bracket (ncqStateCapture sto) (ncqStateDismiss sto)
readStateMay :: forall m . MonadUnliftIO m readStateMay :: forall m . MonadUnliftIO m
=> NCQStorage3 => NCQStorage
-> FileKey -> FileKey
-> m (Maybe NCQState) -> m (Maybe NCQState)
readStateMay sto key = fmap sortIndexes <$> do readStateMay sto key = fmap sortIndexes <$> do

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

@ -15,19 +15,19 @@ import System.Posix.Files qualified as PFS
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.HashMap.Strict qualified as HM import Data.HashMap.Strict qualified as HM
ncqLiveKeysSTM :: NCQStorage3 -> STM (HashSet FileKey) ncqLiveKeysSTM :: NCQStorage -> STM (HashSet FileKey)
ncqLiveKeysSTM NCQStorage3{..} = do ncqLiveKeysSTM NCQStorage{..} = do
s0 <- readTVar ncqState s0 <- readTVar ncqState
merged <- readTVar ncqStateUse <&> (s0<>) . foldMap fst . HM.elems merged <- readTVar ncqStateUse <&> (s0<>) . foldMap fst . HM.elems
pure $ HS.fromList $ universeBi @_ @FileKey merged pure $ HS.fromList $ universeBi @_ @FileKey merged
ncqLiveKeys :: forall m . MonadIO m => NCQStorage3 -> m (HashSet FileKey) ncqLiveKeys :: forall m . MonadIO m => NCQStorage -> m (HashSet FileKey)
ncqLiveKeys ncq = atomically $ ncqLiveKeysSTM ncq ncqLiveKeys ncq = atomically $ ncqLiveKeysSTM ncq
ncqSweepFiles :: forall m . MonadUnliftIO m => NCQStorage3 -> m () ncqSweepFiles :: forall m . MonadUnliftIO m => NCQStorage -> m ()
ncqSweepFiles me@NCQStorage3{..} = withSem ncqServiceSem do ncqSweepFiles me@NCQStorage{..} = withSem ncqServiceSem do
debug "ncqSweepFiles" debug "ncqSweepFiles"
@ -50,8 +50,8 @@ ncqSweepFiles me@NCQStorage3{..} = withSem ncqServiceSem do
rm fn rm fn
ncqSweepObsoleteStates :: forall m . MonadUnliftIO m => NCQStorage3 -> m () ncqSweepObsoleteStates :: forall m . MonadUnliftIO m => NCQStorage -> m ()
ncqSweepObsoleteStates me@NCQStorage3{..} = withSem ncqServiceSem do ncqSweepObsoleteStates me@NCQStorage{..} = withSem ncqServiceSem do
debug $ "ncqSweepObsoleteStates" debug $ "ncqSweepObsoleteStates"
k <- readTVarIO ncqStateKey k <- readTVarIO ncqStateKey

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

@ -71,8 +71,8 @@ data NCQState =
} }
deriving stock (Eq,Generic,Data) deriving stock (Eq,Generic,Data)
data NCQStorage3 = data NCQStorage =
NCQStorage3 NCQStorage
{ ncqRoot :: FilePath { ncqRoot :: FilePath
, ncqGen :: Int , ncqGen :: Int
, ncqSalt :: HashRef , ncqSalt :: HashRef

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

@ -66,7 +66,7 @@ ncq3Tests = do
let num = headDef 1000 [ fromIntegral n | LitIntVal n <- args ] let num = headDef 1000 [ fromIntegral n | LitIntVal n <- args ]
g <- liftIO MWC.createSystemRandom g <- liftIO MWC.createSystemRandom
runTest $ \TestEnv{..} -> do runTest $ \TestEnv{..} -> do
ncqWithStorage3 testEnvDir $ \sto -> do ncqWithStorage testEnvDir $ \sto -> do
notice "start/stop ncq3 storage / write 1000 blocks" notice "start/stop ncq3 storage / write 1000 blocks"
replicateM_ num do replicateM_ num do
n <- liftIO $ uniformRM (1024, 256*1024) g n <- liftIO $ uniformRM (1024, 256*1024) g
@ -79,7 +79,7 @@ ncq3Tests = do
g <- liftIO MWC.createSystemRandom g <- liftIO MWC.createSystemRandom
runTest $ \TestEnv{..} -> do runTest $ \TestEnv{..} -> do
pending <- ncqWithStorage3 testEnvDir $ \sto -> do pending <- ncqWithStorage testEnvDir $ \sto -> do
notice $ "write" <+> pretty num <+> "blocks" notice $ "write" <+> pretty num <+> "blocks"
replicateM_ num do replicateM_ num do
n <- liftIO $ uniformRM (1024, 256*1024) g n <- liftIO $ uniformRM (1024, 256*1024) g
@ -98,7 +98,7 @@ ncq3Tests = do
liftIO $ BS.appendFile dataFile bss liftIO $ BS.appendFile dataFile bss
notice $ "reopen" notice $ "reopen"
ncqWithStorage3 testEnvDir $ \sto -> do ncqWithStorage testEnvDir $ \sto -> do
pause @'Seconds 2 pause @'Seconds 2
notice $ "done" notice $ "done"
@ -114,7 +114,7 @@ ncq3Tests = do
runTest $ \TestEnv{..} -> do runTest $ \TestEnv{..} -> do
hq <- newTQueueIO hq <- newTQueueIO
ncqWithStorage3 testEnvDir $ \sto -> do ncqWithStorage testEnvDir $ \sto -> do
notice $ "write/lookup" <+> pretty num notice $ "write/lookup" <+> pretty num
replicateM_ num do replicateM_ num do
n <- liftIO $ uniformRM (1024, 256*1024) g n <- liftIO $ uniformRM (1024, 256*1024) g
@ -126,7 +126,7 @@ ncq3Tests = do
writeTQueue hq h writeTQueue hq h
modifyTVar w1 succ modifyTVar w1 succ
ncqWithStorage3 testEnvDir $ \sto -> do ncqWithStorage testEnvDir $ \sto -> do
notice $ "reopen/lookup" <+> pretty num notice $ "reopen/lookup" <+> pretty num
hh <- atomically $ STM.flushTQueue hq hh <- atomically $ STM.flushTQueue hq
@ -169,7 +169,7 @@ ncq3Tests = do
g <- liftIO MWC.createSystemRandom g <- liftIO MWC.createSystemRandom
runTest $ \TestEnv{..} -> do runTest $ \TestEnv{..} -> do
ncqWithStorage3 testEnvDir $ \sto@NCQStorage3{..} -> do ncqWithStorage testEnvDir $ \sto@NCQStorage{..} -> do
notice $ "write" <+> pretty num notice $ "write" <+> pretty num
hst <- newTVarIO ( mempty :: HashSet HashRef ) hst <- newTVarIO ( mempty :: HashSet HashRef )
replicateM_ num do replicateM_ num do
@ -210,7 +210,7 @@ ncq3Tests = do
g <- liftIO MWC.createSystemRandom g <- liftIO MWC.createSystemRandom
runTest $ \TestEnv{..} -> do runTest $ \TestEnv{..} -> do
ncqWithStorage3 testEnvDir $ \sto@NCQStorage3{..} -> flip runContT pure do ncqWithStorage testEnvDir $ \sto@NCQStorage{..} -> flip runContT pure do
hst <- newTVarIO ( mempty :: HashSet HashRef ) hst <- newTVarIO ( mempty :: HashSet HashRef )
lostt <- newTVarIO 0 lostt <- newTVarIO 0
@ -267,7 +267,7 @@ ncq3Tests = do
g <- liftIO MWC.createSystemRandom g <- liftIO MWC.createSystemRandom
runTest $ \TestEnv{..} -> do runTest $ \TestEnv{..} -> do
ncqWithStorage3 testEnvDir $ \sto@NCQStorage3{..} -> flip runContT pure do ncqWithStorage testEnvDir $ \sto@NCQStorage{..} -> flip runContT pure do
hst <- newTVarIO ( mempty :: HashSet HashRef ) hst <- newTVarIO ( mempty :: HashSet HashRef )
@ -305,12 +305,12 @@ ncq3Tests = do
Nothing -> liftIO $ Temp.createTempDirectory "." "ncq-long-write-test" Nothing -> liftIO $ Temp.createTempDirectory "." "ncq-long-write-test"
ncqWithStorage3 path $ \sto -> do ncqWithStorage path $ \sto -> do
let writtenLog = ncqGetFileName sto "written.log" let writtenLog = ncqGetFileName sto "written.log"
touch writtenLog touch writtenLog
race (pause @'Seconds (realToFrac seconds) >> ncqStorageStop3 sto) $ forever do race (pause @'Seconds (realToFrac seconds) >> ncqStorageStop sto) $ forever do
n <- liftIO $ uniformRM (1, 256*1024) g n <- liftIO $ uniformRM (1, 256*1024) g
s <- liftIO $ genRandomBS g n s <- liftIO $ genRandomBS g n
h <- ncqPutBS sto (Just B) Nothing s h <- ncqPutBS sto (Just B) Nothing s
@ -356,7 +356,7 @@ ncq3Tests = do
pause @'Seconds 2 pause @'Seconds 2
lift $ ncqWithStorage3 path $ \sto@NCQStorage3{..} -> do lift $ ncqWithStorage path $ \sto@NCQStorage{..} -> do
let log = ncqGetFileName sto "written.log" let log = ncqGetFileName sto "written.log"
hashes <- liftIO (readFile log) <&> fmap words . lines hashes <- liftIO (readFile log) <&> fmap words . lines
@ -443,7 +443,7 @@ ncq3Tests = do
thashes <- newTVarIO mempty thashes <- newTVarIO mempty
ncqWithStorage3 dir $ \sto@NCQStorage3{..} -> do ncqWithStorage dir $ \sto -> do
notice $ "write+immediate delete" <+> pretty n <+> "records" notice $ "write+immediate delete" <+> pretty n <+> "records"
@ -474,7 +474,7 @@ ncq3Tests = do
ncqIndexCompactFull sto ncqIndexCompactFull sto
ncqWithStorage3 dir $ \sto -> do ncqWithStorage dir $ \sto -> do
-- notice "check deleted" -- notice "check deleted"
hashes <- readTVarIO thashes hashes <- readTVarIO thashes
@ -498,7 +498,7 @@ ncq3Tests = do
thashes <- newTVarIO mempty thashes <- newTVarIO mempty
ncqWithStorage3 dir $ \sto@NCQStorage3{..} -> do ncqWithStorage dir $ \sto -> do
sizes <- replicateM n $ liftIO $ uniformRM (32*1024, 256*1024) g sizes <- replicateM n $ liftIO $ uniformRM (32*1024, 256*1024) g
@ -521,7 +521,7 @@ ncq3Tests = do
notice $ "should be deleted" <+> pretty (HS.size deleted) <+> "/" <+> pretty tnum <+> "of" <+> pretty n notice $ "should be deleted" <+> pretty (HS.size deleted) <+> "/" <+> pretty tnum <+> "of" <+> pretty n
ncqWithStorage3 dir $ \sto@NCQStorage3{..} -> do ncqWithStorage dir $ \sto -> do
notice "wait for compaction" notice "wait for compaction"
@ -544,14 +544,14 @@ ncq3Tests = do
flip runContT pure do flip runContT pure do
notice $ "run 1st storage" <+> pretty testEnvDir notice $ "run 1st storage" <+> pretty testEnvDir
sto1 <- ContT $ ncqWithStorage3 testEnvDir sto1 <- ContT $ ncqWithStorage testEnvDir
atomically $ writeTVar w 1 atomically $ writeTVar w 1
pause @'Seconds 1 pause @'Seconds 1
notice $ "run 2nd storage" <+> pretty testEnvDir notice $ "run 2nd storage" <+> pretty testEnvDir
sto1 <- ContT $ ncqWithStorage3 testEnvDir sto1 <- ContT $ ncqWithStorage testEnvDir
pause @'Seconds 1 pause @'Seconds 1
@ -627,7 +627,7 @@ testWriteNThreads3 ncqDir tnn n = do
t0 <- getTimeCoarse t0 <- getTimeCoarse
w <- ncqWithStorage3 (ncqDir </> show tnn) $ \sto -> do w <- ncqWithStorage (ncqDir </> show tnn) $ \sto -> do
ss <- liftIO $ replicateM n $ MWC.uniformRM (64*1024, 256*1024) g ss <- liftIO $ replicateM n $ MWC.uniformRM (64*1024, 256*1024) g
pooledForConcurrentlyN_ tnn ss $ \len -> do pooledForConcurrentlyN_ tnn ss $ \len -> do
@ -687,7 +687,7 @@ testNCQ3Lookup1 syn TestEnv{..} = do
r <- m r <- m
if r && i > 0 then loop (i - 1) else pure r if r && i > 0 then loop (i - 1) else pure r
ncqWithStorage3 ncqDir $ \sto -> liftIO do ncqWithStorage ncqDir $ \sto -> liftIO do
pooledForConcurrentlyN_ 8 sizes $ \size -> do pooledForConcurrentlyN_ 8 sizes $ \size -> do
z <- genRandomBS g size z <- genRandomBS g size
h <- ncqPutBS sto (Just B) Nothing z h <- ncqPutBS sto (Just B) Nothing z