1 files changed, 100 insertions, 0 deletions
diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm
index 86be5a9..90f4968 100644
--- a/guix-data-service/web/compare/html.scm
+++ b/guix-data-service/web/compare/html.scm
@@ -22,6 +22,7 @@
   #:use-module (guix-data-service web query-parameters)
   #:use-module (guix-data-service web view html)
   #:export (compare
+            compare/derivation
             compare/derivations
             compare-by-datetime/derivations
             compare/packages
@@ -232,6 +233,105 @@
                           warnings))))))
             lint-warnings-data))))))))
 
+(define (compare/derivation query-parameters data)
+  (layout
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (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
+        (@ (class "col-md-12"))
+        (div
+         (@ (class "well"))
+         (form
+          (@ (method "get")
+             (action "")
+             (class "form-horizontal"))
+          ,(form-horizontal-control
+            "Base derivation" query-parameters
+            #:required? #t
+            #:help-text "The derivation to use as the basis for the comparison."
+            #:font-family "monospace")
+          ,(form-horizontal-control
+            "Target derivation" query-parameters
+            #:required? #t
+            #:help-text "The derivation to compare against the base commit."
+            #:font-family "monospace")
+          (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 ,(let ((query-parameter-string
+                              (query-parameters->string query-parameters)))
+                         (string-append
+                          "/compare/derivation.json"
+                          (if (string-null? query-parameter-string)
+                              ""
+                              (string-append "?" query-parameter-string))))))
+             "View JSON")))))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (h2 "Outputs")
+        ,@(let ((outputs (assq-ref data 'outputs)))
+            (peek outputs))
+        (h2 "Inputs")
+        ,@(let ((inputs (assq-ref data 'inputs)))
+            `((table
+               (@ (class "table"))
+               (thead
+                (tr
+                 (th "")
+                 (th "Derivation")
+                 (th "Outputs")))
+               (tbody
+                ,@(let ((base-inputs (assq-ref inputs 'base))
+                        (target-inputs (assq-ref inputs 'target))
+                        (common-inputs (assq-ref inputs 'common)))
+                    (append-map
+                     (lambda (label items)
+                       (map
+                        (match-lambda
+                          ((derivation outputs)
+                           `(tr
+                             (td ,label)
+                             (td ,derivation)
+                             (td ,outputs))))
+                        items))
+                     (list "Base" "Target")
+                     (list (assq-ref inputs 'base)
+                           (assq-ref inputs 'target))))))))
+        (h2 "Sources")
+        ,@(let ((sources (assq-ref data 'sources)))
+            sources)
+        (h2 "System")
+        ,@(let ((system (assq-ref data 'system)))
+            system)
+        (h2 "Builder")
+        ,@(let ((builder (assq-ref data 'builder)))
+            builder)
+        (h2 "Arguments")
+        ,@(let ((arguments (assq-ref data 'arguments)))
+            arguments)
+        (h2 "Environment variables")
+        ,(let ((environment-variables (assq-ref data 'environment-variables)))
+           environment-variables)))))))
+
 (define (compare/derivations query-parameters
                              valid-systems
                              valid-build-statuses