Commit | Line | Data |
---|---|---|
b3517f3f | 1 | ;;; GNU Guix --- Functional package management for GNU |
246c0c60 | 2 | ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
53e61956 | 3 | ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org> |
b3517f3f LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix ci) | |
21 | #:use-module (guix http-client) | |
041a9466 | 22 | #:use-module (guix utils) |
3ee0f170 HG |
23 | #:use-module ((guix build download) |
24 | #:select (resolve-uri-reference)) | |
a85a74ce | 25 | #:use-module (json) |
a3b72a8f | 26 | #:use-module (srfi srfi-1) |
a85a74ce | 27 | #:use-module (ice-9 match) |
3ee0f170 | 28 | #:use-module (web uri) |
246c0c60 LC |
29 | #:use-module (guix i18n) |
30 | #:use-module (guix diagnostics) | |
041a9466 | 31 | #:autoload (guix channels) (channel) |
53e61956 MO |
32 | #:export (build-product? |
33 | build-product-id | |
34 | build-product-type | |
35 | build-product-file-size | |
36 | build-product-path | |
37 | ||
38 | build? | |
b3517f3f LC |
39 | build-id |
40 | build-derivation | |
9087af03 | 41 | build-evaluation |
b3517f3f LC |
42 | build-system |
43 | build-status | |
44 | build-timestamp | |
53e61956 | 45 | build-products |
b3517f3f | 46 | |
a3b72a8f LC |
47 | checkout? |
48 | checkout-commit | |
935ede4f | 49 | checkout-channel |
a3b72a8f LC |
50 | |
51 | evaluation? | |
52 | evaluation-id | |
53 | evaluation-spec | |
54 | evaluation-complete? | |
55 | evaluation-checkouts | |
56 | ||
073f198e LC |
57 | job? |
58 | job-build-id | |
59 | job-status | |
60 | job-name | |
61 | ||
bb5f395a MO |
62 | history? |
63 | history-evaluation | |
64 | history-checkouts | |
65 | history-jobs | |
66 | ||
b3517f3f LC |
67 | %query-limit |
68 | queued-builds | |
a3b72a8f | 69 | latest-builds |
1d229a34 | 70 | evaluation |
073f198e LC |
71 | evaluation-jobs |
72 | build | |
73 | job-build | |
bb5f395a | 74 | jobs-history |
a3b72a8f | 75 | latest-evaluations |
041a9466 MO |
76 | evaluations-for-commit |
77 | ||
78 | channel-with-substitutes-available)) | |
b3517f3f LC |
79 | |
80 | ;;; Commentary: | |
81 | ;;; | |
82 | ;;; This module provides a client to the HTTP interface of the Hydra and | |
83 | ;;; Cuirass continuous integration (CI) tools. | |
84 | ;;; | |
85 | ;;; Code: | |
86 | ||
4e05bbb0 MO |
87 | (define-json-mapping <build-product> make-build-product |
88 | build-product? | |
89 | json->build-product | |
53e61956 MO |
90 | (id build-product-id) ;integer |
91 | (type build-product-type) ;string | |
92 | (file-size build-product-file-size) ;integer | |
93 | (path build-product-path)) ;string | |
4e05bbb0 | 94 | |
77dba228 LC |
95 | (define-syntax-rule (define-enumeration-mapping proc |
96 | (names integers) ...) | |
97 | (define (proc value) | |
98 | (match value | |
99 | (integers 'names) ...))) | |
100 | ||
101 | (define-enumeration-mapping integer->build-status | |
102 | ;; Copied from 'build-status' in Cuirass. | |
103 | (submitted -3) | |
104 | (scheduled -2) | |
105 | (started -1) | |
106 | (succeeded 0) | |
107 | (failed 1) | |
108 | (failed-dependency 2) | |
109 | (failed-other 3) | |
110 | (canceled 4)) | |
111 | ||
a85a74ce LC |
112 | (define-json-mapping <build> make-build build? |
113 | json->build | |
114 | (id build-id "id") ;integer | |
b3517f3f | 115 | (derivation build-derivation) ;string | #f |
9087af03 | 116 | (evaluation build-evaluation) ;integer |
b3517f3f | 117 | (system build-system) ;string |
77dba228 LC |
118 | (status build-status "buildstatus" ;symbol |
119 | integer->build-status) | |
4e05bbb0 MO |
120 | (timestamp build-timestamp) ;integer |
121 | (products build-products "buildproducts" ;<build-product>* | |
122 | (lambda (products) | |
123 | (map json->build-product | |
124 | ;; Before Cuirass 3db603c1, #f is always returned. | |
bb76f50b | 125 | (if (vector? products) |
4e05bbb0 MO |
126 | (vector->list products) |
127 | '()))))) | |
b3517f3f | 128 | |
073f198e LC |
129 | (define-json-mapping <job> make-job job? |
130 | json->job | |
131 | (build-id job-build-id "build") ;integer | |
132 | (status job-status "status" ;symbol | |
133 | integer->build-status) | |
134 | (name job-name)) ;string | |
135 | ||
bb5f395a MO |
136 | (define-json-mapping <history> make-history history? |
137 | json->history | |
138 | (evaluation history-evaluation) ;integer | |
139 | (checkouts history-checkouts "checkouts" ;<checkout>* | |
140 | (lambda (checkouts) | |
141 | (map json->checkout | |
142 | (vector->list checkouts)))) | |
143 | (jobs history-jobs "jobs" | |
144 | (lambda (jobs) | |
145 | (map json->job | |
146 | (vector->list jobs))))) | |
147 | ||
a85a74ce LC |
148 | (define-json-mapping <checkout> make-checkout checkout? |
149 | json->checkout | |
a3b72a8f | 150 | (commit checkout-commit) ;string (SHA1) |
935ede4f | 151 | (channel checkout-channel)) ;string (name) |
a3b72a8f | 152 | |
a85a74ce LC |
153 | (define-json-mapping <evaluation> make-evaluation evaluation? |
154 | json->evaluation | |
a3b72a8f | 155 | (id evaluation-id) ;integer |
2c33901f | 156 | (spec evaluation-spec "specification") ;string |
a2155f41 | 157 | (complete? evaluation-complete? "status" |
a85a74ce LC |
158 | (match-lambda |
159 | (0 #t) | |
160 | (_ #f))) ;Boolean | |
161 | (checkouts evaluation-checkouts "checkouts" ;<checkout>* | |
162 | (lambda (checkouts) | |
163 | (map json->checkout | |
164 | (vector->list checkouts))))) | |
a3b72a8f | 165 | |
b3517f3f LC |
166 | (define %query-limit |
167 | ;; Max number of builds requested in queries. | |
168 | 1000) | |
169 | ||
3ee0f170 HG |
170 | (define* (api-url base-url path #:rest query) |
171 | "Build a proper API url, taking into account BASE-URL's trailing slashes. | |
172 | QUERY takes any number of '(\"name\" value) 2-element lists, with VALUE being | |
173 | either a string or a number (which will be converted to a string). If VALUE | |
174 | is #f, the respective element will not be added to the query parameters. | |
175 | Other types of VALUE will raise an error since this low-level function is | |
176 | api-agnostic." | |
177 | ||
178 | (define (build-query-string query) | |
179 | (let lp ((query (or (reverse query) '())) (acc '())) | |
180 | (match query | |
181 | (() (string-concatenate acc)) | |
182 | (((_ #f) . rest) (lp rest acc)) | |
183 | (((name val) . rest) | |
184 | (lp rest (cons* | |
185 | name "=" | |
186 | (if (string? val) (uri-encode val) (number->string val)) | |
187 | (if (null? acc) "" "&") | |
188 | acc)))))) | |
189 | ||
190 | (let* ((query-string (build-query-string query)) | |
191 | (base (string->uri base-url)) | |
192 | (ref (build-relative-ref #:path path #:query query-string))) | |
193 | (resolve-uri-reference ref base))) | |
194 | ||
b3517f3f LC |
195 | (define (json-fetch url) |
196 | (let* ((port (http-fetch url)) | |
197 | (json (json->scm port))) | |
198 | (close-port port) | |
199 | json)) | |
200 | ||
3ee0f170 HG |
201 | (define* (json-api-fetch base-url path #:rest query) |
202 | (json-fetch (apply api-url base-url path query))) | |
203 | ||
b3517f3f LC |
204 | (define* (queued-builds url #:optional (limit %query-limit)) |
205 | "Return the list of queued derivations on URL." | |
3ee0f170 HG |
206 | (let ((queue |
207 | (json-api-fetch url "/api/queue" `("nr" ,limit)))) | |
a85a74ce | 208 | (map json->build (vector->list queue)))) |
b3517f3f | 209 | |
a3b72a8f | 210 | (define* (latest-builds url #:optional (limit %query-limit) |
11334d15 | 211 | #:key evaluation system job jobset status) |
a3b72a8f LC |
212 | "Return the latest builds performed by the CI server at URL. If EVALUATION |
213 | is an integer, restrict to builds of EVALUATION. If SYSTEM is true (a system | |
214 | string such as \"x86_64-linux\"), restrict to builds for SYSTEM." | |
3ee0f170 HG |
215 | (let ((latest (json-api-fetch |
216 | url "/api/latestbuilds" | |
217 | `("nr" ,limit) | |
218 | `("evaluation" ,evaluation) | |
219 | `("system" ,system) | |
220 | `("job" ,job) | |
11334d15 | 221 | `("jobset" ,jobset) |
3ee0f170 | 222 | `("status" ,status)))) |
b3517f3f LC |
223 | ;; Note: Hydra does not provide a "derivation" field for entries in |
224 | ;; 'latestbuilds', but Cuirass does. | |
a85a74ce | 225 | (map json->build (vector->list latest)))) |
a3b72a8f | 226 | |
1d229a34 MO |
227 | (define (evaluation url evaluation) |
228 | "Return the given EVALUATION performed by the CI server at URL." | |
3ee0f170 HG |
229 | (let ((evaluation |
230 | (json-api-fetch url "/api/evaluation" `("id" ,evaluation)))) | |
1d229a34 MO |
231 | (json->evaluation evaluation))) |
232 | ||
316d9e08 MO |
233 | (define* (latest-evaluations url |
234 | #:optional (limit %query-limit) | |
235 | #:key spec) | |
236 | "Return the latest evaluations performed by the CI server at URL. If SPEC | |
237 | is passed, only consider the evaluations for the given SPEC specification." | |
3ee0f170 HG |
238 | (map json->evaluation |
239 | (vector->list | |
240 | (json-api-fetch | |
241 | url "/api/evaluations" `("nr" ,limit) `("spec" ,spec))))) | |
a3b72a8f LC |
242 | |
243 | (define* (evaluations-for-commit url commit #:optional (limit %query-limit)) | |
244 | "Return the evaluations among the latest LIMIT evaluations that have COMMIT | |
245 | as one of their inputs." | |
246 | (filter (lambda (evaluation) | |
247 | (find (lambda (checkout) | |
248 | (string=? (checkout-commit checkout) commit)) | |
249 | (evaluation-checkouts evaluation))) | |
250 | (latest-evaluations url limit))) | |
041a9466 | 251 | |
073f198e LC |
252 | (define (evaluation-jobs url evaluation-id) |
253 | "Return the list of jobs of evaluation EVALUATION-ID." | |
254 | (map json->job | |
255 | (vector->list | |
3ee0f170 | 256 | (json-api-fetch url "/api/jobs" `("evaluation" ,evaluation-id))))) |
073f198e LC |
257 | |
258 | (define (build url id) | |
259 | "Look up build ID at URL and return it. Raise &http-get-error if it is not | |
260 | found (404)." | |
261 | (json->build | |
3ee0f170 HG |
262 | (http-fetch (api-url url (string-append "/build/" ;note: no "/api" here |
263 | (number->string id)))))) | |
073f198e LC |
264 | |
265 | (define (job-build url job) | |
266 | "Return the build associated with JOB." | |
267 | (build url (job-build-id job))) | |
268 | ||
bb5f395a MO |
269 | (define* (jobs-history url jobs |
270 | #:key | |
271 | (specification "master") | |
272 | (limit 20)) | |
273 | "Return the job history for the SPECIFICATION jobs which names are part of | |
274 | the JOBS list, from the CI server at URL. Limit the history to the latest | |
275 | LIMIT evaluations. " | |
276 | (let ((names (string-join jobs ","))) | |
277 | (map json->history | |
278 | (vector->list | |
279 | (json->scm | |
280 | (http-fetch | |
281 | (format #f "~a/api/jobs/history?spec=~a&names=~a&nr=~a" | |
282 | url specification names (number->string limit)))))))) | |
073f198e | 283 | |
041a9466 MO |
284 | (define (find-latest-commit-with-substitutes url) |
285 | "Return the latest commit with available substitutes for the Guix package | |
286 | definitions at URL. Return false if no commit were found." | |
287 | (let* ((job-name (string-append "guix." (%current-system))) | |
288 | (build (match (latest-builds url 1 | |
289 | #:job job-name | |
11334d15 | 290 | #:jobset "guix" |
041a9466 MO |
291 | #:status 0) ;success |
292 | ((build) build) | |
293 | (_ #f))) | |
294 | (evaluation (and build | |
295 | (evaluation url (build-evaluation build)))) | |
296 | (commit (and evaluation | |
297 | (match (evaluation-checkouts evaluation) | |
298 | ((checkout) | |
299 | (checkout-commit checkout)))))) | |
300 | commit)) | |
301 | ||
302 | (define (channel-with-substitutes-available chan url) | |
303 | "Return a channel inheriting from CHAN but which commit field is set to the | |
304 | latest commit with available substitutes for the Guix package definitions at | |
305 | URL. The current system is taken into account. | |
306 | ||
307 | If no commit with available substitutes were found, the commit field is set to | |
308 | false and a warning message is printed." | |
309 | (let ((commit (find-latest-commit-with-substitutes url))) | |
310 | (unless commit | |
311 | (warning (G_ "could not find available substitutes at ~a~%") | |
312 | url)) | |
313 | (channel | |
314 | (inherit chan) | |
315 | (commit commit)))) |