-
Notifications
You must be signed in to change notification settings - Fork 0
/
script.clj
281 lines (257 loc) · 10.1 KB
/
script.clj
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
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
(ns monkey.ci.script
(:require [aleph.http :as http]
[clj-commons.byte-streams :as bs]
[clojure.java.io :as io]
[clojure.tools.logging :as log]
[manifold.deferred :as md]
[medley.core :as mc]
[monkey.ci.build.core :as bc]
[monkey.ci
[artifacts :as art]
[build :as build]
[cache :as cache]
[containers :as c]
[credits :as cr]
[extensions :as ext]
[jobs :as j]
[runtime :as rt]
[spec :as s]
[utils :as u]]
[monkey.ci.containers
[oci]
[podman]]
[monkey.ci.events.core :as ec]
[monkey.ci.spec.build :as sb]
[muuntaja.parse :as mp]))
(defn- wrapped
"Sets the event poster in the runtime."
[f before after]
(let [error (fn [& args]
;; On error, add the exception to the result of the 'after' event
(let [ex (last args)]
(log/error "Got error:" ex)
(assoc (apply after (concat (butlast args) [{}]))
:exception (.getMessage ex))))
w (ec/wrapped f before after error)]
(fn [rt & more]
(apply w rt more))))
(defn- base-event
"Creates an skeleton event with basic properties"
[rt type]
{:type type
:src :script
:sid (build/get-sid rt)
:time (u/now)})
(defn- job-start-evt [{:keys [job] :as rt}]
(-> (base-event rt :job/start)
(assoc :job (j/job->event job)
:message "Job started")))
(defn- job-end-evt [{:keys [job] :as rt} {:keys [status message exception] :as r}]
(let [r (dissoc r :status :exception)]
(-> (base-event rt :job/end)
(assoc :message "Job completed"
:job (cond-> (j/job->event job)
true (assoc :status status)
;; Add any extra information to the result key
(not-empty r) (assoc :result r)
(some? exception) (assoc :message (or message (.getMessage exception))
:stack-trace (u/stack-trace exception)))))))
;; Wraps a job so it fires an event before and after execution, and also
;; catches any exceptions.
(defrecord EventFiringJob [target]
j/Job
(execute! [job rt]
(let [rt-with-job (assoc rt :job target)
handle-error (fn [ex]
(log/error "Got job exception:" ex)
(assoc bc/failure
:exception ex
:message (.getMessage ex)))
base-props {:start-time (u/now)
:credit-multiplier (cr/credit-multiplier target rt)}]
(log/debug "Executing event firing job:" (bc/job-id target))
(md/chain
(rt/post-events rt (job-start-evt
(-> rt-with-job
(update :job
merge base-props {:status :running}))))
(fn [_]
;; Catch both sync and async errors
(try
(-> (j/execute! target rt-with-job)
(md/catch handle-error))
(catch Exception ex
(handle-error ex))))
(fn [r]
(log/debug "Job ended with response:" r)
(md/chain
(rt/post-events rt (job-end-evt
(update rt-with-job :job
merge base-props {:end-time (u/now)})
r))
(constantly r)))))))
(defn- with-fire-events
"Wraps job so events are fired on start and end."
[job]
(map->EventFiringJob (-> (j/job->event job)
(assoc :target job))))
(def with-extensions
"Wraps the job so any registered extensions get executed."
ext/wrap-job)
(defn- pipeline-filter [pipeline]
[[{:label "pipeline"
:value pipeline}]])
(defn run-all-jobs
"Executes all jobs in the set, in dependency order."
[{:keys [pipeline] :as rt} jobs]
(let [pf (cond->> jobs
;; Filter jobs by pipeline, if given
pipeline (j/filter-jobs (j/label-filter (pipeline-filter pipeline)))
true (map (comp with-fire-events with-extensions)))]
(log/debug "Found" (count pf) "matching jobs:" (map bc/job-id pf))
(let [result @(j/execute-jobs! pf rt)]
(log/debug "Jobs executed, result is:" result)
{:status (if (some (comp bc/failed? :result) (vals result)) :failure :success)
:jobs result})))
;;; Script client functions
(defn make-client
"Creates an API client function, that can be invoked by build scripts to
perform certain operations, like retrieve build parameters. The client
uses the token passed by the spawning process to gain access to those
resources."
[{{:keys [url token]} :api}]
(letfn [(throw-on-error [{:keys [status] :as r}]
(if (>= status 400)
(md/error-deferred (ex-info "Failed to invoke API call" r))
r))
(parse-body [{:keys [body headers]}]
(if (= "application/edn" (some-> (get headers "content-type")
(mp/parse-content-type)
first))
(with-open [r (bs/to-reader body)]
(u/parse-edn r))
;; Return non-edn contents as input stream
(bs/to-input-stream body)))]
(log/debug "Connecting to API at" url)
(fn [req]
(-> req
(update :url (partial str url))
(assoc-in [:headers "authorization"] (str "Bearer " token))
(assoc-in [:headers "accept"] "application/edn")
(http/request)
(md/chain
throw-on-error
parse-body)))))
(def valid-config? (every-pred :url :token))
(defmethod rt/setup-runtime :api [conf _]
(when-let [c (:api conf)]
(when (valid-config? c)
{:client (make-client conf)})))
;;; Script loading
(defn- load-script
"Loads the pipelines from the build script, by reading the script files
dynamically. If the build script does not define its own namespace,
one will be randomly generated to avoid collisions."
[dir build-id]
(let [tmp-ns (symbol (or build-id (str "build-" (random-uuid))))]
;; Declare a temporary namespace to load the file in, in case
;; it does not declare an ns of it's own.
(in-ns tmp-ns)
(clojure.core/use 'clojure.core)
(try
(let [path (io/file dir "build.clj")]
(log/debug "Loading script:" path)
;; This should return pipelines to run
(load-file (str path)))
(finally
;; Return
(in-ns 'monkey.ci.script)
(remove-ns tmp-ns)))))
(defn- with-script-evt
"Creates an skeleton event with the script and invokes `f` on it"
[rt f]
(-> rt
(base-event nil)
(assoc :script (-> rt rt/build build/script))
(f)))
(defn- job->evt [job]
(select-keys job [j/job-id j/deps j/labels]))
(defn- script-start-evt [rt jobs]
(letfn [(mark-pending [job]
(assoc job :status :pending))]
(with-script-evt rt
#(-> %
(assoc :type :script/start
:message "Script started")
;; Add all info we already have about jobs
(assoc-in [:script :jobs] (->> jobs
(map (fn [{:keys [id] :as job}]
[id job]))
(into {})
(mc/map-vals (comp mark-pending job->evt))))))))
(defn- script-end-evt [rt jobs res]
(with-script-evt rt
(fn [evt]
(-> evt
(assoc :type :script/end
:message "Script completed")
;; FIXME Jobs don't contain all info here, as they should (like start and end time)
(assoc-in [:script :jobs]
(mc/map-vals (fn [r]
(-> (select-keys (:result r) [:status :message])
(merge (job->evt (:job r)))))
(:jobs res)))))))
(def run-all-jobs*
(wrapped run-all-jobs
script-start-evt
script-end-evt))
(defn- assign-ids
"Assigns an id to each job that does not have one already."
[jobs]
(letfn [(assign-id [x id]
(if (nil? (bc/job-id x))
(assoc x :id id)
x))]
;; TODO Sanitize existing ids
(map-indexed (fn [i job]
(assign-id job (format "job-%d" (inc i))))
jobs)))
(defn resolve-jobs
"The build script either returns a list of pipelines, a set of jobs or a function
that returns either. This function resolves the jobs by processing the script
return value."
[p rt]
(-> (j/resolve-jobs p rt)
(assign-ids)))
(defn load-jobs
"Loads the script and resolves the jobs"
[build rt]
(-> (load-script (build/script-dir build) (build/build-id build))
(resolve-jobs rt)))
(defn exec-script!
"Loads a script from a directory and executes it. The script is executed in
this same process."
[rt+build]
(let [build (rt/build rt+build)
rt rt+build ; TODO Remove build from runtime
build-id (build/build-id build)
script-dir (build/script-dir build)]
(s/valid? ::sb/build build)
;; TODO Replace the runtime with a specific context when passing it to a job
(log/debug "Executing script for build" build-id "at:" script-dir)
(log/debug "Build map:" build)
(try
(let [jobs (load-jobs build rt)]
(log/trace "Jobs:" jobs)
(log/debug "Loaded" (count jobs) "jobs:" (map bc/job-id jobs))
(run-all-jobs* rt jobs))
(catch Exception ex
(log/error "Unable to load build script" ex)
(let [msg ((some-fn (comp ex-message ex-cause)
ex-message) ex)]
(rt/post-events rt [(-> (base-event rt :script/end)
(assoc :script (build/script build)
:message msg))])
(assoc bc/failure
:message msg
:exception ex))))))