aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-data-service/builds.scm82
-rw-r--r--scripts/guix-data-service-query-build-servers.in6
2 files changed, 68 insertions, 20 deletions
diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm
index 7bebc9b..370eee2 100644
--- a/guix-data-service/builds.scm
+++ b/guix-data-service/builds.scm
@@ -7,27 +7,33 @@
#:use-module (web response)
#:use-module (web client)
#:use-module (squee)
+ #:use-module (guix scripts substitute)
+ #:use-module (guix-data-service database)
#:use-module (guix-data-service builds)
+ #:use-module (guix-data-service model utils)
#:use-module (guix-data-service model build)
#:use-module (guix-data-service model build-server)
#:use-module (guix-data-service model build-status)
+ #:use-module (guix-data-service model nar)
#:export (query-build-servers))
-(define (query-build-servers conn)
+(define (query-build-servers conn revision-commits)
(while #t
(let ((build-servers (select-build-servers conn)))
(for-each
(match-lambda
((id url lookup-all-derivations?)
(when lookup-all-derivations?
- (query-build-server conn id url))))
+ (query-build-server conn id url revision-commits))))
build-servers))))
-(define (query-build-server conn id url)
+(define (query-build-server conn id url revision-commits)
(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))
+ (process-derivations conn id url revision-commits)
+ (simple-format #t "\nFetching narinfo files\n")
+ (fetch-narinfo-files conn id url revision-commits))
(define (insert-build-statuses-from-data conn build-server-id build-id data)
(define stop-statuses
@@ -93,7 +99,12 @@
(usleep 200)))
(select-pending-builds conn build-server-id)))
-(define (process-derivations conn build-server-id url)
+(define (process-derivations conn build-server-id url revision-commits)
+ (define derivations
+ (select-derivations-with-no-known-build conn revision-commits))
+
+ (simple-format (current-error-port) "Fetching ~A derivations\n"
+ (length derivations))
(for-each
(match-lambda
((derivation-id derivation-file-name)
@@ -114,7 +125,7 @@
(display "."))
;; Try not to make to many requests at once
(usleep 200)))
- (select-derivations-with-no-known-build conn)))
+ derivations))
(define (json-string->scm* string)
(catch
@@ -128,15 +139,16 @@
#f)))
(define (fetch-build url derivation-file-name)
+ (define build-url
+ (string-append url
+ "build"
+ (string-drop
+ derivation-file-name
+ (string-length "/gnu/store"))))
+
(let-values
(((response body)
- (http-request (string-append
- url
- (string-append
- "build"
- (string-drop
- derivation-file-name
- (string-length "/gnu/store")))))))
+ (http-request build-url)))
(cond
((eq? (response-code response) 200)
@@ -172,18 +184,52 @@ LIMIT 1000")
derivation-file-name)))
(exec-query conn query (list (number->string build-server-id)))))
-(define (select-derivations-with-no-known-build conn)
+(define (select-derivations-with-no-known-build conn 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 derivations.id, derivations.file_name
FROM derivations
WHERE derivations.file_name NOT IN (
SELECT derivation_file_name FROM builds
) AND derivations.id IN (
- SELECT derivation_id FROM package_derivations
-)
-LIMIT 15000")
+ SELECT derivation_id FROM package_derivations"
+ (if (null? revision-commits)
+ "\n"
+ (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) ",")
+ ")"
+ ))
+ ")
+LIMIT 15000"))
(exec-query conn query))
+
+(define (fetch-narinfo-files conn id url revision-commits)
+ (define outputs
+ (select-outputs-for-successful-builds-without-known-nar-entries
+ conn
+ id
+ revision-commits))
+
+ (simple-format #t "Querying ~A outputs\n"
+ (length outputs))
+
+ (let ((narinfos
+ (lookup-narinfos (string-trim-right url #\/) outputs)))
+
+ (simple-format #t "Got ~A narinfo files\n"
+ (length narinfos))
+
+ (unless (eq? (length narinfos) 0)
+ (with-postgresql-transaction
+ conn
+ (lambda (conn)
+ (record-narinfo-details-and-return-ids
+ conn
+ narinfos))))))
diff --git a/scripts/guix-data-service-query-build-servers.in b/scripts/guix-data-service-query-build-servers.in
index 2662c89..aa66a9f 100644
--- a/scripts/guix-data-service-query-build-servers.in
+++ b/scripts/guix-data-service-query-build-servers.in
@@ -26,5 +26,7 @@
(guix-data-service database)
(guix-data-service builds))
-(with-postgresql-connection "query-build-servers"
- query-build-servers)
+(with-postgresql-connection
+ "query-build-servers"
+ (lambda (conn)
+ (query-build-servers conn (cdr (command-line)))))