1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
module Eval (
EvalInput(..),
EvalError(..), textEvalError,
Eval, runEval,
evalJob,
evalJobSet,
evalJobReference,
) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.List
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import System.FilePath
import Config
import Job.Types
import Repo
data EvalInput = EvalInput
{ eiJobRoot :: JobRoot
, eiRootPath :: FilePath
, eiCurrentIdRev :: [ JobIdPart ]
, eiContainingRepo :: Maybe Repo
, eiOtherRepos :: [ ( RepoName, Repo ) ]
}
data EvalError
= OtherEvalError Text
textEvalError :: EvalError -> Text
textEvalError (OtherEvalError text) = text
type Eval a = ReaderT EvalInput (ExceptT EvalError IO) a
runEval :: Eval a -> EvalInput -> IO (Either EvalError a)
runEval action einput = runExceptT $ flip runReaderT einput action
commonPrefix :: Eq a => [ a ] -> [ a ] -> [ a ]
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)
where
matches (JobIdName _) = False
matches (JobIdCommit rname _) = isNothing rname
matches (JobIdTree rname _ _) = isNothing rname
collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ ( Maybe ( RepoName, Maybe Text ), FilePath ) ]
collectOtherRepos dset decl = do
let dependencies = map fst $ jobUses 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
let checkouts =
(if missingDefault then id else (filter (isJust . jcRepo))) $
concat
[ jobCheckout decl
, 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
evalJob :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> DeclaredJob -> Eval Job
evalJob revisionOverrides dset decl = 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
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
]
}
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
}
evalJobSet :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJobSet -> Eval JobSet
evalJobSet revisionOverrides decl = do
jobs <- either (return . Left) (handleToEither . mapM (evalJob revisionOverrides decl)) $ jobsetJobsEither decl
return JobSet
{ jobsetCommit = jobsetCommit decl
, jobsetJobsEither = jobs
}
where
handleToEither = handleError (return . Left . T.unpack . textEvalError) . fmap Right
evalRepo :: Maybe RepoName -> Eval Repo
evalRepo Nothing = asks eiContainingRepo >>= \case
Just repo -> return repo
Nothing -> throwError $ OtherEvalError $ "no default repo"
evalRepo (Just name) = asks (lookup name . eiOtherRepos) >>= \case
Just repo -> return repo
Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined"
canonicalJobName :: [ Text ] -> Config -> Maybe Tree -> Eval Job
canonicalJobName (r : rs) config mbDefaultRepo = do
let name = JobName r
dset = JobSet Nothing $ 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' )
case rs' of
(r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’"
_ -> return ()
evalJob (maybe id ((:) . ( Nothing, )) mbDefaultRepo $ overrides) dset djob
Nothing -> throwError $ OtherEvalError $ "job ‘" <> r <> "’ not found"
canonicalJobName [] _ _ = throwError $ OtherEvalError "expected job name"
readTreeFromIdRef :: [ Text ] -> FilePath -> Repo -> Eval ( Tree, [ Text ] )
readTreeFromIdRef (r : rs) subdir repo = do
tryReadCommit repo r >>= \case
Just commit -> return . (, rs) =<< getSubtree (Just commit) subdir =<< getCommitTree commit
Nothing -> tryReadTree repo subdir r >>= \case
Just tree -> return ( tree, rs )
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
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
evalJobReference (JobRef rs) =
asks eiJobRoot >>= \case
JobRootRepo defRepo -> do
canonicalCommitConfig rs defRepo
JobRootConfig config -> do
canonicalJobName rs config Nothing
|