branch master updated: Support more query parameters on the /builds page

[Christopher Baines]

This is an automated email from the git hooks/post-receive script.

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

The following commit(s) were added to refs/heads/master by this push:
     new f2d98b6  Support more query parameters on the /builds page
f2d98b6 is described below

commit f2d98b626d25fae71b558e79915507c60ee84109
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Mon Feb 8 21:31:39 2021 +0000

    Support more query parameters on the /builds page
---
 guix-data-service/model/build.scm          | 128 ++++++++++++++++-------------
 guix-data-service/web/build/controller.scm |  88 ++++++++++++--------
 guix-data-service/web/build/html.scm       |  21 +++++
 3 files changed, 146 insertions(+), 91 deletions(-)

diff --git a/guix-data-service/model/build.scm 
b/guix-data-service/model/build.scm
index b2ac79f..d0a75b1 100644
--- a/guix-data-service/model/build.scm
+++ b/guix-data-service/model/build.scm
@@ -16,6 +16,8 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (guix-data-service model build)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (ice-9 match)
   #:use-module (squee)
   #:use-module (json)
@@ -46,13 +48,13 @@
               ")"))
             '())
       ,@(if revision-commit
-            '("guix_revisions.commit = $1")
+            `(("guix_revisions.commit = $" . ,revision-commit))
             '())
       ,@(if system
-            '("package_derivations.system = $2")
+            `(("package_derivations.system = $" . ,system))
             '())
       ,@(if target
-            '("package_derivations.target = $3")
+            `(("package_derivations.target = $" . ,target))
             '())))
 
   (define query
@@ -60,15 +62,17 @@
      "
 SELECT latest_build_status.status AS build_status, build_servers.id, COUNT(*)
 FROM derivation_output_details_sets
-CROSS JOIN build_servers
-"
-     (if revision-commit
+CROSS JOIN build_servers"
+     (if (or revision-commit system target)
          "
 INNER JOIN derivations_by_output_details_set
   ON derivation_output_details_sets.id =
      derivations_by_output_details_set.derivation_output_details_set_id
 INNER JOIN package_derivations
-  ON derivations_by_output_details_set.derivation_id = 
package_derivations.derivation_id
+  ON derivations_by_output_details_set.derivation_id = 
package_derivations.derivation_id"
+         "")
+     (if revision-commit
+         "
 INNER JOIN guix_revision_package_derivations
   ON guix_revision_package_derivations.package_derivation_id = 
package_derivations.id
 INNER JOIN guix_revisions
@@ -86,7 +90,14 @@ LEFT JOIN latest_build_status
          ""
          (string-append
           "WHERE "
-          (string-join criteria " AND ")))
+          (string-join (let-values (((with-parameters without-parameters)
+                                     (partition pair? criteria)))
+                         (append (map (lambda (s index)
+                                        (string-append s (number->string 
index)))
+                                      (map car with-parameters)
+                                      (iota (length with-parameters) 1))
+                                 without-parameters))
+                       " AND ")))
      "
 GROUP BY latest_build_status.status, build_servers.id
 ORDER BY status"))
@@ -103,42 +114,40 @@ ORDER BY status"))
         1
         (exec-query conn
                     query
-                    `(,@(if revision-commit
-                            (list revision-commit)
-                            '())
-                      ,@(if system
-                            (list system)
-                            '())
-                      ,@(if target
-                            (list target)
-                            '()))))))
+                    (map (match-lambda
+                           ((sql . value) value))
+                         (filter pair? criteria))))))
 
 (define* (select-builds-with-context conn build-statuses build-server-ids
                                      #:key revision-commit
                                      system target
                                      limit)
   (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)
-                      ", ")
-         ")"))
-      (when revision-commit
-        "guix_revisions.commit = $1")
-      (when system
-        "package_derivations.system = $2")
-      (when target
-        "package_derivations.target = $3"))))
+    `(,@(if (list? build-statuses)
+            (list
+             (string-append
+              "latest_build_status.status IN ("
+              (string-join (map quote-string build-statuses)
+                           ",")
+              ")"))
+            '())
+      ,@(if (list? build-server-ids)
+            (list
+             (string-append
+              "builds.build_server_id IN ("
+              (string-join (map number->string build-server-ids)
+                           ", ")
+              ")"))
+            '())
+      ,@(if revision-commit
+            `(("guix_revisions.commit = $" . ,revision-commit))
+            '())
+      ,@(if system
+            `(("package_derivations.system = $" . ,system))
+            '())
+      ,@(if target
+            `(("package_derivations.target = $" . ,target))
+            '())))
 
   (define query
     (string-append
@@ -148,15 +157,17 @@ SELECT builds.id, build_servers.url,
        latest_build_status.timestamp, latest_build_status.status
 FROM builds
 INNER JOIN build_servers ON build_servers.id = builds.build_server_id
-INNER JOIN derivations ON derivations.file_name = builds.derivation_file_name
-"
-     (if revision-commit
+INNER JOIN derivations ON derivations.file_name = builds.derivation_file_name"
+     (if (or revision-commit system target)
          "
 INNER JOIN derivations_by_output_details_set
   ON builds.derivation_output_details_set_id =
      derivations_by_output_details_set.derivation_output_details_set_id
 INNER JOIN package_derivations
-  ON derivations_by_output_details_set.derivation_id = 
package_derivations.derivation_id
+  ON derivations_by_output_details_set.derivation_id = 
package_derivations.derivation_id"
+         "")
+     (if revision-commit
+         "
 INNER JOIN guix_revision_package_derivations
   ON guix_revision_package_derivations.package_derivation_id = 
package_derivations.id
 INNER JOIN guix_revisions
@@ -164,13 +175,20 @@ INNER JOIN guix_revisions
          "")
      "
 INNER JOIN latest_build_status
-  ON latest_build_status.build_id = builds.id
-"
-                   (if (null? where-conditions)
-                       ""
-                       (string-append
-                        "WHERE "
-                        (string-join where-conditions " AND ")))
+  ON latest_build_status.build_id = builds.id"
+     (if (null? where-conditions)
+         ""
+         (string-append
+          "
+WHERE "
+          (string-join (let-values (((with-parameters without-parameters)
+                                     (partition pair? where-conditions)))
+                         (append (map (lambda (s index)
+                                        (string-append s (number->string 
index)))
+                                      (map car with-parameters)
+                                      (iota (length with-parameters) 1))
+                                 without-parameters))
+                       " AND ")))
                    "
 ORDER BY latest_build_status.timestamp DESC NULLS LAST, derivations.file_name
 "
@@ -181,15 +199,9 @@ ORDER BY latest_build_status.timestamp DESC NULLS LAST, 
derivations.file_name
 
   (exec-query-with-null-handling conn
                                  query
-                                 `(,@(if revision-commit
-                                         (list revision-commit)
-                                         '())
-                                   ,@(if system
-                                         (list system)
-                                         '())
-                                   ,@(if target
-                                         (list target)
-                                         '()))))
+                                 (map (match-lambda
+                                        ((sql . value) value))
+                                      (filter pair? where-conditions))))
 
 (define (select-builds-with-context-by-derivation-file-name
          conn derivation-file-name)
diff --git a/guix-data-service/web/build/controller.scm 
b/guix-data-service/web/build/controller.scm
index 731ba11..a70e10d 100644
--- a/guix-data-service/web/build/controller.scm
+++ b/guix-data-service/web/build/controller.scm
@@ -25,6 +25,7 @@
   #: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 model derivation)
   #:use-module (guix-data-service web build html)
   #:export (build-controller))
 
@@ -66,44 +67,65 @@
   (let ((parsed-query-parameters
          (parse-query-parameters
           request
-          `((build_status ,parse-build-status #:multi-value)
-            (build_server ,parse-build-server #:multi-value)))))
+          `((build_status  ,parse-build-status #:multi-value)
+            (build_server  ,parse-build-server #:multi-value)
+            (system        ,parse-system #:default "x86_64-linux")
+            (target        ,parse-target #:default "")
+            (limit_results ,parse-result-limit
+                           #:no-default-when (all_results)
+                           #:default 50)
+            (all_results   ,parse-checkbox-value)))))
     (if (any-invalid-query-parameters? parsed-query-parameters)
         (render-html
          #:sxml (view-builds parsed-query-parameters
                              build-status-strings
                              '()
                              '()
+                             '()
+                             '()
                              '()))
-        (letpar& ((build-server-options
-                   (with-thread-postgresql-connection
-                    (lambda (conn)
-                      (map (match-lambda
-                             ((id url lookup-all-derivations
-                                  lookup-builds)
-                              (cons url id)))
-                           (select-build-servers conn)))))
-                  (build-stats
-                   (with-thread-postgresql-connection
-                    (lambda (conn)
-                      (select-build-stats
-                       conn
-                       (assq-ref parsed-query-parameters
-                                 'build_server)))))
-                  (builds-with-context
-                   (with-thread-postgresql-connection
-                    (lambda (conn)
-                      (select-builds-with-context
-                       conn
-                       (assq-ref parsed-query-parameters
-                                 'build_status)
-                       (assq-ref parsed-query-parameters
-                                 'build_server)
-                       #:limit 50)))))
+        (let ((system (assq-ref parsed-query-parameters 'system))
+              (target (assq-ref parsed-query-parameters 'target)))
+          (letpar& ((build-server-options
+                     (with-thread-postgresql-connection
+                      (lambda (conn)
+                        (map (match-lambda
+                               ((id url lookup-all-derivations
+                                    lookup-builds)
+                                (cons url id)))
+                             (select-build-servers conn)))))
+                    (build-stats
+                     (with-thread-postgresql-connection
+                      (lambda (conn)
+                        (select-build-stats
+                         conn
+                         (assq-ref parsed-query-parameters
+                                   'build_server)
+                         #:system system
+                         #:target target))))
+                    (builds-with-context
+                     (with-thread-postgresql-connection
+                      (lambda (conn)
+                        (select-builds-with-context
+                         conn
+                         (assq-ref parsed-query-parameters
+                                   'build_status)
+                         (assq-ref parsed-query-parameters
+                                   'build_server)
+                         #:system system
+                         #:target target
+                         #:limit (assq-ref parsed-query-parameters
+                                           'limit_results)))))
+                    (systems
+                     (with-thread-postgresql-connection valid-systems))
+                    (targets
+                     (with-thread-postgresql-connection valid-targets)))
 
-          (render-html
-           #:sxml (view-builds parsed-query-parameters
-                               build-status-strings
-                               build-server-options
-                               build-stats
-                               builds-with-context))))))
+            (render-html
+             #:sxml (view-builds parsed-query-parameters
+                                 build-status-strings
+                                 build-server-options
+                                 systems
+                                 (valid-targets->options targets)
+                                 build-stats
+                                 builds-with-context)))))))
diff --git a/guix-data-service/web/build/html.scm 
b/guix-data-service/web/build/html.scm
index 461f44a..18d045a 100644
--- a/guix-data-service/web/build/html.scm
+++ b/guix-data-service/web/build/html.scm
@@ -25,6 +25,8 @@
 (define (view-builds query-parameters
                      build-status-strings
                      build-server-options
+                     valid-systems
+                     valid-targets
                      stats
                      builds)
   (layout
@@ -82,6 +84,25 @@
             query-parameters
             #:options build-server-options
             #:help-text "Return builds from these build servers.")
+          ,(form-horizontal-control
+            "System" query-parameters
+            #:options valid-systems
+            #:allow-selecting-multiple-options #f
+            #:help-text "Only include derivations for this system."
+            #:font-family "monospace")
+          ,(form-horizontal-control
+            "Target" query-parameters
+            #:options valid-targets
+            #:allow-selecting-multiple-options #f
+            #:help-text "Only include derivations that are build for this 
system."
+            #:font-family "monospace")
+          ,(form-horizontal-control
+            "Limit results" query-parameters
+            #:help-text "The maximum number of results to return.")
+          ,(form-horizontal-control
+            "All results" query-parameters
+            #:type "checkbox"
+            #:help-text "Return all results")
           (div (@ (class "form-group form-group-lg"))
                (div (@ (class "col-sm-offset-2 col-sm-10"))
                     (button (@ (type "submit")