wip, trim .ref files

hbs2-git3/lib/HBS2/Git3/Run.hs

@@ -29,6 +29,8 @@ import Network.ByteOrder qualified as N
 import Text.InterpolatedString.Perl6 (qc)
 import Data.HashSet qualified as HS
 import Data.HashSet (HashSet)
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
 import Data.Fixed
 import Lens.Micro.Platform
 
@@ -427,6 +429,37 @@ compression      ;  prints compression level
           for_  rrefs $ \(r,h) -> do
             liftIO $ print $ fill 20  (pretty h) <+> pretty r
 
+        entry $ bindMatch "reflog:refs:raw" $ nil_ $ \syn -> lift $ connectedDo do
+          refsFiles >>= readRefsRaw >>= liftIO . mapM_ (print . pretty)
+
+        -- entry $ bindMatch "reflog:refs:trimmed" $ nil_ $ \syn -> lift $ connectedDo do
+        --   txi <- txImported
+        --   raw <- readRefsRaw =<< refsFiles
+
+        --   ni_  <- newTQueueIO
+        --   imp_ <- newTVarIO ( mempty :: HashMap Text (Integer, GitHash, HashRef) )
+
+        --   for_ raw $ \case
+        --     ListVal [ SymbolVal "R", HashLike seg, LitIntVal r, GitHashLike v, TextLike n ] -> do
+
+        --       atomically do
+        --         if not (HS.member seg txi) then
+        --           writeTQueue ni_ (n, (r, v, seg))
+        --         else do
+        --           let x = (r, v, seg)
+        --           let fn = HM.insertWith (\a b -> if view _1 a > view _1 b then a else b) n x
+        --           modifyTVar imp_ fn
+
+        --     _ -> none
+
+        --   result <- atomically do
+        --         a <- STM.flushTQueue ni_
+        --         b <- readTVar imp_ <&> HM.toList
+        --         pure (a <> b)
+
+        --   for_ result $ \(n, (r, h, v)) -> do
+        --     liftIO $ print $ "R" <+> pretty h <+> pretty r <+> pretty v <+> pretty n
+
         entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do
           p <- importedCheckpoint
           liftIO $ print $ pretty p

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

@@ -39,6 +39,8 @@ import System.IO (hPrint)
 import Streaming.Prelude qualified as S
 import System.TimeIt
 
+import Lens.Micro.Platform
+import Control.Concurrent.STM qualified as STM
 import UnliftIO.IO.File qualified as UIO
 
 
@@ -371,20 +373,61 @@ updateReflogIndex = do
                       <+> pretty gh
                       <+> pretty nm
 
+      lift trimRefs
+        -- entries <- liftIO $ S.toList_ $ glob ["**/*.ref"] [] idxPath $ \fn -> do
+        --              ls <- liftIO (LBS8.readFile fn) <&> LBS8.lines
+        --              S.each ls
+        --              rm fn
+        --              pure True
 
-        entries <- liftIO $ S.toList_ $ glob ["**/*.ref"] [] idxPath $ \fn -> do
+        -- let es = HS.fromList entries
-                     ls <- liftIO (LBS8.readFile fn) <&> LBS8.lines
-                     S.each ls
-                     rm fn
-                     pure True
 
-        let es = HS.fromList entries
+        -- liftIO do
+        --   name <- emptyTempFile idxPath ".ref"
+        --   UIO.withBinaryFileAtomic name WriteMode $ \wh -> do
+        --     for_ es $ \s -> LBS8.hPutStrLn wh s
 
-        liftIO do
-          name <- emptyTempFile idxPath ".ref"
-          UIO.withBinaryFileAtomic name WriteMode $ \wh -> do
-            for_ es $ \s -> LBS8.hPutStrLn wh s
 
