wip

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

@@ -53,7 +53,8 @@ import System.Posix.IO as PosixBase
 import System.Posix.Types as Posix
 import System.Posix.IO.ByteString as Posix
 import System.Posix.Unistd
-import System.Posix.Files (getFileStatus, modificationTimeHiRes)
+import System.Posix.Files (getFileStatus, modificationTimeHiRes, getFdStatus, FileStatus(..))
+import System.Posix.Files qualified as PFS
 import System.IO.Error (catchIOError)
 import System.IO.MMap as MMap
 import System.IO.Temp (emptyTempFile)
@@ -145,7 +146,7 @@ instance Pretty Location where
   pretty = \case
     InWriteQueue{}   -> "write-queue"
     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 " [mkInt o, mkInt l]
 
 type IsHCQKey h  = ( Eq (Key h)
                    , Hashable (Key h)
@@ -307,8 +308,8 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
 
   refsWriter <- makeRefsWriter
   reader     <- makeReader
-  indexer    <- makeIndexer indexQ
   writer     <- makeWriter indexQ
+  indexer    <- makeIndexer writer indexQ
 
   mapM_ waitCatch [writer,indexer,refsWriter]
   -- mapM_ waitCatch [writer,indexer,refsWriter] -- ,indexer,refsWriter]
@@ -361,7 +362,8 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
             flush <- isEmptyTQueue myFlushQ <&> not
             stop  <- readTVar ncqStopped
             bytes <- readTVar ncqNotWritten
-            if bytes > dumpData || flush || stop then none else STM.retry
+            now   <- readTVar ncqIndexNow <&> (>0)
+            if bytes > dumpData || flush || now || stop then none else STM.retry
 
           void $ atomically (STM.flushTQueue myFlushQ)
 
@@ -410,15 +412,13 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
       pure refsWriter
 
 
-    makeIndexer indexQ = do
-      indexer <- ContT $ withAsync $ untilStopped do
-
-         debug $ "STARTED INDEXER"
+    makeIndexer w indexQ = do
+      indexer <- ContT $ withAsync $ fix \next ->  do
 
          what' <- race (pause @'Seconds 1) $ atomically do
             stop  <- readTVar ncqStopped
             q <- tryPeekTQueue indexQ
-                    if not (stop || isJust q) then
+            if not ( stop  || isJust q) then
               STM.retry
             else do
               STM.flushTQueue indexQ
@@ -431,17 +431,19 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
 
            (key, _) <- ncqIndexFile ncq fn <&> over _2 HS.fromList
 
-           -- atomically do
-           --   r <- readTVar ncqWaitIndex <&> HPSQ.toList
-           --   let new = [(k,p,v) | (k,p,v) <- r, not (k `HS.member` added)]
-           --   writeTVar ncqWaitIndex (HPSQ.fromList new)
-
            ncqAddTrackedFilesIO ncq [key]
            atomically do
              modifyTVar ncqCurrentUsage (IntMap.adjust pred (fromIntegral fd))
 
            ncqLoadSomeIndexes ncq [fromString key]
 
+         down <- atomically do
+           writerDown <- pollSTM w <&> isJust
+           stopped <- readTVar ncqStopped
+           pure (stopped && writerDown)
+
+         unless down next
+
       link indexer
       pure indexer
 
@@ -509,6 +511,12 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
 
       when (fromIntegral size >= ncqMinLog || indexNow > 0) do
 
+        fsize <- readTVarIO ncqCurrentHandleR
+                    >>= getFdStatus
+                    <&> PFS.fileSize
+
+        unless (fsize == 0) do
+
           (n,u) <- atomically do
                         r <- readTVar ncqCurrentHandleR <&> fromIntegral
                         u <- readTVar ncqCurrentUsage <&> fromMaybe 0 . IntMap.lookup r
@@ -518,7 +526,7 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
 
           fossilized <- ncqGetNewFossilName ncq
 
-        warn $ "NEED TRUNCATE" <+> pretty current <+> viaShow size <+> pretty n <+> pretty u
+          debug $ "NEED TRUNCATE" <+> pretty current <+> viaShow size <+> pretty n <+> pretty u
 
           mv current fossilized
 

hbs2-tests/test/TCQ.hs

@@ -182,6 +182,24 @@ main = do
 
           e -> throwIO $ BadFormException @C (mkList e)
 
+        entry $ bindMatch "ncq:fossilize" $ nil_ \case
+          [ isOpaqueOf @TCQ -> Just tcq ] -> lift do
+            ncq <- getNCQ tcq
+            ncqIndexRightNow ncq
+
+          e -> throwIO $ BadFormException @C (mkList e)
+
+        entry $ bindMatch "ncq:locate" $ \case
+          [ isOpaqueOf @TCQ -> Just tcq, HashLike hash ] -> lift do
+            ncq <- getNCQ tcq
+            ncqLocate ncq hash >>= \case
+              Just x -> do
+                parseSyntax (show $ pretty x) & either (error.show) pure
+
+              _      -> pure nil
+
+          e -> throwIO $ BadFormException @C (mkList e)
+
         entry $ bindMatch "ncq:get" $ \case
           [ isOpaqueOf @TCQ -> Just tcq, HashLike hash ] -> lift do
             ncq <- getNCQ tcq