aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-data-service/builds.scm116
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