Update the derivation comparison implementation

This adds more query parameter validation, and uses form-horizontal-control to
neaten up the view code.

2 files changed, 134 insertions, 217 deletions

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 94b8b5e..afe98cb 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -141,13 +141,7 @@
 
 (define (render-compare/derivations content-type
                                     conn
-                                    base-commit
-                                    base-revision-id
-                                    target-commit
-                                    target-revision-id
-                                    systems
-                                    targets
-                                    build-statuses)
+                                    query-parameters)
   (define (derivations->alist derivations)
     (map (match-lambda
            ((file-name system target buildstatus)
@@ -159,49 +153,64 @@
                                    buildstatus)))))
          derivations))
 
-  (let-values
-      (((base-packages-vhash target-packages-vhash)
-        (package-data->package-data-vhashes
-         (package-differences-data conn
-                                   base-revision-id
-                                   target-revision-id))))
-    (let ((base-derivations
-           (package-data-vhash->derivations-and-build-status
-            conn
-            base-packages-vhash
-            systems
-            targets
-            build-statuses))
-          (target-derivations
-           (package-data-vhash->derivations-and-build-status
-            conn
-            target-packages-vhash
-            systems
-            targets
-            build-statuses)))
+  (if (any-invalid-query-parameters? query-parameters)
       (cond
        ((eq? content-type 'json)
         (render-json
-         `((base . ((commit . ,base-commit)
-                    (derivations . ,(list->vector
-                                     (derivations->alist
-                                      base-derivations)))))
-           (target . ((commit . ,target-commit)
-                      (derivations . ,(list->vector
-                                       (derivations->alist
-                                        target-derivations))))))))
+         '((error . "invalid query"))))
        (else
         (apply render-html
                (compare/derivations
+                query-parameters
                 (valid-systems conn)
                 build-status-strings
-                base-commit
-                target-commit
-                base-derivations
-                target-derivations
-                systems
-                targets
-                build-statuses)))))))
+                '()
+                '()))))
+
+      (let ((base-commit    (assq-ref query-parameters 'base_commit))
+            (target-commit  (assq-ref query-parameters 'target_commit))
+            (systems        (assq-ref query-parameters 'system))
+            (targets        (assq-ref query-parameters 'target))
+            (build-statuses (assq-ref query-parameters 'build_status)))
+        (let-values
+            (((base-packages-vhash target-packages-vhash)
+              (package-data->package-data-vhashes
+               (package-differences-data conn
+                                         (commit->revision-id conn base-commit)
+                                         (commit->revision-id conn target-commit)))))
+          (let ((base-derivations
+                 (package-data-vhash->derivations-and-build-status
+                  conn
+                  base-packages-vhash
+                  systems
+                  targets
+                  build-statuses))
+                (target-derivations
+                 (package-data-vhash->derivations-and-build-status
+                  conn
+                  target-packages-vhash
+                  systems
+                  targets
+                  build-statuses)))
+            (cond
+             ((eq? content-type 'json)
+              (render-json
+               `((base . ((commit . ,base-commit)
+                          (derivations . ,(list->vector
+                                           (derivations->alist
+                                            base-derivations)))))
+                 (target . ((commit . ,target-commit)
+                            (derivations . ,(list->vector
+                                             (derivations->alist
+                                              target-derivations))))))))
+             (else
+              (apply render-html
+                     (compare/derivations
+                      query-parameters
+                      (valid-systems conn)
+                      build-status-strings
+                      base-derivations
+                      target-derivations)))))))))
 
 (define (render-compare/packages content-type
                                  conn
@@ -280,6 +289,19 @@
                                           conn output-id))))
                                     derivations)))))))
 
+(define (parse-commit conn)
+  (lambda (s)
+    (if (guix-commit-exists? conn s)
+        s
+        (make-invalid-query-parameter
+         s "unknown commit"))))
+
+(define (parse-system s)
+  s)
+
+(define (parse-build-status s)
+  s)
+
 (define (controller request body conn)
   (define query-parameters
     (-> request
@@ -408,51 +430,29 @@
                             target-commit
                             target-revision-id)))))
     ((GET "compare" "derivations")
-     (with-base-and-target-commits
-      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
-                                           conn
-                                           base-commit
-                                           base-revision-id
-                                           target-commit
-                                           target-revision-id)
-            (render-compare/derivations 'html
-                                        conn
-                                        base-commit
-                                        base-revision-id
-                                        target-commit
-                                        target-revision-id
-                                        (assoc-ref-multiple query-parameters
-                                                            "system")
-                                        (assoc-ref-multiple query-parameters
-                                                            "target")
-                                        (assoc-ref-multiple query-parameters
-                                                            "build_status"))))))
+     (let* ((parsed-query-parameters
+             (parse-query-parameters
+              request
+              `((base_commit   ,(parse-commit conn) #:required)
+                (target_commit ,(parse-commit conn) #:required)
+                (system        ,parse-system #:multi-value)
+                (target        ,parse-system #:multi-value)
+                (build_status  ,parse-build-status #:multi-value)))))
+       (render-compare/derivations 'html
+                                   conn
+                                   parsed-query-parameters)))
     ((GET "compare" "derivations.json")
-     (with-base-and-target-commits
-      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
-                                           conn
-                                           base-commit
-                                           base-revision-id
-                                           target-commit
-                                           target-revision-id)
-            (render-compare/derivations 'json
-                                        conn
-                                        base-commit
-                                        base-revision-id
-                                        target-commit
-                                        target-revision-id
-                                        (assoc-ref-multiple query-parameters
-                                                            "system")
-                                        (assoc-ref-multiple query-parameters
-                                                            "target")
-                                        (assoc-ref-multiple query-parameters
-                                                            "build_status"))))))
+     (let* ((parsed-query-parameters
+             (parse-query-parameters
+              request
+              `((base_commit   ,(parse-commit conn) #:required)
+                (target_commit ,(parse-commit conn) #:required)
+                (system        ,parse-system #:multi-value)
+                (target        ,parse-system #:multi-value)
+                (build_status  ,parse-build-status #:multi-value)))))
+       (render-compare/derivations 'json
+                                   conn
+                                   parsed-query-parameters)))
     ((GET "compare" "packages")
      (with-base-and-target-commits
       query-parameters conn
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index b966853..d7b5725 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -1005,35 +1005,11 @@
                               (cdr data-columns))))))
                 (vector->list derivation-changes)))))))))))
 
