From 03c781c1a60759622e772ac7fb6a167111ed0bea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 21 Dec 2024 13:10:41 +0100 Subject: Repo module to abstract git access --- src/Command/Run.hs | 13 ++++---- src/Job.hs | 22 ++++++------- src/Repo.hs | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 113 insertions(+), 17 deletions(-) create mode 100644 src/Repo.hs (limited to 'src') 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 -- cgit v1.2.3