voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-06-06 12:13:52 +03:00
parent 31dd28329f
commit 68542bdd31
7 changed files with 309 additions and 205 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.fixme-new/config
View File

@ -38,6 +38,10 @@ fixme-comments ";" "--"
(play-log-file ".fixme-new/log") (play-log-file ".fixme-new/log")
) )
(fixme-play-log-action
(play-git-log-file-all ".fixme-new/log")
)
(fixme-play-log-action (fixme-play-log-action
(hello kitty) (hello kitty)
) )

1
fixme-new/fixme.cabal
View File

@ -107,6 +107,7 @@ library
Fixme Fixme
Fixme.Config Fixme.Config
Fixme.Run Fixme.Run
Fixme.Log
Fixme.Types Fixme.Types
Fixme.Prelude Fixme.Prelude
Fixme.State Fixme.State

31
fixme-new/lib/Fixme/Log.hs Normal file
View File

@ -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

3
fixme-new/lib/Fixme/Prelude.hs
View File

@ -1,6 +1,7 @@
module Fixme.Prelude module Fixme.Prelude
( module All ( module All
, GitHash(..) , GitHash(..)
, GitRef(..)
, Serialise(..) , Serialise(..)
, serialise, deserialiseOrFail, deserialise , serialise, deserialiseOrFail, deserialise
) where ) where
@ -10,7 +11,7 @@ import HBS2.Hash as All
import HBS2.Data.Types.Refs as All import HBS2.Data.Types.Refs as All
import HBS2.Misc.PrettyStuff as All import HBS2.Misc.PrettyStuff as All
import HBS2.System.Logger.Simple.ANSI 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 Codec.Serialise (Serialise(..),serialise,deserialise,deserialiseOrFail)
import Data.Functor as All import Data.Functor as All
import Data.Function as All import Data.Function as All

396
fixme-new/lib/Fixme/Run.hs
View File

