From 68542bdd317ce78d4da7a8395944ca1736d5cdc1 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 6 Jun 2024 12:13:52 +0300 Subject: [PATCH] wip --- .fixme-new/config | 4 + fixme-new/fixme.cabal | 1 + fixme-new/lib/Fixme/Log.hs | 31 ++ fixme-new/lib/Fixme/Prelude.hs | 3 +- fixme-new/lib/Fixme/Run.hs | 396 +++++++++++++------------- fixme-new/lib/Fixme/Scan/Git/Local.hs | 76 ++++- hbs2-core/lib/HBS2/System/Dir.hs | 3 + 7 files changed, 309 insertions(+), 205 deletions(-) create mode 100644 fixme-new/lib/Fixme/Log.hs diff --git a/.fixme-new/config b/.fixme-new/config index 3b6a1ddd..a3826d01 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -38,6 +38,10 @@ fixme-comments ";" "--" (play-log-file ".fixme-new/log") ) +(fixme-play-log-action + (play-git-log-file-all ".fixme-new/log") +) + (fixme-play-log-action (hello kitty) ) diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index 534da05e..d8d8997c 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -107,6 +107,7 @@ library Fixme Fixme.Config Fixme.Run + Fixme.Log Fixme.Types Fixme.Prelude Fixme.State diff --git a/fixme-new/lib/Fixme/Log.hs b/fixme-new/lib/Fixme/Log.hs new file mode 100644 index 00000000..47b6f1cd --- /dev/null +++ b/fixme-new/lib/Fixme/Log.hs @@ -0,0 +1,31 @@ +module Fixme.Log where + +import Fixme.Prelude +import Fixme.Types + +import HBS2.Storage.Compact + +import Data.Config.Suckless + +import Data.ByteString.Lazy qualified as LBS +import Data.Maybe +import Data.Either + +{- HLINT ignore "Functor law"-} + +loadAllEntriesFromLog :: FixmePerks m + => CompactStorage HbSync + -> FixmeM m [Syntax C] +loadAllEntriesFromLog sto = do + ks <- keys sto + + entries <- mapM (get sto) ks + <&> catMaybes + <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) + <&> rights + + let top = show $ vcat (fmap pretty entries) + let theLog = parseTop top & fromRight mempty + + pure theLog + diff --git a/fixme-new/lib/Fixme/Prelude.hs b/fixme-new/lib/Fixme/Prelude.hs index 01d266ee..3f69c708 100644 --- a/fixme-new/lib/Fixme/Prelude.hs +++ b/fixme-new/lib/Fixme/Prelude.hs @@ -1,6 +1,7 @@ module Fixme.Prelude ( module All , GitHash(..) + , GitRef(..) , Serialise(..) , serialise, deserialiseOrFail, deserialise ) where @@ -10,7 +11,7 @@ import HBS2.Hash as All import HBS2.Data.Types.Refs as All import HBS2.Misc.PrettyStuff as All import HBS2.System.Logger.Simple.ANSI as All -import HBS2.Git.Local (GitHash(..)) +import HBS2.Git.Local (GitHash(..),GitRef(..)) import Codec.Serialise (Serialise(..),serialise,deserialise,deserialiseOrFail) import Data.Functor as All import Data.Function as All diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 8a5b60cd..a79c74ee 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -10,6 +10,7 @@ import Fixme.Config import Fixme.State import Fixme.Scan.Git.Local as Git import Fixme.Scan as Scan +import Fixme.Log import HBS2.Git.Local.CLI @@ -371,286 +372,279 @@ run what = do runForms (sc <> s0) - where - runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m) - => [Syntax c] - -> FixmeM m () - runForms ss = for_ ss $ \s -> do +runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m) + => [Syntax c] + -> FixmeM m () +runForms ss = for_ ss $ \s -> do - macros <- asks fixmeEnvMacro >>= readTVarIO + macros <- asks fixmeEnvMacro >>= readTVarIO - debug $ pretty s + debug $ pretty s - case s of + case s of - (ListVal (SymbolVal name : rest)) | HM.member name macros -> do - let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ] - maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do - debug $ yellow "run macro" <+> pretty macro - runForms [macro] + (ListVal (SymbolVal name : rest)) | HM.member name macros -> do + let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ] + maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do + debug $ yellow "run macro" <+> pretty macro + runForms [macro] - FixmeFiles xs -> do - t <- asks fixmeEnvFileMask - atomically (modifyTVar t (<> xs)) + FixmeFiles xs -> do + t <- asks fixmeEnvFileMask + atomically (modifyTVar t (<> xs)) - FixmePrefix tag -> do - t <- asks fixmeEnvTags - atomically (modifyTVar t (HS.insert tag)) + FixmePrefix tag -> do + t <- asks fixmeEnvTags + atomically (modifyTVar t (HS.insert tag)) - FixmeGitScanFilterDays d -> do - t <- asks fixmeEnvGitScanDays - atomically (writeTVar t (Just d)) + FixmeGitScanFilterDays d -> do + t <- asks fixmeEnvGitScanDays + atomically (writeTVar t (Just d)) - ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do - let co = Text.pack b & HS.singleton - t <- asks fixmeEnvFileComments - atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co)) + ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do + let co = Text.pack b & HS.singleton + t <- asks fixmeEnvFileComments + atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co)) - ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do - t <- asks fixmeEnvDefComments - let co = fmap Text.pack xs & HS.fromList - atomically $ modifyTVar t (<> co) + ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do + t <- asks fixmeEnvDefComments + let co = fmap Text.pack xs & HS.fromList + atomically $ modifyTVar t (<> co) - ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do - ta <- asks fixmeEnvAttribs - atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs)) + ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do + ta <- asks fixmeEnvAttribs + atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs)) - ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do - t <- asks fixmeEnvCatContext - atomically $ writeTVar t (fromIntegral a, fromIntegral b) + ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do + t <- asks fixmeEnvCatContext + atomically $ writeTVar t (fromIntegral a, fromIntegral b) - ListVal [SymbolVal "fixme-pager", ListVal cmd0] -> do - t <- asks fixmeEnvCatAction - let action = CatAction $ \dict lbs -> do + ListVal [SymbolVal "fixme-pager", ListVal cmd0] -> do + t <- asks fixmeEnvCatAction + let action = CatAction $ \dict lbs -> do - let ccmd = case inject dict cmd0 of - (StringLike p : StringLikeList xs) -> Just (p, xs) - _ -> Nothing + let ccmd = case inject dict cmd0 of + (StringLike p : StringLikeList xs) -> Just (p, xs) + _ -> Nothing - debug $ pretty ccmd + debug $ pretty ccmd - maybe1 ccmd none $ \(p, args) -> do + maybe1 ccmd none $ \(p, args) -> do - let input = byteStringInput lbs - let cmd = setStdin input $ setStderr closed - $ proc p args - void $ runProcess cmd + let input = byteStringInput lbs + let cmd = setStdin input $ setStderr closed + $ proc p args + void $ runProcess cmd - atomically $ writeTVar t action + atomically $ writeTVar t action - ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do - t <- asks fixmeEnvAttribValues - let name = fromString n - let vals = fmap fromString xs & HS.fromList - atomically $ modifyTVar t (HM.insertWith (<>) name vals) + ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do + t <- asks fixmeEnvAttribValues + let name = fromString n + let vals = fmap fromString xs & HS.fromList + atomically $ modifyTVar t (HM.insertWith (<>) name vals) - Init -> init + Init -> init - ScanGitLocal args -> scanGitLocal args Nothing + ScanGitLocal args -> scanGitLocal args Nothing - Update args -> scanGitLocal args Nothing + Update args -> scanGitLocal args Nothing - ListVal (SymbolVal "list" : (Template n [])) -> do - debug $ "list" <+> pretty n - list_ n () + ListVal (SymbolVal "list" : (Template n [])) -> do + debug $ "list" <+> pretty n + list_ n () - ListVal (SymbolVal "list" : (Template n whatever)) -> do - debug $ "list" <+> pretty n - list_ n whatever + ListVal (SymbolVal "list" : (Template n whatever)) -> do + debug $ "list" <+> pretty n + list_ n whatever - ListVal [SymbolVal "cat", SymbolVal "metadata", FixmeHashLike hash] -> do - catFixmeMetadata hash + ListVal [SymbolVal "cat", SymbolVal "metadata", FixmeHashLike hash] -> do + catFixmeMetadata hash - ListVal [SymbolVal "cat", FixmeHashLike hash] -> do - catFixme hash + ListVal [SymbolVal "cat", FixmeHashLike hash] -> do + catFixme hash - ListVal [SymbolVal "delete", FixmeHashLike hash] -> do - delete hash + ListVal [SymbolVal "delete", FixmeHashLike hash] -> do + delete hash - ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do - modify_ hash a b + ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do + modify_ hash a b - ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do - debug $ green $ pretty s - updateFixme (Just t) hash (fromString a) (fromString b) + ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do + debug $ green $ pretty s + updateFixme (Just t) hash (fromString a) (fromString b) - ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do - debug $ green $ pretty s - updateFixme Nothing hash (fromString a) (fromString b) + ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do + debug $ green $ pretty s + updateFixme Nothing hash (fromString a) (fromString b) - ListVal [SymbolVal "deleted", TimeStampLike _, FixmeHashLike hash] -> do - deleteFixme hash + ListVal [SymbolVal "deleted", TimeStampLike _, FixmeHashLike hash] -> do + deleteFixme hash - ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do - deleteFixme hash + ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do + deleteFixme hash - ReadFixmeStdin -> readFixmeStdin + ReadFixmeStdin -> readFixmeStdin - ListVal [SymbolVal "print-env"] -> do - printEnv + ListVal [SymbolVal "print-env"] -> do + printEnv - ListVal (SymbolVal "hello" : xs) -> do - notice $ "hello" <+> pretty xs + ListVal (SymbolVal "hello" : xs) -> do + notice $ "hello" <+> pretty xs - ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do - debug $ yellow "define-macro" <+> pretty name <+> pretty macro - macros <- asks fixmeEnvMacro - atomically $ modifyTVar macros (HM.insert name (fixContext macro)) + ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do + debug $ yellow "define-macro" <+> pretty name <+> pretty macro + macros <- asks fixmeEnvMacro + atomically $ modifyTVar macros (HM.insert name (fixContext macro)) - ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do - trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs) - t <- asks fixmeEnvTemplates - atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs))) + ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do + trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs) + t <- asks fixmeEnvTemplates + atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs))) - ListVal [SymbolVal "set-template", SymbolVal who, SymbolVal w] -> do - templates <- asks fixmeEnvTemplates - t <- readTVarIO templates - for_ (HM.lookup w t) $ \tpl -> do - atomically $ modifyTVar templates (HM.insert who tpl) + ListVal [SymbolVal "set-template", SymbolVal who, SymbolVal w] -> do + templates <- asks fixmeEnvTemplates + t <- readTVarIO templates + for_ (HM.lookup w t) $ \tpl -> do + atomically $ modifyTVar templates (HM.insert who tpl) - -- FIXME: maybe-rename-fixme-update-action - ListVal (SymbolVal "fixme-update-action" : xs) -> do - debug $ "fixme-update-action" <+> pretty xs - env <- ask - t <- asks fixmeEnvUpdateActions - let repl syn = [ ( "$1", syn ) ] - let action = UpdateAction @c $ \syn -> do - liftIO (withFixmeEnv env (runForms (inject (repl syn) xs))) + -- FIXME: maybe-rename-fixme-update-action + ListVal (SymbolVal "fixme-update-action" : xs) -> do + debug $ "fixme-update-action" <+> pretty xs + env <- ask + t <- asks fixmeEnvUpdateActions + let repl syn = [ ( "$1", syn ) ] + let action = UpdateAction @c $ \syn -> do + liftIO (withFixmeEnv env (runForms (inject (repl syn) xs))) - atomically $ modifyTVar t (<> [action]) + atomically $ modifyTVar t (<> [action]) - ListVal (SymbolVal "fixme-play-log-action" : xs) -> do - debug $ "fixme-play-log-action" <+> pretty xs - env <- ask - t <- asks fixmeEnvReadLogActions - let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs)) - atomically $ modifyTVar t (<> [action]) + ListVal (SymbolVal "fixme-play-log-action" : xs) -> do + debug $ "fixme-play-log-action" <+> pretty xs + env <- ask + t <- asks fixmeEnvReadLogActions + let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs)) + atomically $ modifyTVar t (<> [action]) - ListVal (SymbolVal "append-file" : StringLike fn : StringLikeList xs) -> do - debug "append-file" - liftIO $ for_ xs $ \x -> do - appendFile fn x - appendFile fn "\n" + ListVal (SymbolVal "append-file" : StringLike fn : StringLikeList xs) -> do + debug "append-file" + liftIO $ for_ xs $ \x -> do + appendFile fn x + appendFile fn "\n" - ListVal [SymbolVal "play-log-file", StringLike fn] -> do + ListVal [SymbolVal "play-git-log-file-all", StringLike fn] -> do + warn $ red "play-git-log-file-all" <+> pretty fn + scanGitLogLocal fn runForms - env <- ask + ListVal [SymbolVal "play-log-file", StringLike fn] -> do - debug $ red "play-log-file WIP" <+> pretty fn + env <- ask - what <- selectStage + debug $ red "play-log-file" <+> pretty fn - sto <- compactStorageOpen @HbSync mempty fn + what <- selectStage - for_ what $ \w -> do - let k = mkKey w - v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) - case v0 of - Nothing -> do - put sto k (LBS.toStrict $ serialise w) + sto <- compactStorageOpen @HbSync mempty fn - Just (Left{}) -> do - put sto k (LBS.toStrict $ serialise w) + for_ what $ \w -> do + let k = mkKey w + v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) + case v0 of + Nothing -> do + put sto k (LBS.toStrict $ serialise w) - Just (Right prev) | getSequence w > getSequence prev -> do - put sto k (LBS.toStrict $ serialise w) + Just (Left{}) -> do + put sto k (LBS.toStrict $ serialise w) - _ -> pure () + Just (Right prev) | getSequence w > getSequence prev -> do + put sto k (LBS.toStrict $ serialise w) - compactStorageCommit sto + _ -> pure () - ks <- keys sto + compactStorageCommit sto - entries <- mapM (get sto) ks - <&> catMaybes - <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) - <&> rights + loadAllEntriesFromLog sto >>= runForms + cleanStage - let top = show $ vcat (fmap pretty entries) - let theLog = parseTop top & fromRight mempty + compactStorageClose sto - liftIO $ withFixmeEnv env (runForms theLog) - cleanStage + ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do + debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b - compactStorageClose sto + temp <- liftIO $ emptyTempFile "." "merge-result" + sa <- compactStorageOpen @HbSync readonly o + sb <- compactStorageOpen @HbSync readonly b + r <- compactStorageOpen @HbSync mempty temp - ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do - debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b + for_ [sa,sb] $ \sto -> do + ks <- keys sto + for_ ks $ \k -> runMaybeT do + v <- get sto k & MaybeT + put r k v - temp <- liftIO $ emptyTempFile "." "merge-result" - sa <- compactStorageOpen @HbSync readonly o - sb <- compactStorageOpen @HbSync readonly b - r <- compactStorageOpen @HbSync mempty temp + compactStorageClose r + compactStorageClose sa + compactStorageClose sb - for_ [sa,sb] $ \sto -> do - ks <- keys sto - for_ ks $ \k -> runMaybeT do - v <- get sto k & MaybeT - put r k v + mv temp target - compactStorageClose r - compactStorageClose sa - compactStorageClose sb + ListVal [SymbolVal "no-debug"] -> do + setLoggingOff @DEBUG - mv temp target + ListVal [SymbolVal "silence"] -> do + silence - ListVal [SymbolVal "no-debug"] -> do - setLoggingOff @DEBUG + ListVal [SymbolVal "builtin:evolve"] -> do + evolve - ListVal [SymbolVal "silence"] -> do - silence + ListVal [SymbolVal "builtin:cleanup-state"] -> do + cleanupDatabase - ListVal [SymbolVal "builtin:evolve"] -> do - evolve + ListVal [SymbolVal "builtin:clean-stage"] -> do + cleanStage - ListVal [SymbolVal "builtin:cleanup-state"] -> do - cleanupDatabase + ListVal [SymbolVal "builtin:drop-stage"] -> do + cleanStage - ListVal [SymbolVal "builtin:clean-stage"] -> do - cleanStage + ListVal [SymbolVal "builtin:show-stage"] -> do + stage <- selectStage + liftIO $ print $ vcat (fmap pretty stage) - ListVal [SymbolVal "builtin:drop-stage"] -> do - cleanStage + ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do + sto <- compactStorageOpen @HbSync readonly fn - ListVal [SymbolVal "builtin:show-stage"] -> do - stage <- selectStage - liftIO $ print $ vcat (fmap pretty stage) + ks <- keys sto - ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do - sto <- compactStorageOpen @HbSync readonly fn + entries <- mapM (get sto) ks + <&> catMaybes + <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) + <&> rights - ks <- keys sto + liftIO $ print $ vcat (fmap pretty entries) - entries <- mapM (get sto) ks - <&> catMaybes - <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) - <&> rights + compactStorageClose sto - liftIO $ print $ vcat (fmap pretty entries) + ListVal [SymbolVal "builtin:update-indexes"] -> do + updateIndexes - compactStorageClose sto + ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do + w <- selectFixmeHash x + liftIO $ print $ pretty w - ListVal [SymbolVal "builtin:update-indexes"] -> do - updateIndexes + ListVal [SymbolVal "trace"] -> do + setLogging @TRACE (logPrefix "[trace] " . toStderr) + trace "trace on" - ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do - w <- selectFixmeHash x - liftIO $ print $ pretty w + ListVal [SymbolVal "no-trace"] -> do + trace "trace off" + setLoggingOff @TRACE - ListVal [SymbolVal "trace"] -> do - setLogging @TRACE (logPrefix "[trace] " . toStderr) - trace "trace on" + ListVal [SymbolVal "debug"] -> do + setLogging @DEBUG $ toStderr . logPrefix "[debug] " - ListVal [SymbolVal "no-trace"] -> do - trace "trace off" - setLoggingOff @TRACE - - ListVal [SymbolVal "debug"] -> do - setLogging @DEBUG $ toStderr . logPrefix "[debug] " - - w -> err (pretty w) + w -> err (pretty w) diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index 193460be..163a26c7 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -9,7 +9,10 @@ import Fixme.Prelude hiding (indent) import Fixme.Types import Fixme.State import Fixme.Scan as Scan +import Fixme.Log +import HBS2.Storage.Compact +import HBS2.System.Dir import HBS2.Git.Local.CLI import DBPipe.SQLite hiding (field) @@ -34,9 +37,12 @@ import Lens.Micro.Platform import System.Process.Typed import Control.Monad.Trans.Cont import System.IO qualified as IO +import System.IO.Temp (emptySystemTempFile) + import Data.Map qualified as Map +import Streaming.Prelude qualified as S data ScanGitArgs = PrintBlobs @@ -101,6 +107,18 @@ listCommits = do spec = sq <> delims " \t" +listRefs :: FixmePerks m => FixmeM m [(GitHash, GitRef)] +listRefs = do + gd <- fixmeGetGitDirCLIOpt + gitRunCommand [qc|git {gd} show-ref --dereference|] + <&> fromRight mempty + <&> fmap LBS8.words . LBS8.lines + <&> mapMaybe + (\case + [h,b] -> (,) <$> fromStringMay @GitHash (LBS8.unpack h) <*> pure (GitRef (LBS8.toStrict b)) + _ -> Nothing + ) + listBlobs :: FixmePerks m => GitHash -> m [(FilePath,GitHash)] listBlobs co = do -- FIXME: git-dir @@ -112,17 +130,63 @@ listBlobs co = do [a,"blob",h,_,fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h) _ -> Nothing) +filterBlobs0 :: FixmePerks m + => [(Bool,FilePattern)] + -> [(FilePath,GitHash)] + -> FixmeM m [(FilePath,GitHash)] + +filterBlobs0 pat xs = do + -- pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,) + let src = [ ((f,h),f) | (f,h) <- xs ] + let r = [(h,f) | (_,(f,h),_) <- matchMany pat src] & HM.fromList & HM.toList + pure $ [ (b,a) | (a,b) <- r ] + filterBlobs :: FixmePerks m => [(FilePath,GitHash)] -> FixmeM m [(FilePath,GitHash)] filterBlobs xs = do pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,) - let src = [ ((f,h),f) | (f,h) <- xs ] - let r = [(h,f) | (_,(f,h),_) <- matchMany pat src] & HM.fromList & HM.toList - pure $ [ (b,a) | (a,b) <- r ] + filterBlobs0 pat xs +scanGitLogLocal :: FixmePerks m + => FilePath + -> ( [Syntax C] -> FixmeM m () ) + -> FixmeM m () +scanGitLogLocal refMask play = do + warn $ red "scanGitLogLocal" <+> pretty refMask + warn $ yellow "STEP 1" <+> "get all known branches including remote" + + refs <- listRefs + + let hashes = fmap fst refs + + warn $ yellow "STEP 2" <+> "for each branch --- get tree" + + let pat = [(True, refMask)] + + -- FIXME: use-cache-to-skip-already-processed-tips + logz <- S.toList_ do + for_ hashes $ \h -> do + blobs <- lift (listBlobs h >>= filterBlobs0 pat) + for_ blobs $ \(b,h) -> do + S.yield h + + warn $ yellow "STEP 3" <+> "for each tree --- find log" + + warn $ vcat (fmap pretty logz) + + warn $ yellow "STEP 4" <+> "for each log --- scan log" + + flip runContT pure do + for_ logz $ \h -> do + tmp <- ContT $ bracket (liftIO (emptySystemTempFile "fixme-log")) rm + blob <- lift $ gitCatBlob h + liftIO (LBS8.writeFile tmp blob) + sto <- ContT $ bracket (compactStorageOpen @HbSync readonly tmp) compactStorageClose + lift $ loadAllEntriesFromLog sto >>= play + scanGitLocal :: FixmePerks m => [ScanGitArgs] @@ -348,6 +412,12 @@ runLogActions = do updateIndexes +gitCatBlob :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m ByteString +gitCatBlob h = do + gd <- fixmeGetGitDirCLIOpt + (_,s,_) <- readProcess $ shell [qc|git {gd} cat-file blob {pretty h}|] + pure s + startGitCatFile :: (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ()) startGitCatFile = do gd <- fixmeGetGitDirCLIOpt diff --git a/hbs2-core/lib/HBS2/System/Dir.hs b/hbs2-core/lib/HBS2/System/Dir.hs index 643490bb..18a79a1e 100644 --- a/hbs2-core/lib/HBS2/System/Dir.hs +++ b/hbs2-core/lib/HBS2/System/Dir.hs @@ -75,6 +75,9 @@ fileSize = liftIO . D.getFileSize mv :: MonadIO m => FilePath -> FilePath -> m () mv a b = liftIO $ D.renamePath a b +rm :: MonadIO m => FilePath -> m () +rm fn = liftIO $ D.removePathForcibly fn + home :: MonadIO m => m FilePath home = liftIO D.getHomeDirectory