diff options
| -rw-r--r-- | minici.cabal | 1 | ||||
| -rw-r--r-- | src/Command.hs | 15 | ||||
| -rw-r--r-- | src/Command/Checkout.hs | 10 | ||||
| -rw-r--r-- | src/Command/Run.hs | 16 | ||||
| -rw-r--r-- | src/Config.hs | 27 | ||||
| -rw-r--r-- | src/Eval.hs | 53 | ||||
| -rw-r--r-- | src/Job.hs | 4 | ||||
| -rw-r--r-- | src/Job/Types.hs | 28 | ||||
| -rw-r--r-- | src/Main.hs | 28 |
9 files changed, 141 insertions, 41 deletions
diff --git a/minici.cabal b/minici.cabal index 7c05311..c0e7d00 100644 --- a/minici.cabal +++ b/minici.cabal @@ -51,6 +51,7 @@ executable minici Command.Checkout Command.Run Config + Eval Job Job.Types Paths_minici diff --git a/src/Command.hs b/src/Command.hs index c9a77e6..aaaaca1 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -12,6 +12,7 @@ module Command ( getConfigPath, getConfig, getRepo, getDefaultRepo, tryGetDefaultRepo, + getEvalInput, getTerminalOutput, ) where @@ -29,6 +30,7 @@ import System.Exit import System.IO import Config +import Eval import Repo import Terminal @@ -98,7 +100,8 @@ data CommandInput = CommandInput { ciOptions :: CommonOptions , ciConfigPath :: Maybe FilePath , ciConfig :: Either String Config - , ciRepos :: [ ( Maybe RepoName, Repo ) ] + , ciContainingRepo :: Maybe Repo + , ciOtherRepos :: [ ( RepoName, Repo ) ] , ciTerminalOutput :: TerminalOutput } @@ -119,7 +122,7 @@ getConfig = do getRepo :: RepoName -> CommandExec Repo getRepo name = do - CommandExec (asks (lookup (Just name) . ciRepos)) >>= \case + CommandExec (asks (lookup name . ciOtherRepos)) >>= \case Just repo -> return repo Nothing -> tfail $ "repo `" <> textRepoName name <> "' not declared" @@ -130,7 +133,13 @@ getDefaultRepo = do Nothing -> tfail $ "no default repo" tryGetDefaultRepo :: CommandExec (Maybe Repo) -tryGetDefaultRepo = CommandExec $ asks (lookup Nothing . ciRepos) +tryGetDefaultRepo = CommandExec $ asks ciContainingRepo + +getEvalInput :: CommandExec EvalInput +getEvalInput = CommandExec $ do + eiContainingRepo <- asks ciContainingRepo + eiOtherRepos <- asks ciOtherRepos + return EvalInput {..} getTerminalOutput :: CommandExec TerminalOutput getTerminalOutput = CommandExec (asks ciTerminalOutput) diff --git a/src/Command/Checkout.hs b/src/Command/Checkout.hs index 397db79..3667e76 100644 --- a/src/Command/Checkout.hs +++ b/src/Command/Checkout.hs @@ -15,7 +15,7 @@ import Repo data CheckoutCommand = CheckoutCommand CheckoutOptions (Maybe RepoName) (Maybe Text) data CheckoutOptions = CheckoutOptions - { coPath :: Maybe FilePath + { coDestination :: Maybe FilePath , coSubtree :: Maybe FilePath } @@ -31,13 +31,13 @@ instance Command CheckoutCommand where type CommandOptions CheckoutCommand = CheckoutOptions defaultCommandOptions _ = CheckoutOptions - { coPath = Nothing + { coDestination = Nothing , coSubtree = Nothing } commandOptions _ = - [ Option [] [ "path" ] - (ReqArg (\val opts -> opts { coPath = Just val }) "<path>") + [ Option [] [ "dest" ] + (ReqArg (\val opts -> opts { coDestination = Just val }) "<path>") "destination path" , Option [] [ "subtree" ] (ReqArg (\val opts -> opts { coSubtree = Just val }) "<path>") @@ -59,4 +59,4 @@ cmdCheckout (CheckoutCommand CheckoutOptions {..} name mbrev) = do Nothing -> return root Just subtree -> maybe (fail $ "subtree `" <> subtree <> "' not found in " <> maybe "current worktree" (("revision `" <>) . (<> "'") . T.unpack) mbrev) return =<< getSubtree subtree root - checkoutAt tree $ maybe "." id coPath + checkoutAt tree $ maybe "." id coDestination diff --git a/src/Command/Run.hs b/src/Command/Run.hs index bd29455..b297ec1 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -6,7 +6,8 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad -import Control.Monad.Reader +import Control.Monad.Except +import Control.Monad.IO.Class import Data.Either import Data.List @@ -21,6 +22,7 @@ import System.IO import Command import Config +import Eval import Job import Repo import Terminal @@ -124,22 +126,25 @@ argumentJobSource :: [ JobName ] -> CommandExec JobSource argumentJobSource [] = emptyJobSource argumentJobSource names = do config <- getConfig + einput <- getEvalInput jobsetJobsEither <- fmap Right $ forM names $ \name -> case find ((name ==) . jobName) (configJobs config) of Just job -> return job Nothing -> tfail $ "job `" <> textJobName name <> "' not found" jobsetCommit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo - oneshotJobSource [ JobSet {..} ] + oneshotJobSource [ evalJobSet einput JobSet {..} ] rangeSource :: Text -> Text -> CommandExec JobSource rangeSource base tip = do repo <- getDefaultRepo + einput <- getEvalInput commits <- listCommits repo (base <> ".." <> tip) - oneshotJobSource =<< mapM loadJobSetForCommit commits + oneshotJobSource . map (evalJobSet einput) =<< mapM loadJobSetForCommit commits watchBranchSource :: Text -> CommandExec JobSource watchBranchSource branch = do repo <- getDefaultRepo + einput <- getEvalInput getCurrentTip <- watchBranch repo branch let go prev tmvar = do cur <- atomically $ do @@ -150,7 +155,7 @@ watchBranchSource branch = do Nothing -> retry commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur)) - jobsets <- mapM loadJobSetForCommit commits + jobsets <- map (evalJobSet einput) <$> mapM loadJobSetForCommit commits nextvar <- newEmptyTMVarIO atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar ) go cur nextvar @@ -168,12 +173,13 @@ watchBranchSource branch = do watchTagSource :: Pattern -> CommandExec JobSource watchTagSource pat = do chan <- watchTags =<< getDefaultRepo + einput <- getEvalInput let go tmvar = do tag <- atomically $ readTChan chan if match pat $ T.unpack $ tagTag tag then do - jobset <- loadJobSetForCommit $ tagObject tag + jobset <- evalJobSet einput <$> loadJobSetForCommit (tagObject tag) nextvar <- newEmptyTMVarIO atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar ) go nextvar diff --git a/src/Config.hs b/src/Config.hs index e9287e4..68db57d 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -12,6 +12,7 @@ import Control.Monad.Combinators import Control.Monad.IO.Class import Data.ByteString.Lazy qualified as BS +import Data.Either import Data.List import Data.Map qualified as M import Data.Maybe @@ -33,7 +34,7 @@ configFileName = "minici.yaml" data Config = Config - { configJobs :: [ Job ] + { configJobs :: [ DeclaredJob ] , configRepos :: [ DeclaredRepo ] } @@ -67,14 +68,14 @@ instance FromYAML Config where return $ config { configRepos = configRepos config ++ [ repo ] } _ -> return config -parseJob :: Text -> Node Pos -> Parser Job +parseJob :: Text -> Node Pos -> Parser DeclaredJob parseJob name node = flip (withMap "Job") node $ \j -> do let jobName = JobName name - jobCheckout <- choice + ( jobContainingCheckout, jobOtherCheckout ) <- partitionEithers <$> choice [ parseSingleCheckout =<< j .: "checkout" , parseMultipleCheckouts =<< j .: "checkout" , withNull "no checkout" (return []) =<< j .: "checkout" - , return [ ( Nothing, Nothing ) ] + , return [ Left $ JobCheckout Nothing Nothing ] ] jobRecipe <- choice [ cabalJob =<< j .: "cabal" @@ -84,13 +85,17 @@ parseJob name node = flip (withMap "Job") node $ \j -> do jobUses <- maybe (return []) parseUses =<< j .:? "uses" return Job {..} -parseSingleCheckout :: Node Pos -> Parser [ ( Maybe RepoName, Maybe FilePath ) ] +parseSingleCheckout :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, JobCheckout ) ] parseSingleCheckout = withMap "checkout definition" $ \m -> do - name <- m .:? "repo" - subtree <- m .:? "subtree" - return [ ( RepoName <$> name, T.unpack <$> subtree ) ] - -parseMultipleCheckouts :: Node Pos -> Parser [ ( Maybe RepoName, Maybe FilePath ) ] + mbName <- m .:? "repo" + jcSubtree <- fmap T.unpack <$> m .:? "subtree" + jcDestination <- fmap T.unpack <$> m .:? "dest" + let checkout = JobCheckout {..} + return $ (: []) $ case mbName of + Nothing -> Left checkout + Just name -> Right ( DeclaredJobRepo (RepoName name), checkout ) + +parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, JobCheckout ) ] parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout cabalJob :: Node Pos -> Parser [CreateProcess] @@ -156,7 +161,7 @@ loadConfigForCommit commit = do Just content -> either (\_ -> Left $ "failed to parse " <> configFileName) Right $ parseConfig content Nothing -> Left $ configFileName <> " not found" -loadJobSetForCommit :: MonadIO m => Commit -> m JobSet +loadJobSetForCommit :: MonadIO m => Commit -> m DeclaredJobSet loadJobSetForCommit commit = toJobSet <$> loadConfigForCommit commit where toJobSet configEither = JobSet diff --git a/src/Eval.hs b/src/Eval.hs new file mode 100644 index 0000000..9130dd3 --- /dev/null +++ b/src/Eval.hs @@ -0,0 +1,53 @@ +module Eval ( + EvalInput(..), + EvalError(..), textEvalError, + + evalJob, + evalJobSet, +) where + +import Control.Monad.Except + +import Data.Bifunctor +import Data.Text (Text) +import Data.Text qualified as T + +import Job.Types +import Repo + +data EvalInput = EvalInput + { eiContainingRepo :: Maybe Repo + , eiOtherRepos :: [ ( RepoName, Repo ) ] + } + +data EvalError + = OtherEvalError Text + +textEvalError :: EvalError -> Text +textEvalError (OtherEvalError text) = text + +evalJob :: EvalInput -> DeclaredJob -> Except EvalError Job +evalJob EvalInput {..} decl = do + otherCheckout <- forM (jobOtherCheckout decl) $ \( DeclaredJobRepo name, checkout ) -> do + repo <- maybe (throwError $ OtherEvalError $ "repo `" <> textRepoName name <> "' not defined") return $ + lookup name eiOtherRepos + return ( EvaluatedJobRepo repo, checkout ) + return Job + { jobName = jobName decl + , jobContainingCheckout = jobContainingCheckout decl + , jobOtherCheckout = otherCheckout + , jobRecipe = jobRecipe decl + , jobArtifacts = jobArtifacts decl + , jobUses = jobUses decl + } + +evalJobSet :: EvalInput -> DeclaredJobSet -> JobSet +evalJobSet ei decl = do + JobSet + { jobsetCommit = jobsetCommit decl + , jobsetJobsEither = join $ + fmap (sequence . map (runExceptStr . evalJob ei)) $ + jobsetJobsEither decl + } + where + runExceptStr = first (T.unpack . textEvalError) . runExcept @@ -1,6 +1,6 @@ module Job ( - Job(..), - JobSet(..), jobsetJobs, + Job, DeclaredJob, Job'(..), + JobSet, DeclaredJobSet, JobSet'(..), jobsetJobs, JobOutput(..), JobName(..), stringJobName, textJobName, ArtifactName(..), diff --git a/src/Job/Types.hs b/src/Job/Types.hs index 3f6f1f0..a16ba1d 100644 --- a/src/Job/Types.hs +++ b/src/Job/Types.hs @@ -8,14 +8,21 @@ import System.Process import Repo -data Job = Job +data Declared +data Evaluated + +data Job' d = Job { jobName :: JobName - , jobCheckout :: [ ( Maybe RepoName, Maybe FilePath ) ] + , jobContainingCheckout :: [ JobCheckout ] + , jobOtherCheckout :: [ ( JobRepo d, JobCheckout ) ] , jobRecipe :: [ CreateProcess ] , jobArtifacts :: [ ( ArtifactName, CreateProcess ) ] , jobUses :: [ ( JobName, ArtifactName ) ] } +type Job = Job' Evaluated +type DeclaredJob = Job' Declared + data JobName = JobName Text deriving (Eq, Ord, Show) @@ -26,15 +33,28 @@ textJobName :: JobName -> Text textJobName (JobName name) = name +data JobRepo d where + DeclaredJobRepo :: RepoName -> JobRepo Declared + EvaluatedJobRepo :: Repo -> JobRepo Evaluated + +data JobCheckout = JobCheckout + { jcSubtree :: Maybe FilePath + , jcDestination :: Maybe FilePath + } + + data ArtifactName = ArtifactName Text deriving (Eq, Ord, Show) -data JobSet = JobSet +data JobSet' d = JobSet { jobsetCommit :: Maybe Commit - , jobsetJobsEither :: Either String [ Job ] + , jobsetJobsEither :: Either String [ Job' d ] } +type JobSet = JobSet' Evaluated +type DeclaredJobSet = JobSet' Declared + jobsetJobs :: JobSet -> [ Job ] jobsetJobs = either (const []) id . jobsetJobsEither diff --git a/src/Main.hs b/src/Main.hs index f86bd77..826a96d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -184,18 +184,24 @@ runSomeCommand ciConfigPath ciOptions (SC tproxy) args = do let cmd = commandInit tproxy (fcoSpecific opts) cmdargs let CommandExec exec = commandExec cmd - namedRepos <- forM (optRepo ciOptions) $ \decl -> do - openRepo (repoPath decl) >>= \case - Just repo -> return ( Just (repoName decl), repo ) - Nothing -> do - hPutStrLn stderr $ "Failed to open repo `" <> showRepoName (repoName decl) <> "' at " <> repoPath decl - exitFailure + ciContainingRepo <- maybe (return Nothing) (openRepo . takeDirectory) ciConfigPath + + let openDeclaredRepo decl = do + openRepo (repoPath decl) >>= \case + Just repo -> return ( repoName decl, repo ) + Nothing -> do + hPutStrLn stderr $ "Failed to open repo `" <> showRepoName (repoName decl) <> "' at " <> repoPath decl + exitFailure + + cmdlineRepos <- forM (optRepo ciOptions) openDeclaredRepo + configRepos <- case ciConfig of + Right config -> forM (configRepos config) $ \decl -> do + case lookup (repoName decl) cmdlineRepos of + Just repo -> return ( repoName decl, repo ) + Nothing -> openDeclaredRepo decl + Left _ -> return [] - defaultRepo <- maybe (return Nothing) (openRepo . takeDirectory) ciConfigPath - let ciRepos = concat - [ maybe [] (\r -> [ ( Nothing, r ) ]) defaultRepo - , namedRepos - ] + let ciOtherRepos = configRepos ++ cmdlineRepos ciTerminalOutput <- initTerminalOutput flip runReaderT CommandInput {..} exec |