blob: b6541d9cb4749005c55e801bb6a567d42dbad410 (
plain)
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
|
(define-module (guix-qa-frontpage manage-builds)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (guix-build-coordinator utils)
#:use-module (guix-build-coordinator client-communication)
#:use-module (guix-qa-frontpage database)
#:use-module (guix-qa-frontpage patchwork)
#:use-module (guix-qa-frontpage guix-data-service)
#:export (start-submit-patch-builds-thread))
(define (start-submit-patch-builds-thread database
build-coordinator
guix-data-service)
(call-with-new-thread
(lambda ()
(while #t
(simple-format #t "submitting patch builds\n")
(let ((series (with-sqlite-cache
database
'latest-patchwork-series-by-issue
latest-patchwork-series-by-issue
#:ttl 3000)))
(for-each
(match-lambda
((issue-number . series)
(simple-format #t
"considering submitting builds for issue ~A\n"
issue-number)
(let ((derivation-changes
change-details
(with-sqlite-cache
database
'derivation-changes
patch-series-derivation-changes
#:args
(list (patch-series-derivation-changes-url series))
#:ttl 6000)))
(when derivation-changes
(let ((target-commit
(assoc-ref
(assoc-ref
(assoc-ref change-details
"revisions")
"target")
"commit")))
(submit-builds-for-issue build-coordinator
guix-data-service
issue-number
derivation-changes
target-commit))))))
(take series 10)))))))
(define* (submit-build build-coordinator guix-data-service derivation
#:key (priority 0) (tags '()))
(retry-on-error
(lambda ()
(let ((response
(send-submit-build-request
build-coordinator
derivation
(list guix-data-service)
#f
priority
#t
#t
#t
tags)))
(let ((no-build-submitted-response
(assoc-ref response "no-build-submitted")))
(if no-build-submitted-response
(simple-format #t "skipped: ~A\n"
no-build-submitted-response)
(simple-format #t "build submitted as ~A\n"
(assoc-ref response "build-submitted"))))))
;; The TTL Guix uses for transient failures fetching substitutes is 10
;; minutes, so we need to retry for longer than that
#:times 30
#:delay 30))
(define (cancel-issue-builds-not-for-revision build-coordinator
issue
revision
derivations)
(define (builds-after id)
(vector->list
(assoc-ref
(request-builds-list build-coordinator
#:tags
`(((key . category)
(value . package))
((key . issue)
(value . ,issue)))
#:not-tags
`(((key . revision)
(value . ,revision)))
#:canceled #f
#:processed #f
#:limit 1000
#:after-id id)
"builds")))
(simple-format (current-error-port)
"canceling builds for issue ~A and not revision ~A\n"
issue
revision)
(let loop ((builds (builds-after #f)))
(for-each
(lambda (build-details)
(unless (member derivations
(assoc-ref build-details "derivation-name"))
(retry-on-error
(lambda ()
(send-cancel-build-request build-coordinator
(assoc-ref build-details "uuid")))
#:times 6
#:delay 15)
(simple-format (current-error-port)
"canceled ~A\n"
(assoc-ref build-details "uuid"))))
builds)
(unless (null? builds)
(loop (builds-after
(assoc-ref (last builds) "uuid"))))))
(define* (submit-builds-for-issue build-coordinator
guix-data-service
issue
derivation-changes
target-commit)
(define systems
'("x86_64-linux"
"i686-linux"
"aarch64-linux"
"armhf-linux"))
(define target-derivations
(fold (lambda (package result)
(fold
(lambda (change result)
(if (and (string=? (assoc-ref change "target")
"")
(member (assoc-ref change "system")
systems)
(eq? (vector-length
(assoc-ref change "builds"))
0))
(cons (assoc-ref change "derivation-file-name")
result)
result))
result
(vector->list
(assoc-ref package "target"))))
'()
derivation-changes))
(for-each (lambda (derivation)
(submit-build build-coordinator
guix-data-service
derivation
#:priority 0
#:tags
`(((key . category)
(value . package))
((key . issue)
(value . ,issue))
((key . revision)
(value . ,target-commit)))))
target-derivations)
(cancel-issue-builds-not-for-revision
build-coordinator
issue
target-commit
target-derivations))
|