aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service/model/build.scm
blob: b2ac79fae77e91d756810ccfe67ddd05622bb279 (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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
;;; as published by the Free Software Foundation, either version 3 of
;;; the License, or (at your option) any later version.
;;;
;;; This program 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
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (guix-data-service model build)
  #:use-module (ice-9 match)
  #:use-module (squee)
  #:use-module (json)
  #:use-module (guix-data-service database)
  #:use-module (guix-data-service model utils)
  #:export (select-build-stats
            select-builds-with-context
            select-builds-with-context-by-derivation-file-name
            select-builds-with-context-by-derivation-output
            select-build-by-build-server-and-build-server-build-id
            select-build-by-build-server-and-derivation-file-name
            select-required-builds-that-failed
            update-builds-derivation-output-details-set-id
            insert-builds
            insert-build
            ensure-build-exists))

(define* (select-build-stats conn build-servers
                             #:key revision-commit
                             system target)
  (define criteria
    `(,@(if build-servers
            (list
             (string-append
              "builds.build_server_id IN ("
              (string-join (map number->string build-servers)
                           ", ")
              ")"))
            '())
      ,@(if revision-commit
            '("guix_revisions.commit = $1")
            '())
      ,@(if system
            '("package_derivations.system = $2")
            '())
      ,@(if target
            '("package_derivations.target = $3")
            '())))

  (define query
    (string-append
     "
SELECT latest_build_status.status AS build_status, build_servers.id, COUNT(*)
FROM derivation_output_details_sets
CROSS JOIN build_servers
"
     (if revision-commit
         "
INNER JOIN derivations_by_output_details_set
  ON derivation_output_details_sets.id =
     derivations_by_output_details_set.derivation_output_details_set_id
INNER JOIN package_derivations
  ON derivations_by_output_details_set.derivation_id = package_derivations.derivation_id
INNER JOIN guix_revision_package_derivations
  ON guix_revision_package_derivations.package_derivation_id = package_derivations.id
INNER JOIN guix_revisions
  ON guix_revision_package_derivations.revision_id = guix_revisions.id"
         "")
     "
LEFT JOIN builds
   ON builds.derivation_output_details_set_id =
        derivation_output_details_sets.id AND
      builds.build_server_id = build_servers.id
LEFT JOIN latest_build_status
  ON builds.id = latest_build_status.build_id
"
     (if (null? criteria)
         ""
         (string-append
          "WHERE "
          (string-join criteria " AND ")))
     "
GROUP BY latest_build_status.status, build_servers.id
ORDER BY status"))

  (map (match-lambda
         (((build-status) . data)
          (list build-status
                (map (match-lambda
                       ((build-server-id count)
                        (cons (string->number build-server-id)
                              (string->number count))))
                     data))))
       (group-list-by-first-n-fields
        1
        (exec-query conn
                    query
                    `(,@(if revision-commit
                            (list revision-commit)
                            '())
                      ,@(if system
                            (list system)
                            '())
                      ,@(if target
                            (list target)
                            '()))))))

(define* (select-builds-with-context conn build-statuses build-server-ids
                                     #:key revision-commit
                                     system target
                                     limit)
  (define where-conditions
    (filter
     string?
     (list
      (when (list? build-statuses)
        (string-append
         "latest_build_status.status IN ("
         (string-join (map quote-string build-statuses)
                      ",")
         ")"))
      (when (list? build-server-ids)
        (string-append
         "builds.build_server_id IN ("
         (string-join (map number->string build-server-ids)
                      ", ")
         ")"))
      (when revision-commit
        "guix_revisions.commit = $1")
      (when system
        "package_derivations.system = $2")
      (when target
        "package_derivations.target = $3"))))

  (define query
    (string-append
     "
SELECT builds.id, build_servers.url,
       builds.build_server_build_id, derivations.file_name,
       latest_build_status.timestamp, latest_build_status.status
FROM builds
INNER JOIN build_servers ON build_servers.id = builds.build_server_id
INNER JOIN derivations ON derivations.file_name = builds.derivation_file_name
"
     (if revision-commit
         "
INNER JOIN derivations_by_output_details_set
  ON builds.derivation_output_details_set_id =
     derivations_by_output_details_set.derivation_output_details_set_id
INNER JOIN package_derivations
  ON derivations_by_output_details_set.derivation_id = package_derivations.derivation_id
INNER JOIN guix_revision_package_derivations
  ON guix_revision_package_derivations.package_derivation_id = package_derivations.id
INNER JOIN guix_revisions
  ON guix_revision_package_derivations.revision_id = guix_revisions.id"
         "")
     "
INNER JOIN latest_build_status
  ON latest_build_status.build_id = builds.id
"
                   (if (null? where-conditions)
                       ""
                       (string-append
                        "WHERE "
                        (string-join where-conditions " AND ")))
                   "
ORDER BY latest_build_status.timestamp DESC NULLS LAST, derivations.file_name
"
                   (if limit
                       (string-append
                        "LIMIT " (number->string limit))
                       "")))

  (exec-query-with-null-handling conn
                                 query
                                 `(,@(if revision-commit
                                         (list revision-commit)
                                         '())
                                   ,@(if system
                                         (list system)
                                         '())
                                   ,@(if target
                                         (list target)
                                         '()))))

(define (select-builds-with-context-by-derivation-file-name
         conn derivation-file-name)
  (define query
    "
SELECT DISTINCT ON (builds.id)
       builds.id,
       build_servers.id,
       build_servers.url,
       builds.build_server_build_id,
       builds.derivation_file_name,
       latest_build_status.timestamp,
       latest_build_status.status
FROM builds
INNER JOIN build_servers ON build_servers.id = builds.build_server_id
INNER JOIN latest_build_status
  ON latest_build_status.build_id = builds.id
INNER JOIN derivations_by_output_details_set
  ON builds.derivation_output_details_set_id =
     derivations_by_output_details_set.derivation_output_details_set_id
INNER JOIN derivations
  ON derivations.id = derivations_by_output_details_set.derivation_id
WHERE derivations.file_name = $1
ORDER BY builds.id, latest_build_status.timestamp DESC")

  (exec-query conn query (list derivation-file-name)))

(define (select-builds-with-context-by-derivation-output conn output)
  (define query
    "
SELECT build_servers.id,
       build_servers.url,
       builds.build_server_build_id,
       builds.derivation_file_name,
       latest_build_status.timestamp,
       latest_build_status.status
FROM builds
INNER JOIN build_servers ON build_servers.id = builds.build_server_id
INNER JOIN latest_build_status
  ON latest_build_status.build_id = builds.id
INNER JOIN derivation_output_details_sets
  ON builds.derivation_output_details_set_id =
     derivation_output_details_sets.id
INNER JOIN derivation_output_details
  ON ARRAY[derivation_output_details.id] <@
     derivation_output_details_sets.derivation_output_details_ids
WHERE derivation_output_details.path = $1
ORDER BY latest_build_status.timestamp DESC")

  (exec-query-with-null-handling conn query (list output)))

(define (select-build-by-build-server-and-build-server-build-id
         conn build-server-id build-server-build-id)
  (define query
    "
SELECT build_servers.url,
       builds.build_server_build_id,
       builds.derivation_file_name,
       (
         SELECT JSON_AGG(
                  json_build_object(
                    'timestamp', build_status.timestamp,
                    'status', build_status.status
                  )
                  ORDER BY CASE WHEN status = 'scheduled' THEN -2
                                WHEN status = 'started' THEN -1
                                ELSE 0
                           END ASC,
                           timestamp ASC
                )
         FROM build_status
         WHERE build_status.build_id = builds.id
       ) AS statuses
FROM builds
INNER JOIN build_servers
  ON build_servers.id = builds.build_server_id
INNER JOIN derivations_by_output_details_set
  ON builds.derivation_output_details_set_id =
     derivations_by_output_details_set.derivation_output_details_set_id
INNER JOIN derivations
  ON derivations.id = derivations_by_output_details_set.derivation_id
WHERE build_server_id = $1 AND
      builds.build_server_build_id = $2
GROUP BY builds.id, build_servers.url, builds.derivation_file_name")

  (match (exec-query conn
                     query
                     (list (number->string build-server-id)
                           build-server-build-id))
    (((build-server-url build-server-build-id derivation-file-name statuses-json))
     (list build-server-url
           build-server-build-id
           derivation-file-name
           (json-string->scm statuses-json)))
    (()
     #f)))

(define (select-build-by-build-server-and-derivation-file-name
         conn build-server-id derivation-file-name)
  (define query
    "
SELECT build_servers.url,
       builds.build_server_build_id,
       builds.derivation_file_name,
       (
         SELECT JSON_AGG(
                  json_build_object(
                    'timestamp', build_status.timestamp,
                    'status', build_status.status
                  )
                  ORDER BY CASE WHEN status = 'scheduled' THEN -2
                                WHEN status = 'started' THEN -1
                                ELSE 0
                           END ASC,
                           timestamp ASC
                )
         FROM build_status
         WHERE build_status.build_id = builds.id
       ) AS statuses
FROM builds
INNER JOIN build_servers
  ON build_servers.id = builds.build_server_id
INNER JOIN derivations_by_output_details_set
  ON builds.derivation_output_details_set_id =
     derivations_by_output_details_set.derivation_output_details_set_id
INNER JOIN derivations
  ON derivations.id = derivations_by_output_details_set.derivation_id
WHERE build_server_id = $1 AND
      derivations.file_name = $2
GROUP BY builds.id, build_servers.url, builds.derivation_file_name")

  (match (exec-query conn
                     query
                     (list (number->string build-server-id)
                           derivation-file-name))
    (((build-server-url build-server-build-id derivation-file-name statuses-json))
     ;; Returning the derivation-file-name is for consistency with
     ;; select-build-by-build-server-and-build-server-build-id
     (list build-server-url
           build-server-build-id
           derivation-file-name
           (json-string->scm statuses-json)))
    (()
     #f)))

(define (select-required-builds-that-failed conn build-server-id derivation-file-name)
  (define query
    "
WITH RECURSIVE all_derivations(id, file_name) AS (
    SELECT derivations.id, derivations.file_name
    FROM derivations
    WHERE file_name = $1
  UNION
    SELECT derivations.id, derivations.file_name
    FROM all_derivations
    INNER JOIN derivation_inputs
      ON all_derivations.id = derivation_inputs.derivation_id
    INNER JOIN derivation_outputs
      ON derivation_inputs.derivation_output_id = derivation_outputs.id
    INNER JOIN derivations
      ON derivation_outputs.derivation_id = derivations.id
)
SELECT all_derivations.file_name, latest_build_status.status
FROM all_derivations
INNER JOIN derivations_by_output_details_set
  ON all_derivations.id = derivations_by_output_details_set.derivation_id
INNER JOIN builds
  ON derivations_by_output_details_set.derivation_output_details_set_id =
     builds.derivation_output_details_set_id
 AND builds.build_server_id = $2
INNER JOIN latest_build_status
  ON builds.id = latest_build_status.build_id
 AND latest_build_status.status = 'failed'
WHERE NOT EXISTS (
    SELECT 1
    FROM builds AS successful_builds
    INNER JOIN build_status AS successful_builds_build_status
      ON successful_builds.id = successful_builds_build_status.build_id
    WHERE successful_builds.derivation_output_details_set_id =
          builds.derivation_output_details_set_id
      AND successful_builds.build_server_id = $2
      AND successful_builds_build_status.status = 'succeeded'
  )")

  (exec-query conn
              query
              (list derivation-file-name
                    (number->string build-server-id))))

(define (select-build-id-by-build-server-and-derivation-file-name
         conn build-server-id derivation-file-name)
  (define query
    "
SELECT id
FROM builds
WHERE build_server_id = $1 AND derivation_file_name = $2")

  (match (exec-query conn
                     query
                     (list (number->string build-server-id)
                           derivation-file-name))
    (((id))
     (string->number id))
    (_
     #f)))

(define (select-build-id-by-build-server-and-build-server-build-id
         conn build-server-id build-server-build-id)
  (define query
    "
SELECT id
FROM builds
WHERE build_server_id = $1 AND build_server_build_id = $2")

  (match (exec-query conn
                     query
                     (list (number->string build-server-id)
                           build-server-build-id))
    (((id))
     (string->number id))
    (_
     #f)))

(define (update-builds-derivation-output-details-set-id conn derivation-file-names)
  (exec-query
   conn
   (string-append
    "
UPDATE builds SET derivation_output_details_set_id = (
  SELECT derivations_by_output_details_set.derivation_output_details_set_id
  FROM derivations_by_output_details_set
  INNER JOIN derivations
    ON derivations.file_name = builds.derivation_file_name
  WHERE derivations_by_output_details_set.derivation_id = derivations.id
) WHERE builds.derivation_output_details_set_id IS NULL AND
        builds.derivation_file_name IN ("
    (string-join (map quote-string derivation-file-names)
                 ",")
    ")")))

(define (select-derivations-by-output-details-set-id-by-derivation-file-name
         conn
         derivation-file-name)
  (match (exec-query
          conn
          "
SELECT derivation_output_details_set_id
FROM derivations_by_output_details_set
INNER JOIN derivations
  ON derivations.id = derivations_by_output_details_set.derivation_id
WHERE derivations.file_name = $1"
          (list derivation-file-name))
    (((id))
     (string->number id))
    (_
     #f)))

(define (insert-builds conn build-server-id derivation-file-names
                       build-server-build-ids)
  (let ((build-ids
         (insert-missing-data-and-return-all-ids
          conn
          "builds"
          '(build_server_id derivation_file_name build_server_build_id)
          (map (lambda (derivation-file-name build-server-build-id)
                 (list build-server-id
                       derivation-file-name
                       (if (string? build-server-build-id)
                           build-server-build-id
                           '())))
               derivation-file-names
               build-server-build-ids)
          #:delete-duplicates? #t)))

    (exec-query
     conn
     (string-append
      "
UPDATE builds SET derivation_output_details_set_id = (
  SELECT derivations_by_output_details_set.derivation_output_details_set_id
  FROM derivations_by_output_details_set
  INNER JOIN derivations
    ON derivations.file_name = builds.derivation_file_name
  WHERE derivations_by_output_details_set.derivation_id = derivations.id
) WHERE builds.derivation_output_details_set_id IS NULL AND builds.id IN ("
      (string-join (map number->string
                        build-ids)
                   ",")
      ")"))

    build-ids))

(define* (insert-build conn build-server-id derivation-file-name
                       build-server-build-id
                       #:key derivation-output-details-set-id)
  (match (exec-query
          conn
          (string-append
           "
INSERT INTO builds
  (build_server_id, derivation_file_name, derivation_output_details_set_id,
   build_server_build_id)
VALUES ("
           (number->string build-server-id)
           ", "
           (quote-string derivation-file-name)
           ", "
           (or
            (and=>
             (or
              derivation-output-details-set-id
              (select-derivations-by-output-details-set-id-by-derivation-file-name
               conn
               derivation-file-name))
             number->string)
            "NULL")
           ", "
           (or (and=> build-server-build-id
                      quote-string)
               "NULL")
           ")
RETURNING (id)"))
    (((id))
     (string->number id))))

(define* (ensure-build-exists conn
                              build-server-id
                              derivation-file-name
                              build-server-build-id
                              #:key derivation-output-details-set-id)
  (let ((existing-build-id
         (if build-server-build-id
             (select-build-id-by-build-server-and-build-server-build-id
              conn build-server-id build-server-build-id)
             (select-build-id-by-build-server-and-derivation-file-name
              conn build-server-id derivation-file-name))))

    (if existing-build-id
        (begin
          (exec-query
           conn
           "
UPDATE builds SET derivation_output_details_set_id = $2
WHERE builds.id = $1 AND derivation_output_details_set_id IS NULL"
           (list (number->string existing-build-id)
                 (number->string derivation-output-details-set-id)))

          existing-build-id)
        (insert-build conn
                      build-server-id
                      derivation-file-name
                      build-server-build-id
                      #:derivation-output-details-set-id
                      derivation-output-details-set-id))))