+trimRefs :: forall m . ( Git3Perks m
+                       , MonadReader Git3Env m
+                       , HasGitRemoteKey m
+                       , HasStorage m
+                       , HasClientAPI RefLogAPI UNIX m
+                       ) => m ()
+trimRefs = do
+    idxPath <- indexPath
+    files <- refsFiles
+    name <- liftIO $ emptyTempFile idxPath ".ref"
+    UIO.withBinaryFileAtomic name WriteMode $ \wh -> do
+
+      txi <- txImported
+      raw <- readRefsRaw files
+
+      ni_  <- newTQueueIO
+      imp_ <- newTVarIO ( mempty :: HashMap Text (Integer, GitHash, HashRef) )
+
+      for_ raw $ \case
+        ListVal [ SymbolVal "R", HashLike seg, LitIntVal r, GitHashLike v, TextLike n ] -> do
+
+          atomically do
+            if not (HS.member seg txi) then
+              writeTQueue ni_ (n, (r, v, seg))
+            else do
+              let x = (r, v, seg)
+              let fn = HM.insertWith (\a b -> if view _1 a > view _1 b then a else b) n x
+              modifyTVar imp_ fn
+
+        _ -> none
+
+      result <- atomically do
+            a <- STM.flushTQueue ni_
+            b <- readTVar imp_ <&> HM.toList
+            pure (a <> b)
+
+      for_ result $ \(n, (r, h, seg)) -> do
+        liftIO $ hPrint wh $ "R" <+> pretty seg <+> pretty r <+> pretty h <+> pretty n
+
+    mapM_ rm files
 
 importedCheckpoint :: forall m . ( Git3Perks m
                                  , MonadReader Git3Env m
@@ -406,6 +449,38 @@ importedCheckpoint = do
 nullHash :: GitHash
 nullHash = GitHash (BS.replicate 20 0)
 
+txImported :: forall m . ( Git3Perks m
+                         , MonadReader Git3Env m
+                         , HasClientAPI RefLogAPI UNIX m
+                         , HasStorage m
+                         , HasGitRemoteKey m
+                         ) => m (HashSet HashRef)
+
+txImported = maybe mempty HS.fromList <$> runMaybeT do
+     cp <- lift importedCheckpoint >>= toMPlus
+     fmap fst <$> lift (txListAll (Just cp))
+
+
+refsFiles :: forall m . (Git3Perks m, HasGitRemoteKey m) => m [FilePath]
+refsFiles = do
+  state <- getStatePathM
+  dirFiles state
+    <&> filter ( (== ".ref") . takeExtension )
+
+readRefsRaw :: forall m . ( Git3Perks m
+                          , MonadReader Git3Env m
+                          , HasClientAPI RefLogAPI UNIX m
+                          , HasStorage m
+                          , HasGitRemoteKey m
+                          )
+            => [FilePath] -> m [Syntax C]
+
+readRefsRaw files = do
+  mapM (try @_ @IOError . liftIO . readFile) files
+    <&> unlines . rights
+    <&> parseTop
+    <&> fromRight mempty
+
 {- HLINT ignore "Functor law"-}
 importedRefs :: forall m . ( Git3Perks m
                            , MonadReader Git3Env m
@@ -416,18 +491,11 @@ importedRefs :: forall m . ( Git3Perks m
 
 importedRefs = do
 
-  state <- getStatePathM
+  files <- refsFiles
 
-  refs <- dirFiles state
+  refs <- readRefsRaw files
-            <&> filter ( (== ".ref") . takeExtension )
-            >>= mapM (try @_ @IOError . liftIO . readFile)
-            <&> unlines . rights
-            <&> parseTop
-            <&> fromRight mempty
 
-  txh <- maybe mempty HS.fromList <$> runMaybeT do
+  txh <- txImported
-           cp <- lift importedCheckpoint >>= toMPlus
-           fmap fst <$> lift (txListAll (Just cp))
 
   let rrefs = [ (n,((GitRef (BS8.pack n),g),r))
               | ListVal [ SymbolVal "R"