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 12:39:34 +03:00
parent 77a0052ffb
commit 407bfadbff
2 changed files with 40 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -707,7 +707,9 @@ ncqCheckDeleted h (Just loc) act = case loc of
| l == 0 && h /= ncqEmptyDataHash -> pure Nothing | l == 0 && h /= ncqEmptyDataHash -> pure Nothing
| otherwise -> act loc | otherwise -> act loc
_ -> act loc InCurrent (_, l)
| l == 0 && h /= ncqEmptyDataHash -> pure Nothing
| otherwise -> act loc
ncqStorageHasBlock :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe Integer) ncqStorageHasBlock :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe Integer)
ncqStorageHasBlock ncq h = do ncqStorageHasBlock ncq h = do
@ -750,6 +752,7 @@ ncqStorageGet ncq@NCQStorage{..} h = do
pure $ Just lbs pure $ Just lbs
InCurrent (o,l) -> do InCurrent (o,l) -> do
debug $ "IN FUCKIN CURRENT" <+> pretty l
r <- atomically do r <- atomically do
a <- newEmptyTMVar a <- newEmptyTMVar
fd <- readTVar ncqCurrentHandleR fd <- readTVar ncqCurrentHandleR
@ -794,7 +797,10 @@ ncqStorageDel ncq@NCQStorage{..} h = flip runContT pure $ callCC \exit -> do
ncqLocate ncq h >>= atomically . \case ncqLocate ncq h >>= atomically . \case
Just (InFossil _ _) -> writeTombstone (WQItem False Nothing) Just (InFossil _ _) -> writeTombstone (WQItem False Nothing)
Just (InCurrent _) -> writeTombstone (WQItem False Nothing) Just (InCurrent _) -> do
modifyTVar ncqWaitIndex (HPSQ.delete h)
writeTombstone (WQItem False Nothing)
Just (InWriteQueue _) -> writeTombstone (WQItem True Nothing) Just (InWriteQueue _) -> writeTombstone (WQItem True Nothing)
_ -> pure () _ -> pure ()
@ -1002,6 +1008,9 @@ ncqStorageInit_ check path = do
pure ncq pure ncq
ncqStorageFlush :: MonadUnliftIO m => NCQStorage -> m ()
ncqStorageFlush = ncqStorageSync
ncqIndexRightNow :: MonadUnliftIO m => NCQStorage -> m () ncqIndexRightNow :: MonadUnliftIO m => NCQStorage -> m ()
ncqIndexRightNow NCQStorage{..} = atomically $ modifyTVar ncqIndexNow succ ncqIndexRightNow NCQStorage{..} = atomically $ modifyTVar ncqIndexNow succ

29
hbs2-tests/test/TCQ.hs
View File

@ -189,6 +189,13 @@ main = do
e -> throwIO $ BadFormException @C (mkList e) e -> throwIO $ BadFormException @C (mkList e)
entry $ bindMatch "ncq:cached:entries" $ \case
[ isOpaqueOf @TCQ -> Just tcq ] -> lift do
NCQStorage{..} <- getNCQ tcq
readTVarIO ncqCachedEntries <&> mkInt
e -> throwIO $ BadFormException @C (mkList e)
entry $ bindMatch "ncq:locate" $ \case entry $ bindMatch "ncq:locate" $ \case
[ isOpaqueOf @TCQ -> Just tcq, HashLike hash ] -> lift do [ isOpaqueOf @TCQ -> Just tcq, HashLike hash ] -> lift do
ncq <- getNCQ tcq ncq <- getNCQ tcq
@ -200,6 +207,14 @@ main = do
e -> throwIO $ BadFormException @C (mkList e) e -> throwIO $ BadFormException @C (mkList e)
entry $ bindMatch "ncq:has" $ \case
[ isOpaqueOf @TCQ -> Just tcq, HashLike hash ] -> lift do
ncq <- getNCQ tcq
ncqStorageHasBlock ncq hash <&> maybe nil mkInt
e -> throwIO $ BadFormException @C (mkList e)
entry $ bindMatch "ncq:get" $ \case entry $ bindMatch "ncq:get" $ \case
[ isOpaqueOf @TCQ -> Just tcq, HashLike hash ] -> lift do [ isOpaqueOf @TCQ -> Just tcq, HashLike hash ] -> lift do
ncq <- getNCQ tcq ncq <- getNCQ tcq
@ -207,6 +222,20 @@ main = do
e -> throwIO $ BadFormException @C (mkList e) e -> throwIO $ BadFormException @C (mkList e)
entry $ bindMatch "ncq:del" $ nil_ \case
[ isOpaqueOf @TCQ -> Just tcq, HashLike hash ] -> lift do
ncq <- getNCQ tcq
ncqStorageDel ncq hash
e -> throwIO $ BadFormException @C (mkList e)
entry $ bindMatch "ncq:flush" $ nil_ \case
[ isOpaqueOf @TCQ -> Just tcq ] -> lift do
ncq <- getNCQ tcq
ncqStorageFlush ncq
e -> throwIO $ BadFormException @C (mkList e)
entry $ bindMatch "ncq:put" $ \syn -> do entry $ bindMatch "ncq:put" $ \syn -> do
(tcq,bs) <- case syn of (tcq,bs) <- case syn of
[ isOpaqueOf @TCQ -> Just tcq, isOpaqueOf @ByteString -> Just bs ] -> lift do [ isOpaqueOf @TCQ -> Just tcq, isOpaqueOf @ByteString -> Just bs ] -> lift do