blob: 754ef89c58bdbf1068505154a73ba2848733fe58 (
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
|
(define-module (guix-data-service builds)
#: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 (string=? lookup-all-derivations? "t")
(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 (process-pending-builds conn build-server-id url)
(for-each
(match-lambda
((build-id internal-build-id derivation-id derivation-file-name)
(match (fetch-build url build-id)
(#f #f)
(() #f)
(status
(insert-build-status conn
internal-build-id
(assoc-ref status "starttime")
(assoc-ref status "stoptime")
(assq-ref build-statuses
(assoc-ref status "buildstatus")))))
(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)
(and=> (fetch-build-for-derivation url derivation-file-name)
(lambda (status)
(let ((internal-build-id
(ensure-build-exists conn
build-server-id
(assoc-ref status "id")
derivation-id
(assoc-ref status "timestamp"))))
(insert-build-status conn
internal-build-id
(assoc-ref status "starttime")
(assoc-ref status "stoptime")
(assq-ref build-statuses
(assoc-ref status "buildstatus"))))))
(display ".")
;; Try not to make to many requests at once
(usleep 200)))
(select-derivations-with-no-known-build conn)))
(define (fetch-build-for-derivation url derivation-file-name)
(catch
#t
(lambda ()
(match (fetch-latest-builds-for-derivation url derivation-file-name)
((or #f #())
(match (fetch-queued-builds-for-derivation url derivation-file-name)
((or #f #())
(simple-format #t "\nwarning: couldn't find build for ~A on ~A\n"
derivation-file-name
url)
#f)
(#(status)
status)))
(#(status)
status)))
(lambda args
(simple-format #t "\nerror: couldn't fetch build for ~A on ~A\n"
derivation-file-name url)
(simple-format #t "error: ~A\n" args)
#f)))
(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-latest-builds-for-derivation base-url derivation-file-name)
(define url
(string-append base-url
"api/latestbuilds?nr=1"
"&derivation=" derivation-file-name))
(let-values (((response body) (http-request url)))
(let ((code (response-code response)))
(cond
((eq? code 200)
(json-string->scm
(bytevector->string body "utf-8")))
(else
(simple-format #t "\nerror: response code ~A: ~A\n" url code)
#f)))))
(define (fetch-queued-builds-for-derivation base-url derivation-file-name)
(define url
(string-append base-url
"api/queue?nr=1"
"&derivation=" derivation-file-name))
(let-values (((response body) (http-request url)))
(let ((code (response-code response)))
(cond
((eq? code 200)
(json-string->scm
(bytevector->string body "utf-8")))
(else
(simple-format #t "\nerror: response code ~A: ~A\n" url code)
#f)))))
(define (fetch-build url id)
(let-values
(((response body)
(http-request (string-append url "build/" id))))
(cond
((eq? (response-code response) 200)
(json-string->scm
(bytevector->string body "utf-8")))
(else
(simple-format #t "\nwarning: couldn't find build ~A on ~A\n"
id
url)
#f))))
(define (select-pending-builds conn build-server-id)
(define query
(string-append
"SELECT builds.id, builds.internal_id, derivations.id, derivations.file_name "
"FROM derivations "
"INNER JOIN builds "
"ON derivations.id = builds.derivation_id "
"INNER JOIN build_status "
"ON builds.internal_id = build_status.internal_build_id "
"WHERE builds.build_server_id = $1 AND "
"build_status.status IN ("
"'scheduled', 'started'"
") "
"LIMIT 1000"))
(exec-query conn query (list build-server-id)))
(define (select-derivations-with-no-known-build conn)
(define query
(string-append
"SELECT derivations.id, derivations.file_name "
"FROM derivations "
"WHERE derivations.id NOT IN ("
"SELECT derivation_id FROM builds"
") "
"LIMIT 15000"))
(exec-query conn query))
|