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
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix ci)
#:use-module (guix http-client)
#:use-module (guix utils)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (guix i18n)
#:use-module (guix diagnostics)
#:autoload (guix channels) (channel)
#:export (build-product?
build-product-id
build-product-type
build-product-file-size
build-product-path
build?
build-id
build-derivation
build-evaluation
build-system
build-status
build-timestamp
build-products
checkout?
checkout-commit
checkout-channel
evaluation?
evaluation-id
evaluation-spec
evaluation-complete?
evaluation-checkouts
%query-limit
queued-builds
latest-builds
evaluation
latest-evaluations
evaluations-for-commit
channel-with-substitutes-available))
;;; Commentary:
;;;
;;; This module provides a client to the HTTP interface of the Hydra and
;;; Cuirass continuous integration (CI) tools.
;;;
;;; Code:
(define-json-mapping <build-product> make-build-product
build-product?
json->build-product
(id build-product-id) ;integer
(type build-product-type) ;string
(file-size build-product-file-size) ;integer
(path build-product-path)) ;string
(define-json-mapping <build> make-build build?
json->build
(id build-id "id") ;integer
(derivation build-derivation) ;string | #f
(evaluation build-evaluation) ;integer
(system build-system) ;string
(status build-status "buildstatus" ) ;integer
(timestamp build-timestamp) ;integer
(products build-products "buildproducts" ;<build-product>*
(lambda (products)
(map json->build-product
;; Before Cuirass 3db603c1, #f is always returned.
(if (vector? products)
(vector->list products)
'())))))
(define-json-mapping <checkout> make-checkout checkout?
json->checkout
(commit checkout-commit) ;string (SHA1)
(channel checkout-channel)) ;string (name)
(define-json-mapping <evaluation> make-evaluation evaluation?
json->evaluation
(id evaluation-id) ;integer
(spec evaluation-spec "specification") ;string
(complete? evaluation-complete? "status"
(match-lambda
(0 #t)
(_ #f))) ;Boolean
(checkouts evaluation-checkouts "checkouts" ;<checkout>*
(lambda (checkouts)
(map json->checkout
(vector->list checkouts)))))
(define %query-limit
;; Max number of builds requested in queries.
1000)
(define (json-fetch url)
(let* ((port (http-fetch url))
(json (json->scm port)))
(close-port port)
json))
(define* (queued-builds url #:optional (limit %query-limit))
"Return the list of queued derivations on URL."
(let ((queue (json-fetch (string-append url "/api/queue?nr="
(number->string limit)))))
(map json->build (vector->list queue))))
(define* (latest-builds url #:optional (limit %query-limit)
#:key evaluation system job status)
"Return the latest builds performed by the CI server at URL. If EVALUATION
is an integer, restrict to builds of EVALUATION. If SYSTEM is true (a system
string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
(define* (option name value #:optional (->string identity))
(if value
(string-append "&" name "=" (->string value))
""))
(let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
(number->string limit)
(option "evaluation" evaluation
number->string)
(option "system" system)
(option "job" job)
(option "status" status
number->string)))))
;; Note: Hydra does not provide a "derivation" field for entries in
;; 'latestbuilds', but Cuirass does.
(map json->build (vector->list latest))))
(define (evaluation url evaluation)
"Return the given EVALUATION performed by the CI server at URL."
(let ((evaluation (json-fetch
(string-append url "/api/evaluation?id="
(number->string evaluation)))))
(json->evaluation evaluation)))
(define* (latest-evaluations url
#:optional (limit %query-limit)
#:key spec)
"Return the latest evaluations performed by the CI server at URL. If SPEC
is passed, only consider the evaluations for the given SPEC specification."
(let ((spec (if spec
(format #f "&spec=~a" spec)
"")))
(map json->evaluation
(vector->list
(json->scm
(http-fetch
(string-append url "/api/evaluations?nr="
(number->string limit)
spec)))))))
(define* (evaluations-for-commit url commit #:optional (limit %query-limit))
"Return the evaluations among the latest LIMIT evaluations that have COMMIT
as one of their inputs."
(filter (lambda (evaluation)
(find (lambda (checkout)
(string=? (checkout-commit checkout) commit))
(evaluation-checkouts evaluation)))
(latest-evaluations url limit)))
(define (find-latest-commit-with-substitutes url)
"Return the latest commit with available substitutes for the Guix package
definitions at URL. Return false if no commit were found."
(let* ((job-name (string-append "guix." (%current-system)))
(build (match (latest-builds url 1
#:job job-name
#:status 0) ;success
((build) build)
(_ #f)))
(evaluation (and build
(evaluation url (build-evaluation build))))
(commit (and evaluation
(match (evaluation-checkouts evaluation)
((checkout)
(checkout-commit checkout))))))
commit))
(define (channel-with-substitutes-available chan url)
"Return a channel inheriting from CHAN but which commit field is set to the
latest commit with available substitutes for the Guix package definitions at
URL. The current system is taken into account.
If no commit with available substitutes were found, the commit field is set to
false and a warning message is printed."
(let ((commit (find-latest-commit-with-substitutes url)))
(unless commit
(warning (G_ "could not find available substitutes at ~a~%")
url))
(channel
(inherit chan)
(commit commit))))
|
