Repo module to abstract git accessHEADmaster

4 files changed, 115 insertions, 17 deletions

diff --git a/minici.cabal b/minici.cabal
index 2091053..c91800d 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -52,6 +52,7 @@ executable minici
         Config
         Job
         Paths_minici
+        Repo
         Version
         Version.Git
     autogen-modules:
@@ -69,6 +70,7 @@ executable minici
         MultiParamTypeClasses
         MultiWayIf
         OverloadedStrings
+        RecordWildCards
         ScopedTypeVariables
         TupleSections
         TypeApplications
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index daba8af..729a699 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -19,6 +19,7 @@ import System.Process
 import Command
 import Config
 import Job
+import Repo
 
 data RunCommand = RunCommand Text
 
@@ -55,18 +56,18 @@ cmdRun (RunCommand changeset) = do
         [] -> error "splitOn should not return empty list"
 
     liftIO $ do
-        commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$>
-            readProcess "git" [ "log", "--pretty=oneline", "--first-parent", "--reverse", base <> ".." <> tip ] ""
+        Just repo <- openRepo "."
+        commits <- listCommits repo (base <> ".." <> tip)
 
         putStr $ replicate (8 + 50) ' '
         forM_ (configJobs config) $ \job -> do
             T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job
         putStrLn ""
 
-        forM_ commits $ \(cid, desc) -> do
-            let shortCid = T.pack $ take 7 cid
-            outs <- runJobs "./.minici" cid $ configJobs config
-            displayStatusLine shortCid (" " <> fitToLength 50 (T.pack desc)) outs
+        forM_ commits $ \commit -> do
+            let shortCid = T.pack $ take 7 $ showCommitId $ commitId commit
+            outs <- runJobs "./.minici" commit $ configJobs config
+            displayStatusLine shortCid (" " <> fitToLength 50 (commitDescription commit)) outs
 
 
 fitToLength :: Int -> Text -> Text
diff --git a/src/Job.hs b/src/Job.hs
index 65b614f..ccb8611 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -27,6 +27,9 @@ import System.FilePath
 import System.IO
 import System.Process
 
+import Repo
+
+
 data Job = Job
     { jobName :: JobName
     , jobRecipe :: [CreateProcess]
@@ -93,15 +96,14 @@ textJobStatus = \case
     JobDone _ -> "done"
 
 
-runJobs :: FilePath -> String -> [Job] -> IO [TVar (JobStatus JobOutput)]
-runJobs dir cid jobs = do
+runJobs :: FilePath -> Commit -> [Job] -> IO [TVar (JobStatus JobOutput)]
+runJobs dir commit jobs = do
     results <- forM jobs $ \job -> (job,) <$> newTVarIO JobQueued
-    gitLock <- newMVar ()
     forM_ results $ \(job, outVar) -> void $ forkIO $ do
         res <- runExceptT $ do
             uses <- waitForUsedArtifacts job results outVar
             liftIO $ atomically $ writeTVar outVar JobRunning
-            prepareJob gitLock dir cid job $ \checkoutPath jdir -> do
+            prepareJob dir commit job $ \checkoutPath jdir -> do
                 updateStatusFile (jdir </> "status") outVar
                 runJob job uses checkoutPath jdir
 
@@ -150,18 +152,16 @@ updateStatusFile path outVar = void $ liftIO $ forkIO $ loop Nothing
         T.writeFile path $ textJobStatus status <> "\n"
         when (not (jobStatusFinished status)) $ loop $ Just status
 
-prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => MVar () -> FilePath -> String -> Job -> (FilePath -> FilePath -> m a) -> m a
-prepareJob gitLock dir cid job inner = do
+prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Commit -> Job -> (FilePath -> FilePath -> m a) -> m a
+prepareJob dir commit job inner = do
     [checkoutPath] <- fmap lines $ liftIO $
         readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] ""
 
     flip finally (liftIO $ removeDirectoryRecursive checkoutPath) $ do