@ -10,6 +10,7 @@ import Fixme.Config
import Fixme.State import Fixme.State
import Fixme.Scan.Git.Local as Git import Fixme.Scan.Git.Local as Git
import Fixme.Scan as Scan import Fixme.Scan as Scan
import Fixme.Log
import HBS2.Git.Local.CLI import HBS2.Git.Local.CLI
@ -371,286 +372,279 @@ run what = do
runForms (sc <> s0) runForms (sc <> s0)
where
runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m) runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m)
=> [Syntax c] => [Syntax c]
-> FixmeM m () -> FixmeM m ()
runForms ss = for_ ss $ \s -> do 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 (ListVal (SymbolVal name : rest)) | HM.member name macros -> do
let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ] let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ]
maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do
debug $ yellow "run macro" <+> pretty macro debug $ yellow "run macro" <+> pretty macro
runForms [macro] runForms [macro]
FixmeFiles xs -> do FixmeFiles xs -> do
t <- asks fixmeEnvFileMask t <- asks fixmeEnvFileMask
atomically (modifyTVar t (<> xs)) atomically (modifyTVar t (<> xs))
FixmePrefix tag -> do FixmePrefix tag -> do
t <- asks fixmeEnvTags t <- asks fixmeEnvTags
atomically (modifyTVar t (HS.insert tag)) atomically (modifyTVar t (HS.insert tag))
FixmeGitScanFilterDays d -> do FixmeGitScanFilterDays d -> do
t <- asks fixmeEnvGitScanDays t <- asks fixmeEnvGitScanDays
atomically (writeTVar t (Just d)) atomically (writeTVar t (Just d))
ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do
let co = Text.pack b & HS.singleton let co = Text.pack b & HS.singleton
t <- asks fixmeEnvFileComments t <- asks fixmeEnvFileComments
atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co)) atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co))
ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do
t <- asks fixmeEnvDefComments t <- asks fixmeEnvDefComments
let co = fmap Text.pack xs & HS.fromList let co = fmap Text.pack xs & HS.fromList
atomically $ modifyTVar t (<> co) atomically $ modifyTVar t (<> co)
ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do
ta <- asks fixmeEnvAttribs ta <- asks fixmeEnvAttribs
atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs)) atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs))
ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do
t <- asks fixmeEnvCatContext t <- asks fixmeEnvCatContext
atomically $ writeTVar t (fromIntegral a, fromIntegral b) atomically $ writeTVar t (fromIntegral a, fromIntegral b)
ListVal [SymbolVal "fixme-pager", ListVal cmd0] -> do ListVal [SymbolVal "fixme-pager", ListVal cmd0] -> do
t <- asks fixmeEnvCatAction t <- asks fixmeEnvCatAction
let action = CatAction $ \dict lbs -> do let action = CatAction $ \dict lbs -> do
let ccmd = case inject dict cmd0 of let ccmd = case inject dict cmd0 of
(StringLike p : StringLikeList xs) -> Just (p, xs) (StringLike p : StringLikeList xs) -> Just (p, xs)
_ -> Nothing _ -> Nothing
debug $ pretty ccmd debug $ pretty ccmd
maybe1 ccmd none $ \(p, args) -> do maybe1 ccmd none $ \(p, args) -> do
let input = byteStringInput lbs let input = byteStringInput lbs
let cmd = setStdin input $ setStderr closed let cmd = setStdin input $ setStderr closed
$ proc p args $ proc p args
void $ runProcess cmd void $ runProcess cmd
atomically $ writeTVar t action atomically $ writeTVar t action
ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do
t <- asks fixmeEnvAttribValues t <- asks fixmeEnvAttribValues
let name = fromString n let name = fromString n
let vals = fmap fromString xs & HS.fromList let vals = fmap fromString xs & HS.fromList
atomically $ modifyTVar t (HM.insertWith (<>) name vals) 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 ListVal (SymbolVal "list" : (Template n [])) -> do
debug $ "list" <+> pretty n debug $ "list" <+> pretty n
list_ n () list_ n ()
ListVal (SymbolVal "list" : (Template n whatever)) -> do ListVal (SymbolVal "list" : (Template n whatever)) -> do
debug $ "list" <+> pretty n debug $ "list" <+> pretty n
list_ n whatever list_ n whatever
ListVal [SymbolVal "cat", SymbolVal "metadata", FixmeHashLike hash] -> do ListVal [SymbolVal "cat", SymbolVal "metadata", FixmeHashLike hash] -> do
catFixmeMetadata hash catFixmeMetadata hash
ListVal [SymbolVal "cat", FixmeHashLike hash] -> do ListVal [SymbolVal "cat", FixmeHashLike hash] -> do
catFixme hash catFixme hash
ListVal [SymbolVal "delete", FixmeHashLike hash] -> do ListVal [SymbolVal "delete", FixmeHashLike hash] -> do
delete hash delete hash
ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do
modify_ hash a b modify_ hash a b
ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do
debug $ green $ pretty s debug $ green $ pretty s
updateFixme (Just t) hash (fromString a) (fromString b) updateFixme (Just t) hash (fromString a) (fromString b)
ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do
debug $ green $ pretty s debug $ green $ pretty s
updateFixme Nothing hash (fromString a) (fromString b) updateFixme Nothing hash (fromString a) (fromString b)
ListVal [SymbolVal "deleted", TimeStampLike _, FixmeHashLike hash] -> do ListVal [SymbolVal "deleted", TimeStampLike _, FixmeHashLike hash] -> do
deleteFixme hash deleteFixme hash
ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do
deleteFixme hash deleteFixme hash
ReadFixmeStdin -> readFixmeStdin ReadFixmeStdin -> readFixmeStdin
ListVal [SymbolVal "print-env"] -> do ListVal [SymbolVal "print-env"] -> do
printEnv printEnv
ListVal (SymbolVal "hello" : xs) -> do ListVal (SymbolVal "hello" : xs) -> do
notice $ "hello" <+> pretty xs notice $ "hello" <+> pretty xs
ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do
debug $ yellow "define-macro" <+> pretty name <+> pretty macro debug $ yellow "define-macro" <+> pretty name <+> pretty macro
macros <- asks fixmeEnvMacro macros <- asks fixmeEnvMacro
atomically $ modifyTVar macros (HM.insert name (fixContext macro)) atomically $ modifyTVar macros (HM.insert name (fixContext macro))
ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do
trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs) trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs)
t <- asks fixmeEnvTemplates t <- asks fixmeEnvTemplates
atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs))) atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs)))
ListVal [SymbolVal "set-template", SymbolVal who, SymbolVal w] -> do ListVal [SymbolVal "set-template", SymbolVal who, SymbolVal w] -> do
templates <- asks fixmeEnvTemplates templates <- asks fixmeEnvTemplates
t <- readTVarIO templates t <- readTVarIO templates
for_ (HM.lookup w t) $ \tpl -> do for_ (HM.lookup w t) $ \tpl -> do
atomically $ modifyTVar templates (HM.insert who tpl) atomically $ modifyTVar templates (HM.insert who tpl)
-- FIXME: maybe-rename-fixme-update-action -- FIXME: maybe-rename-fixme-update-action
ListVal (SymbolVal "fixme-update-action" : xs) -> do ListVal (SymbolVal "fixme-update-action" : xs) -> do
debug $ "fixme-update-action" <+> pretty xs debug $ "fixme-update-action" <+> pretty xs
env <- ask env <- ask
t <- asks fixmeEnvUpdateActions t <- asks fixmeEnvUpdateActions
let repl syn = [ ( "$1", syn ) ] let repl syn = [ ( "$1", syn ) ]
let action = UpdateAction @c $ \syn -> do let action = UpdateAction @c $ \syn -> do
liftIO (withFixmeEnv env (runForms (inject (repl syn) xs))) liftIO (withFixmeEnv env (runForms (inject (repl syn) xs)))
atomically $ modifyTVar t (<> [action]) atomically $ modifyTVar t (<> [action])
ListVal (SymbolVal "fixme-play-log-action" : xs) -> do ListVal (SymbolVal "fixme-play-log-action" : xs) -> do
debug $ "fixme-play-log-action" <+> pretty xs debug $ "fixme-play-log-action" <+> pretty xs
env <- ask env <- ask
t <- asks fixmeEnvReadLogActions t <- asks fixmeEnvReadLogActions
let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs)) let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs))
atomically $ modifyTVar t (<> [action]) atomically $ modifyTVar t (<> [action])
ListVal (SymbolVal "append-file" : StringLike fn : StringLikeList xs) -> do ListVal (SymbolVal "append-file" : StringLike fn : StringLikeList xs) -> do
debug "append-file" debug "append-file"
liftIO $ for_ xs $ \x -> do liftIO $ for_ xs $ \x -> do
appendFile fn x appendFile fn x
appendFile fn "\n" 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 sto <- compactStorageOpen @HbSync mempty fn
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 (Left{}) -> do for_ what $ \w -> do
put sto k (LBS.toStrict $ serialise w) 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 Just (Left{}) -> do
put sto k (LBS.toStrict $ serialise w) 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 loadAllEntriesFromLog sto >>= runForms
<&> catMaybes
<&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
<&> rights
cleanStage
let top = show $ vcat (fmap pretty entries) compactStorageClose sto
let theLog = parseTop top & fromRight mempty
liftIO $ withFixmeEnv env (runForms theLog) ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do
cleanStage 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 for_ [sa,sb] $ \sto -> do
debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b ks <- keys sto
for_ ks $ \k -> runMaybeT do
v <- get sto k & MaybeT
put r k v
temp <- liftIO $ emptyTempFile "." "merge-result" compactStorageClose r
sa <- compactStorageOpen @HbSync readonly o compactStorageClose sa
sb <- compactStorageOpen @HbSync readonly b compactStorageClose sb
r <- compactStorageOpen @HbSync mempty temp
for_ [sa,sb] $ \sto -> do mv temp target
ks <- keys sto
for_ ks $ \k -> runMaybeT do
v <- get sto k & MaybeT
put r k v
compactStorageClose r ListVal [SymbolVal "no-debug"] -> do
compactStorageClose sa setLoggingOff @DEBUG
compactStorageClose sb
mv temp target ListVal [SymbolVal "silence"] -> do
silence
ListVal [SymbolVal "no-debug"] -> do ListVal [SymbolVal "builtin:evolve"] -> do
setLoggingOff @DEBUG evolve
ListVal [SymbolVal "silence"] -> do ListVal [SymbolVal "builtin:cleanup-state"] -> do
silence cleanupDatabase
ListVal [SymbolVal "builtin:evolve"] -> do ListVal [SymbolVal "builtin:clean-stage"] -> do
evolve cleanStage
ListVal [SymbolVal "builtin:cleanup-state"] -> do ListVal [SymbolVal "builtin:drop-stage"] -> do
cleanupDatabase cleanStage
ListVal [SymbolVal "builtin:clean-stage"] -> do ListVal [SymbolVal "builtin:show-stage"] -> do
cleanStage stage <- selectStage
liftIO $ print $ vcat (fmap pretty stage)
ListVal [SymbolVal "builtin:drop-stage"] -> do ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do
cleanStage sto <- compactStorageOpen @HbSync readonly fn
ListVal [SymbolVal "builtin:show-stage"] -> do ks <- keys sto
stage <- selectStage
liftIO $ print $ vcat (fmap pretty stage)
ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do entries <- mapM (get sto) ks
sto <- compactStorageOpen @HbSync readonly fn <&> catMaybes
<&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
<&> rights
ks <- keys sto liftIO $ print $ vcat (fmap pretty entries)
entries <- mapM (get sto) ks compactStorageClose sto
<&> catMaybes
<&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
<&> rights
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 ListVal [SymbolVal "trace"] -> do
updateIndexes setLogging @TRACE (logPrefix "[trace] " . toStderr)
trace "trace on"
ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do ListVal [SymbolVal "no-trace"] -> do
w <- selectFixmeHash x trace "trace off"
liftIO $ print $ pretty w setLoggingOff @TRACE
ListVal [SymbolVal "trace"] -> do ListVal [SymbolVal "debug"] -> do
setLogging @TRACE (logPrefix "[trace] " . toStderr) setLogging @DEBUG $ toStderr . logPrefix "[debug] "
trace "trace on"
ListVal [SymbolVal "no-trace"] -> do w -> err (pretty w)
trace "trace off"
setLoggingOff @TRACE
ListVal [SymbolVal "debug"] -> do
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
w -> err (pretty w)

