summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG.md27
-rw-r--r--README.md29
-rw-r--r--minici.cabal16
-rw-r--r--src/Command.hs98
-rw-r--r--src/Command/Checkout.hs58
-rw-r--r--src/Command/JobId.hs39
-rw-r--r--src/Command/Run.hs317
-rw-r--r--src/Config.hs84
-rw-r--r--src/Eval.hs111
-rw-r--r--src/Job.hs290
-rw-r--r--src/Job/Types.hs51
-rw-r--r--src/Main.hs130
-rw-r--r--src/Repo.hs347
-rw-r--r--src/Terminal.hs79
14 files changed, 1463 insertions, 213 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 494e3c8..d54acba 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,32 @@
# Revision history for MiniCI
+## 0.1.6 -- 2025-03-30
+
+* Added `jobid` command resolving job reference to canonical ID
+* Fix copying of used artifacts to appropriate working directory
+
+## 0.1.5 -- 2025-03-20
+
+* Accept job file path on command line
+* Added `checkout` command
+* Reference and checkout other repositories from job file
+* Accept names of jobs to run as command-line arguments
+
+## 0.1.4 -- 2025-02-04
+
+* Fix invocation of `minici run` without arguments
+* Fix that empty temporary dir was not deleted in some cases
+* Add explicit `--since-upstream` option for the `run` command
+
+## 0.1.3 -- 2025-01-25
+
+* Run jobs based on configuration in associated commit
+* Configurable number of concurrently running jobs (using `-j` option)
+* Concurrently run jobs for multiple commits
+* Properly cancel and clean up jobs on user interrupt
+* Added `--new-commits-on` and `--new-tags` options for `run` command to dynamically generate jobs based on branch/tags changes
+* Support for GHC up to 9.12
+
## 0.1.2 -- 2024-07-30
* Explicit run command
diff --git a/README.md b/README.md
index abd0500..0829ed6 100644
--- a/README.md
+++ b/README.md
@@ -11,7 +11,7 @@ Job definition
--------------
The top-level elements of the YAML file are `job <name>` defining steps to
-perform the job and potentially listing artefacts produced or required.
+perform the job and potentially listing artifacts produced or required.
Example:
@@ -52,12 +52,35 @@ To run jobs for a git commit range:
minici run <commit>..<commit>
```
+or:
+```
+minici run --range=<commit>..<commit>
+```
+
To run jobs for commits that are in local `<branch>`, but not yet in its upstream:
```
-minici run <branch>
+minici run --since-upstream=<branch>
```
-For currently branch, the name can be omitted:
+For current branch, the name can be omitted:
```
minici run
```
+
+To run selected jobs with the current working tree, including uncommitted
+changes, list the job names on command line:
+```
+minici run <job name> [<job name> ...]
+```
+
+To watch changes on given `<branch>` and run jobs for each new commit:
+```
+minici run --new-commits-on=<branch>
+```
+
+To watch new tags and run jobs for each tag matching given pattern:
+```
+minici run --new-tags=<pattern>
+```
+
+The above options `--range`, `--since-upstream`, etc can be arbitrarily combined.
diff --git a/minici.cabal b/minici.cabal
index 7f20ac1..aa7561c 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: minici
-version: 0.1.2
+version: 0.1.6
synopsis: Minimalist CI framework to run checks on local machine
description:
Runs defined jobs, for example to build and test a project, for each git
@@ -30,7 +30,7 @@ flag ci
source-repository head
type: git
- location: git://erebosprotocol.net/minici
+ location: https://code.erebosprotocol.net/minici
executable minici
main-is: Main.hs
@@ -48,12 +48,16 @@ executable minici
other-modules:
Command
+ Command.Checkout
+ Command.JobId
Command.Run
Config
+ Eval
Job
Job.Types
Paths_minici
Repo
+ Terminal
Version
Version.Git
autogen-modules:
@@ -82,20 +86,24 @@ executable minici
TemplateHaskell
build-depends:
- base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 },
+ base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 },
bytestring ^>= { 0.10, 0.11, 0.12 },
containers ^>= { 0.6, 0.7 },
directory ^>= { 1.3 },
exceptions ^>= { 0.10 },
filepath ^>= { 1.4, 1.5 },
+ Glob ^>= { 0.10.2 },
+ hinotify ^>= { 0.4 },
HsYAML ^>= { 0.2 },
mtl ^>= { 2.2, 2.3 },
parser-combinators ^>= { 1.3 },
process ^>= { 1.6 },
stm ^>= { 2.5 },
- template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22 },
+ template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 },
+ temporary ^>= { 1.3 },
text ^>= { 1.2, 2.0, 2.1 },
th-compat ^>= { 0.1 },
+ unix ^>= { 2.7.2, 2.8.4 },
hs-source-dirs: src
default-language: Haskell2010
diff --git a/src/Command.hs b/src/Command.hs
index 0ca6710..0d333e8 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -1,21 +1,51 @@
module Command (
+ CommonOptions(..),
+ defaultCommonOptions,
+
Command(..),
CommandArgumentsType(..),
CommandExec(..),
+ tfail,
+ CommandInput(..),
+ getCommonOptions,
+ getConfigPath,
getConfig,
+ getRepo, getDefaultRepo, tryGetDefaultRepo,
+ getEvalInput,
+ getTerminalOutput,
+ getStorageDir,
) where
+import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Reader
import Data.Kind
import Data.Text (Text)
import Data.Text qualified as T
+import Data.Text.IO qualified as T
import System.Console.GetOpt
+import System.Exit
+import System.FilePath
+import System.IO
import Config
+import Eval
+import Repo
+import Terminal
+
+data CommonOptions = CommonOptions
+ { optJobs :: Int
+ , optRepo :: [ DeclaredRepo ]
+ }
+
+defaultCommonOptions :: CommonOptions
+defaultCommonOptions = CommonOptions
+ { optJobs = 2
+ , optRepo = []
+ }
class CommandArgumentsType (CommandArguments c) => Command c where
commandName :: proxy c -> String
@@ -53,9 +83,71 @@ instance CommandArgumentsType (Maybe Text) where
argsFromStrings [str] = return $ Just (T.pack str)
argsFromStrings _ = throwError "expected at most one argument"
+instance CommandArgumentsType [ Text ] where
+ argsFromStrings strs = return $ map T.pack strs
+
+
+newtype CommandExec a = CommandExec (ReaderT CommandInput IO a)
+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
+
+instance MonadFail CommandExec where
+ fail = tfail . T.pack
+
+tfail :: Text -> CommandExec a
+tfail err = liftIO $ do
+ T.hPutStrLn stderr err
+ exitFailure
+
+data CommandInput = CommandInput
+ { ciOptions :: CommonOptions
+ , ciConfigPath :: Maybe FilePath
+ , ciConfig :: Either String Config
+ , ciContainingRepo :: Maybe Repo
+ , ciOtherRepos :: [ ( RepoName, Repo ) ]
+ , ciTerminalOutput :: TerminalOutput
+ , ciStorageDir :: Maybe FilePath
+ }
+
+getCommonOptions :: CommandExec CommonOptions
+getCommonOptions = CommandExec (asks ciOptions)
-newtype CommandExec a = CommandExec (ReaderT Config IO a)
- deriving (Functor, Applicative, Monad, MonadIO)
+getConfigPath :: CommandExec FilePath
+getConfigPath = do
+ CommandExec (asks ciConfigPath) >>= \case
+ Nothing -> tfail $ "no job file found"
+ Just path -> return path
getConfig :: CommandExec Config
-getConfig = CommandExec ask
+getConfig = do
+ CommandExec (asks ciConfig) >>= \case
+ Left err -> fail err
+ Right config -> return config
+
+getRepo :: RepoName -> CommandExec Repo
+getRepo name = do
+ CommandExec (asks (lookup name . ciOtherRepos)) >>= \case
+ Just repo -> return repo
+ Nothing -> tfail $ "repo `" <> textRepoName name <> "' not declared"
+
+getDefaultRepo :: CommandExec Repo
+getDefaultRepo = do
+ tryGetDefaultRepo >>= \case
+ Just repo -> return repo
+ Nothing -> tfail $ "no default repo"
+
+tryGetDefaultRepo :: CommandExec (Maybe Repo)
+tryGetDefaultRepo = CommandExec $ asks ciContainingRepo
+
+getEvalInput :: CommandExec EvalInput
+getEvalInput = CommandExec $ do
+ eiContainingRepo <- asks ciContainingRepo
+ eiOtherRepos <- asks ciOtherRepos
+ return EvalInput {..}
+
+getTerminalOutput :: CommandExec TerminalOutput
+getTerminalOutput = CommandExec (asks ciTerminalOutput)
+
+getStorageDir :: CommandExec FilePath
+getStorageDir = CommandExec (asks ciStorageDir) >>= \case
+ Just dir -> return dir
+ Nothing -> ((</> ".minici") . takeDirectory) <$> getConfigPath
diff --git a/src/Command/Checkout.hs b/src/Command/Checkout.hs
new file mode 100644
index 0000000..7cba593
--- /dev/null
+++ b/src/Command/Checkout.hs
@@ -0,0 +1,58 @@
+module Command.Checkout (
+ CheckoutCommand,
+) where
+
+import Data.Maybe
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import System.Console.GetOpt
+
+import Command
+import Repo
+
+
+data CheckoutCommand = CheckoutCommand CheckoutOptions (Maybe RepoName) (Maybe Text)
+
+data CheckoutOptions = CheckoutOptions
+ { coDestination :: Maybe FilePath
+ , coSubtree :: Maybe FilePath
+ }
+
+instance Command CheckoutCommand where
+ commandName _ = "checkout"
+ commandDescription _ = "Checkout (part of) a given repository"
+
+ type CommandArguments CheckoutCommand = [ Text ]
+
+ commandUsage _ = T.pack $ unlines $
+ [ "Usage: minici checkout [<repo> [<revision>]] [<option>...]"
+ ]
+
+ type CommandOptions CheckoutCommand = CheckoutOptions
+ defaultCommandOptions _ = CheckoutOptions
+ { coDestination = Nothing
+ , coSubtree = Nothing
+ }
+
+ commandOptions _ =
+ [ Option [] [ "dest" ]
+ (ReqArg (\val opts -> opts { coDestination = Just val }) "<path>")
+ "destination path"
+ , Option [] [ "subtree" ]
+ (ReqArg (\val opts -> opts { coSubtree = Just val }) "<path>")
+ "repository subtree to checkout"
+ ]
+
+ commandInit _ co args = CheckoutCommand co
+ (RepoName <$> listToMaybe args)
+ (listToMaybe $ drop 1 args)
+ commandExec = cmdCheckout
+
+cmdCheckout :: CheckoutCommand -> CommandExec ()
+cmdCheckout (CheckoutCommand CheckoutOptions {..} name mbrev) = do
+ repo <- maybe getDefaultRepo getRepo name
+ mbCommit <- sequence $ fmap (readCommit repo) mbrev
+ root <- getCommitTree =<< maybe (createWipCommit repo) return mbCommit
+ tree <- maybe return (getSubtree mbCommit) coSubtree $ root
+ checkoutAt tree $ maybe "." id coDestination
diff --git a/src/Command/JobId.hs b/src/Command/JobId.hs
new file mode 100644
index 0000000..9f531d6
--- /dev/null
+++ b/src/Command/JobId.hs
@@ -0,0 +1,39 @@
+module Command.JobId (
+ JobIdCommand,
+) where
+
+import Control.Monad.IO.Class
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import Command
+import Eval
+import Job.Types
+
+
+data JobIdCommand = JobIdCommand JobRef
+
+instance Command JobIdCommand where
+ commandName _ = "jobid"
+ commandDescription _ = "Resolve job reference to canonical job ID"
+
+ type CommandArguments JobIdCommand = Text
+
+ commandUsage _ = T.pack $ unlines $
+ [ "Usage: minici jobid <job ref>"
+ ]
+
+ commandInit _ _ = JobIdCommand . JobRef . T.splitOn "."
+ commandExec = cmdJobId
+
+
+cmdJobId :: JobIdCommand -> CommandExec ()
+cmdJobId (JobIdCommand ref) = do
+ config <- getConfig
+ einput <- getEvalInput
+ JobId ids <- either (tfail . textEvalError) return =<<
+ liftIO (runEval (evalJobReference config ref) einput)
+
+ liftIO $ T.putStrLn $ T.intercalate "." $ map textJobIdPart ids
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index 73baee0..905204e 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -4,80 +4,277 @@ module Command.Run (
import Control.Concurrent
import Control.Concurrent.STM
+import Control.Exception
import Control.Monad
-import Control.Monad.Reader
+import Control.Monad.IO.Class
+import Data.Either
import Data.List
-import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
-import System.Exit
+import System.Console.GetOpt
+import System.FilePath.Glob
import System.IO
-import System.Process
import Command
import Config
+import Eval
import Job
import Repo
+import Terminal
-data RunCommand = RunCommand Text
+
+data RunCommand = RunCommand RunOptions [ Text ]
+
+data RunOptions = RunOptions
+ { roRanges :: [ Text ]
+ , roSinceUpstream :: [ Text ]
+ , roNewCommitsOn :: [ Text ]
+ , roNewTags :: [ Pattern ]
+ }
instance Command RunCommand where
commandName _ = "run"
commandDescription _ = "Execude jobs per minici.yaml for given commits"
- type CommandArguments RunCommand = Maybe Text
+ type CommandArguments RunCommand = [ Text ]
commandUsage _ = T.pack $ unlines $
[ "Usage: minici run"
, " run jobs for commits on current branch not yet in upstream branch"
- , " or: minici run <ref>"
- , " run jobs for commits on <ref> not yet in its upstream ref"
- , " or: minici run <commit>..<commit>"
+ , " or: minici run <job>..."
+ , " run jobs specified on the command line"
+ , " or: minici run [--range=]<commit>..<commit>"
, " run jobs for commits in given range"
+ , " or: minici run <option>..."
+ , " run jobs based on given options (see below)"
+ ]
+
+ type CommandOptions RunCommand = RunOptions
+ defaultCommandOptions _ = RunOptions
+ { roRanges = []
+ , roSinceUpstream = []
+ , roNewCommitsOn = []
+ , roNewTags = []
+ }
+
+ commandOptions _ =
+ [ Option [] [ "range" ]
+ (ReqArg (\val opts -> opts { roRanges = T.pack val : roRanges opts }) "<range>")
+ "run jobs for commits in given range"
+ , Option [] [ "since-upstream" ]
+ (ReqArg (\val opts -> opts { roSinceUpstream = T.pack val : roSinceUpstream opts }) "<ref>")
+ "run jobs for commits on <ref> not yet in its upstream ref"
+ , Option [] [ "new-commits-on" ]
+ (ReqArg (\val opts -> opts { roNewCommitsOn = T.pack val : roNewCommitsOn opts }) "<branch>")
+ "run jobs for new commits on given branch"
+ , Option [] [ "new-tags" ]
+ (ReqArg (\val opts -> opts { roNewTags = compile val : roNewTags opts }) "<pattern>")
+ "run jobs for new annotated tags matching pattern"
]
- commandInit _ _ = RunCommand . fromMaybe "HEAD"
+ commandInit _ = RunCommand
commandExec = cmdRun
+
+data JobSource = JobSource (TMVar (Maybe ( [ JobSet ], JobSource )))
+
+emptyJobSource :: MonadIO m => m JobSource
+emptyJobSource = JobSource <$> liftIO (newTMVarIO Nothing)
+
+oneshotJobSource :: MonadIO m => [ JobSet ] -> m JobSource
+oneshotJobSource jobsets = do
+ next <- emptyJobSource
+ JobSource <$> liftIO (newTMVarIO (Just ( jobsets, next )))
+
+takeJobSource :: JobSource -> STM (Maybe ( [ JobSet ], JobSource ))
+takeJobSource (JobSource tmvar) = takeTMVar tmvar
+
+mergeSources :: [ JobSource ] -> IO JobSource
+mergeSources sources = do
+ let go tmvar [] = do
+ atomically (putTMVar tmvar Nothing)
+ go tmvar cur = do
+ ( jobsets, next ) <- atomically (select cur)
+ if null next
+ then do
+ go tmvar next
+ else do
+ nextvar <- newEmptyTMVarIO
+ atomically $ putTMVar tmvar (Just ( jobsets, JobSource nextvar ))
+ go nextvar next
+
+ tmvar <- newEmptyTMVarIO
+ void $ forkIO $ go tmvar sources
+ return $ JobSource tmvar
+
+ where
+ select :: [ JobSource ] -> STM ( [ JobSet ], [ JobSource ] )
+ select [] = retry
+ select (x@(JobSource tmvar) : xs) = do
+ tryTakeTMVar tmvar >>= \case
+ Nothing -> fmap (x :) <$> select xs
+ Just Nothing -> return ( [], xs )
+ Just (Just ( jobsets, x' )) -> return ( jobsets, x' : xs )
+
+
+argumentJobSource :: [ JobName ] -> CommandExec JobSource
+argumentJobSource [] = emptyJobSource
+argumentJobSource names = do
+ config <- getConfig
+ einput <- getEvalInput
+ jobsetJobsEither <- fmap Right $ forM names $ \name ->
+ case find ((name ==) . jobName) (configJobs config) of
+ Just job -> return job
+ Nothing -> tfail $ "job `" <> textJobName name <> "' not found"
+ jobsetCommit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo
+ oneshotJobSource [ evalJobSet einput JobSet {..} ]
+
+rangeSource :: Text -> Text -> CommandExec JobSource
+rangeSource base tip = do
+ repo <- getDefaultRepo
+ einput <- getEvalInput
+ commits <- listCommits repo (base <> ".." <> tip)
+ oneshotJobSource . map (evalJobSet einput) =<< mapM loadJobSetForCommit commits
+
+watchBranchSource :: Text -> CommandExec JobSource
+watchBranchSource branch = do
+ repo <- getDefaultRepo
+ einput <- getEvalInput
+ getCurrentTip <- watchBranch repo branch
+ let go prev tmvar = do
+ cur <- atomically $ do
+ getCurrentTip >>= \case
+ Just cur -> do
+ when (cur == prev) retry
+ return cur
+ Nothing -> retry
+
+ commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur))
+ jobsets <- map (evalJobSet einput) <$> mapM loadJobSetForCommit commits
+ nextvar <- newEmptyTMVarIO
+ atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar )
+ go cur nextvar
+
+ liftIO $ do
+ tmvar <- newEmptyTMVarIO
+ atomically getCurrentTip >>= \case
+ Just commit ->
+ void $ forkIO $ go commit tmvar
+ Nothing -> do
+ T.hPutStrLn stderr $ "Branch `" <> branch <> "' not found"
+ atomically $ putTMVar tmvar Nothing
+ return $ JobSource tmvar
+
+watchTagSource :: Pattern -> CommandExec JobSource
+watchTagSource pat = do
+ chan <- watchTags =<< getDefaultRepo
+ einput <- getEvalInput
+
+ let go tmvar = do
+ tag <- atomically $ readTChan chan
+ if match pat $ T.unpack $ tagTag tag
+ then do
+ jobset <- evalJobSet einput <$> loadJobSetForCommit (tagObject tag)
+ nextvar <- newEmptyTMVarIO
+ atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar )
+ go nextvar
+ else do
+ go tmvar
+
+ liftIO $ do
+ tmvar <- newEmptyTMVarIO
+ void $ forkIO $ go tmvar
+ return $ JobSource tmvar
+
cmdRun :: RunCommand -> CommandExec ()
-cmdRun (RunCommand changeset) = do
- ( base, tip ) <- case T.splitOn (T.pack "..") changeset of
- base : tip : _ -> return ( T.unpack base, T.unpack tip )
- [ param ] -> liftIO $ do
- [ deref ] <- readProcessWithExitCode "git" [ "symbolic-ref", "--quiet", T.unpack param ] "" >>= \case
- ( ExitSuccess, out, _ ) -> return $ lines out
- ( _, _, _ ) -> return [ T.unpack param ]
- [ _, tip ] : _ <- fmap words . lines <$> readProcess "git" [ "show-ref", deref ] ""
- [ base ] <- lines <$> readProcess "git" [ "for-each-ref", "--format=%(upstream)", tip ] ""
- return ( base, tip )
- [] -> error "splitOn should not return empty list"
+cmdRun (RunCommand RunOptions {..} args) = do
+ CommonOptions {..} <- getCommonOptions
+ tout <- getTerminalOutput
+ storageDir <- getStorageDir
+
+ ( rangeOptions, jobOptions ) <- partitionEithers . concat <$> sequence
+ [ forM roRanges $ \range -> case T.splitOn ".." range of
+ [ base, tip ] -> return $ Left ( Just base, tip )
+ _ -> tfail $ "invalid range: " <> range
+ , forM roSinceUpstream $ return . Left . ( Nothing, )
+ , forM args $ \arg -> case T.splitOn ".." arg of
+ [ base, tip ] -> return $ Left ( Just base, tip )
+ [ _ ] -> do
+ config <- getConfig
+ if any ((JobName arg ==) . jobName) (configJobs config)
+ then return $ Right $ JobName arg
+ else do
+ liftIO $ T.hPutStrLn stderr $ "standalone `" <> arg <> "' argument deprecated, use `--since-upstream=" <> arg <> "' instead"
+ return $ Left ( Nothing, arg )
+ _ -> tfail $ "invalid argument: " <> arg
+ ]
+
+ argumentJobs <- argumentJobSource jobOptions
+
+ let rangeOptions'
+ | null rangeOptions, null roNewCommitsOn, null roNewTags, null jobOptions = [ ( Nothing, "HEAD" ) ]
+ | otherwise = rangeOptions
+
+ ranges <- forM rangeOptions' $ \( mbBase, paramTip ) -> do
+ ( base, tip ) <- case mbBase of
+ Just base -> return ( base, paramTip )
+ Nothing -> do
+ Just base <- flip findUpstreamRef paramTip =<< getDefaultRepo
+ return ( base, paramTip )
+ rangeSource base tip
+
+ branches <- mapM watchBranchSource roNewCommitsOn
+ tags <- mapM watchTagSource roNewTags
liftIO $ do
- Just repo <- openRepo "."
- commits <- listCommits repo (base <> ".." <> tip)
- jobssets <- mapM loadJobSetForCommit commits
- let names = nub $ map jobName $ concatMap jobsetJobs jobssets
-
- putStr $ replicate (8 + 50) ' '
- forM_ names $ \name -> do
- T.putStr $ (" "<>) $ fitToLength 7 $ textJobName name
- putStrLn ""
-
- forM_ jobssets $ \jobset -> do
- let commit = jobsetCommit jobset
- shortCid = T.pack $ take 7 $ showCommitId $ commitId commit
- shortDesc = fitToLength 50 (commitDescription commit)
- case jobsetJobsEither jobset of
- Right jobs -> do
- outs <- runJobs "./.minici" commit jobs
- let findJob name = snd <$> find ((name ==) . jobName . fst) outs
- displayStatusLine shortCid (" " <> shortDesc) $ map findJob names
- Left err -> do
- T.putStrLn $ "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m"
- hFlush stdout
+ mngr <- newJobManager storageDir optJobs
+
+ source <- mergeSources $ concat [ [ argumentJobs ], ranges, branches, tags ]
+ headerLine <- newLine tout ""
+
+ threadCount <- newTVarIO (0 :: Int)
+ let changeCount f = atomically $ do
+ writeTVar threadCount . f =<< readTVar threadCount
+ let waitForJobs = atomically $ do
+ flip when retry . (0 <) =<< readTVar threadCount
+
+ let loop _ Nothing = return ()
+ loop names (Just ( [], next )) = do
+ loop names =<< atomically (takeJobSource next)
+
+ loop pnames (Just ( jobset : rest, next )) = do
+ let names = nub $ (pnames ++) $ map jobName $ jobsetJobs jobset
+ when (names /= pnames) $ do
+ redrawLine headerLine $ T.concat $
+ T.replicate (8 + 50) " " :
+ map ((" " <>) . fitToLength 7 . textJobName) names
+
+ let commit = jobsetCommit jobset
+ shortCid = T.pack $ take 7 $ maybe (repeat ' ') (showCommitId . commitId) commit
+ shortDesc <- fitToLength 50 <$> maybe (return "") getCommitTitle commit
+
+ case jobsetJobsEither jobset of
+ Right jobs -> do
+ outs <- runJobs mngr tout commit jobs
+ let findJob name = snd <$> find ((name ==) . jobName . fst) outs
+ line <- newLine tout ""
+ mask $ \restore -> do
+ changeCount (+ 1)
+ void $ forkIO $ (>> changeCount (subtract 1)) $
+ try @SomeException $ restore $ do
+ displayStatusLine tout line shortCid (" " <> shortDesc) $ map findJob names
+ Left err -> do
+ void $ newLine tout $
+ "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m"
+ loop names (Just ( rest, next ))
+
+ handle @SomeException (\_ -> cancelAllJobs mngr) $ do
+ loop [] =<< atomically (takeJobSource source)
+ waitForJobs
+ waitForJobs
fitToLength :: Int -> Text -> Text
@@ -91,33 +288,35 @@ showStatus blink = \case
JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
JobSkipped -> "\ESC[0m-\ESC[0m "
JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m "
- JobError _ -> "\ESC[91m!!\ESC[0m "
+ JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (show (footnoteNumber fnote)) <> "]") <> "\ESC[0m"
JobFailed -> "\ESC[91m✗\ESC[0m "
+ JobCancelled -> "\ESC[0mC\ESC[0m "
JobDone _ -> "\ESC[92m✓\ESC[0m "
-displayStatusLine :: Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO ()
-displayStatusLine prefix1 prefix2 statuses = do
- blinkVar <- newTVarIO False
- t <- forkIO $ forever $ do
- threadDelay 500000
- atomically $ writeTVar blinkVar . not =<< readTVar blinkVar
- go blinkVar "\0"
- killThread t
+ JobDuplicate _ s -> case s of
+ JobQueued -> "\ESC[94m^\ESC[0m "
+ JobWaiting _ -> "\ESC[94m^\ESC[0m "
+ JobSkipped -> "\ESC[0m-\ESC[0m "
+ JobRunning -> "\ESC[96m" <> (if blink then "*" else "^") <> "\ESC[0m "
+ _ -> showStatus blink s
+
+displayStatusLine :: TerminalOutput -> TerminalLine -> Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO ()
+displayStatusLine tout line prefix1 prefix2 statuses = do
+ go "\0"
where
- go blinkVar prev = do
+ go prev = do
(ss, cur) <- atomically $ do
ss <- mapM (sequence . fmap readTVar) statuses
- blink <- readTVar blinkVar
+ blink <- terminalBlinkStatus tout
let cur = T.concat $ map (maybe " " ((" " <>) . showStatus blink)) ss
when (cur == prev) retry
return (ss, cur)
- when (not $ T.null prev) $ putStr "\r"
+
let prefix1' = if any (maybe False jobStatusFailed) ss
then "\ESC[91m" <> prefix1 <> "\ESC[0m"
else prefix1
- T.putStr $ prefix1' <> prefix2 <> cur
- hFlush stdout
+ redrawLine line $ prefix1' <> prefix2 <> cur
if all (maybe True jobStatusFinished) ss
- then T.putStrLn ""
- else go blinkVar cur
+ then return ()
+ else go cur
diff --git a/src/Config.hs b/src/Config.hs
index a24ee56..5631179 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -9,8 +9,10 @@ module Config (
import Control.Monad
import Control.Monad.Combinators
+import Control.Monad.IO.Class
import Data.ByteString.Lazy qualified as BS
+import Data.Either
import Data.List
import Data.Map qualified as M
import Data.Maybe
@@ -21,6 +23,7 @@ import Data.YAML
import System.Directory
import System.FilePath
+import System.FilePath.Glob
import System.Process
import Job.Types
@@ -32,17 +35,20 @@ configFileName = "minici.yaml"
data Config = Config
- { configJobs :: [Job]
+ { configJobs :: [ DeclaredJob ]
+ , configRepos :: [ DeclaredRepo ]
}
instance Semigroup Config where
a <> b = Config
{ configJobs = configJobs a ++ configJobs b
+ , configRepos = configRepos a ++ configRepos b
}
instance Monoid Config where
mempty = Config
{ configJobs = []
+ , configRepos = []
}
instance FromYAML Config where
@@ -51,21 +57,48 @@ instance FromYAML Config where
(Mapping pos _ _, _) -> pos
(Sequence pos _ _, _) -> pos
(Anchor pos _ _, _) -> pos
- jobs <- fmap catMaybes $ forM (sortBy (comparing $ posLine . getpos) $ M.assocs m) $ \case
- (Scalar _ (SStr tag), node) | ["job", name] <- T.words tag -> do
- Just <$> parseJob name node
- _ -> return Nothing
- return $ Config jobs
-
-parseJob :: Text -> Node Pos -> Parser Job
-parseJob name node = flip (withMap "Job") node $ \j -> Job
- <$> pure (JobName name)
- <*> choice
+ foldM go mempty $ sortBy (comparing $ posLine . getpos) $ M.assocs m
+ where
+ go config = \case
+ (Scalar _ (SStr tag), node)
+ | [ "job", name ] <- T.words tag -> do
+ job <- parseJob name node
+ return $ config { configJobs = configJobs config ++ [ job ] }
+ | [ "repo", name ] <- T.words tag -> do
+ repo <- parseRepo name node
+ return $ config { configRepos = configRepos config ++ [ repo ] }
+ _ -> return config
+
+parseJob :: Text -> Node Pos -> Parser DeclaredJob
+parseJob name node = flip (withMap "Job") node $ \j -> do
+ let jobName = JobName name
+ ( jobContainingCheckout, jobOtherCheckout ) <- partitionEithers <$> choice
+ [ parseSingleCheckout =<< j .: "checkout"
+ , parseMultipleCheckouts =<< j .: "checkout"
+ , withNull "no checkout" (return []) =<< j .: "checkout"
+ , return [ Left $ JobCheckout Nothing Nothing ]
+ ]
+ jobRecipe <- choice
[ cabalJob =<< j .: "cabal"
, shellJob =<< j .: "shell"
]
- <*> parseArtifacts j
- <*> (maybe (return []) parseUses =<< j .:? "uses")
+ jobArtifacts <- parseArtifacts j
+ jobUses <- maybe (return []) parseUses =<< j .:? "uses"
+ return Job {..}
+
+parseSingleCheckout :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, Maybe Text, JobCheckout ) ]
+parseSingleCheckout = withMap "checkout definition" $ \m -> do
+ jcSubtree <- fmap T.unpack <$> m .:? "subtree"
+ jcDestination <- fmap T.unpack <$> m .:? "dest"
+ let checkout = JobCheckout {..}
+ m .:? "repo" >>= \case
+ Nothing -> return [ Left checkout ]
+ Just name -> do
+ revision <- m .:? "revision"
+ return [ Right ( DeclaredJobRepo (RepoName name), revision, checkout ) ]
+
+parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, Maybe Text, JobCheckout ) ]
+parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout
cabalJob :: Node Pos -> Parser [CreateProcess]
cabalJob = withMap "cabal job" $ \m -> do
@@ -80,7 +113,7 @@ shellJob :: Node Pos -> Parser [CreateProcess]
shellJob = withSeq "shell commands" $ \xs -> do
fmap (map shell) $ forM xs $ withStr "shell command" $ return . T.unpack
-parseArtifacts :: Mapping Pos -> Parser [(ArtifactName, CreateProcess)]
+parseArtifacts :: Mapping Pos -> Parser [ ( ArtifactName, Pattern ) ]
parseArtifacts m = do
fmap catMaybes $ forM (M.assocs m) $ \case
(Scalar _ (SStr tag), node) | ["artifact", name] <- T.words tag -> do
@@ -88,8 +121,8 @@ parseArtifacts m = do
_ -> return Nothing
where
parseArtifact name = withMap "Artifact" $ \am -> do
- path <- am .: "path"
- return (ArtifactName name, proc "echo" [ T.unpack path ])
+ pat <- compile . T.unpack <$> am .: "path"
+ return ( ArtifactName name, pat )
parseUses :: Node Pos -> Parser [(JobName, ArtifactName)]
parseUses = withSeq "Uses list" $ mapM $
@@ -97,6 +130,13 @@ parseUses = withSeq "Uses list" $ mapM $
[job, art] <- return $ T.split (== '.') text
return (JobName job, ArtifactName art)
+
+parseRepo :: Text -> Node Pos -> Parser DeclaredRepo
+parseRepo name node = flip (withMap "Repo") node $ \r -> DeclaredRepo
+ <$> pure (RepoName name)
+ <*> (T.unpack <$> r .: "path")
+
+
findConfig :: IO (Maybe FilePath)
findConfig = go "."
where
@@ -117,16 +157,16 @@ parseConfig contents = do
Left $ prettyPosWithSource pos contents err
Right conf -> Right conf
-loadConfigForCommit :: Commit -> IO (Either String Config)
-loadConfigForCommit commit = do
- readCommittedFile commit configFileName >>= return . \case
+loadConfigForCommit :: MonadIO m => Tree -> m (Either String Config)
+loadConfigForCommit tree = do
+ readCommittedFile tree configFileName >>= return . \case
Just content -> either (\_ -> Left $ "failed to parse " <> configFileName) Right $ parseConfig content
Nothing -> Left $ configFileName <> " not found"
-loadJobSetForCommit :: Commit -> IO JobSet
-loadJobSetForCommit commit = toJobSet <$> loadConfigForCommit commit
+loadJobSetForCommit :: (MonadIO m, MonadFail m) => Commit -> m DeclaredJobSet
+loadJobSetForCommit commit = return . toJobSet =<< loadConfigForCommit =<< getCommitTree commit
where
toJobSet configEither = JobSet
- { jobsetCommit = commit
+ { jobsetCommit = Just commit
, jobsetJobsEither = fmap configJobs configEither
}
diff --git a/src/Eval.hs b/src/Eval.hs
new file mode 100644
index 0000000..1828468
--- /dev/null
+++ b/src/Eval.hs
@@ -0,0 +1,111 @@
+module Eval (
+ EvalInput(..),
+ EvalError(..), textEvalError,
+ Eval, runEval,
+
+ evalJob,
+ evalJobSet,
+ evalJobReference,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+
+import Data.Bifunctor
+import Data.List
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Config
+import Job.Types
+import Repo
+
+data EvalInput = EvalInput
+ { eiContainingRepo :: Maybe Repo
+ , eiOtherRepos :: [ ( RepoName, Repo ) ]
+ }
+
+data EvalError
+ = OtherEvalError Text
+
+textEvalError :: EvalError -> Text
+textEvalError (OtherEvalError text) = text
+
+
+type Eval a = ReaderT EvalInput (ExceptT EvalError IO) a
+
+runEval :: Eval a -> EvalInput -> IO (Either EvalError a)
+runEval action einput = runExceptT $ flip runReaderT einput action
+
+
+evalJob :: EvalInput -> DeclaredJob -> Except EvalError Job
+evalJob EvalInput {..} decl = do
+ otherCheckout <- forM (jobOtherCheckout decl) $ \( DeclaredJobRepo name, revision, checkout ) -> do
+ repo <- maybe (throwError $ OtherEvalError $ "repo `" <> textRepoName name <> "' not defined") return $
+ lookup name eiOtherRepos
+ return ( EvaluatedJobRepo repo, revision, checkout )
+ return Job
+ { jobName = jobName decl
+ , jobContainingCheckout = jobContainingCheckout decl
+ , jobOtherCheckout = otherCheckout
+ , jobRecipe = jobRecipe decl
+ , jobArtifacts = jobArtifacts decl
+ , jobUses = jobUses decl
+ }
+
+evalJobSet :: EvalInput -> DeclaredJobSet -> JobSet
+evalJobSet ei decl = do
+ JobSet
+ { jobsetCommit = jobsetCommit decl
+ , jobsetJobsEither = join $
+ fmap (sequence . map (runExceptStr . evalJob ei)) $
+ jobsetJobsEither decl
+ }
+ where
+ runExceptStr = first (T.unpack . textEvalError) . runExcept
+
+
+canonicalJobName :: [ Text ] -> Config -> Eval [ JobIdPart ]
+canonicalJobName (r : rs) config = do
+ einput <- ask
+ let name = JobName r
+ case find ((name ==) . jobName) (configJobs config) of
+ Just djob -> do
+ job <- either throwError return $ runExcept $ evalJob einput djob
+ let repos = nub $ map (\( EvaluatedJobRepo repo, _, _ ) -> repo) $ jobOtherCheckout job
+ (JobIdName name :) <$> canonicalOtherCheckouts rs repos
+ Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found"
+canonicalJobName [] _ = throwError $ OtherEvalError "expected job name"
+
+canonicalOtherCheckouts :: [ Text ] -> [ Repo ] -> Eval [ JobIdPart ]
+canonicalOtherCheckouts (r : rs) (repo : repos) = do
+ tree <- tryReadCommit repo r >>= \case
+ Just commit -> getCommitTree commit
+ Nothing -> tryReadTree repo r >>= \case
+ Just tree -> return tree
+ Nothing -> throwError $ OtherEvalError $ "failed to resolve ‘" <> r <> "’ to a commit or tree in " <> T.pack (show repo)
+ (JobIdTree (treeId tree) :) <$> canonicalOtherCheckouts rs repos
+canonicalOtherCheckouts [] [] = return []
+canonicalOtherCheckouts [] (_ : _ ) = throwError $ OtherEvalError $ "expected commit or tree reference"
+canonicalOtherCheckouts (r : _) [] = throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r <> "’"
+
+canonicalCommitConfig :: [ Text ] -> Repo -> Eval [ JobIdPart ]
+canonicalCommitConfig (r : rs) repo = do
+ tree <- tryReadCommit repo r >>= \case
+ Just commit -> getCommitTree commit
+ Nothing -> tryReadTree repo r >>= \case
+ Just tree -> return tree
+ Nothing -> throwError $ OtherEvalError $ "failed to resolve ‘" <> r <> "’ to a commit or tree in " <> T.pack (show repo)
+ config <- either fail return =<< loadConfigForCommit tree
+ (JobIdTree (treeId tree) :) <$> canonicalJobName rs config
+canonicalCommitConfig [] _ = throwError $ OtherEvalError "expected commit or tree reference"
+
+evalJobReference :: Config -> JobRef -> Eval JobId
+evalJobReference config (JobRef rs) =
+ fmap JobId $ do
+ asks eiContainingRepo >>= \case
+ Just defRepo -> do
+ canonicalCommitConfig rs defRepo
+ Nothing -> do
+ canonicalJobName rs config
diff --git a/src/Job.hs b/src/Job.hs
index 068a076..a9effba 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -1,11 +1,12 @@
module Job (
- Job(..),
- JobSet(..), jobsetJobs,
+ Job, DeclaredJob, Job'(..),
+ JobSet, DeclaredJobSet, JobSet'(..), jobsetJobs,
JobOutput(..),
JobName(..), stringJobName, textJobName,
ArtifactName(..),
JobStatus(..),
jobStatusFinished, jobStatusFailed,
+ JobManager(..), newJobManager, cancelAllJobs,
runJobs,
) where
@@ -18,6 +19,11 @@ import Control.Monad.Except
import Control.Monad.IO.Class
import Data.List
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Set (Set)
+import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
@@ -25,11 +31,15 @@ import Data.Text.IO qualified as T
import System.Directory
import System.Exit
import System.FilePath
+import System.FilePath.Glob
import System.IO
+import System.IO.Temp
+import System.Posix.Signals
import System.Process
import Job.Types
import Repo
+import Terminal
data JobOutput = JobOutput
@@ -47,70 +57,207 @@ data ArtifactOutput = ArtifactOutput
data JobStatus a = JobQueued
+ | JobDuplicate JobId (JobStatus a)
| JobWaiting [JobName]
| JobRunning
| JobSkipped
- | JobError Text
+ | JobError TerminalFootnote
| JobFailed
+ | JobCancelled
| JobDone a
deriving (Eq)
jobStatusFinished :: JobStatus a -> Bool
jobStatusFinished = \case
- JobQueued {} -> False
- JobWaiting {} -> False
- JobRunning {} -> False
- _ -> True
+ JobQueued {} -> False
+ JobDuplicate _ s -> jobStatusFinished s
+ JobWaiting {} -> False
+ JobRunning {} -> False
+ _ -> True
jobStatusFailed :: JobStatus a -> Bool
jobStatusFailed = \case
- JobError {} -> True
- JobFailed {} -> True
- _ -> False
+ JobDuplicate _ s -> jobStatusFailed s
+ JobError {} -> True
+ JobFailed {} -> True
+ _ -> False
textJobStatus :: JobStatus a -> Text
textJobStatus = \case
JobQueued -> "queued"
+ JobDuplicate {} -> "duplicate"
JobWaiting _ -> "waiting"
JobRunning -> "running"
JobSkipped -> "skipped"
- JobError err -> "error\n" <> err
+ JobError err -> "error\n" <> footnoteText err
JobFailed -> "failed"
+ JobCancelled -> "cancelled"
JobDone _ -> "done"
-runJobs :: FilePath -> Commit -> [Job] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
-runJobs dir commit jobs = do
- results <- forM jobs $ \job -> (job,) <$> newTVarIO JobQueued
- forM_ results $ \(job, outVar) -> void $ forkIO $ do
- res <- runExceptT $ do
- uses <- waitForUsedArtifacts job results outVar
- liftIO $ atomically $ writeTVar outVar JobRunning
- prepareJob dir commit job $ \checkoutPath jdir -> do
- updateStatusFile (jdir </> "status") outVar
- runJob job uses checkoutPath jdir
+data JobManager = JobManager
+ { jmSemaphore :: TVar Int
+ , jmDataDir :: FilePath
+ , jmJobs :: TVar (Map JobId (TVar (JobStatus JobOutput)))
+ , jmNextTaskId :: TVar TaskId
+ , jmNextTask :: TVar (Maybe TaskId)
+ , jmReadyTasks :: TVar (Set TaskId)
+ , jmRunningTasks :: TVar (Map TaskId ThreadId)
+ , jmCancelled :: TVar Bool
+ }
+
+newtype TaskId = TaskId Int
+ deriving (Eq, Ord)
+
+data JobCancelledException = JobCancelledException
+ deriving (Show)
+
+instance Exception JobCancelledException
+
+
+newJobManager :: FilePath -> Int -> IO JobManager
+newJobManager jmDataDir queueLen = do
+ jmSemaphore <- newTVarIO queueLen
+ jmJobs <- newTVarIO M.empty
+ jmNextTaskId <- newTVarIO (TaskId 0)
+ jmNextTask <- newTVarIO Nothing
+ jmReadyTasks <- newTVarIO S.empty
+ jmRunningTasks <- newTVarIO M.empty
+ jmCancelled <- newTVarIO False
+ return JobManager {..}
+
+cancelAllJobs :: JobManager -> IO ()
+cancelAllJobs JobManager {..} = do
+ threads <- atomically $ do
+ writeTVar jmCancelled True
+ M.elems <$> readTVar jmRunningTasks
+
+ mapM_ (`throwTo` JobCancelledException) threads
+
+reserveTaskId :: JobManager -> STM TaskId
+reserveTaskId JobManager {..} = do
+ tid@(TaskId n) <- readTVar jmNextTaskId
+ writeTVar jmNextTaskId (TaskId (n + 1))
+ return tid
+
+runManagedJob :: (MonadIO m, MonadMask m) => JobManager -> TaskId -> m a -> m a -> m a
+runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case
+ True -> cancel
+ False -> job
+ where
+ acquire = liftIO $ do
+ atomically $ do
+ writeTVar jmReadyTasks . S.insert tid =<< readTVar jmReadyTasks
+ trySelectNext
+ threadId <- myThreadId
+ atomically $ do
+ readTVar jmCancelled >>= \case
+ True -> return True
+ False -> readTVar jmNextTask >>= \case
+ Just tid' | tid' == tid -> do
+ writeTVar jmNextTask Nothing
+ writeTVar jmRunningTasks . M.insert tid threadId =<< readTVar jmRunningTasks
+ return False
+ _ -> retry
- case res of
- Left (JobError err) -> T.putStrLn err
- _ -> return ()
+ release False = liftIO $ atomically $ do
+ free <- readTVar jmSemaphore
+ writeTVar jmSemaphore $ free + 1
+ trySelectNext
+ release True = return ()
- atomically $ writeTVar outVar $ either id JobDone res
- return results
+ trySelectNext = do
+ readTVar jmNextTask >>= \case
+ Just _ -> return ()
+ Nothing -> do
+ readTVar jmSemaphore >>= \case
+ 0 -> return ()
+ sem -> (S.minView <$> readTVar jmReadyTasks) >>= \case
+ Nothing -> return ()
+ Just ( tid', ready ) -> do
+ writeTVar jmReadyTasks ready
+ writeTVar jmSemaphore (sem - 1)
+ writeTVar jmNextTask (Just tid')
+ writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks
+
+
+runJobs :: JobManager -> TerminalOutput -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
+runJobs mngr@JobManager {..} tout commit jobs = do
+ tree <- sequence $ fmap getCommitTree commit
+ results <- atomically $ do
+ forM jobs $ \job -> do
+ let jid = JobId $ concat [ JobIdTree . treeId <$> maybeToList tree, [ JobIdName (jobName job) ] ]
+ tid <- reserveTaskId mngr
+ managed <- readTVar jmJobs
+ ( job, tid, ) <$> case M.lookup jid managed of
+ Just origVar -> do
+ newTVar . JobDuplicate jid =<< readTVar origVar
+
+ Nothing -> do
+ statusVar <- newTVar JobQueued
+ writeTVar jmJobs $ M.insert jid statusVar managed
+ return statusVar
+
+ forM_ results $ \( job, tid, outVar ) -> void $ forkIO $ do
+ let handler e = if
+ | Just JobCancelledException <- fromException e -> do
+ atomically $ writeTVar outVar $ JobCancelled
+ | otherwise -> do
+ footnote <- newFootnote tout $ T.pack $ displayException e
+ atomically $ writeTVar outVar $ JobError footnote
+ handle handler $ do
+ res <- runExceptT $ do
+ duplicate <- liftIO $ atomically $ do
+ readTVar outVar >>= \case
+ JobDuplicate jid _ -> do
+ fmap ( jid, ) . M.lookup jid <$> readTVar jmJobs
+ _ -> do
+ return Nothing
+
+ case duplicate of
+ Nothing -> do
+ uses <- waitForUsedArtifacts tout job results outVar
+ runManagedJob mngr tid (return JobCancelled) $ do
+ liftIO $ atomically $ writeTVar outVar JobRunning
+ prepareJob jmDataDir commit job $ \checkoutPath jdir -> do
+ updateStatusFile (jdir </> "status") outVar
+ JobDone <$> runJob job uses checkoutPath jdir
+
+ Just ( jid, origVar ) -> do
+ let wait = do
+ status <- atomically $ do
+ status <- readTVar origVar
+ out <- readTVar outVar
+ if status == out
+ then retry
+ else do
+ writeTVar outVar $ JobDuplicate jid status
+ return status
+ if jobStatusFinished status
+ then return $ JobDuplicate jid status
+ else wait
+ liftIO wait
+
+ atomically $ writeTVar outVar $ either id id res
+ return $ map (\( job, _, var ) -> ( job, var )) results
waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) =>
- Job -> [(Job, TVar (JobStatus JobOutput))] -> TVar (JobStatus JobOutput) -> m [ArtifactOutput]
-waitForUsedArtifacts job results outVar = do
+ TerminalOutput ->
+ Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ]
+waitForUsedArtifacts tout job results outVar = do
+ origState <- liftIO $ atomically $ readTVar outVar
ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do
- case find ((==ujobName) . jobName . fst) results of
- Just (_, var) -> return (var, (ujobName, uartName))
- Nothing -> throwError $ JobError $ "Job '" <> tjobName <> "' not found"
+ case find (\( j, _, _ ) -> jobName j == ujobName) results of
+ Just ( _, _, var ) -> return ( var, ( ujobName, uartName ))
+ Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Job '" <> tjobName <> "' not found")
let loop prev = do
ustatuses <- atomically $ do
ustatuses <- forM ujobs $ \(uoutVar, uartName) -> do
(,uartName) <$> readTVar uoutVar
when (Just (map fst ustatuses) == prev) retry
- writeTVar outVar $ JobWaiting $ map (fst . snd) $ filter (not . jobStatusFinished . fst) ustatuses
+ let remains = map (fst . snd) $ filter (not . jobStatusFinished . fst) ustatuses
+ writeTVar outVar $ if null remains then origState else JobWaiting remains
return ustatuses
if all (jobStatusFinished . fst) ustatuses
then return ustatuses
@@ -121,7 +268,7 @@ waitForUsedArtifacts job results outVar = do
case ustatus of
JobDone out -> case find ((==uartName) . aoutName) $ outArtifacts out of
Just art -> return art
- Nothing -> throwError $ JobError $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found"
+ Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found")
_ -> throwError JobSkipped
updateStatusFile :: MonadIO m => FilePath -> TVar (JobStatus JobOutput) -> m ()
@@ -135,16 +282,29 @@ 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) => 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"] ""
+prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Maybe Commit -> Job -> (FilePath -> FilePath -> m a) -> m a
+prepareJob dir mbCommit job inner = do
+ withSystemTempDirectory "minici" $ \checkoutPath -> do
+ jdirCommit <- case mbCommit of
+ Just commit -> do
+ tree <- getCommitTree commit
+ forM_ (jobContainingCheckout job) $ \(JobCheckout mbsub dest) -> do
+ subtree <- maybe return (getSubtree mbCommit) mbsub $ tree
+ checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
+ return $ showTreeId (treeId tree) </> stringJobName (jobName job)
+ Nothing -> do
+ when (not $ null $ jobContainingCheckout job) $ do
+ fail $ "no containing repository, can't do checkout"
+ return $ stringJobName (jobName job)
- flip finally (liftIO $ removeDirectoryRecursive checkoutPath) $ do
- checkoutAt commit checkoutPath
- tid <- readTreeId commit
+ jdirOther <- forM (jobOtherCheckout job) $ \( EvaluatedJobRepo repo, revision, JobCheckout mbsub dest ) -> do
+ commit <- readCommit repo $ fromMaybe "HEAD" revision
+ tree <- getCommitTree commit
+ subtree <- maybe return (getSubtree (Just commit)) mbsub $ tree
+ checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
+ return $ showTreeId (treeId tree)
- let jdir = dir </> "jobs" </> showTreeId tid </> stringJobName (jobName job)
+ let jdir = dir </> "jobs" </> jdirCommit </> joinPath jdirOther
liftIO $ createDirectoryIfMissing True jdir
inner checkoutPath jdir
@@ -165,24 +325,32 @@ runJob job uses checkoutPath jdir = do
, std_err = UseHandle logs
}
liftIO $ hClose hin
- exit <- liftIO $ waitForProcess hp
-
- when (exit /= ExitSuccess) $
- throwError JobFailed
-
- let adir = jdir </> "artifacts"
- artifacts <- forM (jobArtifacts job) $ \(name@(ArtifactName tname), pathCmd) -> liftIO $ do
- [path] <- lines <$> readCreateProcess pathCmd { cwd = Just checkoutPath } ""
- let target = adir </> T.unpack tname
- createDirectoryIfMissing True adir
- copyFile (checkoutPath </> path) target
- return $ ArtifactOutput
- { aoutName = name
- , aoutWorkPath = path
- , aoutStorePath = target
- }
+ liftIO (waitForProcess hp) >>= \case
+ ExitSuccess -> return ()
+ ExitFailure n
+ | fromIntegral n == -sigINT -> throwError JobCancelled
+ | otherwise -> throwError JobFailed
- return JobOutput
- { outName = jobName job
- , outArtifacts = artifacts
- }
+ let adir = jdir </> "artifacts"
+ artifacts <- forM (jobArtifacts job) $ \( name@(ArtifactName tname), pathPattern ) -> do
+ path <- liftIO (globDir1 pathPattern checkoutPath) >>= \case
+ [ path ] -> return path
+ found -> do
+ liftIO $ hPutStrLn logs $
+ (if null found then "no file" else "multiple files") <> " found matching pattern `" <>
+ decompile pathPattern <> "' for artifact `" <> T.unpack tname <> "'"
+ throwError JobFailed
+ let target = adir </> T.unpack tname </> takeFileName path
+ liftIO $ do
+ createDirectoryIfMissing True $ takeDirectory target
+ copyFile path target
+ return $ ArtifactOutput
+ { aoutName = name
+ , aoutWorkPath = makeRelative checkoutPath path
+ , aoutStorePath = target
+ }
+
+ return JobOutput
+ { outName = jobName job
+ , outArtifacts = artifacts
+ }
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index 6918738..0447615 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -3,18 +3,27 @@ module Job.Types where
import Data.Text (Text)
import Data.Text qualified as T
+import System.FilePath.Glob
import System.Process
import Repo
-data Job = Job
+data Declared
+data Evaluated
+
+data Job' d = Job
{ jobName :: JobName
+ , jobContainingCheckout :: [ JobCheckout ]
+ , jobOtherCheckout :: [ ( JobRepo d, Maybe Text, JobCheckout ) ]
, jobRecipe :: [ CreateProcess ]
- , jobArtifacts :: [ ( ArtifactName, CreateProcess ) ]
+ , jobArtifacts :: [ ( ArtifactName, Pattern ) ]
, jobUses :: [ ( JobName, ArtifactName ) ]
}
+type Job = Job' Evaluated
+type DeclaredJob = Job' Declared
+
data JobName = JobName Text
deriving (Eq, Ord, Show)
@@ -25,14 +34,46 @@ textJobName :: JobName -> Text
textJobName (JobName name) = name
+data JobRepo d where
+ DeclaredJobRepo :: RepoName -> JobRepo Declared
+ EvaluatedJobRepo :: Repo -> JobRepo Evaluated
+
+data JobCheckout = JobCheckout
+ { jcSubtree :: Maybe FilePath
+ , jcDestination :: Maybe FilePath
+ }
+
+
data ArtifactName = ArtifactName Text
deriving (Eq, Ord, Show)
-data JobSet = JobSet
- { jobsetCommit :: Commit
- , jobsetJobsEither :: Either String [ Job ]
+data JobSet' d = JobSet
+ { jobsetCommit :: Maybe Commit
+ , jobsetJobsEither :: Either String [ Job' d ]
}
+type JobSet = JobSet' Evaluated
+type DeclaredJobSet = JobSet' Declared
+
jobsetJobs :: JobSet -> [ Job ]
jobsetJobs = either (const []) id . jobsetJobsEither
+
+
+newtype JobId = JobId [ JobIdPart ]
+ deriving (Eq, Ord)
+
+data JobIdPart
+ = JobIdName JobName
+ | JobIdCommit CommitId
+ | JobIdTree TreeId
+ deriving (Eq, Ord)
+
+newtype JobRef = JobRef [ Text ]
+ deriving (Eq, Ord)
+
+textJobIdPart :: JobIdPart -> Text
+textJobIdPart = \case
+ JobIdName name -> textJobName name
+ JobIdCommit cid -> textCommitId cid
+ JobIdTree tid -> textTreeId tid
diff --git a/src/Main.hs b/src/Main.hs
index 971bffe..9e9214f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -6,45 +6,75 @@ import Control.Monad.Reader
import Data.ByteString.Lazy qualified as BL
import Data.List
+import Data.List.NonEmpty qualified as NE
import Data.Proxy
import Data.Text qualified as T
import System.Console.GetOpt
+import System.Directory
import System.Environment
import System.Exit
+import System.FilePath
import System.IO
import Command
+import Command.Checkout
+import Command.JobId
import Command.Run
import Config
+import Repo
+import Terminal
import Version
data CmdlineOptions = CmdlineOptions
{ optShowHelp :: Bool
, optShowVersion :: Bool
+ , optCommon :: CommonOptions
+ , optStorage :: Maybe FilePath
}
defaultCmdlineOptions :: CmdlineOptions
defaultCmdlineOptions = CmdlineOptions
{ optShowHelp = False
, optShowVersion = False
+ , optCommon = defaultCommonOptions
+ , optStorage = Nothing
}
-options :: [OptDescr (CmdlineOptions -> CmdlineOptions)]
+options :: [ OptDescr (CmdlineOptions -> Except String CmdlineOptions) ]
options =
- [ Option ['h'] ["help"]
- (NoArg $ \opts -> opts { optShowHelp = True })
+ [ Option [ 'h' ] [ "help" ]
+ (NoArg $ \opts -> return opts { optShowHelp = True })
"show this help and exit"
- , Option ['V'] ["version"]
- (NoArg $ \opts -> opts { optShowVersion = True })
+ , Option [ 'V' ] [ "version" ]
+ (NoArg $ \opts -> return opts { optShowVersion = True })
"show version and exit"
+ , Option [ 'j' ] [ "jobs" ]
+ (ReqArg (\num opts -> return opts { optCommon = (optCommon opts) { optJobs = read num }}) "<num>")
+ ("number of jobs to run simultaneously (default " <> show (optJobs defaultCommonOptions) <> ")")
+ , Option [] [ "repo" ]
+ (ReqArg (\value opts ->
+ case span (/= ':') value of
+ ( repo, ':' : path ) -> return opts
+ { optCommon = (optCommon opts)
+ { optRepo = DeclaredRepo (RepoName $ T.pack repo) path : optRepo (optCommon opts)
+ }
+ }
+ _ -> throwError $ "--repo: invalid value `" <> value <> "'"
+ ) "<repo>:<path>")
+ ("override or declare repo path")
+ , Option [] [ "storage" ]
+ (ReqArg (\value opts -> return opts { optStorage = Just value }) "<path>")
+ "set storage path"
]
data SomeCommandType = forall c. Command c => SC (Proxy c)
-commands :: [ SomeCommandType ]
+commands :: NE.NonEmpty SomeCommandType
commands =
- [ SC $ Proxy @RunCommand
+ ( SC $ Proxy @RunCommand) NE.:|
+ [ SC $ Proxy @CheckoutCommand
+ , SC $ Proxy @JobIdCommand
]
lookupCommand :: String -> Maybe SomeCommandType
@@ -55,25 +85,40 @@ lookupCommand name = find p commands
main :: IO ()
main = do
args <- getArgs
- (opts, cmdargs) <- case getOpt RequireOrder options args of
- (o, cmdargs, []) -> return (foldl (flip id) defaultCmdlineOptions o, cmdargs)
+ let ( mbConfigPath, args' ) = case args of
+ (path : rest)
+ | any isPathSeparator path -> ( Just path, rest )
+ _ -> ( Nothing, args )
+
+ (opts, cmdargs) <- case getOpt RequireOrder options args' of
+ (os, cmdargs, []) -> do
+ let merge :: ([String], CmdlineOptions) -> (CmdlineOptions -> Except String CmdlineOptions) -> ([String], CmdlineOptions)
+ merge ( errs, o ) f = case runExcept $ f o of
+ Left err -> ( err : errs, o )
+ Right o' -> ( errs, o' )
+
+ case foldl merge ( [], defaultCmdlineOptions ) os of
+ ( [], opts ) -> return ( opts , cmdargs )
+ ( errs, _ ) -> do
+ hPutStrLn stderr $ unlines (reverse errs) <> "Try `minici --help' for more information."
+ exitFailure
(_, _, errs) -> do
hPutStrLn stderr $ concat errs <> "Try `minici --help' for more information."
exitFailure
when (optShowHelp opts) $ do
- let header = "Usage: minici [<option>...] <command> [<args>]\n\nCommon options are:"
+ let header = "Usage: minici [<job-file>] [<option>...] <command> [<args>]\n\nCommon options are:"
commandDesc (SC proxy) = " " <> padCommand (commandName proxy) <> commandDescription proxy
padTo n str = str <> replicate (n - length str) ' '
padCommand = padTo (maxCommandNameLength + 3)
commandNameLength (SC proxy) = length $ commandName proxy
- maxCommandNameLength = maximum $ map commandNameLength commands
+ maxCommandNameLength = maximum $ fmap commandNameLength commands
putStr $ usageInfo header options <> unlines (
[ ""
, "Available commands:"
- ] ++ map commandDesc commands
+ ] ++ map commandDesc (NE.toList commands)
)
exitSuccess
@@ -81,8 +126,17 @@ main = do
putStrLn versionLine
exitSuccess
- (ncmd, cargs) <- case cmdargs of
- [] -> return (head commands, [])
+ ( configPath, cmdargs' ) <- case ( mbConfigPath, cmdargs ) of
+ ( Just path, _ )
+ -> return ( Just path, cmdargs )
+ ( _, path : rest )
+ | any isPathSeparator path
+ -> return ( Just path, rest )
+ _ -> ( , cmdargs ) <$> findConfig
+
+ ( ncmd, cargs ) <- case cmdargs' of
+ [] -> return ( NE.head commands, [] )
+
(cname : cargs)
| Just nc <- lookupCommand cname -> return (nc, cargs)
| otherwise -> do
@@ -92,7 +146,7 @@ main = do
]
exitFailure
- runSomeCommand ncmd cargs
+ runSomeCommand configPath opts ncmd cargs
data FullCommandOptions c = FullCommandOptions
{ fcoSpecific :: CommandOptions c
@@ -114,8 +168,10 @@ fullCommandOptions proxy =
"show this help and exit"
]
-runSomeCommand :: SomeCommandType -> [ String ] -> IO ()
-runSomeCommand (SC tproxy) args = do
+runSomeCommand :: Maybe FilePath -> CmdlineOptions -> SomeCommandType -> [ String ] -> IO ()
+runSomeCommand ciConfigPath gopts (SC tproxy) args = do
+ let ciOptions = optCommon gopts
+ ciStorageDir = optStorage gopts
let exitWithErrors errs = do
hPutStrLn stderr $ concat errs <> "Try `minici " <> commandName tproxy <> " --help' for more information."
exitFailure
@@ -132,12 +188,34 @@ runSomeCommand (SC tproxy) args = do
putStr $ usageInfo (T.unpack $ commandUsage tproxy) (fullCommandOptions tproxy)
exitSuccess
- Just configPath <- findConfig
- BL.readFile configPath >>= return . parseConfig >>= \case
- Left err -> do
- putStr err
- exitFailure
- Right config -> do
- let cmd = commandInit tproxy (fcoSpecific opts) cmdargs
- let CommandExec exec = commandExec cmd
- flip runReaderT config exec
+ ciConfig <- case ciConfigPath of
+ Just path -> parseConfig <$> BL.readFile path
+ Nothing -> return $ Left "no job file found"
+
+ let cmd = commandInit tproxy (fcoSpecific opts) cmdargs
+ let CommandExec exec = commandExec cmd
+
+ ciContainingRepo <- maybe (return Nothing) (openRepo . takeDirectory) ciConfigPath
+
+ let openDeclaredRepo dir decl = do
+ let path = dir </> repoPath decl
+ openRepo path >>= \case
+ Just repo -> return ( repoName decl, repo )
+ Nothing -> do
+ absPath <- makeAbsolute path
+ hPutStrLn stderr $ "Failed to open repo `" <> showRepoName (repoName decl) <> "' at " <> repoPath decl <> " (" <> absPath <> ")"
+ exitFailure
+
+ cmdlineRepos <- forM (optRepo ciOptions) (openDeclaredRepo "")
+ configRepos <- case ( ciConfigPath, ciConfig ) of
+ ( Just path, Right config ) ->
+ forM (configRepos config) $ \decl -> do
+ case lookup (repoName decl) cmdlineRepos of
+ Just repo -> return ( repoName decl, repo )
+ Nothing -> openDeclaredRepo (takeDirectory path) decl
+ _ -> return []
+
+ let ciOtherRepos = configRepos ++ cmdlineRepos
+
+ ciTerminalOutput <- initTerminalOutput
+ flip runReaderT CommandInput {..} exec
diff --git a/src/Repo.hs b/src/Repo.hs
index c0500f3..f22b211 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -1,28 +1,58 @@
module Repo (
- Repo(..), Commit(..),
- CommitId, showCommitId,
- TreeId, showTreeId,
+ Repo,
+ DeclaredRepo(..),
+ RepoName(..), textRepoName, showRepoName,
+ Commit, commitId,
+ CommitId, textCommitId, showCommitId,
+ Tree, treeId, treeRepo,
+ TreeId, textTreeId, showTreeId,
+ Tag(..),
openRepo,
+ readCommit, tryReadCommit,
+ readTree, tryReadTree,
+ readBranch,
+ readTag,
listCommits,
+ findUpstreamRef,
+
+ getCommitTree,
+ getCommitTitle,
+ getCommitMessage,
+
+ getSubtree,
+
checkoutAt,
- readTreeId,
+ createWipCommit,
readCommittedFile,
+
+ watchBranch,
+ watchTags,
) where
import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception (IOException)
import Control.Monad
+import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
+import Data.Function
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
+import Data.Text.Encoding
-import System.Directory
+import System.Environment
import System.Exit
import System.FilePath
+import System.INotify
+import System.IO.Temp
import System.Process
@@ -30,31 +60,94 @@ data Repo
= GitRepo
{ gitDir :: FilePath
, gitLock :: MVar ()
+ , gitInotify :: MVar (Maybe ( INotify, TChan (Tag Commit) ))
+ , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ])
}
+instance Show Repo where
+ show GitRepo {..} = gitDir
+
+data DeclaredRepo = DeclaredRepo
+ { repoName :: RepoName
+ , repoPath :: FilePath
+ }
+
+newtype RepoName = RepoName Text
+ deriving (Eq, Ord)
+
+textRepoName :: RepoName -> Text
+textRepoName (RepoName text) = text
+
+showRepoName :: RepoName -> String
+showRepoName = T.unpack . textRepoName
+
+
data Commit = Commit
{ commitRepo :: Repo
- , commitId :: CommitId
- , commitDescription :: Text
+ , commitId_ :: CommitId
+ , commitDetails :: MVar (Maybe CommitDetails)
+ }
+
+commitId :: Commit -> CommitId
+commitId = commitId_
+
+data CommitDetails = CommitDetails
+ { commitTree :: Tree
+ , commitTitle :: Text
+ , commitMessage :: Text
+ }
+
+data Tree = Tree
+ { treeRepo :: Repo
+ , treeId :: TreeId
+ }
+
+data Tag a = Tag
+ { tagTag :: Text
+ , tagObject :: a
+ , tagMessage :: Text
}
+instance Eq Repo where
+ (==) = (==) `on` gitLock
+
+instance Eq Commit where
+ x == y = commitRepo x == commitRepo y &&
+ commitId_ x == commitId_ y
+
newtype CommitId = CommitId ByteString
+ deriving (Eq, Ord)
+
+textCommitId :: CommitId -> Text
+textCommitId (CommitId cid) = decodeUtf8 cid
showCommitId :: CommitId -> String
showCommitId (CommitId cid) = BC.unpack cid
newtype TreeId = TreeId ByteString
+ deriving (Eq, Ord)
+
+textTreeId :: TreeId -> Text
+textTreeId (TreeId tid) = decodeUtf8 tid
showTreeId :: TreeId -> String
showTreeId (TreeId tid) = BC.unpack tid
+runGitCommand :: MonadIO m => Repo -> [ String ] -> m String
+runGitCommand GitRepo {..} args = liftIO $ do
+ withMVar gitLock $ \_ -> do
+ readProcess "git" (("--git-dir=" <> gitDir) : args) ""
+
+
openRepo :: FilePath -> IO (Maybe Repo)
openRepo path = do
findGitDir >>= \case
Just gitDir -> do
gitLock <- newMVar ()
+ gitInotify <- newMVar Nothing
+ gitWatchedBranches <- newMVar M.empty
return $ Just GitRepo {..}
Nothing -> do
return Nothing
@@ -69,39 +162,193 @@ openRepo path = do
Just dir -> return (Just dir)
_ -> return Nothing
+mkCommit :: MonadIO m => Repo -> CommitId -> m Commit
+mkCommit commitRepo commitId_ = do
+ commitDetails <- liftIO $ newMVar Nothing
+ return $ Commit {..}
+
+readCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m Commit
+readCommit repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadCommit repo ref
+ where err = "revision `" <> T.unpack ref <> "' not found in `" <> gitDir <> "'"
+
+tryReadCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Commit)
+tryReadCommit repo ref = sequence . fmap (mkCommit repo . CommitId) =<< tryReadObjectId repo "commit" ref
+
+readTree :: (MonadIO m, MonadFail m) => Repo -> Text -> m Tree
+readTree repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadTree repo ref
+ where err = "tree `" <> T.unpack ref <> "' not found in `" <> gitDir <> "'"
+
+tryReadTree :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Tree)
+tryReadTree repo ref = return . fmap (Tree repo . TreeId) =<< tryReadObjectId repo "tree" ref
+
+tryReadObjectId :: (MonadIO m, MonadFail m) => Repo -> Text -> Text -> m (Maybe ByteString)
+tryReadObjectId GitRepo {..} otype ref = do
+ liftIO (readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", T.unpack ref <> "^{" <> T.unpack otype <> "}" ] "") >>= \case
+ ( ExitSuccess, out, _ ) | oid : _ <- lines out -> return $ Just $ BC.pack oid
+ _ -> return Nothing
+
+
+readCommitFromFile :: MonadIO m => Repo -> FilePath -> m (Maybe Commit)
+readCommitFromFile repo@GitRepo {..} path = liftIO $ do
+ try @IO @IOException (BC.readFile $ gitDir </> path) >>= \case
+ Right content | (cid : _) <- BC.lines content -> do
+ Just <$> mkCommit repo (CommitId cid)
+ _ -> do
+ return Nothing
+
+readBranch :: MonadIO m => Repo -> Text -> m (Maybe Commit)
+readBranch repo branch = readCommitFromFile repo ("refs/heads" </> T.unpack branch)
-listCommits :: MonadIO m => Repo -> String -> m [ Commit ]
+readTag :: MonadIO m => Repo -> Text -> m (Maybe (Tag Commit))
+readTag repo tag = do
+ ( infoPart, message ) <-
+ fmap (fmap (drop 1) . span (not . null) . lines) $
+ runGitCommand repo [ "cat-file", "tag", T.unpack tag ]
+ let info = map (fmap (drop 1) . span (/= ' ')) infoPart
+
+ sequence $ do
+ otype <- lookup "type" info
+ guard (otype == "commit")
+ tagTag <- T.pack <$> lookup "tag" info
+ cid <- CommitId . BC.pack <$> lookup "object" info
+ let tagMessage = T.pack $ unlines $ dropWhile null message
+ Just $ do
+ tagObject <- liftIO $ mkCommit repo cid
+ return Tag {..}
+
+listCommits :: MonadIO m => Repo -> Text -> 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
+ out <- runGitCommand commitRepo [ "log", "--pretty=%H", "--first-parent", "--reverse", T.unpack range ]
+ forM (lines out) $ \cid -> do
+ let commitId_ = CommitId (BC.pack cid)
+ commitDetails <- newMVar Nothing
return Commit {..}
+findUpstreamRef :: MonadIO m => Repo -> Text -> m (Maybe Text)
+findUpstreamRef repo@GitRepo {..} ref = liftIO $ do
+ deref <- readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "symbolic-ref", "--quiet", T.unpack ref ] "" >>= \case
+ ( ExitSuccess, out, _ ) | [ deref ] <- lines out -> return deref
+ ( _, _, _ ) -> return $ T.unpack ref
+ runGitCommand repo [ "show-ref", deref ] >>= \case
+ out | [ _, fullRef ] : _ <- words <$> lines out
+ -> runGitCommand repo [ "for-each-ref", "--format=%(upstream)", fullRef ] >>= \case
+ out' | [ upstream ] <- lines out'
+ -> return $ Just $ T.pack upstream
+ _ -> return Nothing
+ _ -> return Nothing
-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"
+getCommitDetails :: (MonadIO m, MonadFail m) => Commit -> m CommitDetails
+getCommitDetails Commit {..} = do
+ liftIO $ do
+ modifyMVar commitDetails $ \case
+ cur@(Just details) -> do
+ return ( cur, details )
+ Nothing -> do
+ ( infoPart, _ : title : message ) <-
+ fmap (span (not . null) . lines) $
+ runGitCommand commitRepo [ "cat-file", "commit", showCommitId commitId_ ]
+ let info = map (fmap (drop 1) . span (/= ' ')) infoPart
-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
+ Just treeId <- return $ TreeId . BC.pack <$> lookup "tree" info
+ let treeRepo = commitRepo
+ let commitTree = Tree {..}
+ let commitTitle = T.pack title
+ let commitMessage = T.pack $ unlines $ dropWhile null message
+
+ let details = CommitDetails {..}
+ return ( Just details, details )
+
+getCommitTree :: (MonadIO m, MonadFail m) => Commit -> m Tree
+getCommitTree = fmap commitTree . getCommitDetails
+
+getCommitTitle :: (MonadIO m, MonadFail m) => Commit -> m Text
+getCommitTitle = fmap commitTitle . getCommitDetails
+
+getCommitMessage :: (MonadIO m, MonadFail m) => Commit -> m Text
+getCommitMessage = fmap commitMessage . getCommitDetails
+
+
+getSubtree :: (MonadIO m, MonadFail m) => Maybe Commit -> FilePath -> Tree -> m Tree
+getSubtree mbCommit path tree = liftIO $ do
+ let GitRepo {..} = treeRepo tree
+ readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", showTreeId (treeId tree) <> ":" <> path ] "" >>= \case
+ ( ExitSuccess, out, _ ) | tid : _ <- lines out -> do
+ return Tree
+ { treeRepo = treeRepo tree
+ , treeId = TreeId (BC.pack tid)
+ }
+ _ -> do
+ fail $ "subtree `" <> path <> "' not found" <> maybe "" (("in revision `" <>) . (<> "'") . showCommitId . commitId) mbCommit
-readCommittedFile :: Commit -> FilePath -> IO (Maybe BL.ByteString)
-readCommittedFile Commit {..} path = do
- let GitRepo {..} = commitRepo
+checkoutAt :: (MonadIO m, MonadFail m) => Tree -> FilePath -> m ()
+checkoutAt Tree {..} dest = do
+ let GitRepo {..} = treeRepo
+ liftIO $ withSystemTempFile "minici-checkout.index" $ \index _ -> do
+ curenv <- getEnvironment
+ let readGitProcess args input =
+ withMVar gitLock $ \_ ->
+ readCreateProcess (proc "git" args)
+ { env = Just $ concat
+ [ [ ( "GIT_INDEX_FILE", index ) ]
+ , [ ( "GIT_DIR", gitDir ) ]
+ , [ ( "GIT_WORK_TREE", "." ) ]
+ , curenv
+ ]
+ } input
+ "" <- readGitProcess [ "read-tree", showTreeId treeId ] ""
+ "" <- readGitProcess [ "checkout-index", "--all", "--prefix=" <> addTrailingPathSeparator dest ] ""
+ return ()
+
+createWipCommit :: (MonadIO m, MonadMask m, MonadFail m) => Repo -> m Commit
+createWipCommit repo@GitRepo {..} = do
+ withSystemTempFile "minici-wip.index" $ \index _ -> do
+ curenv <- liftIO getEnvironment
+ let readGitProcess mbWorkTree args input = liftIO $ do
+ withMVar gitLock $ \_ ->
+ readCreateProcess (proc "git" args)
+ { env = Just $ concat
+ [ [ ( "GIT_INDEX_FILE", index ) ]
+ , [ ( "GIT_DIR", gitDir ) ]
+ , map (( "GIT_WORK_TREE", ) . T.unpack) $ maybeToList mbWorkTree
+ , curenv
+ ]
+ } input
+ mkPair = fmap (T.dropWhile (== ' ')) . T.break (== ' ')
+ info <- map mkPair . takeWhile (not . T.null) . T.splitOn "\0". T.pack <$>
+ readGitProcess Nothing [ "worktree", "list", "--porcelain", "-z" ] ""
+ case ( lookup "worktree" info, lookup "HEAD" info ) of
+ ( Just worktree, Just headRev ) -> do
+ let readGitProcessW = readGitProcess (Just worktree)
+
+ headCommit <- mkCommit repo (CommitId $ encodeUtf8 headRev)
+ headTree <- getCommitTree headCommit
+
+ "" <- readGitProcessW [ "read-tree", "--empty" ] ""
+ status <- map mkPair . T.splitOn "\0" . T.pack <$>
+ readGitProcessW [ "status", "--porcelain=v1", "-z", "--untracked-files=all" ] ""
+ "" <- readGitProcessW [ "update-index", "--add", "-z", "--stdin" ] $ T.unpack $ T.intercalate "\0" $ map snd status
+ [ tid ] <- lines <$> readGitProcessW [ "write-tree" ] ""
+
+ if TreeId (BC.pack tid) == treeId headTree
+ then return headCommit
+ else do
+ headMsg <- getCommitTitle headCommit
+ let wipMsg = case lookup "branch" info of
+ Just branch -> "WIP on " <> branch <> ": " <> headMsg
+ Nothing -> "WIP: " <> headMsg
+ [ cid ] <- lines <$> readGitProcessW [ "commit-tree", "-m", T.unpack wipMsg, "-p", T.unpack headRev, tid ] ""
+ mkCommit repo (CommitId $ BC.pack cid)
+
+ _ -> readCommit repo "HEAD"
+
+
+readCommittedFile :: MonadIO m => Tree -> FilePath -> m (Maybe BL.ByteString)
+readCommittedFile Tree {..} path = do
+ let GitRepo {..} = treeRepo
liftIO $ withMVar gitLock $ \_ -> do
- let cmd = (proc "git" [ "--git-dir=" <> gitDir, "cat-file", "blob", showCommitId commitId <> ":" <> path ])
+ let cmd = (proc "git" [ "--git-dir=" <> gitDir, "cat-file", "blob", showTreeId treeId <> ":" <> path ])
{ std_in = NoStream
, std_out = CreatePipe
}
@@ -120,3 +367,43 @@ readCommittedFile Commit {..} path = do
_ ->
return (Just content)
| otherwise -> error "createProcess must return stdout handle"
+
+
+repoInotify :: Repo -> IO ( INotify, TChan (Tag Commit) )
+repoInotify repo@GitRepo {..} = modifyMVar gitInotify $ \case
+ cur@(Just info) ->
+ return ( cur, info )
+ Nothing -> do
+ inotify <- initINotify
+ tagsChan <- newBroadcastTChanIO
+ let info = ( inotify, tagsChan )
+
+ _ <- addWatch inotify [ MoveIn ] (BC.pack headsDir) $ \event -> do
+ let branch = decodeUtf8 $ filePath event
+ tvars <- fromMaybe [] . M.lookup branch <$> readMVar gitWatchedBranches
+ when (not $ null tvars) $ do
+ commit <- readBranch repo branch
+ atomically $ do
+ mapM_ (`writeTVar` commit) tvars
+
+ _ <- addWatch inotify [ MoveIn ] (BC.pack tagsDir) $ \event -> do
+ readTag repo (decodeUtf8 $ filePath event) >>= \case
+ Just tag -> atomically $ writeTChan tagsChan tag
+ Nothing -> return ()
+
+ return ( Just info, info )
+ where
+ headsDir = gitDir </> "refs/heads"
+ tagsDir = gitDir </> "refs/tags"
+
+watchBranch :: MonadIO m => Repo -> Text -> m (STM (Maybe Commit))
+watchBranch repo@GitRepo {..} branch = liftIO $ do
+ var <- newTVarIO =<< readBranch repo branch
+ void $ repoInotify repo
+ modifyMVar_ gitWatchedBranches $ return . M.insertWith (++) branch [ var ]
+ return $ readTVar var
+
+watchTags :: MonadIO m => Repo -> m (TChan (Tag Commit))
+watchTags repo = liftIO $ do
+ tagsChan <- snd <$> repoInotify repo
+ atomically $ dupTChan tagsChan
diff --git a/src/Terminal.hs b/src/Terminal.hs
new file mode 100644
index 0000000..aa7335c
--- /dev/null
+++ b/src/Terminal.hs
@@ -0,0 +1,79 @@
+module Terminal (
+ TerminalOutput,
+ TerminalLine,
+ TerminalFootnote(..),
+ initTerminalOutput,
+ newLine,
+ redrawLine,
+ newFootnote,
+ terminalBlinkStatus,
+) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+
+import Data.Function
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.IO
+
+
+data TerminalOutput = TerminalOutput
+ { outNumLines :: MVar Int
+ , outNextFootnote :: MVar Int
+ , outBlinkVar :: TVar Bool
+ }
+
+instance Eq TerminalOutput where
+ (==) = (==) `on` outNumLines
+
+data TerminalLine = TerminalLine
+ { lineOutput :: TerminalOutput
+ , lineNum :: Int
+ }
+ deriving (Eq)
+
+data TerminalFootnote = TerminalFootnote
+ { footnoteLine :: TerminalLine
+ , footnoteNumber :: Int
+ , footnoteText :: Text
+ }
+ deriving (Eq)
+
+initTerminalOutput :: IO TerminalOutput
+initTerminalOutput = do
+ outNumLines <- newMVar 0
+ outNextFootnote <- newMVar 1
+ outBlinkVar <- newTVarIO False
+ void $ forkIO $ forever $ do
+ threadDelay 500000
+ atomically $ writeTVar outBlinkVar . not =<< readTVar outBlinkVar
+ return TerminalOutput {..}
+
+newLine :: TerminalOutput -> Text -> IO TerminalLine
+newLine lineOutput@TerminalOutput {..} text = do
+ modifyMVar outNumLines $ \lineNum -> do
+ T.putStrLn text
+ hFlush stdout
+ return ( lineNum + 1, TerminalLine {..} )
+
+redrawLine :: TerminalLine -> Text -> IO ()
+redrawLine TerminalLine {..} text = do
+ let TerminalOutput {..} = lineOutput
+ withMVar outNumLines $ \total -> do
+ let moveBy = total - lineNum
+ T.putStr $ "\ESC[s\ESC[" <> T.pack (show moveBy) <> "F" <> text <> "\ESC[u"
+ hFlush stdout
+
+newFootnote :: TerminalOutput -> Text -> IO TerminalFootnote
+newFootnote tout@TerminalOutput {..} footnoteText = do
+ modifyMVar outNextFootnote $ \footnoteNumber -> do
+ footnoteLine <- newLine tout $ "[" <> T.pack (show footnoteNumber) <> "] " <> footnoteText
+ hFlush stdout
+ return ( footnoteNumber + 1, TerminalFootnote {..} )
+
+terminalBlinkStatus :: TerminalOutput -> STM Bool
+terminalBlinkStatus TerminalOutput {..} = readTVar outBlinkVar
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-04 15:36:45 +0000