diff options
| -rw-r--r-- | guix-data-service/builds.scm | 116 |
1 files changed, 114 insertions, 2 deletions
diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm index fcd739c..64b04ad 100644 --- a/guix-data-service/builds.scm +++ b/guix-data-service/builds.scm @@ -132,7 +132,7 @@ initial connection on which HTTP requests are sent." (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 revision-commits) + (process-derivation-outputs conn id url revision-commits) (simple-format #t "\nFetching narinfo files\n") (fetch-narinfo-files conn id url revision-commits)) @@ -144,7 +144,9 @@ initial connection on which HTTP requests are sent." (let* ((status-string (assq-ref build-statuses - (assoc-ref data "buildstatus"))) + (or (assoc-ref data "buildstatus") + ;; status is for the /output/ requests + (assoc-ref data "status")))) (finished? (member status-string stop-statuses)) (existing-status-entries @@ -200,6 +202,31 @@ initial connection on which HTTP requests are sent." (usleep 200))) (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 derivations (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")))) 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 query " @@ -362,6 +423,57 @@ LIMIT 15000")) (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 outputs (select-outputs-without-known-nar-entries |