minici 0.1.8 → 0.1.9
raw patch · 20 files changed
+870/−268 lines, 20 files
Files
- CHANGELOG.md +8/−0
- README.md +115/−9
- minici.cabal +6/−1
- src/Command.hs +6/−1
- src/Command/Extract.hs +15/−23
- src/Command/JobId.hs +1/−1
- src/Command/Log.hs +1/−1
- src/Command/Run.hs +65/−30
- src/Command/Shell.hs +2/−2
- src/Config.hs +54/−13
- src/Config.hs-boot +3/−0
- src/Destination.hs +54/−0
- src/Eval.hs +175/−102
- src/FileUtils.c +18/−0
- src/FileUtils.hs +69/−0
- src/Job.hs +186/−76
- src/Job/Types.hs +30/−2
- src/Main.hs +46/−6
- src/Output.hs +15/−0
- src/Repo.hs +1/−1
CHANGELOG.md view
@@ -1,5 +1,13 @@ # Revision history for MiniCI +## 0.1.9 -- 2025-12-29++* Reuse job status and artifacts from previous runs+* Added `--rerun-*` command-line options to configure which jobs should be rerun+* Job section to publish artifacts to specified destination+* Accept literal text block for the `shell` section+* Prepare used artifacts for the `shell` command+ ## 0.1.8 -- 2025-07-06 * Added `shell` command to open a shell prepared for given job
README.md view
@@ -10,40 +10,50 @@ Job definition -------------- -The top-level elements of the YAML file are `job <name>` defining steps to-perform the job and potentially listing artifacts produced or required.+The basic top-level elements of the YAML file are `job <name>` defining steps+to perform the job and potentially listing artifacts produced or required. Example: ``` job build:- shell:- - make+ shell: |+ ./configure+ make artifact bin: path: build/example job test: uses: - build.bin- shell:- - ./build/example test+ shell: |+ ./build/example test ``` Each job is a map with the following attributes: `shell`-: List of shell commands to perform the job+: Shell script to perform the job. -`artifact <name>` (optional)+`artifact <name>` : Defines artifact `<name>` produced by this job. Is itself defined as a dictionary. `artifact <name>.path` : Path to the produced artifact file, relative to the root of the project. -`uses` (optional)+`uses` : List of artifact required for this job, in the form `<job>.<artifact>`. +`checkout`+: List of repositories to checkout into the work directory before starting+ the job (see below). If not specified, the default repository (containing+ the YAML file) will be checked out to the root of the work directory. +`publish`+: List of artifacts (produced by this or other jobs) to publish to specified+ destinations (see below).++ Usage ----- @@ -84,3 +94,99 @@ ``` The above options `--range`, `--since-upstream`, etc can be arbitrarily combined.+++Explicit script file+--------------------++Normally, `minici` uses the `minici.yaml` file from the repository in the current working directory;+the path to a repository used can also be specified on the command line before the command (e.g. `run`).+That path must contain a slash character to disambiguate it from a command name, e.g.:+```+minici ../path/to/some/other/repo run some_job+```++Whether using the implicit repository or one specified on the command line, when+executing jobs for a range of commits, `minici` uses the `minici.yaml` file+version from each individual commit. So for example, running:+```+minici run HEAD~5..HEAD+```+can execute different jobs for each commit, if the job file was changed in each of the last five commits.++To force usage of particular version of `minici.yaml` file, explicit path to that file can be given:+```+minici ./minici.yaml run HEAD~5..HEAD+```+In this case, the jobs specified in the current version of `minici.yaml` will+be used for all of the five commits.+++Additional repositories and checkouts+-------------------------------------++Jobs can also use repositories other than the default one (which contains the `minici.yaml` file).+The additional repositories need to be declared at the top level of the `minici.yaml` file as:+```+repo <name>:+ path: <path/to/repository> (optional, only relevant for explicit script file)+```++The path of a repository `<name>` can be given (or overridden) on command line by passing argument in the form `--repo=<name>:<path>` before the command name.+To explicitly set what repositories to check out, set the list in the `checkout` element of the job definition:++```+job some_job:+ checkout:+ - repo: some_repo+ dest: destination/path+ ...+```++The elements of the `checkout` list are dictionaries with following elements:++`repo`+: Name of the repo to checkout from. If not given, the default repo (containing the `minici.yaml` file) is used.++`dest`+: Path within the work directory to use for the checkout. If not given, the root of the work directory is used.++`subtree`+: If provided, checkout only given subtree of the repository. If the given path does not exist within a particular commit, the checkout and the whole job fail.++All checkouts are performed before running the script given in the `shell` element.+If no `checkout` list is given, the whole default repo is checked out to the root of the work directory.+++Destinations+------------++Apart from a recipe, a job can also contain instructions to publish artifacts to given destinations.+The artifacts can be produced either by the publishing job or other jobs, and the destination must be declared at the top of the job file:++```+destination <name>:+ url: <destination url> (optional, only relevant for explicit script file)+```++**Note**: only local filesystem path is currently supported as `url`.++The URL of a destination `<name>` can be given (or overridden) on command line by passing argument in the form `--destination=<name>:<url>` before the command name.+The artifacts to publish are then given in the `publish` list of a job definition:+```+job publish_something:+ publish:+ - to: some_destination+ artifact: other_job.some_artifact+```++Elements of the `publish` list are dictionaries with following elements:++`to`+: Name of the destinations to publish to.++`artifact`+: Artifact to publish—either `<artifact-name>` if produced by this job, or `<job-name>.<artifact-name>` if produced by other job.++`path`+: Path within the destination to publish this artifact to. If not given, artifact path from the work directory is used.
minici.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: minici-version: 0.1.8+version: 0.1.9 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@@ -56,7 +56,9 @@ Command.Shell Command.Subtree Config+ Destination Eval+ FileUtils Job Job.Types Output@@ -67,6 +69,9 @@ Version.Git autogen-modules: Paths_minici++ c-sources:+ src/FileUtils.c default-extensions: DefaultSignatures
src/Command.hs view
@@ -30,19 +30,22 @@ import System.IO import Config+import Destination import Eval import Output import Repo data CommonOptions = CommonOptions { optJobs :: Int- , optRepo :: [ DeclaredRepo ]+ , optRepo :: [ ( RepoName, FilePath ) ]+ , optDestination :: [ ( DestinationName, Text ) ] } defaultCommonOptions :: CommonOptions defaultCommonOptions = CommonOptions { optJobs = 2 , optRepo = []+ , optDestination = [] } class CommandArgumentsType (CommandArguments c) => Command c where@@ -102,6 +105,7 @@ , ciJobRoot :: JobRoot , ciContainingRepo :: Maybe Repo , ciOtherRepos :: [ ( RepoName, Repo ) ]+ , ciDestinations :: [ ( DestinationName, Destination ) ] , ciOutput :: Output , ciStorageDir :: FilePath }@@ -137,6 +141,7 @@ eiCurrentIdRev <- return [] eiContainingRepo <- asks ciContainingRepo eiOtherRepos <- asks ciOtherRepos+ eiDestinations <- asks ciDestinations return EvalInput {..} cmdEvalWith :: (EvalInput -> EvalInput) -> Eval a -> CommandExec a
src/Command/Extract.hs view
@@ -78,30 +78,22 @@ _:_:_ -> tfail $ "destination ‘" <> T.pack extractDestination <> "’ is not a directory" _ -> return False - forM_ extractArtifacts $ \( ref, ArtifactName aname ) -> do- jid@(JobId ids) <- either (tfail . textEvalError) (return . jobId . fst) =<<+ forM_ extractArtifacts $ \( ref, aname ) -> do+ jid <- either (tfail . textEvalError) (return . jobId) =<< liftIO (runEval (evalJobReference ref) einput) - let jdir = joinPath $ (storageDir :) $ ("jobs" :) $ map (T.unpack . textJobIdPart) ids- adir = jdir </> "artifacts" </> T.unpack aname-- liftIO (doesDirectoryExist jdir) >>= \case- True -> return ()- False -> tfail $ "job ‘" <> textJobId jid <> "’ not yet executed"-- liftIO (doesDirectoryExist adir) >>= \case- True -> return ()- False -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"+ tpath <- if+ | isdir -> do+ wpath <- either tfail return =<< runExceptT (getArtifactWorkPath storageDir jid aname)+ return $ extractDestination </> takeFileName wpath+ | otherwise -> return extractDestination - afile <- liftIO (listDirectory adir) >>= \case- [ file ] -> return file- [] -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"- _:_:_ -> tfail $ "unexpected files in ‘" <> T.pack adir <> "’"+ liftIO (doesPathExist tpath) >>= \case+ True+ | extractForce -> liftIO (doesDirectoryExist tpath) >>= \case+ True -> liftIO $ removeDirectoryRecursive tpath+ False -> liftIO $ removeFile tpath+ | otherwise -> tfail $ "destination ‘" <> T.pack tpath <> "’ already exists"+ False -> return () - let tpath | isdir = extractDestination </> afile- | otherwise = extractDestination- when (not extractForce) $ do- liftIO (doesPathExist tpath) >>= \case- True -> tfail $ "destination ‘" <> T.pack tpath <> "’ already exists"- False -> return ()- liftIO $ copyRecursiveForce (adir </> afile) tpath+ either tfail return =<< runExceptT (copyArtifact storageDir jid aname tpath)
src/Command/JobId.hs view
@@ -52,7 +52,7 @@ cmdJobId (JobIdCommand JobIdOptions {..} ref) = do einput <- getEvalInput out <- getOutput- JobId ids <- either (tfail . textEvalError) (return . jobId . fst) =<<+ JobId ids <- either (tfail . textEvalError) (return . jobId) =<< liftIO (runEval (evalJobReference ref) einput) outputMessage out $ textJobId $ JobId ids
src/Command/Log.hs view
@@ -37,7 +37,7 @@ cmdLog :: LogCommand -> CommandExec () cmdLog (LogCommand ref) = do einput <- getEvalInput- jid <- either (tfail . textEvalError) (return . jobId . fst) =<<+ jid <- either (tfail . textEvalError) (return . jobId) =<< liftIO (runEval (evalJobReference ref) einput) output <- getOutput storageDir <- getStorageDir
src/Command/Run.hs view
@@ -8,6 +8,7 @@ import Control.Monad import Control.Monad.IO.Class +import Data.Containers.ListUtils import Data.Either import Data.List import Data.Maybe@@ -32,12 +33,19 @@ data RunCommand = RunCommand RunOptions [ Text ] data RunOptions = RunOptions- { roRanges :: [ Text ]+ { roRerun :: RerunOption+ , roRanges :: [ Text ] , roSinceUpstream :: [ Text ] , roNewCommitsOn :: [ Text ] , roNewTags :: [ Pattern ] } +data RerunOption+ = RerunExplicit+ | RerunFailed+ | RerunAll+ | RerunNone+ instance Command RunCommand where commandName _ = "run" commandDescription _ = "Execude jobs per minici.yaml for given commits"@@ -57,14 +65,27 @@ type CommandOptions RunCommand = RunOptions defaultCommandOptions _ = RunOptions- { roRanges = []+ { roRerun = RerunExplicit+ , roRanges = [] , roSinceUpstream = [] , roNewCommitsOn = [] , roNewTags = [] } commandOptions _ =- [ Option [] [ "range" ]+ [ Option [] [ "rerun-explicit" ]+ (NoArg (\opts -> opts { roRerun = RerunExplicit }))+ "rerun jobs given explicitly on command line and their failed dependencies (default)"+ , Option [] [ "rerun-failed" ]+ (NoArg (\opts -> opts { roRerun = RerunFailed }))+ "rerun failed jobs only"+ , Option [] [ "rerun-all" ]+ (NoArg (\opts -> opts { roRerun = RerunAll }))+ "rerun all jobs"+ , Option [] [ "rerun-none" ]+ (NoArg (\opts -> opts { roRerun = RerunNone }))+ "do not rerun any job"+ , Option [] [ "range" ] (ReqArg (\val opts -> opts { roRanges = T.pack val : roRanges opts }) "<range>") "run jobs for commits in given range" , Option [] [ "since-upstream" ]@@ -126,7 +147,8 @@ argumentJobSource :: [ JobName ] -> CommandExec JobSource argumentJobSource [] = emptyJobSource argumentJobSource names = do- ( config, jcommit ) <- getJobRoot >>= \case+ jobRoot <- getJobRoot+ ( config, jcommit ) <- case jobRoot of JobRootConfig config -> do commit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo return ( config, commit )@@ -138,43 +160,46 @@ jobtree <- case jcommit of Just commit -> (: []) <$> getCommitTree commit Nothing -> return []- let cidPart = map (JobIdTree Nothing "" . treeId) jobtree+ let cidPart = case jobRoot of+ JobRootConfig {} -> []+ JobRootRepo {} -> map (JobIdTree Nothing "" . treeId) jobtree forM_ names $ \name -> case find ((name ==) . jobName) (configJobs config) of Just _ -> return () Nothing -> tfail $ "job ‘" <> textJobName name <> "’ not found" jset <- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) $ do- fullSet <- evalJobSet (map ( Nothing, ) jobtree) JobSet+ evalJobSetSelected names (map ( Nothing, ) jobtree) JobSet { jobsetId = ()+ , jobsetConfig = Just config , jobsetCommit = jcommit+ , jobsetExplicitlyRequested = names , jobsetJobsEither = Right (configJobs config) }- let selectedSet = fullSet { jobsetJobsEither = fmap (filter ((`elem` names) . jobName)) (jobsetJobsEither fullSet) }- fillInDependencies selectedSet oneshotJobSource [ jset ] refJobSource :: [ JobRef ] -> CommandExec JobSource refJobSource [] = emptyJobSource refJobSource refs = do- jobs <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReference refs)- sets <- cmdEvalWith id $ do- forM jobs $ \( sid, js ) -> do- fillInDependencies $ JobSet sid Nothing (Right $ reverse js)+ sets <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReferenceToSet refs) oneshotJobSource sets where- addJobToList :: [ ( JobSetId, [ Job ] ) ] -> ( Job, JobSetId ) -> [ ( JobSetId, [ Job ] ) ]- addJobToList (( sid, js ) : rest ) ( job, jsid )- | sid == jsid = ( sid, job : js ) : rest- | otherwise = ( sid, js ) : addJobToList rest ( job, jsid )- addJobToList [] ( job, jsid ) = [ ( jsid, [ job ] ) ]+ addJobToList :: [ JobSet ] -> JobSet -> [ JobSet ]+ addJobToList (cur : rest) jset+ | jobsetId cur == jobsetId jset = cur { jobsetJobsEither = fmap (nubOrdOn jobId) $ (++) <$> (jobsetJobsEither cur) <*> (jobsetJobsEither jset)+ , jobsetExplicitlyRequested = nubOrd $ jobsetExplicitlyRequested cur ++ jobsetExplicitlyRequested jset+ } : rest+ | otherwise = cur : addJobToList rest jset+ addJobToList [] jset = [ jset ] loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet loadJobSetFromRoot root commit = case root of JobRootRepo _ -> loadJobSetForCommit commit JobRootConfig config -> return JobSet { jobsetId = ()+ , jobsetConfig = Just config , jobsetCommit = Just commit+ , jobsetExplicitlyRequested = [] , jobsetJobsEither = Right $ configJobs config } @@ -311,8 +336,10 @@ 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 waitForJobs = do+ atomically $ do+ flip when retry . (0 <) =<< readTVar threadCount+ waitForRemainingTasks mngr let loop _ Nothing = return () loop names (Just ( [], next )) = do@@ -332,7 +359,11 @@ case jobsetJobsEither jobset of Right jobs -> do- outs <- runJobs mngr output jobs+ outs <- runJobs mngr output jobs $ case roRerun of+ RerunExplicit -> \jid status -> jid `elem` jobsetExplicitlyRequested jobset || jobStatusFailed status+ RerunFailed -> \_ status -> jobStatusFailed status+ RerunAll -> \_ _ -> True+ RerunNone -> \_ _ -> False let findJob name = snd <$> find ((name ==) . jobName . fst) outs statuses = map findJob names forM_ (outputTerminal output) $ \tout -> do@@ -365,21 +396,25 @@ showStatus :: Bool -> JobStatus a -> Text showStatus blink = \case- JobQueued -> "\ESC[94m…\ESC[0m "+ JobQueued -> " \ESC[94m…\ESC[0m " 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 "+ JobSkipped -> " \ESC[0m-\ESC[0m "+ JobRunning -> " \ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m " JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (maybe "?" (show . tfNumber) (footnoteTerminal fnote)) <> "]") <> "\ESC[0m"- JobFailed -> "\ESC[91m✗\ESC[0m "- JobCancelled -> "\ESC[0mC\ESC[0m "- JobDone _ -> "\ESC[92m✓\ESC[0m "+ JobFailed -> " \ESC[91m✗\ESC[0m "+ JobCancelled -> " \ESC[0mC\ESC[0m "+ JobDone _ -> " \ESC[92m✓\ESC[0m " 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 "+ 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++ JobPreviousStatus (JobDone _) -> "\ESC[90m«\ESC[32m✓\ESC[0m "+ JobPreviousStatus (JobFailed) -> "\ESC[90m«\ESC[31m✗\ESC[0m "+ JobPreviousStatus s -> "\ESC[90m«" <> T.init (showStatus blink s) displayStatusLine :: TerminalOutput -> TerminalLine -> Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO () displayStatusLine tout line prefix1 prefix2 statuses = do
src/Command/Shell.hs view
@@ -37,10 +37,10 @@ cmdShell :: ShellCommand -> CommandExec () cmdShell (ShellCommand ref) = do einput <- getEvalInput- job <- either (tfail . textEvalError) (return . fst) =<<+ job <- either (tfail . textEvalError) return =<< liftIO (runEval (evalJobReference ref) einput) sh <- fromMaybe "/bin/sh" <$> liftIO (lookupEnv "SHELL") storageDir <- getStorageDir- prepareJob storageDir job $ \checkoutPath _ -> do+ prepareJob storageDir job $ \checkoutPath -> do liftIO $ withCreateProcess (proc sh []) { cwd = Just checkoutPath } $ \_ _ _ ph -> do void $ waitForProcess ph
src/Config.hs view
@@ -26,6 +26,7 @@ import System.FilePath.Glob import System.Process +import Destination import Job.Types import Repo @@ -42,18 +43,21 @@ data Config = Config { configJobs :: [ DeclaredJob ] , configRepos :: [ DeclaredRepo ]+ , configDestinations :: [ DeclaredDestination ] } instance Semigroup Config where a <> b = Config { configJobs = configJobs a ++ configJobs b , configRepos = configRepos a ++ configRepos b+ , configDestinations = configDestinations a ++ configDestinations b } instance Monoid Config where mempty = Config { configJobs = [] , configRepos = []+ , configDestinations = [] } instance FromYAML Config where@@ -72,24 +76,31 @@ | [ "repo", name ] <- T.words tag -> do repo <- parseRepo name node return $ config { configRepos = configRepos config ++ [ repo ] }+ | [ "destination", name ] <- T.words tag -> do+ destination <- parseDestination name node+ return $ config { configDestinations = configDestinations config ++ [ destination ] } _ -> return config parseJob :: Text -> Node Pos -> Parser DeclaredJob parseJob name node = flip (withMap "Job") node $ \j -> do let jobName = JobName name jobId = jobName+ jobRecipe <- choice+ [ fmap Just $ cabalJob =<< j .: "cabal"+ , fmap Just $ shellJob =<< j .: "shell"+ , return Nothing+ ] jobCheckout <- choice [ parseSingleCheckout =<< j .: "checkout" , parseMultipleCheckouts =<< j .: "checkout" , withNull "no checkout" (return []) =<< j .: "checkout"- , return [ JobCheckout Nothing Nothing Nothing ]- ]- jobRecipe <- choice- [ cabalJob =<< j .: "cabal"- , shellJob =<< j .: "shell"+ , return $ if isJust jobRecipe+ then [ JobCheckout Nothing Nothing Nothing ]+ else [] ] jobArtifacts <- parseArtifacts j jobUses <- maybe (return []) parseUses =<< j .:? "uses"+ jobPublish <- maybe (return []) (parsePublish jobName) =<< j .:? "publish" return Job {..} parseSingleCheckout :: Node Pos -> Parser [ JobCheckout Declared ]@@ -106,18 +117,23 @@ parseMultipleCheckouts :: Node Pos -> Parser [ JobCheckout Declared ] parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout -cabalJob :: Node Pos -> Parser [CreateProcess]+cabalJob :: Node Pos -> Parser [ Either CreateProcess Text ] cabalJob = withMap "cabal job" $ \m -> do ghcOptions <- m .:? "ghc-options" >>= \case Nothing -> return [] Just s -> withSeq "GHC option list" (mapM (withStr "GHC option" return)) s return- [ proc "cabal" $ concat [ ["build"], ("--ghc-option="++) . T.unpack <$> ghcOptions ] ]+ [ Left $ proc "cabal" $ concat [ ["build"], ("--ghc-option="++) . T.unpack <$> ghcOptions ] ] -shellJob :: Node Pos -> Parser [CreateProcess]-shellJob = withSeq "shell commands" $ \xs -> do- fmap (map shell) $ forM xs $ withStr "shell command" $ return . T.unpack+shellJob :: Node Pos -> Parser [ Either CreateProcess Text ]+shellJob node = do+ commands <- choice+ [ withStr "shell commands" return node+ , withSeq "shell commands" (\xs -> do+ fmap T.unlines $ forM xs $ withStr "shell command" $ return) node+ ]+ return [ Right commands ] parseArtifacts :: Mapping Pos -> Parser [ ( ArtifactName, Pattern ) ] parseArtifacts m = do@@ -136,13 +152,36 @@ [job, art] <- return $ T.split (== '.') text return (JobName job, ArtifactName art) +parsePublish :: JobName -> Node Pos -> Parser [ JobPublish Declared ]+parsePublish ownName = withSeq "Publish list" $ mapM $+ withMap "Publish specification" $ \m -> do+ artifact <- m .: "artifact"+ jpArtifact <- case T.split (== '.') artifact of+ [ job, art ] -> return ( JobName job, ArtifactName art )+ [ art ] -> return ( ownName, ArtifactName art )+ _ -> mzero+ jpDestination <- DestinationName <$> m .: "to"+ jpPath <- fmap T.unpack <$> m .:? "path"+ return JobPublish {..} + parseRepo :: Text -> Node Pos -> Parser DeclaredRepo-parseRepo name node = flip (withMap "Repo") node $ \r -> DeclaredRepo- <$> pure (RepoName name)- <*> (T.unpack <$> r .: "path")+parseRepo name node = choice+ [ flip (withNull "Repo") node $ return $ DeclaredRepo (RepoName name) Nothing+ , flip (withMap "Repo") node $ \r -> DeclaredRepo+ <$> pure (RepoName name)+ <*> (fmap T.unpack <$> r .:? "path")+ ] +parseDestination :: Text -> Node Pos -> Parser DeclaredDestination+parseDestination name node = choice+ [ flip (withNull "Destination") node $ return $ DeclaredDestination (DestinationName name) Nothing+ , flip (withMap "Destination") node $ \r -> DeclaredDestination+ <$> pure (DestinationName name)+ <*> (r .:? "url")+ ] + findConfig :: IO (Maybe FilePath) findConfig = go "." where@@ -174,6 +213,8 @@ where toJobSet configEither = JobSet { jobsetId = ()+ , jobsetConfig = either (const Nothing) Just configEither , jobsetCommit = Just commit+ , jobsetExplicitlyRequested = [] , jobsetJobsEither = fmap configJobs configEither }
+ src/Config.hs-boot view
@@ -0,0 +1,3 @@+module Config where++data Config
+ src/Destination.hs view
@@ -0,0 +1,54 @@+module Destination (+ Destination,+ DeclaredDestination(..),+ DestinationName(..), textDestinationName, showDestinationName,++ openDestination,+ copyToDestination,++ copyRecursive,+ copyRecursiveForce,+) where++import Control.Monad.IO.Class++import Data.Text (Text)+import Data.Text qualified as T++import System.FilePath+import System.Directory++import FileUtils+++data Destination+ = FilesystemDestination FilePath++data DeclaredDestination = DeclaredDestination+ { destinationName :: DestinationName+ , destinationUrl :: Maybe Text+ }+++newtype DestinationName = DestinationName Text+ deriving (Eq, Ord, Show)++textDestinationName :: DestinationName -> Text+textDestinationName (DestinationName text) = text++showDestinationName :: DestinationName -> String+showDestinationName = T.unpack . textDestinationName+++openDestination :: FilePath -> Text -> IO Destination+openDestination baseDir url = do+ let path = baseDir </> T.unpack url+ createDirectoryIfMissing True path+ return $ FilesystemDestination path++copyToDestination :: MonadIO m => FilePath -> Destination -> FilePath -> m ()+copyToDestination source (FilesystemDestination base) inner = do+ let target = base </> dropWhile isPathSeparator inner+ liftIO $ do+ createDirectoryIfMissing True $ takeDirectory target+ copyRecursiveForce source target
src/Eval.hs view
@@ -3,12 +3,12 @@ EvalError(..), textEvalError, Eval, runEval, - evalJob, evalJobSet,+ evalJobSetSelected, evalJobReference,+ evalJobReferenceToSet, loadJobSetById,- fillInDependencies, ) where import Control.Monad@@ -17,13 +17,13 @@ import Data.List import Data.Maybe-import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T import System.FilePath import Config+import Destination import Job.Types import Repo @@ -33,6 +33,7 @@ , eiCurrentIdRev :: [ JobIdPart ] , eiContainingRepo :: Maybe Repo , eiOtherRepos :: [ ( RepoName, Repo ) ]+ , eiDestinations :: [ ( DestinationName, Destination ) ] } data EvalError@@ -52,81 +53,169 @@ commonPrefix (x : xs) (y : ys) | x == y = x : commonPrefix xs ys commonPrefix _ _ = [] -isDefaultRepoMissingInId :: DeclaredJob -> Eval Bool-isDefaultRepoMissingInId djob- | all (isJust . jcRepo) (jobCheckout djob) = return False- | otherwise = asks (not . any matches . eiCurrentIdRev)+checkIfAlreadyHasDefaultRepoId :: Eval Bool+checkIfAlreadyHasDefaultRepoId = do+ asks (any isDefaultRepoId . eiCurrentIdRev) where- matches (JobIdName _) = False- matches (JobIdCommit rname _) = isNothing rname- matches (JobIdTree rname _ _) = isNothing rname+ isDefaultRepoId (JobIdName _) = False+ isDefaultRepoId (JobIdCommit rname _) = isNothing rname+ isDefaultRepoId (JobIdTree rname _ _) = isNothing rname +collectJobSetRepos :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval [ ( Maybe RepoName, Tree ) ]+collectJobSetRepos revisionOverrides dset = do+ jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset+ let someJobUsesDefaultRepo = any (any (isNothing . jcRepo) . jobCheckout) jobs+ repos =+ (if someJobUsesDefaultRepo then (Nothing :) else id) $+ map (Just . repoName) $ maybe [] configRepos $ jobsetConfig dset+ forM repos $ \rname -> do+ case lookup rname revisionOverrides of+ Just tree -> return ( rname, tree )+ Nothing -> do+ repo <- evalRepo rname+ tree <- getCommitTree =<< readCommit repo "HEAD"+ return ( rname, tree )+ collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ ( Maybe ( RepoName, Maybe Text ), FilePath ) ] collectOtherRepos dset decl = do- let dependencies = map fst $ jobUses decl+ jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset+ let gatherDependencies seen (d : ds)+ | d `elem` seen = gatherDependencies seen ds+ | Just job <- find ((d ==) . jobName) jobs+ = gatherDependencies (d : seen) (map fst (jobRequiredArtifacts job) ++ ds)+ | otherwise = gatherDependencies (d : seen) ds+ gatherDependencies seen [] = seen++ let dependencies = gatherDependencies [] [ jobName decl ] dependencyRepos <- forM dependencies $ \name -> do- jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset job <- maybe (throwError $ OtherEvalError $ "job ‘" <> textJobName name <> "’ not found") return . find ((name ==) . jobName) $ jobs return $ jobCheckout job - missingDefault <- isDefaultRepoMissingInId decl-+ alreadyHasDefaultRepoId <- checkIfAlreadyHasDefaultRepoId let checkouts =- (if missingDefault then id else (filter (isJust . jcRepo))) $- concat- [ jobCheckout decl- , concat dependencyRepos- ]+ (if alreadyHasDefaultRepoId then filter (isJust . jcRepo) else id) $+ concat dependencyRepos+ let commonSubdir reporev = joinPath $ foldr1 commonPrefix $ map (maybe [] splitDirectories . jcSubtree) . filter ((reporev ==) . jcRepo) $ checkouts- return $ map (\r -> ( r, commonSubdir r )) . nub . map jcRepo $ checkouts+ let canonicalRepoOrder = Nothing : maybe [] (map (Just . repoName) . configRepos) (jobsetConfig dset)+ getCheckoutsForName rname = map (\r -> ( r, commonSubdir r )) $ nub $ filter ((rname ==) . fmap fst) $ map jcRepo checkouts+ return $ concatMap getCheckoutsForName canonicalRepoOrder -evalJob :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> DeclaredJob -> Eval ( Job, JobSetId )-evalJob revisionOverrides dset decl = do+evalJobs+ :: [ DeclaredJob ] -> [ Either JobName Job ]+ -> [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> [ JobName ] -> Eval [ Job ]+evalJobs _ _ _ JobSet { jobsetJobsEither = Left err } _ = throwError $ OtherEvalError $ T.pack err++evalJobs [] evaluated repos dset@JobSet { jobsetJobsEither = Right decl } (req : reqs)+ | any ((req ==) . either id jobName) evaluated+ = evalJobs [] evaluated repos dset reqs+ | Just d <- find ((req ==) . jobName) decl+ = evalJobs [ d ] evaluated repos dset reqs+ | otherwise+ = throwError $ OtherEvalError $ "job ‘" <> textJobName req <> "’ not found in jobset"+evalJobs [] evaluated _ _ [] = return $ mapMaybe (either (const Nothing) Just) evaluated++evalJobs (current : evaluating) evaluated repos dset reqs+ | any ((jobName current ==) . jobName) evaluating = throwError $ OtherEvalError $ "cyclic dependency when evaluating job ‘" <> textJobName (jobName current) <> "’"+ | any ((jobName current ==) . either id jobName) evaluated = evalJobs evaluating evaluated repos dset reqs++evalJobs (current : evaluating) evaluated repos dset reqs+ | Just missing <- find (`notElem` (jobName current : map (either id jobName) evaluated)) $ map fst $ jobRequiredArtifacts current+ , d <- either (const Nothing) (find ((missing ==) . jobName)) (jobsetJobsEither dset)+ = evalJobs (fromJust d : current : evaluating) evaluated repos dset reqs++evalJobs (current : evaluating) evaluated repos dset reqs = do EvalInput {..} <- ask- otherRepos <- collectOtherRepos dset decl- otherRepoTrees <- forM otherRepos $ \( mbrepo, commonPath ) -> do- ( mbrepo, ) . ( commonPath, ) <$> do- case lookup (fst <$> mbrepo) revisionOverrides of- Just tree -> return tree- Nothing -> do- repo <- evalRepo (fst <$> mbrepo)- commit <- readCommit repo (fromMaybe "HEAD" $ join $ snd <$> mbrepo)- getSubtree (Just commit) commonPath =<< getCommitTree commit+ otherRepos <- collectOtherRepos dset current+ otherRepoTreesMb <- forM otherRepos $ \( mbrepo, commonPath ) -> do+ Just tree <- return $ lookup (fst <$> mbrepo) repos+ mbSubtree <- case snd =<< mbrepo of+ Just revisionOverride -> return . Just =<< getCommitTree =<< readCommit (treeRepo tree) revisionOverride+ Nothing+ | treeSubdir tree == commonPath -> do+ return $ Just tree+ | splitDirectories (treeSubdir tree) `isPrefixOf` splitDirectories commonPath -> do+ Just <$> getSubtree Nothing (makeRelative (treeSubdir tree) commonPath) tree+ | otherwise -> do+ return Nothing+ return $ fmap (\subtree -> ( mbrepo, ( commonPath, subtree ) )) mbSubtree+ let otherRepoTrees = catMaybes otherRepoTreesMb+ if all isJust otherRepoTreesMb+ then do+ let otherRepoIds = flip mapMaybe otherRepoTrees $ \case+ ( repo, ( subtree, tree )) -> do+ guard $ maybe True (isNothing . snd) repo -- use only checkouts without explicit revision in job id+ Just $ JobIdTree (fst <$> repo) subtree (treeId tree)+ let currentJobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId current) : eiCurrentIdRev - checkouts <- forM (jobCheckout decl) $ \dcheckout -> do- return dcheckout- { jcRepo =- fromMaybe (error $ "expecting repo in either otherRepoTrees or revisionOverrides: " <> show (textRepoName . fst <$> jcRepo dcheckout)) $- msum- [ snd <$> lookup (jcRepo dcheckout) otherRepoTrees- , lookup (fst <$> jcRepo dcheckout) revisionOverrides- ]- }+ checkouts <- forM (jobCheckout current) $ \dcheckout -> do+ return dcheckout+ { jcRepo =+ fromMaybe (error $ "expecting repo in either otherRepoTrees or repos: " <> show (textRepoName . fst <$> jcRepo dcheckout)) $+ msum+ [ snd <$> lookup (jcRepo dcheckout) otherRepoTrees+ , lookup (fst <$> jcRepo dcheckout) repos -- for containing repo if filtered from otherRepos+ ]+ } - let otherRepoIds = map (\( repo, ( subtree, tree )) -> JobIdTree (fst <$> repo) subtree (treeId tree)) otherRepoTrees- return- ( Job- { jobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId decl) : eiCurrentIdRev- , jobName = jobName decl- , jobCheckout = checkouts- , jobRecipe = jobRecipe decl- , jobArtifacts = jobArtifacts decl- , jobUses = jobUses decl- }- , JobSetId $ reverse $ reverse otherRepoIds ++ eiCurrentIdRev- )+ uses <- forM (jobUses current) $ \( jname, aname ) -> do+ Just (Right job) <- return $ find ((jname ==) . either id jobName) evaluated+ return ( jobId job, aname ) + destinations <- forM (jobPublish current) $ \dpublish -> do+ let ( jname, _ ) = jpArtifact dpublish+ jid <- if+ | jname == jobName current -> return currentJobId+ | otherwise -> do+ Just (Right job) <- return $ find ((jname ==) . either id jobName) evaluated+ return $ jobId job++ case lookup (jpDestination dpublish) eiDestinations of+ Just dest -> return dpublish+ { jpArtifact = ( jid, snd (jpArtifact dpublish) )+ , jpDestination = dest+ }+ Nothing -> throwError $ OtherEvalError $ "no url defined for destination ‘" <> textDestinationName (jpDestination dpublish) <> "’"++ let job = Job+ { jobId = currentJobId+ , jobName = jobName current+ , jobCheckout = checkouts+ , jobRecipe = jobRecipe current+ , jobArtifacts = jobArtifacts current+ , jobUses = uses+ , jobPublish = destinations+ }+ evalJobs evaluating (Right job : evaluated) repos dset reqs+ else do+ evalJobs evaluating (Left (jobName current) : evaluated) repos dset reqs+ evalJobSet :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet-evalJobSet revisionOverrides decl = do+evalJobSet revisionOverrides decl = evalJobSetSelected (either (const []) (map jobName) (jobsetJobsEither decl)) revisionOverrides decl++evalJobSetSelected :: [ JobName ] -> [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet+evalJobSetSelected selected revisionOverrides decl = do EvalInput {..} <- ask- jobs <- fmap (fmap (map fst))- $ either (return . Left) (handleToEither . mapM (evalJob revisionOverrides decl))- $ jobsetJobsEither decl+ repos <- collectJobSetRepos revisionOverrides decl+ alreadyHasDefaultRepoId <- checkIfAlreadyHasDefaultRepoId+ let addedRepoIds =+ map (\( mbname, tree ) -> JobIdTree mbname (treeSubdir tree) (treeId tree)) $+ (if alreadyHasDefaultRepoId then filter (isJust . fst) else id) $+ repos++ evaluated <- handleToEither $ evalJobs [] [] repos decl selected+ let jobs = case liftM2 (,) evaluated (jobsetJobsEither decl) of+ Left err -> Left err+ Right ( ejobs, djobs ) -> Right $ mapMaybe (\dj -> find ((jobName dj ==) . jobName) ejobs) djobs++ let explicit = mapMaybe (\name -> jobId <$> find ((name ==) . jobName) (either (const []) id jobs)) $ jobsetExplicitlyRequested decl return JobSet- { jobsetId = JobSetId $ reverse $ eiCurrentIdRev+ { jobsetId = JobSetId $ reverse $ reverse addedRepoIds ++ eiCurrentIdRev+ , jobsetConfig = jobsetConfig decl , jobsetCommit = jobsetCommit decl+ , jobsetExplicitlyRequested = explicit , jobsetJobsEither = jobs } where@@ -141,21 +230,31 @@ Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined" -canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval ( Job, JobSetId )+canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval JobSet canonicalJobName (r : rs) config mbDefaultRepo = do let name = JobName r- dset = JobSet () Nothing $ Right $ configJobs config+ dset = JobSet+ { jobsetId = ()+ , jobsetConfig = Just config+ , jobsetCommit = Nothing+ , jobsetExplicitlyRequested = [ name ]+ , jobsetJobsEither = Right $ configJobs config+ } case find ((name ==) . jobName) (configJobs config) of Just djob -> do otherRepos <- collectOtherRepos dset djob ( overrides, rs' ) <- (\f -> foldM f ( [], rs ) otherRepos) $- \( overrides, crs ) ( mbrepo, path ) -> do- ( tree, crs' ) <- readTreeFromIdRef crs path =<< evalRepo (fst <$> mbrepo)- return ( ( fst <$> mbrepo, tree ) : overrides, crs' )+ \( overrides, crs ) ( mbrepo, path ) -> if+ | Just ( _, Just _ ) <- mbrepo -> do+ -- use only checkouts without explicit revision in job id+ return ( overrides, crs )+ | otherwise -> do+ ( tree, crs' ) <- readTreeFromIdRef crs path =<< evalRepo (fst <$> mbrepo)+ return ( ( fst <$> mbrepo, tree ) : overrides, crs' ) case rs' of (r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’" _ -> return ()- evalJob (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset djob+ evalJobSetSelected (jobsetExplicitlyRequested dset) (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found" canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name" @@ -168,26 +267,33 @@ Nothing -> throwError $ OtherEvalError $ "failed to resolve ‘" <> r <> "’ to a commit or tree in " <> T.pack (show repo) readTreeFromIdRef [] _ _ = throwError $ OtherEvalError $ "expected commit or tree reference" -canonicalCommitConfig :: [ Text ] -> Repo -> Eval ( Job, JobSetId )+canonicalCommitConfig :: [ Text ] -> Repo -> Eval JobSet canonicalCommitConfig rs repo = do ( tree, rs' ) <- readTreeFromIdRef rs "" repo config <- either fail return =<< loadConfigForCommit tree local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $ canonicalJobName rs' config (Just tree) -evalJobReference :: JobRef -> Eval ( Job, JobSetId )-evalJobReference (JobRef rs) =+evalJobReferenceToSet :: JobRef -> Eval JobSet+evalJobReferenceToSet (JobRef rs) = asks eiJobRoot >>= \case JobRootRepo defRepo -> do canonicalCommitConfig rs defRepo JobRootConfig config -> do canonicalJobName rs config Nothing +evalJobReference :: JobRef -> Eval Job+evalJobReference ref = do+ jset <- evalJobReferenceToSet ref+ jobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither jset+ [ name ] <- return $ jobsetExplicitlyRequested jset+ maybe (error "missing job in evalJobReferenceToSet result") return $ find ((name ==) . jobId) jobs + jobsetFromConfig :: [ JobIdPart ] -> Config -> Maybe Tree -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] ) jobsetFromConfig sid config _ = do EvalInput {..} <- ask- let dset = JobSet () Nothing $ Right $ configJobs config+ let dset = JobSet () (Just config) Nothing [] $ Right $ configJobs config otherRepos <- forM sid $ \case JobIdName name -> do throwError $ OtherEvalError $ "expected tree id, not a job name ‘" <> textJobName name <> "’"@@ -209,7 +315,7 @@ throwError $ OtherEvalError $ "expected root commit or tree id" tree <- readTreeId repo path tid config <- either fail return =<< loadConfigForCommit tree- local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $ do+ local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev ei }) $ do ( dset, idRev, otherRepos ) <- jobsetFromConfig sid config (Just tree) return ( dset, idRev, ( Nothing, tree ) : otherRepos ) @@ -217,7 +323,7 @@ when (isJust name) $ do throwError $ OtherEvalError $ "expected default repo commit or tree id" tree <- getCommitTree =<< readCommitId repo cid- jobsetFromCommitConfig (JobIdTree name "" (treeId tree) : sid) repo+ jobsetFromCommitConfig (JobIdTree name (treeSubdir tree) (treeId tree) : sid) repo jobsetFromCommitConfig (JobIdName name : _) _ = do throwError $ OtherEvalError $ "expected commit or tree id, not a job name ‘" <> textJobName name <> "’"@@ -232,36 +338,3 @@ jobsetFromCommitConfig sid defRepo JobRootConfig config -> do jobsetFromConfig sid config Nothing--fillInDependencies :: JobSet -> Eval JobSet-fillInDependencies jset = do- ( dset, idRev, otherRepos ) <- local (\ei -> ei { eiCurrentIdRev = [] }) $ do- loadJobSetById (jobsetId jset)- origJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither jset- declJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset- deps <- gather declJobs S.empty (map jobName origJobs)-- jobs <- local (\ei -> ei { eiCurrentIdRev = idRev }) $ do- fmap catMaybes $ forM declJobs $ \djob -> if- | Just job <- find ((jobName djob ==) . jobName) origJobs- -> return (Just job)-- | jobName djob `S.member` deps- -> Just . fst <$> evalJob otherRepos dset djob-- | otherwise- -> return Nothing-- return $ jset { jobsetJobsEither = Right jobs }- where- gather djobs cur ( name : rest )- | name `S.member` cur- = gather djobs cur rest-- | Just djob <- find ((name ==) . jobName) djobs- = gather djobs (S.insert name cur) $ map fst (jobUses djob) ++ rest-- | otherwise- = throwError $ OtherEvalError $ "dependency ‘" <> textJobName name <> "’ not found"-- gather _ cur [] = return cur
+ src/FileUtils.c view
@@ -0,0 +1,18 @@+#include <fcntl.h>+#include <sys/stat.h>+#include <unistd.h>++int minici_fd_open_read( const char * from )+{+ return open( from, O_RDONLY | O_CLOEXEC );+}++int minici_fd_create_write( const char * from, int fd_perms )+{+ struct stat st;+ mode_t mode = 0600;+ if( fstat( fd_perms, & st ) == 0 )+ mode = st.st_mode;++ return open( from, O_CREAT | O_WRONLY | O_TRUNC | O_CLOEXEC, mode );+}
+ src/FileUtils.hs view
@@ -0,0 +1,69 @@+module FileUtils where++import Control.Monad+import Control.Monad.Catch++import Data.ByteString (useAsCString)+import Data.Text qualified as T+import Data.Text.Encoding++import Foreign.C.Error+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Ptr++import System.Directory+import System.FilePath+import System.Posix.IO.ByteString+import System.Posix.Types+++-- As of directory-1.3.9 and file-io-0.1.5, the provided copyFile creates a+-- temporary file without O_CLOEXEC, sometimes leaving the write descriptor+-- open in child processes.+safeCopyFile :: FilePath -> FilePath -> IO ()+safeCopyFile from to = do+ allocaBytes (fromIntegral bufferSize) $ \buf ->+ useAsCString (encodeUtf8 $ T.pack from) $ \cfrom ->+ useAsCString (encodeUtf8 $ T.pack to) $ \cto ->+ bracket (throwErrnoPathIfMinus1 "open" from $ c_fd_open_read cfrom) closeFd $ \fromFd ->+ bracket (throwErrnoPathIfMinus1 "open" to $ c_fd_create_write cto fromFd) closeFd $ \toFd -> do+ let goRead = do+ count <- throwErrnoIfMinus1Retry ("read " <> from) $ fdReadBuf fromFd buf bufferSize+ when (count > 0) $ do+ goWrite count 0+ goWrite count written+ | written < count = do+ written' <- throwErrnoIfMinus1Retry ("write " <> to) $+ fdWriteBuf toFd (buf `plusPtr` fromIntegral written) (count - written)+ goWrite count (written + written')+ | otherwise = do+ goRead+ goRead+ where+ bufferSize = 131072++-- Custom open(2) wrappers using O_CLOEXEC. The `cloexec` in `OpenFileFlags` is+-- available only since unix-2.8.0.0+foreign import ccall "minici_fd_open_read" c_fd_open_read :: CString -> IO Fd+foreign import ccall "minici_fd_create_write" c_fd_create_write :: CString -> Fd -> IO Fd+++copyRecursive :: FilePath -> FilePath -> IO ()+copyRecursive from to = do+ doesDirectoryExist from >>= \case+ False -> do+ safeCopyFile from to+ True -> do+ createDirectory to+ content <- listDirectory from+ forM_ content $ \name -> do+ copyRecursive (from </> name) (to </> name)++copyRecursiveForce :: FilePath -> FilePath -> IO ()+copyRecursiveForce from to = do+ doesDirectoryExist to >>= \case+ False -> return ()+ True -> removeDirectoryRecursive to+ copyRecursive from to
src/Job.hs view
@@ -7,8 +7,12 @@ JobStatus(..), jobStatusFinished, jobStatusFailed, JobManager(..), newJobManager, cancelAllJobs,- runJobs,+ runJobs, waitForRemainingTasks,+ prepareJob,+ getArtifactWorkPath,+ copyArtifact,+ jobStorageSubdir, copyRecursive,@@ -34,6 +38,7 @@ import Data.Text.IO qualified as T import System.Directory+import System.Environment import System.Exit import System.FilePath import System.FilePath.Glob@@ -42,14 +47,14 @@ import System.Posix.Signals import System.Process +import Destination import Job.Types import Output import Repo data JobOutput = JobOutput- { outName :: JobName- , outArtifacts :: [ArtifactOutput]+ { outArtifacts :: [ArtifactOutput] } deriving (Eq) @@ -63,6 +68,7 @@ data JobStatus a = JobQueued | JobDuplicate JobId (JobStatus a)+ | JobPreviousStatus (JobStatus a) | JobWaiting [JobName] | JobRunning | JobSkipped@@ -74,23 +80,33 @@ jobStatusFinished :: JobStatus a -> Bool jobStatusFinished = \case- JobQueued {} -> False- JobDuplicate _ s -> jobStatusFinished s- JobWaiting {} -> False- JobRunning {} -> False- _ -> True+ JobQueued {} -> False+ JobDuplicate _ s -> jobStatusFinished s+ JobPreviousStatus s -> jobStatusFinished s+ JobWaiting {} -> False+ JobRunning {} -> False+ _ -> True jobStatusFailed :: JobStatus a -> Bool jobStatusFailed = \case- JobDuplicate _ s -> jobStatusFailed s- JobError {} -> True- JobFailed {} -> True- _ -> False+ JobDuplicate _ s -> jobStatusFailed s+ JobPreviousStatus s -> jobStatusFailed s+ JobError {} -> True+ JobFailed {} -> True+ _ -> False +jobResult :: JobStatus a -> Maybe a+jobResult = \case+ JobDone x -> Just x+ JobDuplicate _ s -> jobResult s+ JobPreviousStatus s -> jobResult s+ _ -> Nothing+ textJobStatus :: JobStatus a -> Text textJobStatus = \case JobQueued -> "queued" JobDuplicate {} -> "duplicate"+ JobPreviousStatus s -> textJobStatus s JobWaiting _ -> "waiting" JobRunning -> "running" JobSkipped -> "skipped"@@ -99,9 +115,21 @@ JobCancelled -> "cancelled" JobDone _ -> "done" +readJobStatus :: (MonadIO m) => Output -> Text -> m a -> m (Maybe (JobStatus a))+readJobStatus tout text readResult = case T.lines text of+ "queued" : _ -> return (Just JobQueued)+ "running" : _ -> return (Just JobRunning)+ "skipped" : _ -> return (Just JobSkipped)+ "error" : note : _ -> Just . JobError <$> liftIO (outputFootnote tout note)+ "failed" : _ -> return (Just JobFailed)+ "cancelled" : _ -> return (Just JobCancelled)+ "done" : _ -> Just . JobDone <$> readResult+ _ -> return Nothing+ textJobStatusDetails :: JobStatus a -> Text textJobStatusDetails = \case JobError err -> footnoteText err <> "\n"+ JobPreviousStatus s -> textJobStatusDetails s _ -> "" @@ -114,6 +142,7 @@ , jmReadyTasks :: TVar (Set TaskId) , jmRunningTasks :: TVar (Map TaskId ThreadId) , jmCancelled :: TVar Bool+ , jmOpenStatusUpdates :: TVar Int } newtype TaskId = TaskId Int@@ -134,6 +163,7 @@ jmReadyTasks <- newTVarIO S.empty jmRunningTasks <- newTVarIO M.empty jmCancelled <- newTVarIO False+ jmOpenStatusUpdates <- newTVarIO 0 return JobManager {..} cancelAllJobs :: JobManager -> IO ()@@ -191,8 +221,10 @@ writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks -runJobs :: JobManager -> Output -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]-runJobs mngr@JobManager {..} tout jobs = do+runJobs :: JobManager -> Output -> [ Job ]+ -> (JobId -> JobStatus JobOutput -> Bool) -- ^ Rerun condition+ -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]+runJobs mngr@JobManager {..} tout jobs rerun = do results <- atomically $ do forM jobs $ \job -> do tid <- reserveTaskId mngr@@ -214,7 +246,7 @@ | otherwise -> do JobError <$> outputFootnote tout (T.pack $ displayException e) atomically $ writeTVar outVar status- outputEvent tout $ JobFinished (jobId job) (textJobStatus status)+ outputJobFinishedEvent tout job status handle handler $ do res <- runExceptT $ do duplicate <- liftIO $ atomically $ do@@ -226,13 +258,22 @@ case duplicate of Nothing -> do- uses <- waitForUsedArtifacts tout job results outVar- runManagedJob mngr tid (return JobCancelled) $ do- liftIO $ atomically $ writeTVar outVar JobRunning- liftIO $ outputEvent tout $ JobStarted (jobId job)- prepareJob jmDataDir job $ \checkoutPath jdir -> do- updateStatusFile (jdir </> "status") outVar- JobDone <$> runJob job uses checkoutPath jdir+ let jdir = jmDataDir </> jobStorageSubdir (jobId job)+ readStatusFile tout job jdir >>= \case+ Just status | status /= JobCancelled && not (rerun (jobId job) status) -> do+ let status' = JobPreviousStatus status+ liftIO $ atomically $ writeTVar outVar status'+ return status'+ mbStatus -> do+ when (isJust mbStatus) $ do+ liftIO $ removeDirectoryRecursive jdir+ uses <- waitForUsedArtifacts tout job results outVar+ runManagedJob mngr tid (return JobCancelled) $ do+ liftIO $ atomically $ writeTVar outVar JobRunning+ liftIO $ outputEvent tout $ JobStarted (jobId job)+ prepareJob jmDataDir job $ \checkoutPath -> do+ updateStatusFile mngr jdir outVar+ JobDone <$> runJob job uses checkoutPath jdir Just ( jid, origVar ) -> do let wait = do@@ -250,25 +291,41 @@ liftIO wait atomically $ writeTVar outVar $ either id id res- outputEvent tout $ JobFinished (jobId job) (textJobStatus $ either id id res)+ outputJobFinishedEvent tout job $ either id id res return $ map (\( job, _, var ) -> ( job, var )) results -waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) =>- Output ->- Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ]+waitForRemainingTasks :: JobManager -> IO ()+waitForRemainingTasks JobManager {..} = do+ atomically $ do+ remainingStatusUpdates <- readTVar jmOpenStatusUpdates+ when (remainingStatusUpdates > 0) retry++waitForUsedArtifacts+ :: (MonadIO m, MonadError (JobStatus JobOutput) m)+ => Output -> Job+ -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ]+ -> TVar (JobStatus JobOutput)+ -> m [ ( ArtifactSpec Evaluated, ArtifactOutput ) ] waitForUsedArtifacts tout job results outVar = do origState <- liftIO $ atomically $ readTVar outVar- ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do- case find (\( j, _, _ ) -> jobName j == ujobName) results of- Just ( _, _, var ) -> return ( var, ( ujobName, uartName ))- Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Job '" <> tjobName <> "' not found")+ let ( selfSpecs, artSpecs ) = partition ((jobId job ==) . fst) $ jobRequiredArtifacts job + forM_ selfSpecs $ \( _, artName@(ArtifactName tname) ) -> do+ when (not (artName `elem` map fst (jobArtifacts job))) $ do+ throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact ‘" <> tname <> "’ not produced by the job")++ ujobs <- forM artSpecs $ \( ujobId, uartName ) -> do+ case find (\( j, _, _ ) -> jobId j == ujobId) results of+ Just ( _, _, var ) -> return ( var, ( ujobId, uartName ))+ Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Job ‘" <> textJobId ujobId <> "’ not found")+ let loop prev = do ustatuses <- atomically $ do- ustatuses <- forM ujobs $ \(uoutVar, uartName) -> do- (,uartName) <$> readTVar uoutVar+ ustatuses <- forM ujobs $ \( uoutVar, uartSpec ) -> do+ (, uartSpec) <$> readTVar uoutVar when (Just (map fst ustatuses) == prev) retry- let remains = map (fst . snd) $ filter (not . jobStatusFinished . fst) ustatuses+ let remains = map (fromMaybe (JobName "?") . lastJobNameId . fst . snd) $+ filter (not . jobStatusFinished . fst) ustatuses writeTVar outVar $ if null remains then origState else JobWaiting remains return ustatuses if all (jobStatusFinished . fst) ustatuses@@ -276,62 +333,124 @@ else loop $ Just $ map fst ustatuses ustatuses <- liftIO $ loop Nothing - forM ustatuses $ \(ustatus, (JobName tjobName, uartName@(ArtifactName tartName))) -> do- case ustatus of- JobDone out -> case find ((==uartName) . aoutName) $ outArtifacts out of- Just art -> return art- Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found")+ forM ustatuses $ \( ustatus, spec@( tjobId, uartName@(ArtifactName tartName)) ) -> do+ case jobResult ustatus of+ Just out -> case find ((==uartName) . aoutName) $ outArtifacts out of+ Just art -> return ( spec, art )+ Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact ‘" <> textJobId tjobId <> "." <> tartName <> "’ not found") _ -> throwError JobSkipped -updateStatusFile :: MonadIO m => FilePath -> TVar (JobStatus JobOutput) -> m ()-updateStatusFile path outVar = void $ liftIO $ forkIO $ loop Nothing+outputJobFinishedEvent :: Output -> Job -> JobStatus a -> IO ()+outputJobFinishedEvent tout job = \case+ JobDuplicate _ s -> outputEvent tout $ JobIsDuplicate (jobId job) (textJobStatus s)+ JobPreviousStatus s -> outputEvent tout $ JobPreviouslyFinished (jobId job) (textJobStatus s)+ JobSkipped -> outputEvent tout $ JobWasSkipped (jobId job)+ s -> outputEvent tout $ JobFinished (jobId job) (textJobStatus s)++readStatusFile :: (MonadIO m, MonadCatch m) => Output -> Job -> FilePath -> m (Maybe (JobStatus JobOutput))+readStatusFile tout job jdir = do+ handleIOError (\_ -> return Nothing) $ do+ text <- liftIO $ T.readFile (jdir </> "status")+ readJobStatus tout text $ do+ artifacts <- forM (jobArtifacts job) $ \( aoutName@(ArtifactName tname), _ ) -> do+ let adir = jdir </> "artifacts" </> T.unpack tname+ aoutStorePath = adir </> "data"+ aoutWorkPath <- fmap T.unpack $ liftIO $ T.readFile (adir </> "path")+ return ArtifactOutput {..}++ return JobOutput+ { outArtifacts = artifacts+ }++updateStatusFile :: MonadIO m => JobManager -> FilePath -> TVar (JobStatus JobOutput) -> m ()+updateStatusFile JobManager {..} jdir outVar = liftIO $ do+ atomically $ writeTVar jmOpenStatusUpdates . (+ 1) =<< readTVar jmOpenStatusUpdates+ void $ forkIO $ loop Nothing where loop prev = do status <- atomically $ do status <- readTVar outVar when (Just status == prev) retry return status- T.writeFile path $ textJobStatus status <> "\n" <> textJobStatusDetails status- when (not (jobStatusFinished status)) $ loop $ Just status+ T.writeFile (jdir </> "status") $ textJobStatus status <> "\n" <> textJobStatusDetails status+ if (not (jobStatusFinished status))+ then loop $ Just status+ else atomically $ writeTVar jmOpenStatusUpdates . (subtract 1) =<< readTVar jmOpenStatusUpdates jobStorageSubdir :: JobId -> FilePath jobStorageSubdir (JobId jidParts) = "jobs" </> joinPath (map (T.unpack . textJobIdPart) (jidParts)) -prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Job -> (FilePath -> FilePath -> m a) -> m a++prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Job -> (FilePath -> m a) -> m a prepareJob dir job inner = do withSystemTempDirectory "minici" $ \checkoutPath -> do forM_ (jobCheckout job) $ \(JobCheckout tree mbsub dest) -> do subtree <- maybe return (getSubtree Nothing . makeRelative (treeSubdir tree)) mbsub $ tree checkoutAt subtree $ checkoutPath </> fromMaybe "" dest + liftIO $ forM_ (jobUses job) $ \( jid, aname ) -> do+ modifyError (userError . T.unpack) $ do+ wpath <- getArtifactWorkPath dir jid aname+ let target = checkoutPath </> wpath+ liftIO $ createDirectoryIfMissing True $ takeDirectory target+ copyArtifact dir jid aname target+ let jdir = dir </> jobStorageSubdir (jobId job) liftIO $ createDirectoryIfMissing True jdir- inner checkoutPath jdir+ inner checkoutPath -runJob :: Job -> [ArtifactOutput] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput-runJob job uses checkoutPath jdir = do- liftIO $ forM_ uses $ \aout -> do- let target = checkoutPath </> aoutWorkPath aout- createDirectoryIfMissing True $ takeDirectory target- copyRecursive (aoutStorePath aout) target+getArtifactStoredPath :: (MonadIO m, MonadError Text m) => FilePath -> JobId -> ArtifactName -> m FilePath+getArtifactStoredPath storageDir jid@(JobId ids) (ArtifactName aname) = do+ let jdir = joinPath $ (storageDir :) $ ("jobs" :) $ map (T.unpack . textJobIdPart) ids+ adir = jdir </> "artifacts" </> T.unpack aname + liftIO (doesDirectoryExist jdir) >>= \case+ True -> return ()+ False -> throwError $ "job ‘" <> textJobId jid <> "’ not yet executed"++ liftIO (doesDirectoryExist adir) >>= \case+ True -> return ()+ False -> throwError $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"++ return adir++getArtifactWorkPath :: (MonadIO m, MonadError Text m) => FilePath -> JobId -> ArtifactName -> m FilePath+getArtifactWorkPath storageDir jid aname = do+ adir <- getArtifactStoredPath storageDir jid aname+ liftIO $ readFile (adir </> "path")++copyArtifact :: (MonadIO m, MonadError Text m) => FilePath -> JobId -> ArtifactName -> FilePath -> m ()+copyArtifact storageDir jid aname tpath = do+ adir <- getArtifactStoredPath storageDir jid aname+ liftIO $ copyRecursive (adir </> "data") tpath+++runJob :: Job -> [ ( ArtifactSpec Evaluated, ArtifactOutput) ] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput+runJob job uses checkoutPath jdir = do bracket (liftIO $ openFile (jdir </> "log") WriteMode) (liftIO . hClose) $ \logs -> do- forM_ (jobRecipe job) $ \p -> do+ forM_ (fromMaybe [] $ jobRecipe job) $ \ep -> do+ ( p, input ) <- case ep of+ Left p -> return ( p, "" )+ Right script -> do+ sh <- fromMaybe "/bin/sh" <$> liftIO (lookupEnv "SHELL")+ return ( proc sh [], script ) (Just hin, _, _, hp) <- liftIO $ createProcess_ "" p { cwd = Just checkoutPath , std_in = CreatePipe , std_out = UseHandle logs , std_err = UseHandle logs }- liftIO $ hClose hin+ liftIO $ void $ forkIO $ do+ T.hPutStr hin input+ hClose hin liftIO (waitForProcess hp) >>= \case ExitSuccess -> return () ExitFailure n | fromIntegral n == -sigINT -> throwError JobCancelled | otherwise -> throwError JobFailed - let adir = jdir </> "artifacts" artifacts <- forM (jobArtifacts job) $ \( name@(ArtifactName tname), pathPattern ) -> do+ let adir = jdir </> "artifacts" </> T.unpack tname path <- liftIO (globDir1 pathPattern checkoutPath) >>= \case [ path ] -> return path found -> do@@ -339,36 +458,27 @@ (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+ let target = adir </> "data"+ workPath = makeRelative checkoutPath path liftIO $ do createDirectoryIfMissing True $ takeDirectory target copyRecursiveForce path target+ T.writeFile (adir </> "path") $ T.pack workPath return $ ArtifactOutput { aoutName = name- , aoutWorkPath = makeRelative checkoutPath path+ , aoutWorkPath = workPath , aoutStorePath = target } + forM_ (jobPublish job) $ \pub -> do+ Just aout <- return $ lookup (jpArtifact pub) $ map (\aout -> ( ( jobId job, aoutName aout ), aout )) artifacts ++ uses+ let ppath = case jpPath pub of+ Just path+ | hasTrailingPathSeparator path -> path </> takeFileName (aoutWorkPath aout)+ | otherwise -> path+ Nothing -> aoutWorkPath aout+ copyToDestination (aoutStorePath aout) (jpDestination pub) ppath+ return JobOutput- { outName = jobName job- , outArtifacts = artifacts+ { outArtifacts = artifacts }---copyRecursive :: FilePath -> FilePath -> IO ()-copyRecursive from to = do- doesDirectoryExist from >>= \case- False -> do- copyFile from to- True -> do- createDirectory to- content <- listDirectory from- forM_ content $ \name -> do- copyRecursive (from </> name) (to </> name)--copyRecursiveForce :: FilePath -> FilePath -> IO ()-copyRecursiveForce from to = do- doesDirectoryExist to >>= \case- False -> return ()- True -> removeDirectoryRecursive to- copyRecursive from to
src/Job/Types.hs view
@@ -1,5 +1,6 @@ module Job.Types where +import Data.Containers.ListUtils import Data.Kind import Data.Text (Text) import Data.Text qualified as T@@ -7,6 +8,8 @@ import System.FilePath.Glob import System.Process +import {-# SOURCE #-} Config+import Destination import Repo @@ -17,9 +20,10 @@ { jobId :: JobId' d , jobName :: JobName , jobCheckout :: [ JobCheckout d ]- , jobRecipe :: [ CreateProcess ]+ , jobRecipe :: Maybe [ Either CreateProcess Text ] , jobArtifacts :: [ ( ArtifactName, Pattern ) ]- , jobUses :: [ ( JobName, ArtifactName ) ]+ , jobUses :: [ ArtifactSpec d ]+ , jobPublish :: [ JobPublish d ] } type Job = Job' Evaluated@@ -38,7 +42,10 @@ textJobName :: JobName -> Text textJobName (JobName name) = name +jobRequiredArtifacts :: Ord (JobId' d) => Job' d -> [ ArtifactSpec d ]+jobRequiredArtifacts job = nubOrd $ jobUses job ++ (map jpArtifact $ jobPublish job) + type family JobRepo d :: Type where JobRepo Declared = Maybe ( RepoName, Maybe Text ) JobRepo Evaluated = Tree@@ -49,14 +56,28 @@ , jcDestination :: Maybe FilePath } +type family JobDestination d :: Type where+ JobDestination Declared = DestinationName+ JobDestination Evaluated = Destination +data JobPublish d = JobPublish+ { jpArtifact :: ArtifactSpec d+ , jpDestination :: JobDestination d+ , jpPath :: Maybe FilePath+ }++ data ArtifactName = ArtifactName Text deriving (Eq, Ord, Show) +type ArtifactSpec d = ( JobId' d, ArtifactName ) + data JobSet' d = JobSet { jobsetId :: JobSetId' d+ , jobsetConfig :: Maybe Config , jobsetCommit :: Maybe Commit+ , jobsetExplicitlyRequested :: [ JobId' d ] , jobsetJobsEither :: Either String [ Job' d ] } @@ -108,3 +129,10 @@ Just ( '(', rest' ) -> go (plevel + 1) (cur <> part) rest' Just ( ')', rest' ) -> go (plevel - 1) (cur <> part) rest' _ -> [ cur <> part ]++lastJobNameId :: JobId -> Maybe JobName+lastJobNameId (JobId ids) = go Nothing ids+ where+ go _ (JobIdName name : rest) = go (Just name) rest+ go cur (_ : rest) = go cur rest+ go cur [] = cur
src/Main.hs view
@@ -28,6 +28,7 @@ import Command.Shell import Command.Subtree import Config+import Destination import Output import Repo import Version@@ -65,12 +66,23 @@ case span (/= ':') value of ( repo, ':' : path ) -> return opts { optCommon = (optCommon opts)- { optRepo = DeclaredRepo (RepoName $ T.pack repo) path : optRepo (optCommon opts)+ { optRepo = ( RepoName $ T.pack repo, path ) : optRepo (optCommon opts) } } _ -> throwError $ "--repo: invalid value ‘" <> value <> "’" ) "<repo>:<path>") ("override or declare repo path")+ , Option [] [ "destination" ]+ (ReqArg (\value opts ->+ case span (/= ':') value of+ ( dest, ':' : url ) -> return opts+ { optCommon = (optCommon opts)+ { optDestination = ( DestinationName $ T.pack dest, T.pack url ) : optDestination (optCommon opts)+ }+ }+ _ -> throwError $ "--repo: invalid value ‘" <> value <> "’"+ ) "<destination>:<url>")+ ("override or declare destination") , Option [] [ "storage" ] (ReqArg (\value opts -> return opts { optStorage = Just value }) "<path>") "set storage path"@@ -243,13 +255,13 @@ JobRootRepo repo -> return (Just repo) JobRootConfig _ -> openRepo $ takeDirectory ciRootPath - let openDeclaredRepo dir decl = do- let path = dir </> repoPath decl+ let openDeclaredRepo dir ( name, dpath ) = do+ let path = dir </> dpath openRepo path >>= \case- Just repo -> return ( repoName decl, repo )+ Just repo -> return ( name, repo ) Nothing -> do absPath <- makeAbsolute path- hPutStrLn stderr $ "Failed to open repo ‘" <> showRepoName (repoName decl) <> "’ at " <> repoPath decl <> " (" <> absPath <> ")"+ hPutStrLn stderr $ "Failed to open repo ‘" <> showRepoName name <> "’ at " <> dpath <> " (" <> absPath <> ")" exitFailure cmdlineRepos <- forM (optRepo ciOptions) (openDeclaredRepo "")@@ -258,10 +270,38 @@ forM (configRepos config) $ \decl -> do case lookup (repoName decl) cmdlineRepos of Just repo -> return ( repoName decl, repo )- Nothing -> openDeclaredRepo (takeDirectory ciRootPath) decl+ Nothing+ | Just path <- repoPath decl+ -> openDeclaredRepo (takeDirectory ciRootPath) ( repoName decl, path )++ | otherwise+ -> do+ hPutStrLn stderr $ "No path defined for repo ‘" <> showRepoName (repoName decl) <> "’"+ exitFailure _ -> return [] + let openDeclaredDestination dir ( name, url ) = do+ dest <- openDestination dir url+ return ( name, dest )++ cmdlineDestinations <- forM (optDestination ciOptions) (openDeclaredDestination "")+ cfgDestinations <- case ciJobRoot of+ JobRootConfig config -> do+ forM (configDestinations config) $ \decl -> do+ case lookup (destinationName decl) cmdlineDestinations of+ Just dest -> return ( destinationName decl, dest )+ Nothing+ | Just url <- destinationUrl decl+ -> openDeclaredDestination (takeDirectory ciRootPath) ( destinationName decl, url )++ | otherwise+ -> do+ hPutStrLn stderr $ "No url defined for destination ‘" <> showDestinationName (destinationName decl) <> "’"+ exitFailure+ _ -> return []+ let ciOtherRepos = configRepos ++ cmdlineRepos+ ciDestinations = cfgDestinations ++ cmdlineDestinations outputTypes <- case optOutput gopts of Just types -> return types
src/Output.hs view
@@ -44,6 +44,9 @@ | LogMessage Text | JobStarted JobId | JobFinished JobId Text+ | JobIsDuplicate JobId Text+ | JobPreviouslyFinished JobId Text+ | JobWasSkipped JobId data OutputFootnote = OutputFootnote { footnoteText :: Text@@ -108,6 +111,18 @@ JobFinished jid status -> do forM_ outLogs $ \h -> outStrLn out h ("Finished " <> textJobId jid <> " (" <> status <> ")") forM_ outTest $ \h -> outStrLn out h ("job-finish " <> textJobId jid <> " " <> status)++ JobIsDuplicate jid status -> do+ forM_ outLogs $ \h -> outStrLn out h ("Duplicate " <> textJobId jid <> " (" <> status <> ")")+ forM_ outTest $ \h -> outStrLn out h ("job-duplicate " <> textJobId jid <> " " <> status)++ JobPreviouslyFinished jid status -> do+ forM_ outLogs $ \h -> outStrLn out h ("Previously finished " <> textJobId jid <> " (" <> status <> ")")+ forM_ outTest $ \h -> outStrLn out h ("job-previous " <> textJobId jid <> " " <> status)++ JobWasSkipped jid -> do+ forM_ outLogs $ \h -> outStrLn out h ("Skipped " <> textJobId jid)+ forM_ outTest $ \h -> outStrLn out h ("job-skip " <> textJobId jid) outputFootnote :: Output -> Text -> IO OutputFootnote outputFootnote out@Output {..} footnoteText = do
src/Repo.hs view
@@ -72,7 +72,7 @@ data DeclaredRepo = DeclaredRepo { repoName :: RepoName- , repoPath :: FilePath+ , repoPath :: Maybe FilePath } newtype RepoName = RepoName Text