05/06: Allow only fetching builds for a specific system

[Christopher Baines]

cbaines pushed a commit to branch master
in repository data-service.

commit f485423d5aabfbfb48ccf258d6e6ea6f0404db10
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sun Nov 1 22:49:49 2020 +0000

    Allow only fetching builds for a specific system
---
 guix-data-service/builds.scm                     | 53 +++++++++++++++++++++---
 scripts/guix-data-service-query-build-servers.in |  9 ++++
 2 files changed, 56 insertions(+), 6 deletions(-)

diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm
index 0b0feb9..38c853a 100644
--- a/guix-data-service/builds.scm
+++ b/guix-data-service/builds.scm
@@ -141,7 +141,8 @@ WHERE status IN ('started', 'scheduled')
 (define verbose-output?
   (make-parameter #f))
 
-(define* (query-build-servers conn build-server-ids revision-commits
+(define* (query-build-servers conn build-server-ids systems
+                              revision-commits
                               outputs
                               #:key verbose?)
   (cleanup-bad-build-data conn)
@@ -167,6 +168,7 @@ WHERE status IN ('started', 'scheduled')
                         (query-build-server conn
                                             id
                                             url
+                                            systems
                                             revision-commits
                                             outputs))))
                   (lambda (key . args)
@@ -176,7 +178,7 @@ WHERE status IN ('started', 'scheduled')
                      key args)))))))
          build-servers)))))
 
-(define (query-build-server conn id url revision-commits outputs)
+(define (query-build-server conn id url systems revision-commits outputs)
   (define (fetch-derivation-output-details-set-id output)
     (match (exec-query
             conn
@@ -196,7 +198,7 @@ WHERE derivation_output_details.path = $1"
       (() #f)))
 
   (simple-format #t "\nFetching pending builds\n")
-  (process-pending-builds conn id revision-commits url)
+  (process-pending-builds conn id systems revision-commits url)
   (simple-format #t "\nFetching unseen derivations\n")
   (process-derivation-outputs
    conn id url
@@ -209,6 +211,7 @@ WHERE derivation_output_details.path = $1"
              outputs)
        (select-derivation-outputs-with-no-known-build conn
                                                       id
+                                                      systems
                                                       revision-commits))))
 
 (define* (insert-build-statuses-from-data conn build-server-id build-id data
@@ -267,9 +270,10 @@ WHERE derivation_output_details.path = $1"
                        stoptime)
                    status-string)))))))
 
-(define (process-pending-builds conn build-server-id revision-commits url)
+(define (process-pending-builds conn build-server-id
+                                systems revision-commits url)
   (define pending-builds
-    (select-pending-builds conn build-server-id revision-commits))
+    (select-pending-builds conn build-server-id systems revision-commits))
 
   (simple-format #t "fetching the status of ~A pending builds\n"
                  (length pending-builds))
@@ -494,7 +498,7 @@ WHERE derivation_output_details.path = $1"
         derivation-outputs)
    #:batch-size 100))
 
-(define (select-pending-builds conn build-server-id revision-commits)
+(define (select-pending-builds conn build-server-id systems revision-commits)
   (define query
     (string-append
      "
@@ -525,6 +529,15 @@ WHERE builds.build_server_id = $1 AND
          (string-join (map quote-string revision-commits) ",")
          ")
       )"))
+    (if systems
+        (string-append
+         "
+      AND derivations.system IN ("
+        (string-join
+         (map quote-string systems)
+         ",")
+        ")")
+        "")
     "
 ORDER BY latest_build_status.status DESC, -- 'started' first
          latest_build_status.timestamp ASC
@@ -586,6 +599,7 @@ LIMIT 30000"))
 
 (define (select-derivation-outputs-with-no-known-build conn
                                                        build-server-id
+                                                       systems
                                                        revision-commits)
   (define query
     ;; Only select derivations that are in the package_derivations table, as
@@ -626,6 +640,15 @@ WHERE NOT EXISTS (
   WHERE guix_revisions.commit IN ("
           (string-join (map quote-string revision-commits) ",")
           ")"))
+     (if systems
+         (string-append
+          "
+      AND package_derivations.system IN ("
+          (string-join
+           (map quote-string systems)
+           ",")
+          ")")
+         "")
      "
   UNION ALL
   SELECT derivations_by_output_details_set.derivation_output_details_set_id
@@ -643,6 +666,15 @@ WHERE NOT EXISTS (
   WHERE guix_revisions.commit IN ("
          (string-join (map quote-string revision-commits) ",")
          ")"))
+     (if systems
+         (string-append
+          "
+      AND guix_revision_system_test_derivations.system IN ("
+          (string-join
+           (map quote-string systems)
+           ",")
+          ")")
+         "")
      "
   UNION ALL
   SELECT derivations_by_output_details_set.derivation_output_details_set_id
@@ -660,6 +692,15 @@ WHERE NOT EXISTS (
   WHERE guix_revisions.commit IN ("
          (string-join (map quote-string revision-commits) ",")
          ")"))
+     (if systems
+         (string-append
+          "
+      AND channel_instances.system IN ("
+          (string-join
+           (map quote-string systems)
+           ",")
+          ")")
+         "")
      "
 )
 ORDER BY derivation_output_details_sets.id DESC, derivation_output_details.id
diff --git a/scripts/guix-data-service-query-build-servers.in 
b/scripts/guix-data-service-query-build-servers.in
index 8b87310..ba92a9e 100644
--- a/scripts/guix-data-service-query-build-servers.in
+++ b/scripts/guix-data-service-query-build-servers.in
@@ -36,6 +36,14 @@
                          (or (assoc-ref result 'build-server-ids)
                              '()))
                    (alist-delete 'build-server-ids result))))
+        (option '("system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons
+                   'systems
+                   (cons arg
+                         (or (assoc-ref result 'systems)
+                             '()))
+                   (alist-delete 'systems result))))
         (option '("verbose") #f #f
                 (lambda (opt name _ result)
                   (alist-cons 'verbose #t result)))))
@@ -67,6 +75,7 @@
    (lambda (conn)
      (query-build-servers conn
                           (assq-ref opts 'build-server-ids)
+                          (assq-ref opts 'systems)
                           (assq-ref opts 'revision-commits)
                           (assq-ref opts 'outputs)
                           #:verbose? (assq-ref opts 'verbose)))))