76
fixme-new/lib/Fixme/Scan/Git/Local.hs
View File

@ -9,7 +9,10 @@ import Fixme.Prelude hiding (indent)
import Fixme.Types import Fixme.Types
import Fixme.State import Fixme.State
import Fixme.Scan as Scan import Fixme.Scan as Scan
import Fixme.Log
import HBS2.Storage.Compact
import HBS2.System.Dir
import HBS2.Git.Local.CLI import HBS2.Git.Local.CLI
import DBPipe.SQLite hiding (field) import DBPipe.SQLite hiding (field)
@ -34,9 +37,12 @@ import Lens.Micro.Platform
import System.Process.Typed import System.Process.Typed
import Control.Monad.Trans.Cont import Control.Monad.Trans.Cont
import System.IO qualified as IO import System.IO qualified as IO
import System.IO.Temp (emptySystemTempFile)
import Data.Map qualified as Map import Data.Map qualified as Map
import Streaming.Prelude qualified as S
data ScanGitArgs = data ScanGitArgs =
PrintBlobs PrintBlobs
@ -101,6 +107,18 @@ listCommits = do
spec = sq <> delims " \t" 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 :: FixmePerks m => GitHash -> m [(FilePath,GitHash)]
listBlobs co = do listBlobs co = do
-- FIXME: git-dir -- FIXME: git-dir
@ -112,17 +130,63 @@ listBlobs co = do
[a,"blob",h,_,fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h) [a,"blob",h,_,fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h)
_ -> Nothing) _ -> 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 filterBlobs :: FixmePerks m
=> [(FilePath,GitHash)] => [(FilePath,GitHash)]
-> FixmeM m [(FilePath,GitHash)] -> FixmeM m [(FilePath,GitHash)]
filterBlobs xs = do filterBlobs xs = do
pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,) pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,)
let src = [ ((f,h),f) | (f,h) <- xs ] filterBlobs0 pat xs
let r = [(h,f) | (_,(f,h),_) <- matchMany pat src] & HM.fromList & HM.toList
pure $ [ (b,a) | (a,b) <- r ]
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 scanGitLocal :: FixmePerks m
=> [ScanGitArgs] => [ScanGitArgs]
@ -348,6 +412,12 @@ runLogActions = do
updateIndexes 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 :: (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ())
startGitCatFile = do startGitCatFile = do
gd <- fixmeGetGitDirCLIOpt gd <- fixmeGetGitDirCLIOpt

3
hbs2-core/lib/HBS2/System/Dir.hs
View File

@ -75,6 +75,9 @@ fileSize = liftIO . D.getFileSize
mv :: MonadIO m => FilePath -> FilePath -> m () mv :: MonadIO m => FilePath -> FilePath -> m ()
mv a b = liftIO $ D.renamePath a b 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 :: MonadIO m => m FilePath
home = liftIO D.getHomeDirectory home = liftIO D.getHomeDirectory