-        tid <- liftIO $ withMVar gitLock $ \_ -> do
-            "" <- readProcess "git" ["--work-tree=" <> checkoutPath, "restore", "--source=" <> cid, "--", "."] ""
-            ["tree", tid]:_ <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] ""
-            return tid
+        checkoutAt commit checkoutPath
+        tid <- readTreeId commit
 
-        let jdir = dir </> "jobs" </> tid </> stringJobName (jobName job)
+        let jdir = dir </> "jobs" </> showTreeId tid </> stringJobName (jobName job)
         liftIO $ createDirectoryIfMissing True jdir
 
         inner checkoutPath jdir
diff --git a/src/Repo.hs b/src/Repo.hs
new file mode 100644
index 0000000..9e05ccd
--- /dev/null
+++ b/src/Repo.hs
@@ -0,0 +1,95 @@
+module Repo (
+    Repo(..), Commit(..),
+    CommitId, showCommitId,
+    TreeId, showTreeId,
+
+    openRepo,
+    listCommits,
+    checkoutAt,
+    readTreeId,
+) where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.IO.Class
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BC
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.Process
+
+
+data Repo
+    = GitRepo
+        { gitDir :: FilePath
+        , gitLock :: MVar ()
+        }
+
+data Commit = Commit
+    { commitRepo :: Repo
+    , commitId :: CommitId
+    , commitDescription :: Text
+    }
+
+
+newtype CommitId = CommitId ByteString
+
+showCommitId :: CommitId -> String
+showCommitId (CommitId cid) = BC.unpack cid
+
+newtype TreeId = TreeId ByteString
+
+showTreeId :: TreeId -> String
+showTreeId (TreeId tid) = BC.unpack tid
+
+
+openRepo :: FilePath -> IO (Maybe Repo)
+openRepo path = do
+    findGitDir >>= \case
+        Just gitDir -> do
+            gitLock <- newMVar ()
+            return $ Just GitRepo {..}
+        Nothing -> do
+            return Nothing
+  where
+    tryGitDir gpath = readProcessWithExitCode "git" [ "rev-parse", "--resolve-git-dir", gpath ] "" >>= \case
+        ( ExitSuccess, out, _ ) | dir : _ <- lines out -> return (Just dir)
+        _                                              -> return Nothing
+    findGitDir = do
+        tryGitDir path >>= \case
+            Just dir -> return (Just dir)
+            Nothing  -> tryGitDir (path </> ".git") >>= \case
+                Just dir -> return (Just dir)
+                _        -> return Nothing
+
+
+listCommits :: MonadIO m => Repo -> String -> m [ Commit ]
+listCommits commitRepo range = liftIO $ do
+    out <- readProcess "git" [ "log", "--pretty=oneline", "--first-parent", "--reverse", range ] ""
+    forM (lines out) $ \line -> do
+        let ( cid, desc ) = fmap (drop 1) $ (span (/=' ')) line
+            commitId = CommitId (BC.pack cid)
+            commitDescription = T.pack desc
+        return Commit {..}
+
+
+checkoutAt :: (MonadIO m, MonadFail m) => Commit -> FilePath -> m ()
+checkoutAt Commit {..} dest = do
+    let GitRepo {..} = commitRepo
+    liftIO $ withMVar gitLock $ \_ -> do
+        "" <- readProcess "git" [ "clone", "--quiet", "--shared", "--no-checkout", gitDir, dest ] ""
+        "" <- readProcess "git" [ "-C", dest, "restore", "--worktree", "--source=" <> showCommitId commitId, "--", "." ] ""
+        removeDirectoryRecursive $ dest </> ".git"
+
+
+readTreeId :: (MonadIO m, MonadFail m) => Commit -> m TreeId
+readTreeId Commit {..} = do
+    let GitRepo {..} = commitRepo
+    liftIO $ withMVar gitLock $ \_ -> do
+        [ "tree", tid ] : _ <- map words . lines <$> readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "commit", showCommitId commitId ] ""
+        return $ TreeId $ BC.pack tid