diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,40 +10,50 @@ Job definition -------------- -The top-level elements of the YAML file are `job ` defining steps to -perform the job and potentially listing artifacts produced or required. +The basic top-level elements of the YAML file are `job ` 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 ` (optional) +`artifact ` : Defines artifact `` produced by this job. Is itself defined as a dictionary. `artifact .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 `.`. +`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 : + path: (optional, only relevant for explicit script file) +``` + +The path of a repository `` can be given (or overridden) on command line by passing argument in the form `--repo=:` 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 : + url: (optional, only relevant for explicit script file) +``` + +**Note**: only local filesystem path is currently supported as `url`. + +The URL of a destination `` can be given (or overridden) on command line by passing argument in the form `--destination=:` 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 `` if produced by this job, or `.` 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. diff --git a/minici.cabal b/minici.cabal --- a/minici.cabal +++ b/minici.cabal @@ -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 diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -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 diff --git a/src/Command/Extract.hs b/src/Command/Extract.hs --- a/src/Command/Extract.hs +++ b/src/Command/Extract.hs @@ -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) diff --git a/src/Command/JobId.hs b/src/Command/JobId.hs --- a/src/Command/JobId.hs +++ b/src/Command/JobId.hs @@ -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 diff --git a/src/Command/Log.hs b/src/Command/Log.hs --- a/src/Command/Log.hs +++ b/src/Command/Log.hs @@ -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 diff --git a/src/Command/Run.hs b/src/Command/Run.hs --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -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 }) "") "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 diff --git a/src/Command/Shell.hs b/src/Command/Shell.hs --- a/src/Command/Shell.hs +++ b/src/Command/Shell.hs @@ -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 diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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 } diff --git a/src/Config.hs-boot b/src/Config.hs-boot new file mode 100644 --- /dev/null +++ b/src/Config.hs-boot @@ -0,0 +1,3 @@ +module Config where + +data Config diff --git a/src/Destination.hs b/src/Destination.hs new file mode 100644 --- /dev/null +++ b/src/Destination.hs @@ -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 diff --git a/src/Eval.hs b/src/Eval.hs --- a/src/Eval.hs +++ b/src/Eval.hs @@ -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 diff --git a/src/FileUtils.c b/src/FileUtils.c new file mode 100644 --- /dev/null +++ b/src/FileUtils.c @@ -0,0 +1,18 @@ +#include +#include +#include + +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 ); +} diff --git a/src/FileUtils.hs b/src/FileUtils.hs new file mode 100644 --- /dev/null +++ b/src/FileUtils.hs @@ -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 diff --git a/src/Job.hs b/src/Job.hs --- a/src/Job.hs +++ b/src/Job.hs @@ -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 diff --git a/src/Job/Types.hs b/src/Job/Types.hs --- a/src/Job/Types.hs +++ b/src/Job/Types.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 <> "’" ) ":") ("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 <> "’" + ) ":") + ("override or declare destination") , Option [] [ "storage" ] (ReqArg (\value opts -> return opts { optStorage = Just value }) "") "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 diff --git a/src/Output.hs b/src/Output.hs --- a/src/Output.hs +++ b/src/Output.hs @@ -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 diff --git a/src/Repo.hs b/src/Repo.hs --- a/src/Repo.hs +++ b/src/Repo.hs @@ -72,7 +72,7 @@ data DeclaredRepo = DeclaredRepo { repoName :: RepoName - , repoPath :: FilePath + , repoPath :: Maybe FilePath } newtype RepoName = RepoName Text