Support querying builds by build servers

3 files changed, 60 insertions, 12 deletions

diff --git a/guix-data-service/model/build.scm b/guix-data-service/model/build.scm
index ef6b167..79da81b 100644
--- a/guix-data-service/model/build.scm
+++ b/guix-data-service/model/build.scm
@@ -28,7 +28,24 @@ ORDER BY status")
 
   (exec-query conn query))
 
-(define (select-builds-with-context conn build-statuses)
+(define (select-builds-with-context conn build-statuses build-server-ids)
+  (define where-conditions
+    (filter
+     string?
+     (list
+      (when (list? build-statuses)
+        (string-append
+         "latest_build_status.status IN ("
+         (string-join (map quote-string build-statuses)
+                      ",")
+         ")"))
+      (when (list? build-server-ids)
+        (string-append
+         "builds.build_server_id IN ("
+         (string-join (map number->string build-server-ids)
+                      ", ")
+         ")")))))
+
   (define query
     (string-append "
 SELECT builds.id, build_servers.url, derivations.file_name,
@@ -44,14 +61,12 @@ INNER JOIN
 ) AS latest_build_status
 ON latest_build_status.build_id = builds.id
 "
-    (if (list? build-statuses)
-        (string-append
-         "WHERE latest_build_status.status IN ("
-         (string-join (map quote-string build-statuses)
-                      ",")
-         ")")
-        "")
-    "
+                   (if (null? where-conditions)
+                       ""
+                       (string-append
+                        "WHERE "
+                        (string-join where-conditions " AND ")))
+                   "
 ORDER BY latest_build_status.timestamp DESC
 LIMIT 100"))
 
diff --git a/guix-data-service/web/build/controller.scm b/guix-data-service/web/build/controller.scm
index df08e3c..afa8de9 100644
--- a/guix-data-service/web/build/controller.scm
+++ b/guix-data-service/web/build/controller.scm
@@ -16,11 +16,13 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (guix-data-service web build controller)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:use-module (guix-data-service web render)
   #:use-module (guix-data-service web query-parameters)
   #:use-module (guix-data-service model build)
   #:use-module (guix-data-service model build-status)
+  #:use-module (guix-data-service model build-server)
   #:use-module (guix-data-service web build html)
   #:export (build-controller))
 
@@ -32,6 +34,20 @@
        (string-append "unknown build status: "
                       status))))
 
+(define (parse-build-server conn)
+  (lambda (v)
+    (let ((build-servers (select-build-servers conn)))
+      (or (any (match-lambda
+                 ((id url lookup-all-derivations?)
+                  (if (eq? (string->number v)
+                           id)
+                      id
+                      #f)))
+               build-servers)
+          (make-invalid-query-parameter
+           v
+           "unknown build server")))))
+
 (define (build-controller request
                           method-and-path-components
                           mime-types
@@ -48,18 +64,26 @@
   (let ((parsed-query-parameters
          (parse-query-parameters
           request
-          `((build_status ,parse-build-status #:multi-value)))))
+          `((build_status ,parse-build-status #:multi-value)
+            (build_server ,(parse-build-server conn) #:multi-value)))))
     (if (any-invalid-query-parameters? parsed-query-parameters)
         (render-html
          #:sxml (view-builds parsed-query-parameters
                              build-status-strings
                              '()
+                             '()
                              '()))
         (render-html
          #:sxml (view-builds parsed-query-parameters
                              build-status-strings
+                             (map (match-lambda
+                                    ((id url lookup-all-derivations)
+                                     (cons url id)))
+                                  (select-build-servers conn))
                              (select-build-stats conn)
                              (select-builds-with-context
                               conn
                               (assq-ref parsed-query-parameters
-                                        'build_status)))))))
+                                        'build_status)
+                              (assq-ref parsed-query-parameters
+                                        'build_server)))))))
diff --git a/guix-data-service/web/build/html.scm b/guix-data-service/web/build/html.scm
index 65c4e66..679cda6 100644
--- a/guix-data-service/web/build/html.scm
+++ b/guix-data-service/web/build/html.scm
@@ -21,7 +21,11 @@
   #:use-module (guix-data-service web view html)
   #:export (view-builds))
 
-(define (view-builds query-parameters build-status-strings stats builds)
+(define (view-builds query-parameters
+                     build-status-strings
+                     build-server-options
+                     stats
+                     builds)
   (layout
    #:body
    `(,(header)
@@ -64,6 +68,11 @@
                          build-status))
                  build-status-strings)
             #:help-text "Return builds with these statuses.")
+          ,(form-horizontal-control
+            "Build server"
+            query-parameters
+            #:options build-server-options
+            #:help-text "Return builds from these build servers.")
           (div (@ (class "form-group form-group-lg"))
                (div (@ (class "col-sm-offset-2 col-sm-10"))
                     (button (@ (type "submit")