Add a lookup_builds field to the build_servers table

This is to allow for build servers where only the substitutes should be
queried, and it shouldn't be assumed that they're running Cuirass.

12 files changed, 55 insertions, 39 deletions

diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm
index 2c37885..c3421b9 100644
--- a/guix-data-service/builds.scm
+++ b/guix-data-service/builds.scm
@@ -135,11 +135,11 @@ initial connection on which HTTP requests are sent."
       (let ((build-servers (select-build-servers conn)))
         (for-each
          (match-lambda
-           ((id url lookup-all-derivations?)
+           ((id url lookup-all-derivations? lookup-builds?)
             (when (or (or (not build-servers)
                           (not build-server-ids))
                       (member id build-server-ids))
-              (when lookup-all-derivations?
+              (when lookup-builds?
                 (simple-format #t "\nQuerying ~A\n" url)
                 (catch #t
                   (lambda ()
diff --git a/guix-data-service/model/build-server.scm b/guix-data-service/model/build-server.scm
index 44b4b7d..a03410d 100644
--- a/guix-data-service/model/build-server.scm
+++ b/guix-data-service/model/build-server.scm
@@ -19,21 +19,23 @@
   #:use-module (ice-9 match)
   #:use-module (squee)
   #:export (select-build-servers
-            select-build-server))
+            select-build-server
+            select-build-server-urls-by-id))
 
 (define (select-build-servers conn)
   (define query
     "
-SELECT id, url, lookup_all_derivations
+SELECT id, url, lookup_all_derivations, lookup_builds
 FROM build_servers
 ORDER BY id")
 
   (map
    (match-lambda
-     ((id url lookup-all-derivations)
+     ((id url lookup-all-derivations lookup-builds)
       (list (string->number id)
             url
-            (string=? lookup-all-derivations "t"))))
+            (string=? lookup-all-derivations "t")
+            (string=? lookup-builds))))
    (exec-query conn query)))
 
 (define (select-build-server conn id)
@@ -46,6 +48,13 @@ WHERE id = $1")
   (match (exec-query conn query (list (number->string id)))
     (()
      #f)
-    (((url lookup_all_derivations))
+    (((url lookup_all_derivations lookup_builds))
      (list url
-           (string=? lookup_all_derivations "t")))))
+           (string=? lookup_all_derivations "t")
+           (string=? lookup_builds "t")))))
+
+(define (select-build-server-urls-by-id conn)
+  (map (match-lambda
+         ((id url lookup-all-derivations? lookup-builds?)
+          (cons id url)))
+       (select-build-servers conn)))
diff --git a/guix-data-service/substitutes.scm b/guix-data-service/substitutes.scm
index 6dd069e..b6c29f2 100644
--- a/guix-data-service/substitutes.scm
+++ b/guix-data-service/substitutes.scm
@@ -35,7 +35,7 @@
       (let ((build-servers (select-build-servers conn)))
         (for-each
          (match-lambda
-           ((id url lookup-all-derivations?)
+           ((id url lookup-all-derivations? lookup-builds?)
             (when (or (or (not build-servers)
                           (not build-server-ids))
                       (member id build-server-ids))
diff --git a/guix-data-service/web/build-server/html.scm b/guix-data-service/web/build-server/html.scm
index bb15e11..319ab79 100644
--- a/guix-data-service/web/build-server/html.scm
+++ b/guix-data-service/web/build-server/html.scm
@@ -103,7 +103,7 @@
         (h2 "Build servers")
         ,@(map
            (match-lambda
-             ((id url lookup-all-derivations?)
+             ((id url lookup-all-derivations? lookup-builds?)
               `(dl
                 (@ (class "dl-horizontal"))
                 (dt "URL")
@@ -112,6 +112,10 @@
                 (dt "Lookup all " (br) "derivations?")
                 (dd ,(if lookup-all-derivations?
                          "Yes"
+                         "No"))
+                (dt "Lookup " (br) "builds?")
+                (dd ,(if lookup-builds?
+                         "Yes"
                          "No")))))
            build-servers)))))))
 
diff --git a/guix-data-service/web/build/controller.scm b/guix-data-service/web/build/controller.scm
index e7d1399..a79d558 100644
--- a/guix-data-service/web/build/controller.scm
+++ b/guix-data-service/web/build/controller.scm
@@ -38,7 +38,7 @@
   (lambda (v)
     (let ((build-servers (select-build-servers conn)))
       (or (any (match-lambda
-                 ((id url lookup-all-derivations?)
+                 ((id url lookup-all-derivations? lookup-builds?)
                   (if (eq? (string->number v)
                            id)
                       id
diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm
index 88739d5..0f8a5e7 100644
--- a/guix-data-service/web/repository/controller.scm
+++ b/guix-data-service/web/repository/controller.scm
@@ -295,11 +295,7 @@
                                             target
                                             package-name))
            (build-server-urls
-           (group-to-alist
-            (match-lambda
-              ((id url lookup-all-derivations)
-               (cons id url)))
-            (select-build-servers conn))))
+            (select-build-server-urls-by-id conn)))
       (case (most-appropriate-mime-type
              '(application/json text/html)
              mime-types)
@@ -364,11 +360,7 @@
                                         package-name
                                         output-name))
            (build-server-urls
-            (group-to-alist
-             (match-lambda
-               ((id url lookup-all-derivations)
-                (cons id url)))
-             (select-build-servers conn))))
+            (select-build-server-urls-by-id conn)))
       (case (most-appropriate-mime-type
              '(application/json text/html)
              mime-types)
diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm
index 0dc6eb4..f5ed8f0 100644
--- a/guix-data-service/web/revision/controller.scm
+++ b/guix-data-service/web/revision/controller.scm
@@ -77,7 +77,7 @@
   (lambda (v)
     (let ((build-servers (select-build-servers conn)))
       (or (any (match-lambda
-                 ((id url lookup-all-derivations?)
+                 ((id url lookup-all-derivations? lookup-builds?)
                   (if (eq? (string->number v)
                            id)
                       id
@@ -454,11 +454,7 @@
   (let ((substitute-availability
          (select-package-output-availability-for-revision conn commit-hash))
         (build-server-urls
-         (group-to-alist
-          (match-lambda
-            ((id url lookup-all-derivations)
-             (cons id url)))
-          (select-build-servers conn))))
+         (select-build-server-urls-by-id conn)))
     (case (most-appropriate-mime-type
            '(application/json text/html)
            mime-types)
@@ -796,11 +792,7 @@
                    #:after-name (assq-ref query-parameters 'after_name)
                    #:include-builds? (member "builds" fields))))
              (build-server-urls
-              (group-to-alist
-               (match-lambda
-                 ((id url lookup-all-derivations)
-                  (cons id url)))
-               (select-build-servers conn)))
+              (select-build-server-urls-by-id conn))
              (show-next-page?
               (if all-results
                   #f
@@ -898,11 +890,7 @@
                #:limit-results limit-results
                #:after-path (assq-ref query-parameters 'after_path)))
              (build-server-urls
-              (group-to-alist
-               (match-lambda
-                 ((id url lookup-all-derivations)
-                  (cons id url)))
-               (select-build-servers conn)))
+              (select-build-server-urls-by-id conn))
              (show-next-page?
               (if all-results
                   #f
@@ -960,7 +948,8 @@
                                       (valid-targets->options
                                        (valid-targets conn))
                                       (map (match-lambda
-                                             ((id url lookup-all-derivations)
+                                             ((id url lookup-all-derivations
+                                                  lookup-builds)
                                               (cons url id)))
                                            (select-build-servers conn))
                                       (select-build-stats
diff --git a/scripts/guix-data-service-manage-build-servers.in b/scripts/guix-data-service-manage-build-servers.in
index b994e2b..0ca1706 100644
--- a/scripts/guix-data-service-manage-build-servers.in
+++ b/scripts/guix-data-service-manage-build-servers.in
@@ -54,7 +54,7 @@
    (lambda (conn)
      (for-each
       (match-lambda
-        ((id url lookup-all-derivations?)
+        ((id url lookup-all-derivations? lookup-builds?)
          (simple-format #t "\nBuild server: ~A (id: ~A)\n"
                         url
                         id)
diff --git a/sqitch/deploy/build_servers_lookup_builds.sql b/sqitch/deploy/build_servers_lookup_builds.sql
new file mode 100644
index 0000000..dc16602
--- /dev/null
+++ b/sqitch/deploy/build_servers_lookup_builds.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-data-service:build_servers_lookup_builds to pg
+
+BEGIN;
+
+ALTER TABLE build_servers ADD COLUMN lookup_builds boolean NOT NULL DEFAULT TRUE;
+
+COMMIT;
diff --git a/sqitch/revert/build_servers_lookup_builds.sql b/sqitch/revert/build_servers_lookup_builds.sql
new file mode 100644
index 0000000..62f55a1
--- /dev/null
+++ b/sqitch/revert/build_servers_lookup_builds.sql
@@ -0,0 +1,7 @@
+-- Revert guix-data-service:build_servers_lookup_builds from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index ab6ce17..6e73371 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -57,3 +57,4 @@ drop_package_versions_by_guix_revision_range 2020-03-24T20:40:38Z Christopher Ba
 create_narinfo_fetch_records_index 2020-03-25T19:07:28Z Christopher Baines <mail@cbaines.net> # Create an index on narinfo_fetch_records
 load_new_guix_revision_jobs_make_commits_unique 2020-03-27T21:38:42Z Christopher Baines <mail@cbaines.net> # Make load_new_guix_revision_jobs commits unique
 remove_odd_package_derivations 2020-04-24T20:36:06Z Christopher Baines <mail@cbaines.net> # Remove odd package derivations
+build_servers_lookup_builds 2020-05-24T15:18:09Z Christopher Baines <mail@cbaines.net> # Add build_servers.lookup_builds
diff --git a/sqitch/verify/build_servers_lookup_builds.sql b/sqitch/verify/build_servers_lookup_builds.sql
new file mode 100644
index 0000000..7db4be7
--- /dev/null
+++ b/sqitch/verify/build_servers_lookup_builds.sql
@@ -0,0 +1,7 @@
+-- Verify guix-data-service:build_servers_lookup_builds on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;