wip

hbs2-git3/app/Main.hs

@@ -981,9 +981,9 @@ theDict = do
 
           _ -> throwIO (BadFormException @C nil)
 
-        entry $ bindMatch "test:git:reflog:index:list" $ nil_ $ \syn -> lift do
+        entry $ bindMatch "reflog:index:list" $ nil_ $ const $ lift do
-          let (_, argz) = splitOpts [] syn
+          files <- listObjectIndexFiles
-          for_ [ x | StringLike x <- argz ] $ \ifn -> do
+          for_ files  $ \(ifn,_) -> do
             lbs <- liftIO $ LBS.readFile ifn
 
             void $ runConsumeLBS lbs $ readSections $ \s ss -> do
@@ -1085,10 +1085,16 @@ theDict = do
             let f = makeRelative cur f'
             liftIO $ print $ fill 10 (pretty s) <+> pretty f
 
+        entry $ bindMatch "reflog:index:list:tx" $ nil_ $ const $ lift do
+          r <- newTVarIO ( mempty :: HashSet HashRef )
+          enumEntries $ \bs -> do
+            atomically $ modifyTVar r (HS.insert (coerce $ BS.take 32 $ BS.drop 20 bs))
+          z <- readTVarIO r <&> HS.toList
+          liftIO $ mapM_ ( print . pretty ) z
+
         entry $ bindMatch "reflog:index:build" $ nil_ $ const $ lift $ connectedDo do
           writeReflogIndex
 
-
         entry $ bindMatch "git:list:objects:new" $ nil_ $ \syn -> lift do
           let (opts,argz) = splitOpts [] syn
 

hbs2-git3/hbs2-git3.cabal

@@ -92,6 +92,7 @@ common shared-properties
       , scientific
       , streaming
       , stm
+      , stm-hamt
       , split
       , text
       , temporary

hbs2-git3/lib/HBS2/Git3/State/Index.hs

@@ -15,6 +15,8 @@ import Network.ByteOrder qualified as N
 import System.IO.Temp as Temp
 import Data.ByteString.Lazy qualified as LBS
 import Data.Maybe
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
 
 import Codec.Compression.Zstd.Lazy qualified as ZstdL
 import Streaming.Prelude qualified as S
@@ -99,20 +101,37 @@ startReflogIndexQueryQueue rq = flip runContT pure do
 
   mmaped <- liftIO $ for files (liftIO . flip mmapFileByteString Nothing)
 
-  forever $ liftIO do
+  r <- newTVarIO (mempty :: HashMap N.ByteString N.ByteString)
+
+  -- FIXME: may-explode
+  for_ mmaped $ \bs -> do
+    scanBS bs $ \segment -> do
+      let ha = BS.take 20 segment & coerce
+      atomically $ modifyTVar r (HM.insert ha segment)
+
+  forever do
     (s, f, answ) <- atomically $ readTQueue rq
+    found <- readTVarIO r <&> HM.lookup s
 
-    found <- forConcurrently mmaped $ \bs -> runMaybeT do
+    atomically do
-               -- FIXME: size-hardcodes
+      case found of
-               w <- binarySearchBS 56 ( BS.take 20 . BS.drop 4 ) s bs
+        Nothing -> writeTMVar answ Nothing
-                      >>= toMPlus
+        Just x  -> writeTMVar answ (Just (f x))
 
-               let v = BS.drop ( w * 56 ) bs
+  -- forever $ liftIO do
+  --   (s, f, answ) <- atomically $ readTQueue rq
 
-               pure $ f v
+  --   found <- forConcurrently mmaped $ \bs -> runMaybeT do
+  --              -- FIXME: size-hardcodes
+  --              w <- binarySearchBS 56 ( BS.take 20 . BS.drop 4 ) s bs
+  --                     >>= toMPlus
 
-    let what = headMay (catMaybes found)
+  --              let v = BS.drop ( w * 56 ) bs
-    atomically $ writeTMVar answ what
+
+  --              pure $ f v
+
+  --   let what = headMay (catMaybes found)
+  --   atomically $ writeTMVar answ what
 
 writeReflogIndex :: forall m . ( Git3Perks m
                                , MonadReader Git3Env m