wip

.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)
 )

fixme-new/fixme.cabal

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

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
+

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

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,12 +372,11 @@ run what = do
 
   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]
          -> FixmeM m ()
-    runForms ss = for_  ss $ \s -> do
+runForms ss = for_  ss $ \s -> do
 
   macros  <- asks fixmeEnvMacro >>= readTVarIO
 
@@ -534,11 +534,15 @@ run what = do
         appendFile  fn x
         appendFile fn "\n"
 
+    ListVal [SymbolVal "play-git-log-file-all", StringLike fn] -> do
+      warn $ red "play-git-log-file-all" <+> pretty fn
+      scanGitLogLocal fn runForms
+
     ListVal [SymbolVal "play-log-file", StringLike fn] -> do
 
       env <- ask
 
-          debug $ red "play-log-file WIP" <+> pretty  fn
+      debug $ red "play-log-file" <+> pretty  fn
 
       what <- selectStage
 
@@ -561,18 +565,8 @@ run what = do
 
       compactStorageCommit sto
 
-          ks <- keys sto
+      loadAllEntriesFromLog sto >>= runForms
 
-          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
-
-          liftIO $ withFixmeEnv env (runForms theLog)
       cleanStage
 
       compactStorageClose sto

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

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