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
|
module Eval (
EvalInput(..),
EvalError(..), textEvalError,
Eval, runEval,
evalJob,
evalJobSet,
evalJobReference,
) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.Bifunctor
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
| [] <- jobContainingCheckout djob = return False
| otherwise = asks (not . any matches . eiCurrentIdRev)
where
matches (JobIdName _) = False
matches (JobIdCommit rname _) = isNothing rname
matches (JobIdTree rname _) = isNothing rname
collectOtherRepos :: DeclaredJob -> Eval [ (( Maybe RepoName, Maybe Text ), FilePath ) ]
collectOtherRepos decl = do
missingDefault <- isDefaultRepoMissingInId decl
let checkouts = concat
[ if missingDefault then map (( Nothing, Nothing ), ) $ jobContainingCheckout decl else []
, map (first (first Just)) $ jobOtherCheckout decl
]
let commonSubdir reporev = joinPath $ foldr1 commonPrefix $
map (maybe [] splitDirectories . jcSubtree . snd) . filter ((reporev ==) . fst) $ checkouts
return $ map (\r -> ( r, commonSubdir r )) . nub . map fst $ checkouts
evalJob :: [ ( Maybe RepoName, Tree ) ] -> DeclaredJob -> Eval Job
evalJob revisionOverrides decl = do
EvalInput {..} <- ask
otherRepos <- collectOtherRepos decl
otherRepoTrees <- forM otherRepos $ \(( mbname, mbrev ), commonPath ) -> do
( mbname, ) <$> case lookup mbname revisionOverrides of
Just tree -> return tree
Nothing -> case maybe eiContainingRepo (flip lookup eiOtherRepos) mbname of
Just repo -> do
commit <- readCommit repo (fromMaybe "HEAD" mbrev)
getSubtree (Just commit) commonPath =<< getCommitTree commit
Nothing -> throwError $ OtherEvalError $ "repo ‘" <> maybe "" textRepoName mbname <> "’ not defined"
otherCheckout <- forM (jobOtherCheckout decl) $ \(( name, _ ), checkout ) -> do
(, checkout ) <$> case lookup (Just name) otherRepoTrees of
Just tree -> return tree
Nothing -> throwError $ OtherEvalError $ "repo ‘" <> textRepoName name <> "’ not defined"
let otherRepoIds = map (uncurry JobIdTree . fmap treeId) otherRepoTrees
return Job
{ jobId = JobId $ reverse $ reverse otherRepoIds ++ JobIdName (jobId decl) : eiCurrentIdRev
, jobName = jobName decl
, jobContainingCheckout = jobContainingCheckout decl
, jobOtherCheckout = otherCheckout
, 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)) $ 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 -> Eval JobId
canonicalJobName (r : rs) config = do
let name = JobName r
case find ((name ==) . jobName) (configJobs config) of
Just djob -> do
otherRepos <- collectOtherRepos djob
( overrides, rs' ) <- (\f -> foldM f ( [], rs ) otherRepos) $
\( overrides, crs ) (( mbname, _ ), path ) -> do
( tree, crs' ) <- readTreeFromIdRef crs path =<< evalRepo mbname
return ( ( mbname, tree ) : overrides, crs' )
case rs' of
(r' : _) -> throwError $ OtherEvalError $ "unexpected job ref part ‘" <> r' <> "’"
_ -> return ()
jobId <$> evalJob overrides 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 JobId
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
evalJobReference :: JobRef -> Eval JobId
evalJobReference (JobRef rs) =
asks eiJobRoot >>= \case
JobRootRepo defRepo -> do
canonicalCommitConfig rs defRepo
JobRootConfig config -> do
canonicalJobName rs config
|