blob: 7bebc9baff8bbb4065f5536067b450fa9f0cff8c (
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
181
182
183
184
185
186
187
188
189
|
(define-module (guix-data-service builds)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (ice-9 match)
#:use-module (ice-9 iconv)
#:use-module (json parser)
#:use-module (web response)
#:use-module (web client)
#:use-module (squee)
#:use-module (guix-data-service builds)
#:use-module (guix-data-service model build)
#:use-module (guix-data-service model build-server)
#:use-module (guix-data-service model build-status)
#:export (query-build-servers))
(define (query-build-servers conn)
(while #t
(let ((build-servers (select-build-servers conn)))
(for-each
(match-lambda
((id url lookup-all-derivations?)
(when lookup-all-derivations?
(query-build-server conn id url))))
build-servers))))
(define (query-build-server conn id url)
(simple-format #t "\nFetching pending builds\n")
(process-pending-builds conn id url)
(simple-format #t "\nFetching unseen derivations\n")
(process-derivations conn id url))
(define (insert-build-statuses-from-data conn build-server-id build-id data)
(define stop-statuses
(lset-difference string=?
build-status-strings
'("scheduled" "started")))
(let* ((status-string
(assq-ref build-statuses
(assoc-ref data "buildstatus")))
(finished?
(member status-string stop-statuses))
(existing-status-entries
(map second
(select-build-statuses-by-build-id conn
build-id
build-server-id)))
(timestamp
(assoc-ref data "timestamp"))
(starttime
(assoc-ref data "starttime"))
(stoptime
(assoc-ref data "stoptime")))
(map (match-lambda
((timestamp status)
(insert-build-status conn build-id timestamp status)))
(filter
list?
(list
(when (and
;; Cuirass returns the stoptime as the timestamp if the
;; build has finished, so only use the timestamp if the
;; build hasn't finished.
(not finished?)
(not (member "scheduled" existing-status-entries)))
(list timestamp "scheduled"))
(when (and (< 0 starttime)
(not (member "started" existing-status-entries)))
(list starttime "started"))
(when (and (< 0 stoptime)
(not (member status-string existing-status-entries)))
(list stoptime status-string)))))))
(define (process-pending-builds conn build-server-id url)
(for-each
(match-lambda
((build-id derivation-file-name)
(match (fetch-build url derivation-file-name)
(#f
(display ".")
#f)
(()
(display ".")
#f)
(data
(insert-build-statuses-from-data
conn
build-server-id
build-id
data)
(display "-")))
;; Try not to make to many requests at once
(usleep 200)))
(select-pending-builds conn build-server-id)))
(define (process-derivations conn build-server-id url)
(for-each
(match-lambda
((derivation-id derivation-file-name)
(if
(and=> (fetch-build url derivation-file-name)
(lambda (data)
(let ((build-id
(ensure-build-exists conn
build-server-id
derivation-file-name)))
(insert-build-statuses-from-data
conn
build-server-id
build-id
data))
#t))
(display "-")
(display "."))
;; Try not to make to many requests at once
(usleep 200)))
(select-derivations-with-no-known-build conn)))
(define (json-string->scm* string)
(catch
'json-invalid
(lambda ()
(json-string->scm string))
(lambda args
(display args)
(newline)
(simple-format #t "\nerror parsing: ~A\n" string)
#f)))
(define (fetch-build url derivation-file-name)
(let-values
(((response body)
(http-request (string-append
url
(string-append
"build"
(string-drop
derivation-file-name
(string-length "/gnu/store")))))))
(cond
((eq? (response-code response) 200)
(json-string->scm
(bytevector->string body "utf-8")))
(else
#f))))
(define (select-pending-builds conn build-server-id)
(define query
"
SELECT builds.id, derivations.file_name
FROM derivations
INNER JOIN builds
ON derivations.file_name = builds.derivation_file_name
LEFT JOIN (
SELECT DISTINCT ON (build_id) *
FROM build_status
ORDER BY build_id, timestamp DESC
) AS latest_build_status
ON builds.id = latest_build_status.build_id
WHERE builds.build_server_id = $1 AND
latest_build_status.status IN (
'scheduled', 'started'
)
ORDER BY latest_build_status.status DESC -- 'started' first
LIMIT 1000")
(map
(match-lambda
((build-id derivation-file-name)
(list (string->number build-id)
derivation-file-name)))
(exec-query conn query (list (number->string build-server-id)))))
(define (select-derivations-with-no-known-build conn)
(define query
;; Only select derivations that are in the package_derivations table, as
;; Cuirass doesn't build the intermediate derivations
"
SELECT derivations.id, derivations.file_name
FROM derivations
WHERE derivations.file_name NOT IN (
SELECT derivation_file_name FROM builds
) AND derivations.id IN (
SELECT derivation_id FROM package_derivations
)
LIMIT 15000")
(exec-query conn query))
|