Switch to querying builds by output, rather than derivation

This is better, as Cuirass will return a build for the derivation it built to
generate that output. This avoids having to query for multiple derivations
that generate a single output, until the one that Cuirass used is found.
This commit is contained in:
Christopher Baines 2020-01-16 20:42:56 +00:00
parent bd52629674
commit cf407fe830

View file

@ -132,7 +132,7 @@ initial connection on which HTTP requests are sent."
(simple-format #t "\nFetching pending builds\n") (simple-format #t "\nFetching pending builds\n")
(process-pending-builds conn id url) (process-pending-builds conn id url)
(simple-format #t "\nFetching unseen derivations\n") (simple-format #t "\nFetching unseen derivations\n")
(process-derivations conn id url revision-commits) (process-derivation-outputs conn id url revision-commits)
(simple-format #t "\nFetching narinfo files\n") (simple-format #t "\nFetching narinfo files\n")
(fetch-narinfo-files conn id url revision-commits)) (fetch-narinfo-files conn id url revision-commits))
@ -144,7 +144,9 @@ initial connection on which HTTP requests are sent."
(let* ((status-string (let* ((status-string
(assq-ref build-statuses (assq-ref build-statuses
(assoc-ref data "buildstatus"))) (or (assoc-ref data "buildstatus")
;; status is for the /output/ requests
(assoc-ref data "status"))))
(finished? (finished?
(member status-string stop-statuses)) (member status-string stop-statuses))
(existing-status-entries (existing-status-entries
@ -200,6 +202,31 @@ initial connection on which HTTP requests are sent."
(usleep 200))) (usleep 200)))
(select-pending-builds conn build-server-id))) (select-pending-builds conn build-server-id)))
(define (process-derivation-outputs conn build-server-id url revision-commits)
(define derivation-outputs
(select-derivation-outputs-with-no-known-build conn
build-server-id
revision-commits))
(simple-format (current-error-port) "Fetching ~A derivation outputs\n"
(length derivation-outputs))
(fetch-builds-by-output
url
derivation-outputs
(lambda (data)
(if data
(let ((build-id
(ensure-build-exists conn
build-server-id
(assoc-ref data "derivation"))))
(insert-build-statuses-from-data
conn
build-server-id
build-id
(assoc-ref data "build"))
(display "-"))
(display ".")))))
(define (process-derivations conn build-server-id url revision-commits) (define (process-derivations conn build-server-id url revision-commits)
(define derivations (define derivations
(select-derivations-with-no-known-build conn (select-derivations-with-no-known-build conn
@ -289,6 +316,40 @@ initial connection on which HTTP requests are sent."
#:headers '((User-Agent . "Guix Data Service")))) #:headers '((User-Agent . "Guix Data Service"))))
derivation-file-names))) derivation-file-names)))
(define (fetch-builds-by-output url derivation-outputs handler)
(define (read-to-eof port)
"Read from PORT until EOF is reached. The data are discarded."
(dump-port port (%make-void-port "w")))
(http-multiple-get
(string->uri url)
(lambda (request response port result)
(let* ((len (response-content-length response))
(response-body
(if len
(get-bytevector-n port len)
(read-to-eof port))))
(handler
(cond
((eq? (response-code response) 200)
(json-string->scm
(bytevector->string response-body
"utf-8")))
(else
#f)))))
'()
(map (lambda (output-file-name)
(build-request
(string->uri
(string-append url
"output"
(string-drop
output-file-name
(string-length "/gnu/store"))))
#:method 'GET
#:headers '((User-Agent . "Guix Data Service"))))
derivation-outputs)))
(define (select-pending-builds conn build-server-id) (define (select-pending-builds conn build-server-id)
(define query (define query
" "
@ -362,6 +423,57 @@ LIMIT 15000"))
(exec-query conn query (list (number->string build-server-id)))) (exec-query conn query (list (number->string build-server-id))))
(define (select-derivation-outputs-with-no-known-build conn
build-server-id
revision-commits)
(define query
;; Only select derivations that are in the package_derivations table, as
;; Cuirass doesn't build the intermediate derivations
(string-append
"
SELECT derivation_output_details.path
FROM derivation_output_details
INNER JOIN derivation_output_details_sets
ON derivation_output_details.id =
derivation_output_details_sets.derivation_output_details_ids[1]
WHERE NOT EXISTS (
SELECT 1
FROM builds
WHERE builds.derivation_output_details_set_id =
derivation_output_details_sets.id
AND build_server_id = $1
) AND derivation_output_details_sets.id IN (
SELECT derivation_output_details_set_id
FROM package_derivations
INNER JOIN derivations_by_output_details_set
ON package_derivations.derivation_id =
derivations_by_output_details_set.derivation_id
INNER JOIN build_servers_build_config
ON build_servers_build_config.build_server_id = $1
AND build_servers_build_config.system = package_derivations.system
AND build_servers_build_config.target = package_derivations.target
"
(if (null? revision-commits)
""
(string-append
"
INNER JOIN guix_revision_package_derivations
ON package_derivations.id =
guix_revision_package_derivations.package_derivation_id
INNER JOIN guix_revisions
ON guix_revisions.id = guix_revision_package_derivations.revision_id
WHERE guix_revisions.commit IN ("
(string-join (map quote-string revision-commits) ",")
")"))
"
)
ORDER BY derivation_output_details_sets.id, derivation_output_details.id
LIMIT 15000"))
(map first
(exec-query conn query (list (number->string build-server-id)))))
(define (fetch-narinfo-files conn build-server-id build-server-url revision-commits) (define (fetch-narinfo-files conn build-server-id build-server-url revision-commits)
(define outputs (define outputs
(select-outputs-without-known-nar-entries (select-outputs-without-known-nar-entries