wip, fixed ncqCheckDeleted

hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs

@@ -137,10 +137,9 @@ data NCQStorage =
 
 
 data Location =
-    InWriteQueue LBS.ByteString
+    InWriteQueue WQItem
   | InCurrent    (Word64, Word64)
   | InFossil     CachedEntry (Word64, Word64)
-  deriving stock (Show)
 
 instance Pretty Location where
   pretty = \case
@@ -595,11 +594,10 @@ ncqStoragePutFaster = ncqStoragePut_ False
 
 ncqLocatedSize :: Location -> Integer
 ncqLocatedSize = \case
-  InWriteQueue lbs   -> fromIntegral $ LBS.length lbs
+  InWriteQueue WQItem{..} -> fromIntegral $ maybe 0 LBS.length wqData
   InCurrent (_,s)         -> fromIntegral s
   InFossil _ (_,s)        -> fromIntegral s
 
-
 evictIfNeededSTM :: NCQStorage -> Maybe Int -> STM ()
 evictIfNeededSTM NCQStorage{..} howMany = do
   cur <- readTVar ncqCachedEntries
@@ -634,7 +632,7 @@ ncqLocate ncq@NCQStorage{..} h = flip runContT pure $ callCC \exit -> do
     inQ <- readTVar ncqWriteQueue
             <&> (fmap snd . HPSQ.lookup h)
             <&> \case
-                Just (WQItem{ wqData = Just bs})  -> Just (InWriteQueue bs)
+                Just wq  -> Just (InWriteQueue wq)
                 _        -> Nothing
 
     inC <- readTVar ncqWaitIndex  <&> (fmap snd . HPSQ.lookup h) <&> fmap InCurrent
@@ -699,9 +697,9 @@ ncqCheckDeleted :: Monad m
 ncqCheckDeleted _ Nothing _ = pure Nothing
 
 ncqCheckDeleted h (Just loc) act = case loc of
-  InWriteQueue bs
-    | LBS.null bs && h /= ncqEmptyDataHash -> pure Nothing
-    | otherwise -> act loc
+  InWriteQueue WQItem{ wqData = Nothing } -> pure Nothing
+
+  InWriteQueue WQItem{ wqData = Just _ }  -> act loc
 
   InFossil _ (_, l)
     | l == 0 && h /= ncqEmptyDataHash -> pure Nothing
@@ -748,11 +746,10 @@ ncqStorageGet :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe LBS.ByteSt
 ncqStorageGet ncq@NCQStorage{..} h = do
   location <- ncqLocate ncq h
   ncqCheckDeleted h location \case
-    InWriteQueue lbs ->
+    InWriteQueue WQItem{ wqData = Just lbs } -> do
       pure $ Just lbs
 
     InCurrent (o,l) -> do
-      debug $ "IN FUCKIN CURRENT" <+> pretty l
       r <- atomically do
         a <- newEmptyTMVar
         fd <- readTVar ncqCurrentHandleR
@@ -768,6 +765,7 @@ ncqStorageGet ncq@NCQStorage{..} h = do
       let chunk = BS.take (fromIntegral l) (BS.drop (fromIntegral o + 4 + 32) (cachedMmapedData ce))
       pure $ Just $ LBS.fromStrict chunk
 
+    _ -> pure Nothing
 
 ncqStorageGetRef :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe HashRef)
 ncqStorageGetRef NCQStorage{..} ref = readTVarIO ncqRefsMem <&> HM.lookup ref

hbs2-tests/test/TCQ.hs

@@ -189,6 +189,22 @@ main = do
 
           e -> throwIO $ BadFormException @C (mkList e)
 
+        entry $ bindMatch "ncq:close" $ nil_ \case
+          [ isOpaqueOf @TCQ -> Just tcq ] -> lift do
+            ncq <- getNCQ tcq
+            ncqStorageStop ncq
+
+            void $ runMaybeT do
+              (s,r) <- readTVarIO instances
+                      <&> HM.lookup (coerce tcq)
+                      >>= toMPlus
+
+              wait r
+              atomically $ modifyTVar instances (HM.delete (coerce tcq))
+
+          e -> throwIO $ BadFormException @C (mkList e)
+
+
         entry $ bindMatch "ncq:cached:entries" $ \case
           [ isOpaqueOf @TCQ -> Just tcq ] -> lift do
             NCQStorage{..} <- getNCQ tcq
@@ -207,7 +223,6 @@ main = do
 
           e -> throwIO $ BadFormException @C (mkList e)
 
-
         entry $ bindMatch "ncq:has" $ \case
           [ isOpaqueOf @TCQ -> Just tcq, HashLike hash ] -> lift do
             ncq <- getNCQ tcq