diff options
author | Roman Smrž <roman.smrz@seznam.cz> | 2025-04-01 23:33:06 +0200 |
---|---|---|
committer | Roman Smrž <roman.smrz@seznam.cz> | 2025-04-04 21:25:00 +0200 |
commit | 1f01dbd2b1d3fb89efdaab56bc52d82a8ed0483e (patch) | |
tree | ed2a279157f6af16dbdd3b620e10e6028a320f23 /src | |
parent | 7e8ec380763292d8afa4f3d0f03a679ffe384d49 (diff) |
Job root either as repo or jobfile
Diffstat (limited to 'src')
-rw-r--r-- | src/Command.hs | 30 | ||||
-rw-r--r-- | src/Command/JobId.hs | 3 | ||||
-rw-r--r-- | src/Command/Run.hs | 36 | ||||
-rw-r--r-- | src/Config.hs | 6 | ||||
-rw-r--r-- | src/Eval.hs | 34 | ||||
-rw-r--r-- | src/Main.hs | 52 | ||||
-rw-r--r-- | src/Repo.hs | 5 |
7 files changed, 105 insertions, 61 deletions
diff --git a/src/Command.hs b/src/Command.hs index 0d333e8..e2ef911 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -9,8 +9,7 @@ module Command ( tfail, CommandInput(..), getCommonOptions, - getConfigPath, - getConfig, + getRootPath, getJobRoot, getRepo, getDefaultRepo, tryGetDefaultRepo, getEvalInput, getTerminalOutput, @@ -28,7 +27,6 @@ import Data.Text.IO qualified as T import System.Console.GetOpt import System.Exit -import System.FilePath import System.IO import Config @@ -100,28 +98,22 @@ tfail err = liftIO $ do data CommandInput = CommandInput { ciOptions :: CommonOptions - , ciConfigPath :: Maybe FilePath - , ciConfig :: Either String Config + , ciRootPath :: FilePath + , ciJobRoot :: JobRoot , ciContainingRepo :: Maybe Repo , ciOtherRepos :: [ ( RepoName, Repo ) ] , ciTerminalOutput :: TerminalOutput - , ciStorageDir :: Maybe FilePath + , ciStorageDir :: FilePath } getCommonOptions :: CommandExec CommonOptions getCommonOptions = CommandExec (asks ciOptions) -getConfigPath :: CommandExec FilePath -getConfigPath = do - CommandExec (asks ciConfigPath) >>= \case - Nothing -> tfail $ "no job file found" - Just path -> return path +getRootPath :: CommandExec FilePath +getRootPath = CommandExec (asks ciRootPath) -getConfig :: CommandExec Config -getConfig = do - CommandExec (asks ciConfig) >>= \case - Left err -> fail err - Right config -> return config +getJobRoot :: CommandExec JobRoot +getJobRoot = CommandExec (asks ciJobRoot) getRepo :: RepoName -> CommandExec Repo getRepo name = do @@ -140,6 +132,8 @@ tryGetDefaultRepo = CommandExec $ asks ciContainingRepo getEvalInput :: CommandExec EvalInput getEvalInput = CommandExec $ do + eiJobRoot <- asks ciJobRoot + eiRootPath <- asks ciRootPath eiContainingRepo <- asks ciContainingRepo eiOtherRepos <- asks ciOtherRepos return EvalInput {..} @@ -148,6 +142,4 @@ getTerminalOutput :: CommandExec TerminalOutput getTerminalOutput = CommandExec (asks ciTerminalOutput) getStorageDir :: CommandExec FilePath -getStorageDir = CommandExec (asks ciStorageDir) >>= \case - Just dir -> return dir - Nothing -> ((</> ".minici") . takeDirectory) <$> getConfigPath +getStorageDir = CommandExec (asks ciStorageDir) diff --git a/src/Command/JobId.hs b/src/Command/JobId.hs index 9f531d6..eb51a66 100644 --- a/src/Command/JobId.hs +++ b/src/Command/JobId.hs @@ -31,9 +31,8 @@ instance Command JobIdCommand where cmdJobId :: JobIdCommand -> CommandExec () cmdJobId (JobIdCommand ref) = do - config <- getConfig einput <- getEvalInput JobId ids <- either (tfail . textEvalError) return =<< - liftIO (runEval (evalJobReference config ref) einput) + liftIO (runEval (evalJobReference ref) einput) liftIO $ T.putStrLn $ T.intercalate "." $ map textJobIdPart ids diff --git a/src/Command/Run.hs b/src/Command/Run.hs index 905204e..e0277c3 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -123,24 +123,41 @@ mergeSources sources = do argumentJobSource :: [ JobName ] -> CommandExec JobSource argumentJobSource [] = emptyJobSource argumentJobSource names = do - config <- getConfig + ( config, jobsetCommit ) <- getJobRoot >>= \case + JobRootConfig config -> do + commit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo + return ( config, commit ) + JobRootRepo repo -> do + commit <- createWipCommit repo + config <- either fail return =<< loadConfigForCommit =<< getCommitTree commit + return ( config, Just commit ) + 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 {..} ] +loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet +loadJobSetFromRoot root commit = case root of + JobRootRepo _ -> loadJobSetForCommit commit + JobRootConfig config -> return JobSet + { jobsetCommit = Just commit + , jobsetJobsEither = Right $ configJobs config + } + rangeSource :: Text -> Text -> CommandExec JobSource rangeSource base tip = do + root <- getJobRoot repo <- getDefaultRepo einput <- getEvalInput commits <- listCommits repo (base <> ".." <> tip) - oneshotJobSource . map (evalJobSet einput) =<< mapM loadJobSetForCommit commits + oneshotJobSource . map (evalJobSet einput) =<< mapM (loadJobSetFromRoot root) commits watchBranchSource :: Text -> CommandExec JobSource watchBranchSource branch = do + root <- getJobRoot repo <- getDefaultRepo einput <- getEvalInput getCurrentTip <- watchBranch repo branch @@ -153,7 +170,7 @@ watchBranchSource branch = do Nothing -> retry commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur)) - jobsets <- map (evalJobSet einput) <$> mapM loadJobSetForCommit commits + jobsets <- map (evalJobSet einput) <$> mapM (loadJobSetFromRoot root) commits nextvar <- newEmptyTMVarIO atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar ) go cur nextvar @@ -170,6 +187,7 @@ watchBranchSource branch = do watchTagSource :: Pattern -> CommandExec JobSource watchTagSource pat = do + root <- getJobRoot chan <- watchTags =<< getDefaultRepo einput <- getEvalInput @@ -177,7 +195,7 @@ watchTagSource pat = do tag <- atomically $ readTChan chan if match pat $ T.unpack $ tagTag tag then do - jobset <- evalJobSet einput <$> loadJobSetForCommit (tagObject tag) + jobset <- evalJobSet einput <$> (loadJobSetFromRoot root) (tagObject tag) nextvar <- newEmptyTMVarIO atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar ) go nextvar @@ -202,13 +220,7 @@ cmdRun (RunCommand RunOptions {..} args) = do , 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 ) + [ _ ] -> return $ Right $ JobName arg _ -> tfail $ "invalid argument: " <> arg ] diff --git a/src/Config.hs b/src/Config.hs index 5631179..bc66ea9 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -1,4 +1,5 @@ module Config ( + JobRoot(..), Config(..), findConfig, parseConfig, @@ -34,6 +35,11 @@ configFileName :: FilePath configFileName = "minici.yaml" +data JobRoot + = JobRootRepo Repo + | JobRootConfig Config + + data Config = Config { configJobs :: [ DeclaredJob ] , configRepos :: [ DeclaredRepo ] diff --git a/src/Eval.hs b/src/Eval.hs index 1828468..7e53128 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -14,6 +14,7 @@ import Control.Monad.Reader import Data.Bifunctor import Data.List +import Data.Maybe import Data.Text (Text) import Data.Text qualified as T @@ -22,7 +23,9 @@ import Job.Types import Repo data EvalInput = EvalInput - { eiContainingRepo :: Maybe Repo + { eiJobRoot :: JobRoot + , eiRootPath :: FilePath + , eiContainingRepo :: Maybe Repo , eiOtherRepos :: [ ( RepoName, Repo ) ] } @@ -66,17 +69,22 @@ evalJobSet ei decl = do runExceptStr = first (T.unpack . textEvalError) . runExcept -canonicalJobName :: [ Text ] -> Config -> Eval [ JobIdPart ] -canonicalJobName (r : rs) config = do +canonicalJobName :: [ Text ] -> Maybe Tree -> Config -> Eval [ JobIdPart ] +canonicalJobName (r : rs) mbTree 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 + repos <- concat <$> sequence + [ case mbTree of + Just _ -> return [] + Nothing -> maybeToList <$> asks eiContainingRepo + , return $ 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" +canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name" canonicalOtherCheckouts :: [ Text ] -> [ Repo ] -> Eval [ JobIdPart ] canonicalOtherCheckouts (r : rs) (repo : repos) = do @@ -98,14 +106,14 @@ canonicalCommitConfig (r : rs) repo = do 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 + (JobIdTree (treeId tree) :) <$> canonicalJobName rs (Just tree) 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 +evalJobReference :: JobRef -> Eval JobId +evalJobReference (JobRef rs) = + JobId <$> do + asks eiJobRoot >>= \case + JobRootRepo defRepo -> do canonicalCommitConfig rs defRepo - Nothing -> do - canonicalJobName rs config + JobRootConfig config -> do + canonicalJobName rs Nothing config diff --git a/src/Main.hs b/src/Main.hs index 9e9214f..1b062e8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -85,7 +85,7 @@ lookupCommand name = find p commands main :: IO () main = do args <- getArgs - let ( mbConfigPath, args' ) = case args of + let ( mbRootPath, args' ) = case args of (path : rest) | any isPathSeparator path -> ( Just path, rest ) _ -> ( Nothing, args ) @@ -126,13 +126,13 @@ main = do putStrLn versionLine exitSuccess - ( configPath, cmdargs' ) <- case ( mbConfigPath, cmdargs ) of + ( rootPath, cmdargs' ) <- case ( mbRootPath, cmdargs ) of ( Just path, _ ) -> return ( Just path, cmdargs ) ( _, path : rest ) | any isPathSeparator path -> return ( Just path, rest ) - _ -> ( , cmdargs ) <$> findConfig + _ -> return ( Nothing , cmdargs ) ( ncmd, cargs ) <- case cmdargs' of [] -> return ( NE.head commands, [] ) @@ -146,7 +146,7 @@ main = do ] exitFailure - runSomeCommand configPath opts ncmd cargs + runSomeCommand rootPath opts ncmd cargs data FullCommandOptions c = FullCommandOptions { fcoSpecific :: CommandOptions c @@ -169,9 +169,35 @@ fullCommandOptions proxy = ] runSomeCommand :: Maybe FilePath -> CmdlineOptions -> SomeCommandType -> [ String ] -> IO () -runSomeCommand ciConfigPath gopts (SC tproxy) args = do +runSomeCommand rootPath gopts (SC tproxy) args = do + let reportFailure err = hPutStrLn stderr err >> exitFailure + ( ciRootPath, ciJobRoot ) <- case rootPath of + Just path -> do + doesFileExist path >>= \case + True -> BL.readFile path >>= return . parseConfig >>= \case + Right config -> return ( path, JobRootConfig config ) + Left err -> reportFailure $ "Failed to parse job file ‘" <> path <> "’:" <> err + False -> doesDirectoryExist path >>= \case + True -> openRepo path >>= \case + Just repo -> return ( path, JobRootRepo repo ) + Nothing -> reportFailure $ "Failed to open repository ‘" <> path <> "’" + False -> reportFailure $ "File or directory ‘" <> path <> "’ not found" + Nothing -> do + openRepo "." >>= \case + Just repo -> return ( ".", JobRootRepo repo ) + Nothing -> findConfig >>= \case + Just path -> BL.readFile path >>= return . parseConfig >>= \case + Right config -> return ( path, JobRootConfig config ) + Left err -> reportFailure $ "Failed to parse job file ‘" <> path <> "’:" <> err + Nothing -> reportFailure $ "No job file or repository found" + + let storageFileName = ".minici" + ciStorageDir = case ( optStorage gopts, ciRootPath, ciJobRoot ) of + ( Just path, _ , _ ) -> path + ( Nothing , path, JobRootConfig {} ) -> takeDirectory path </> storageFileName + ( Nothing , _ , JobRootRepo repo ) -> getRepoWorkDir repo </> storageFileName + let ciOptions = optCommon gopts - ciStorageDir = optStorage gopts let exitWithErrors errs = do hPutStrLn stderr $ concat errs <> "Try `minici " <> commandName tproxy <> " --help' for more information." exitFailure @@ -188,14 +214,12 @@ runSomeCommand ciConfigPath gopts (SC tproxy) args = do putStr $ usageInfo (T.unpack $ commandUsage tproxy) (fullCommandOptions tproxy) exitSuccess - 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 + ciContainingRepo <- case ciJobRoot of + JobRootRepo repo -> return (Just repo) + JobRootConfig _ -> openRepo $ takeDirectory ciRootPath let openDeclaredRepo dir decl = do let path = dir </> repoPath decl @@ -207,12 +231,12 @@ runSomeCommand ciConfigPath gopts (SC tproxy) args = do exitFailure cmdlineRepos <- forM (optRepo ciOptions) (openDeclaredRepo "") - configRepos <- case ( ciConfigPath, ciConfig ) of - ( Just path, Right config ) -> + configRepos <- case ciJobRoot of + JobRootConfig config -> forM (configRepos config) $ \decl -> do case lookup (repoName decl) cmdlineRepos of Just repo -> return ( repoName decl, repo ) - Nothing -> openDeclaredRepo (takeDirectory path) decl + Nothing -> openDeclaredRepo (takeDirectory ciRootPath) decl _ -> return [] let ciOtherRepos = configRepos ++ cmdlineRepos diff --git a/src/Repo.hs b/src/Repo.hs index f22b211..dc88c4b 100644 --- a/src/Repo.hs +++ b/src/Repo.hs @@ -1,5 +1,5 @@ module Repo ( - Repo, + Repo, getRepoWorkDir, DeclaredRepo(..), RepoName(..), textRepoName, showRepoName, Commit, commitId, @@ -67,6 +67,9 @@ data Repo instance Show Repo where show GitRepo {..} = gitDir +getRepoWorkDir :: Repo -> FilePath +getRepoWorkDir GitRepo {..} = takeDirectory gitDir + data DeclaredRepo = DeclaredRepo { repoName :: RepoName , repoPath :: FilePath |