summaryrefslogtreecommitdiff
path: root/src/Command
diff options
context:
space:
mode:
Diffstat (limited to 'src/Command')
-rw-r--r--src/Command/Checkout.hs58
-rw-r--r--src/Command/JobId.hs39
-rw-r--r--src/Command/Run.hs317
3 files changed, 355 insertions, 59 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-04 15:43:45 +0000