diff options
| -rw-r--r-- | minici.cabal | 2 | ||||
| -rw-r--r-- | src/Command/Run.hs | 13 | ||||
| -rw-r--r-- | src/Job.hs | 22 | ||||
| -rw-r--r-- | src/Repo.hs | 95 |
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 @@ -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 |