-(define (compare/derivations valid-systems
+(define (compare/derivations query-parameters
+                             valid-systems
                              valid-build-statuses
-                             base-commit
-                             target-commit
                              base-derivations
-                             target-derivations
-                             systems
-                             targets
-                             build-statuses)
-  (define query-params
-    (string-append
-     "?"
-     (string-join
-      `(,(string-append "base_commit=" base-commit)
-        ,(string-append "target_commit=" target-commit)
-        ,@(map (lambda (system)
-                 (string-append
-                  "system=" system))
-               systems)
-        ,@(map (lambda (target)
-                 (string-append
-                  "target=" target))
-               targets)
-        ,@(map (lambda (build_status)
-                 (string-append
-                  "build_status=" build_status))
-               build-statuses))
-      "&")))
-
+                             target-derivations)
   (layout
    #:extra-headers
    '((cache-control . ((max-age . 60))))
@@ -1043,10 +1019,14 @@
       (@ (class "container"))
       (div
        (@ (class "row"))
-       (h1 "Comparing "
-           (samp ,(string-take base-commit 8) "…")
-           " and "
-           (samp ,(string-take target-commit 8) "…")))
+       (h1 ,@(let ((base-commit (assq-ref query-parameters 'base_commit))
+                   (target-commit (assq-ref query-parameters 'target_commit)))
+               (if (every string? (list base-commit target-commit))
+                   `("Comparing "
+                     (samp ,(string-take base-commit 8) "…")
+                     " and "
+                     (samp ,(string-take target-commit 8) "…"))
+                   '("Comparing derivations")))))
       (div
        (@ (class "row"))
        (div
@@ -1057,114 +1037,49 @@
           (@ (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-statuses)
-                                                 '((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.")))
+          ,(form-horizontal-control
+            "Base commit" query-parameters
+            #:required? #t
+            #:help-text "The commit to use as the basis for the comparison.")
+          ,(form-horizontal-control
+            "Target commit" query-parameters
+            #:required? #t
+            #:help-text "The commit to compare against the base commit.")
+          ,(form-horizontal-control
+            "System" query-parameters
+            #:options valid-systems
+            #:help-text "Only include derivations for this system.")
+          ,(form-horizontal-control
+            "Target" query-parameters
+            #:options valid-systems
+            #:help-text "Only include derivations that are build for this system.")
+          ,(form-horizontal-control
+            "Build status" query-parameters
+            #:options valid-build-statuses
+            #:help-text "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)))
+                (href ,(let ((query-parameter-string
+                              (query-parameters->string query-parameters)))
+                         (string-append
+                          "/compare/derivations.json"
+                          (if (string-null? query-parameter-string)
+                              ""
+                              (string-append "?" query-parameter-string))))))
              "View JSON")))))
       (div
        (@ (class "row"))
        (div
         (@ (class "col-sm-12"))
-        (h3 "Base ("
-            (samp ,base-commit)
-            ")")
+        (h3 "Base"
+            ,@(let ((base-commit (assq-ref query-parameters 'base_commit)))
+                (if (string? base-commit)
+                    `(" (" (samp ,base-commit) ")")
+                    '())))
         (p "Derivations found only in the base revision.")
         (table
          (@ (class "table"))
@@ -1189,9 +1104,11 @@
        (@ (class "row"))
        (div
         (@ (class "col-sm-12"))
-        (h3 "Target ("
-            (samp ,target-commit)
-            ")")
+        (h3 "Target"
+            ,@(let ((target-commit (assq-ref query-parameters 'target_commit)))
+                (if (string? target-commit)
+                    `(" (" (samp ,target-commit) ")")
+                    '())))
         (p "Derivations found only in the target revision.")
         (table
          (@ (class "table"))