Improve the compare derivations page

Add support for filtering the results, and add the system and target
to the output.

5 files changed, 254 insertions, 51 deletions

diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index 68cafa8..733d740 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -98,7 +98,9 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
           (select-derivations-by-id conn derivation-ids)))
     derivation-data))
 
-(define (package-data-vhash->derivations-and-build-status conn packages-vhash)
+(define (package-data-vhash->derivations-and-build-status conn packages-vhash
+                                                          systems targets
+                                                          build-statuses)
   (define (vhash->derivation-file-names vhash)
     (vhash-fold (lambda (key value result)
                   (cons (third value)
@@ -109,9 +111,12 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
   (let* ((derivation-file-names
           (vhash->derivation-file-names packages-vhash))
          (derivation-data
-          (select-derivations-and-build-status-by-file-name
+          (select-derivations-and-build-status
            conn
-           derivation-file-names)))
+           #:file-names derivation-file-names
+           #:systems systems
+           #:targets targets
+           #:build-statuses build-statuses)))
     derivation-data))
 
 (define (package-data-vhash->package-name-and-version-vhash vhash)
diff --git a/guix-data-service/model/build-status.scm b/guix-data-service/model/build-status.scm
index d6fde3a..26efde1 100644
--- a/guix-data-service/model/build-status.scm
+++ b/guix-data-service/model/build-status.scm
@@ -1,6 +1,7 @@
 (define-module (guix-data-service model build-status)
   #:use-module (squee)
   #:export (build-statuses
+            build-status-strings
             insert-build-status))
 
 (define build-statuses
@@ -12,6 +13,9 @@
     (3 . "failed-other")
     (4 . "canceled")))
 
+(define build-status-strings
+  (map cdr build-statuses))
+
 (define (insert-build-status conn internal-build-id
                              starttime stoptime status)
   (exec-query conn
diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm
index 3104059..7a710de 100644
--- a/guix-data-service/model/derivation.scm
+++ b/guix-data-service/model/derivation.scm
@@ -8,7 +8,8 @@
   #:use-module (guix memoization)
   #:use-module (guix derivations)
   #:use-module (guix-data-service model utils)
-  #:export (select-derivation-by-file-name
+  #:export (valid-systems
+            select-derivation-by-file-name
             select-derivation-outputs-by-derivation-id
             select-derivation-by-output-filename
             select-derivations-using-output
@@ -16,10 +17,16 @@
             select-derivation-inputs-by-derivation-id
             select-existing-derivations
             select-derivations-by-id
-            select-derivations-and-build-status-by-file-name
+            select-derivations-and-build-status
             insert-into-derivations
             derivation-file-names->derivation-ids))
 
+(define (valid-systems conn)
+  (map car
+       (exec-query
+        conn
+        "SELECT DISTINCT system FROM derivations ORDER BY 1")))
+
 (define (select-existing-derivations file-names)
   (string-append "SELECT id, file_name "
                  "FROM derivations "
@@ -462,11 +469,45 @@ ORDER BY derivations.system DESC,
 
   (exec-query conn query))
 
-(define (select-derivations-and-build-status-by-file-name conn file-names)
+(define* (select-derivations-and-build-status conn #:key
+                                              file-names
+                                              systems
+                                              targets
+                                              build-statuses)
+  (define criteria
+    (string-join
+     (filter-map
+      (lambda (field values)
+        (if (and values (not (null? values)))
+            (string-append
+             field " IN ("
+             (string-join (map (lambda (value)
+                                 (simple-format #f "'~A'" value))
+                               values)
+                          ",")
+             ")")
+            #f))
+      '("derivations.file_name"
+        "derivations.system"
+        "target"
+        "latest_build_status.status")
+      (list file-names
+            systems
+            targets
+            build-statuses))
+     " AND "))
+
   (define query
     (string-append
-     "SELECT derivations.file_name, latest_build_status.status "
+     "SELECT derivations.file_name, derivations.system, ("
+     "  SELECT DISTINCT package_derivations.target"
+     "  FROM package_derivations"
+     "  WHERE derivations.id = package_derivations.derivation_id"
+     ") AS target, "
+     "latest_build_status.status "
      "FROM derivations "
+     "INNER JOIN package_derivations"
+     " ON derivations.id = package_derivations.derivation_id "
      "LEFT OUTER JOIN builds ON derivations.id = builds.derivation_id "
      "LEFT OUTER JOIN "
      "(SELECT DISTINCT ON (internal_build_id) * "
@@ -474,12 +515,7 @@ ORDER BY derivations.system DESC,
      "ORDER BY internal_build_id, status_fetched_at DESC"
      ") AS latest_build_status "
      "ON builds.internal_id = latest_build_status.internal_build_id "
-     "WHERE derivations.file_name IN "
-     "(" (string-join (map (lambda (file-name)
-                             (simple-format #f "'~A'" file-name))
-                           file-names)
-                      ",")
-     ");"))
+     "WHERE " criteria ";"))
 
   (exec-query conn query))
 
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 1b83b02..bf0e127 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -32,6 +32,7 @@
   #:use-module (guix-data-service model package-derivation)
   #:use-module (guix-data-service model package-metadata)
   #:use-module (guix-data-service model derivation)
+  #:use-module (guix-data-service model build-status)
   #:use-module (guix-data-service model build)
   #:use-module (guix-data-service jobs load-new-guix-revision)
   #:use-module (guix-data-service web render)
@@ -57,17 +58,18 @@
   ;;     (render-html (error-page message))))
   )
 
-(define (with-base-and-target-commits request conn f)
-  (let ((base-commit (-> request
-                         request-uri
-                         uri-query
-                         parse-query-string
-                         (cut assoc-ref <> "base_commit")))
-        (target-commit (-> request
-                           request-uri
-                           uri-query
-                           parse-query-string
-                           (cut assoc-ref <> "target_commit"))))
+(define (assoc-ref-multiple alist key)
+  (filter-map
+   (match-lambda
+     ((k . value)
+      (and (string=? k key)
+           value)))
+   alist))
+
+(define (with-base-and-target-commits query-parameters conn f)
+  (let* ((base-commit (assoc-ref query-parameters "base_commit"))
+         (target-commit (assoc-ref query-parameters "target_commit")))
+
     (f base-commit
        (commit->revision-id conn base-commit)
        target-commit
@@ -139,11 +141,16 @@
                                     base-commit
                                     base-revision-id
                                     target-commit
-                                    target-revision-id)
+                                    target-revision-id
+                                    systems
+                                    targets
+                                    build-statuses)
   (define (derivations->alist derivations)
     (map (match-lambda
-           ((file-name buildstatus)
+           ((file-name system target buildstatus)
             `((file_name . ,file-name)
+              (system . ,system)
+              (target . ,target)
               (build_status . ,(if (string=? "")
                                    "unknown"
                                    buildstatus)))))
@@ -158,11 +165,17 @@
     (let ((base-derivations
            (package-data-vhash->derivations-and-build-status
             conn
-            base-packages-vhash))
+            base-packages-vhash
+            systems
+            targets
+            build-statuses))
           (target-derivations
            (package-data-vhash->derivations-and-build-status
             conn
-            target-packages-vhash)))
+            target-packages-vhash
+            systems
+            targets
+            build-statuses)))
       (cond
        ((eq? content-type 'json)
         (render-json
@@ -177,10 +190,15 @@
        (else
         (apply render-html
                (compare/derivations
+                (valid-systems conn)
+                build-status-strings
                 base-commit
                 target-commit
                 base-derivations
-                target-derivations)))))))
+                target-derivations
+                systems
+                targets
+                build-statuses)))))))
 
 (define (render-compare/packages content-type
                                  conn
@@ -260,6 +278,12 @@
                                     derivations)))))))
 
 (define (controller request body conn)
+  (define query-parameters
+    (-> request
+        request-uri
+        uri-query
+        parse-query-string))
+
   (match-lambda
     ((GET)
      (apply render-html (index
@@ -303,7 +327,7 @@
          (render-store-item conn (string-append "/gnu/store/" filename))))
     ((GET "compare")
      (with-base-and-target-commits
-      request conn
+      query-parameters conn
       (lambda (base-commit base-revision-id target-commit target-revision-id)
         (if (not (and base-revision-id target-revision-id))
             (render-compare-unknown-commit 'html
@@ -320,7 +344,7 @@
                             target-revision-id)))))
     ((GET "compare.json")
      (with-base-and-target-commits
-      request conn
+      query-parameters conn
       (lambda (base-commit base-revision-id target-commit target-revision-id)
         (if (not (and base-revision-id target-revision-id))
             (render-compare-unknown-commit 'json
@@ -337,7 +361,7 @@
                             target-revision-id)))))
     ((GET "compare" "derivations")
      (with-base-and-target-commits
-      request conn
+      query-parameters conn
       (lambda (base-commit base-revision-id target-commit target-revision-id)
         (if (not (and base-revision-id target-revision-id))
             (render-compare-unknown-commit 'html
@@ -351,10 +375,16 @@
                                         base-commit
                                         base-revision-id
                                         target-commit
-                                        target-revision-id)))))
+                                        target-revision-id
+                                        (assoc-ref-multiple query-parameters
+                                                            "system")
+                                        (assoc-ref-multiple query-parameters
+                                                            "target")
+                                        (assoc-ref-multiple query-parameters
+                                                            "build_status"))))))
     ((GET "compare" "derivations.json")
      (with-base-and-target-commits
-      request conn
+      query-parameters conn
       (lambda (base-commit base-revision-id target-commit target-revision-id)
         (if (not (and base-revision-id target-revision-id))
             (render-compare-unknown-commit 'json
@@ -368,10 +398,16 @@
                                         base-commit
                                         base-revision-id
                                         target-commit
-                                        target-revision-id)))))
+                                        target-revision-id
+                                        (assoc-ref-multiple query-parameters
+                                                            "system")
+                                        (assoc-ref-multiple query-parameters
+                                                            "target")
+                                        (assoc-ref-multiple query-parameters
+                                                            "build_status"))))))
     ((GET "compare" "packages")
      (with-base-and-target-commits
-      request conn
+      query-parameters conn
       (lambda (base-commit base-revision-id target-commit target-revision-id)
         (if (not (and base-revision-id target-revision-id))
             (render-compare-unknown-commit 'html
@@ -388,7 +424,7 @@
                                      target-revision-id)))))
     ((GET "compare" "packages.json")
      (with-base-and-target-commits
-      request conn
+      query-parameters conn
       (lambda (base-commit base-revision-id target-commit target-revision-id)
         (if (not (and base-revision-id target-revision-id))
             (render-compare-unknown-commit 'json
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 40d5d74..07f5f1a 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -641,11 +641,13 @@
                        (td ,name)
                        (td (ul
                             ,@(map (match-lambda
-                                     ((type . #(version))
+                                     ((type . versions)
                                       `(li (@ (class ,(if (eq? type 'base)
                                                           "text-danger"
                                                           "text-success")))
-                                           ,version
+                                           ,(string-join
+                                             (vector->list versions)
+                                             ", ")
                                            ,(if (eq? type 'base)
                                                 " (old)"
                                                 " (new)"))))
@@ -726,10 +728,15 @@
                              (cdr data-columns))))))
                (vector->list derivation-changes))))))))))
 
-(define (compare/derivations base-commit
+(define (compare/derivations valid-systems
+                             valid-build-statuses
+                             base-commit
                              target-commit
                              base-derivations
-                             target-derivations)
+                             target-derivations
+                             systems
+                             targets
+                             build-statues)
   (define query-params
     (string-append "?base_commit=" base-commit
                    "&target_commit=" target-commit))
@@ -746,11 +753,118 @@
        (h1 "Comparing "
            (samp ,(string-take base-commit 8) "…")
            " and "
-           (samp ,(string-take target-commit 8) "…"))
-       (a (@ (class "btn btn-default btn-lg")
-             (href ,(string-append
-                     "/compare/derivations.json" query-params)))
-          "View JSON"))
+           (samp ,(string-take target-commit 8) "…")))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (div
+         (@ (class "well"))
+         (form
+          (@ (method "get")
+             (action "")
+             (class "form-horizontal"))
+          (div (@ (class "form-group form-group-lg"))
+               (label (@ (for "inputBaseCommit")
+                         (class "col-sm-2 control-label"))
+                      "Base commit")
+               (div (@ (class "col-sm-9"))
+                    (input (@ (class "form-control")
+                              (style "font-family: monospace;")
+                              (id "inputBaseCommit")
+                              (required #t)
+                              (aria-describedby "baseCommitHelp")
+                              (name "base_commit")
+                              (value ,base-commit)))
+                    (span (@ (id "baseCommitHelp")
+                             (class "help-block"))
+                          (strong "Required.")
+                          " The commit to use as the basis for the comparison.")))
+          (div (@ (class "form-group form-group-lg"))
+               (label (@ (for "inputTargetCommit")
+                         (class "col-sm-2 control-label"))
+                      "Target commit")
+               (div (@ (class "col-sm-9"))
+                    (input (@ (class "form-control")
+                              (style "font-family: monospace;")
+                              (id "inputTargetCommit")
+                              (required #t)
+                              (aria-describedby "targetCommitHelp")
+                              (name "target_commit")
+                              (value ,target-commit)))
+                    (span (@ (id "targetCommitHelp")
+                             (class "help-block"))
+                          (strong "Required.")
+                          " The commit to compare against the base commit.")))
+          (div (@ (class "form-group form-group-lg"))
+               (label (@ (for "inputSystem")
+                         (class "col-sm-2 control-label"))
+                      "System")
+               (div (@ (class "col-sm-9"))
+                    (select (@ (class "form-control")
+                               (style "font-family: monospace;")
+                               (multiple #t)
+                               (id "inputSystem")
+                               (aria-describedby "systemHelp")
+                               (name "system"))
+                      ,@(map (lambda (system)
+                               `(option (@ ,@(if (member system systems)
+                                                 '((selected ""))
+                                                 '()))
+                                        ,system))
+                             valid-systems))
+                    (span (@ (id "systemHelp")
+                             (class "help-block"))
+                          "Only include derivations for this system.")))
+          (div (@ (class "form-group form-group-lg"))
+               (label (@ (for "inputTarget")
+                         (class "col-sm-2 control-label"))
+                      "Target")
+               (div (@ (class "col-sm-9"))
+                    (select (@ (class "form-control")
+                               (style "font-family: monospace;")
+                               (multiple #t)
+                               (id "inputTarget")
+                               (aria-describedby "targetHelp")
+                               (name "target"))
+                      ,@(map (lambda (system)
+                               `(option (@ ,@(if (member system targets)
+                                                 '((selected ""))
+                                                 '()))
+                                        ,system))
+                             valid-systems))
+                    (span (@ (id "targetHelp")
+                             (class "help-block"))
+                          "Only include derivations that are build for this system.")))
+          (div (@ (class "form-group form-group-lg"))
+               (label (@ (for "inputBuildStatus")
+                         (class "col-sm-2 control-label"))
+                      "Build status")
+               (div (@ (class "col-sm-9"))
+                    (select (@ (class "form-control")
+                               (id "inputBuildStatus")
+                               (aria-describedby "buildStatusHelp")
+                               (multiple #t)
+                               (name "build_status"))
+                      ,@(map (lambda (build-status)
+                               `(option (@ ,@(if (member build-status build-statues)
+                                                 '((selected ""))
+                                                 '())
+                                           (value ,build-status))
+                                        ,(build-status-value->display-string build-status)))
+                             valid-build-statuses))
+                    (span (@ (id "buildStatusHelp")
+                             (class "help-block"))
+                          "Only include derivations which have this build status.")))
+          (div (@ (class "form-group form-group-lg"))
+               (div (@ (class "col-sm-offset-2 col-sm-10"))
+                    (button (@ (type "submit")
+                               (class "btn btn-lg btn-primary"))
+                            "Update results")))
+          (a (@ (class "btn btn-default btn-lg pull-right")
+                (href ,(string-append
+                        "/compare/derivations.json" query-params)))
+             "View JSON")))))
       (div
        (@ (class "row"))
        (h3 "Base ("
@@ -761,15 +875,19 @@
         (@ (class "table"))
         (thead
          (tr
-          (th (@ (class "col-md-8")) "File Name")
+          (th (@ (class "col-md-6")) "File Name")
+          (th (@ (class "col-md-2")) "System")
+          (th (@ (class "col-md-2")) "Target")
           (th (@ (class "col-md-4")) "Build status")))
         (tbody
          ,@(map
             (match-lambda
-              ((file-name build-status)
+              ((file-name system target build-status)
                `(tr
                  (td (a (@ (href ,file-name))
-                        ,(display-store-item file-name)))
+                        ,(display-store-item-short file-name)))
+                 (td (samp ,system))
+                 (td (samp ,target))
                  (td ,(build-status-span build-status)))))
             base-derivations))))
       (div
@@ -783,14 +901,18 @@
         (thead
          (tr
           (th (@ (class "col-md-8")) "File Name")
+          (th (@ (class "col-md-2")) "System")
+          (th (@ (class "col-md-2")) "Target")
           (th (@ (class "col-md-4")) "Build status")))
         (tbody
          ,@(map
             (match-lambda
-              ((file-name build-status)
+              ((file-name system target build-status)
                `(tr
                  (td (a (@ (href ,file-name))
-                        ,(display-store-item file-name)))
+                        ,(display-store-item-short file-name)))
+                 (td (samp ,system))
+                 (td (samp ,target))
                  (td ,(build-status-span build-status)))))
             target-derivations))))))))