From 00e24115ec79e0838ce03b5e0aff39908615ca59 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 20 Jan 2025 11:46:16 +0300 Subject: [PATCH] wip, trim .ref files --- hbs2-git3/lib/HBS2/Git3/Run.hs | 33 ++++++ .../lib/HBS2/Git3/State/Internal/Index.hs | 108 ++++++++++++++---- 2 files changed, 121 insertions(+), 20 deletions(-) diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 26b5e4e7..0a836806 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/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 diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs index d6d3e1ab..da605988 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs +++ b/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 - ls <- liftIO (LBS8.readFile fn) <&> LBS8.lines - S.each ls - rm fn - pure True + -- let es = HS.fromList entries - 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 - <&> filter ( (== ".ref") . takeExtension ) - >>= mapM (try @_ @IOError . liftIO . readFile) - <&> unlines . rights - <&> parseTop - <&> fromRight mempty + refs <- readRefsRaw files - txh <- maybe mempty HS.fromList <$> runMaybeT do - cp <- lift importedCheckpoint >>= toMPlus - fmap fst <$> lift (txListAll (Just cp)) + txh <- txImported let rrefs = [ (n,((GitRef (BS8.pack n),g),r)) | ListVal [ SymbolVal "R"