blob: a9a945c07e056b58aa17685c4ef87e615bcdf9d7 (
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
|
(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)
(process-pending-builds conn id url)
(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)
(match (array->list
(fetch-latest-builds-for-derivation url derivation-file-name))
(#f #f)
(()
(match (array->list
(fetch-queued-builds-for-derivation url derivation-file-name))
(#f #f)
(() #f)
((status)
status)))
((status)
status)))
(define (json-string->scm* string)
(catch
'json-invalid
(lambda ()
(json-string->scm string))
(lambda args
(display args)
(newline)
(simple-format #t "error parsing: ~A\n" string)
#f)))
(define (fetch-latest-builds-for-derivation url derivation-file-name)
(let-values
(((response body)
(http-request (string-append
url
"api/latestbuilds?nr=10"
"&derivation=" derivation-file-name))))
(cond
((eq? (response-code response) 200)
(json-string->scm
(bytevector->string body "utf-8")))
(else #f))))
(define (fetch-queued-builds-for-derivation url derivation-file-name)
(let-values
(((response body)
(http-request (string-append
url
"api/queue?nr=10"
"&derivation=" derivation-file-name))))
(cond
((eq? (response-code response) 200)
(json-string->scm
(bytevector->string body "utf-8")))
(else #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 #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 1000"))
(exec-query conn query))
|