From e31f370de0601c69269fadd52708886bff5accce Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Thu, 14 Nov 2019 20:57:21 +0000
Subject: Add a basic derivation comparison page

---
 guix-data-service/comparison.scm             | 217 +++++++++++++++++++++++-
 guix-data-service/web/compare/controller.scm |  52 ++++++
 guix-data-service/web/compare/html.scm       | 245 +++++++++++++++++++++++++++
 guix-data-service/web/view/html.scm          |   1 +
 4 files changed, 514 insertions(+), 1 deletion(-)

diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index 9aa8863..9931358 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -4,8 +4,11 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (squee)
+  #:use-module (guix-data-service model utils)
   #:use-module (guix-data-service model derivation)
-  #:export (package-data->package-data-vhashes
+  #:export (derivation-differences-data
+
+            package-data->package-data-vhashes
             package-differences-data
             package-data-vhash->derivations
             package-data->names-and-versions
@@ -17,6 +20,218 @@
 
             lint-warning-differences-data))
 
+(define (group-to-alist process lst)
+  (fold (lambda (element result)
+          (match (process element)
+            ((key . value)
+             (match (assoc key result)
+               ((_ . existing-values)
+                `((,key . ,(cons value existing-values))
+                  ,@result))
+               (#f
+                `((,key . (,value))
+                  ,@result))))))
+        '()
+        lst))
+
+(define (derivation-differences-data conn
+                                     base-derivation-file-name
+                                     target-derivation-file-name)
+  (define base-derivation
+    (select-derivation-by-file-name conn base-derivation-file-name))
+
+  (define target-derivation
+    (select-derivation-by-file-name conn target-derivation-file-name))
+
+  (define group-by-last-element
+    (lambda (vals)
+      (let ((groups (last vals)))
+        (cons (if (eq? (length groups) 2)
+                  'common
+                  (first groups))
+              (drop-right vals 1)))))
+
+  (define (fetch-value alist key)
+    (assq-ref (find (lambda (env-var)
+                      (if (string=? key (assq-ref env-var 'key))
+                          (assq-ref env-var 'value)
+                          #f))
+                    alist)
+              'value))
+
+  `((outputs
+     . ,(group-to-alist
+         group-by-last-element
+         (derivation-outputs-differences-data conn
+                                              (first base-derivation)
+                                              (first target-derivation))))
+    (inputs
+     . ,(group-to-alist
+         group-by-last-element
+         (derivation-inputs-differences-data conn
+                                             (first base-derivation)
+                                             (first target-derivation))))
+    (sources
+     . ,(group-to-alist
+         group-by-last-element
+         (derivation-sources-differences-data conn
+                                              (first base-derivation)
+                                              (first target-derivation))))
+    ,@(match base-derivation
+        ((_ _ base-builder base-args base-env-vars base-system)
+         (match target-derivation
+           ((_ _ target-builder target-args target-env-vars target-system)
+            `((system
+               . ,(if (string=? base-system target-system)
+                      `((common . ,base-system))
+                      `((base . ,base-system)
+                        (target . ,target-system))))
+              (builder
+               . ,(if (string=? base-builder target-builder)
+                      `((common . ,base-builder))
+                      `((base . ,base-builder)
+                        (target . ,target-builder))))
+              (arguments
+               . ,(if (eq? base-args target-args)
+                      `((common . ,base-args))
+                      `((base . ,base-args)
+                        (target . ,target-args))))
+              (environment-variables
+               . ,(map (lambda (key)
+                         (let ((base-value (fetch-value base-env-vars key))
+                               (target-value (fetch-value target-env-vars key)))
+                           (if (and base-value target-value)
+                               `(,key
+                                 . ,(if (string=? base-value target-value)
+                                        `((common . ,base-value))
+                                        `((base . ,base-value)
+                                          (target . ,target-value))))
+                               (if base-value
+                                   `(,key . ((base . ,base-value)))
+                                   `(,key . ((target . ,target-value)))))))
+                       (delete-duplicates
+                        (map (lambda (env-var)
+                               (assq-ref env-var 'key))
+                             (append base-env-vars
+                                     target-env-vars))
+                        string=?))))))))))
+
+(define (derivation-outputs-differences-data conn
+                                             base-derivation-id
+                                             target-derivation-id)
+  (define query
+    (string-append
+     "
+SELECT derivation_outputs.name,
+       derivation_output_details.path,
+       derivation_output_details.hash_algorithm,
+       derivation_output_details.hash,
+       derivation_output_details.recursive,
+       ARRAY_AGG(derivation_outputs.derivation_id) AS derivation_ids
+FROM derivation_outputs
+INNER JOIN derivation_output_details
+  ON derivation_output_details_id = derivation_output_details.id
+WHERE derivation_outputs.derivation_id IN ("
+     (simple-format #f "~A,~A"
+                    base-derivation-id
+                    target-derivation-id) "
+)
+GROUP BY 1, 2, 3, 4, 5"))
+
+  (map (match-lambda
+         ((output-name path hash-algorithm hash recursive
+                       derivation_ids)
+          (let ((parsed-derivation-ids
+                 (map string->number
+                      (parse-postgresql-array-string derivation_ids))))
+            (list output-name
+                  path
+                  hash-algorithm
+                  hash
+                  recursive
+                  (append (if (memq base-derivation-id
+                                    parsed-derivation-ids)
+                              '(base)
+                              '())
+                          (if (memq target-derivation-id
+                                    parsed-derivation-ids)
+                              '(target)
+                              '()))))))
+       (exec-query conn query)))
+
+(define (derivation-inputs-differences-data conn
+                                            base-derivation-id
+                                            target-derivation-id)
+  (define query
+    (string-append
+     "
+SELECT derivations.file_name,
+       derivation_outputs.name,
+       relevant_derivation_inputs.derivation_ids
+FROM derivation_outputs
+INNER JOIN (
+  SELECT derivation_output_id,
+         ARRAY_AGG(derivation_id) AS derivation_ids
+  FROM derivation_inputs
+  WHERE derivation_id IN (" (simple-format #f "~A,~A"
+                                           base-derivation-id
+                                           target-derivation-id)
+  ") GROUP BY derivation_output_id
+) AS relevant_derivation_inputs
+  ON derivation_outputs.id = relevant_derivation_inputs.derivation_output_id
+INNER JOIN derivations ON derivation_outputs.derivation_id = derivations.id
+"))
+
+  (map (match-lambda
+         ((derivation_file_name derivation_output_name
+                                derivation_ids)
+          (let ((parsed-derivation-ids
+                 (map string->number
+                      (parse-postgresql-array-string derivation_ids))))
+          (list derivation_file_name
+                derivation_output_name
+                (append (if (memq base-derivation-id
+                                  parsed-derivation-ids)
+                            '(base)
+                            '())
+                        (if (memq target-derivation-id
+                                  parsed-derivation-ids)
+                            '(target)
+                            '()))))))
+       (exec-query conn query)))
+
+(define (derivation-sources-differences-data conn
+                                             base-derivation-id
+                                             target-derivation-id)
+  (define query
+    (string-append
+     "
+SELECT derivation_source_files.store_path, ARRAY_AGG(derivation_sources.derivation_id)
+FROM derivation_source_files
+INNER JOIN derivation_sources
+  ON derivation_source_files.id = derivation_sources.derivation_source_file_id
+WHERE derivation_sources.derivation_id IN (" (simple-format #f "~A,~A"
+                                                            base-derivation-id
+                                                            target-derivation-id)
+")
+GROUP BY derivation_source_files.store_path"))
+
+  (map (match-lambda
+         ((store_path derivation_ids)
+          (let ((parsed-derivation-ids
+                 (map string->number
+                      (parse-postgresql-array-string derivation_ids))))
+            (list store_path
+                  (append (if (memq base-derivation-id
+                                    parsed-derivation-ids)
+                              '(base)
+                              '())
+                          (if (memq target-derivation-id
+                                    parsed-derivation-ids)
+                              '(target)
+                              '()))))))
+       (exec-query conn query)))
+
 (define* (package-differences-data conn
                                    base_guix_revision_id
                                    target_guix_revision_id
diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm
index 381d25b..16dcf39 100644
--- a/guix-data-service/web/compare/controller.scm
+++ b/guix-data-service/web/compare/controller.scm
@@ -53,6 +53,13 @@
         (make-invalid-query-parameter
          s "unknown commit"))))
 
+(define (parse-derivation conn)
+  (lambda (file-name)
+    (if (select-derivation-by-file-name conn file-name)
+        file-name
+        (make-invalid-query-parameter
+         file-name "unknown derivation"))))
+
 (define (compare-controller request
                             method-and-path-components
                             mime-types
@@ -79,6 +86,15 @@
        (render-compare-by-datetime mime-types
                                    conn
                                    parsed-query-parameters)))
+    (('GET "compare" "derivation")
+     (let* ((parsed-query-parameters
+             (parse-query-parameters
+              request
+              `((base_derivation   ,(parse-derivation conn) #:required)
+                (target_derivation ,(parse-derivation conn) #:required)))))
+       (render-compare/derivation mime-types
+                                  conn
+                                  parsed-query-parameters)))
     (('GET "compare" "derivations")
      (let* ((parsed-query-parameters
              (parse-query-parameters
@@ -287,6 +303,42 @@
                                   lint-warnings-data)
                   #:extra-headers http-headers-for-unchanging-content)))))))))
 
+(define (render-compare/derivation mime-types
+                                   conn
+                                   query-parameters)
+  (if (any-invalid-query-parameters? query-parameters)
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          '((error . "invalid query"))))
+        (else
+         (render-html
+          #:sxml (compare/derivation
+                  query-parameters
+                  '()))))
+
+      (let ((base-derivation    (assq-ref query-parameters 'base_derivation))
+            (target-derivation  (assq-ref query-parameters 'target_derivation)))
+        (let ((data
+               (derivation-differences-data conn
+                                            base-derivation
+                                            target-derivation)))
+          (case (most-appropriate-mime-type
+                 '(application/json text/html)
+                 mime-types)
+            ((application/json)
+             (render-json
+              '((error . "unimplemented")) ; TODO
+              #:extra-headers http-headers-for-unchanging-content))
+            (else
+             (render-html
+              #:sxml (compare/derivation
+                      query-parameters
+                      data)
+              #:extra-headers http-headers-for-unchanging-content)))))))
+
 (define (render-compare/derivations mime-types
                                     conn
                                     query-parameters)
diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm
index afb103d..92e76ff 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,250 @@
                           warnings))))))
             lint-warnings-data))))))))
 
+(define (compare/derivation query-parameters data)
+  (define base
+    '(span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
+              (style "font-size: 1.5em; padding-right: 0.4em;"))))
+
+  (define target
+    '(span (@ (class "text-success glyphicon glyphicon-plus pull-left")
+              (style "font-size: 1.5em; padding-right: 0.4em;"))))
+
+  (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)))
+            `((table
+               (@ (class "table"))
+               (thead
+                (tr
+                 (th "")
+                 (th "Name")
+                 (th "Path")
+                 (th "Hash algorithm")
+                 (th "Hash")
+                 (th "Recursive")))
+               (tbody
+                ,@(let ((base-outputs (assq-ref outputs 'base))
+                        (target-outputs (assq-ref outputs 'target))
+                        (common-outputs (assq-ref outputs 'common)))
+                    (append-map
+                     (lambda (label items)
+                       (map
+                        (match-lambda
+                          ((name path hash-algorithm hash recursive)
+                           `(tr
+                             (td ,label)
+                             (td ,name)
+                             (td (a (@ (href ,path))
+                                    ,(display-store-item path)))
+                             (td ,hash-algorithm)
+                             (td ,hash)
+                             (td ,recursive))))
+                        (or items '())))
+                     (list base target "Common")
+                     (list (assq-ref outputs 'base)
+                           (assq-ref outputs 'target)
+                           (assq-ref outputs 'common))))))))
+        (h2 "Inputs")
+        ,@(let ((inputs (assq-ref data 'inputs)))
+            `((table
+               (@ (class "table"))
+               (thead
+                (tr
+                 (th "")
+                 (th "Derivation")
+                 (th "Outputs")))
+               (tbody
+                ,@(append-map
+                   (lambda (label items)
+                     (map
+                      (match-lambda
+                        ((derivation outputs)
+                         `(tr
+                           (td ,label)
+                           (td (a (@ (href ,derivation))
+                                  ,(display-store-item derivation)))
+                           (td ,outputs))))
+                      (or items '())))
+                   (list base target)
+                   (list (assq-ref inputs 'base)
+                         (assq-ref inputs 'target)))))))
+        (p "Common inputs are omitted.")
+        (h2 "Sources")
+        ,@(let ((sources (assq-ref data 'sources)))
+            `((table
+               (@ (class "table"))
+               (thead
+                (tr
+                 (th "")
+                 (th "Derivation")))
+               (tbody
+                ,@(append-map
+                   (lambda (label items)
+                     (map
+                      (match-lambda
+                        ((file)
+                         `(tr
+                           (td ,label)
+                           (td (a (@ (href ,file))
+                                  ,(display-store-item file))))))
+                      (or items '())))
+                   (list base target "Common")
+                   (list (assq-ref sources 'base)
+                         (assq-ref sources 'target)
+                         (assq-ref sources 'common)))))))
+        (h2 "System")
+        ,@(let ((system (assq-ref data 'system)))
+            (let ((common-system (assq-ref system 'common)))
+              (if common-system
+                  (list common-system)
+                  `(table
+                    (@ (class "table"))
+                    (thead
+                     (tr
+                      (th "")
+                      (th "System")))
+                    (tbody
+                     ,@(let ((base-system (assq-ref system 'base))
+                             (target-system (assq-ref system 'target)))
+                         `((tr
+                            (td ,base)
+                            (td ,base-system))
+                           (tr
+                            (td ,target)
+                            (td ,target-system)))))))))
+        (h2 "Builder and arguments")
+        ,(let ((builder (assq-ref data 'builder))
+               (arguments (assq-ref data 'arguments)))
+           (let ((common-builder (assq-ref builder 'common))
+                 (common-args (assq-ref arguments 'common)))
+             (if (and common-builder
+                      common-args)
+                 `(table
+                   (@ (class "table"))
+                   (thead
+                    (th "Builder")
+                    (th "Arguments"))
+                   (tbody
+                    (tr
+                     (td ,common-builder)
+                     (td (ol
+                          ,@(map (lambda (arg)
+                                   `(li ,arg))
+                                 common-args))))))
+                 `(table
+                   (@ (class "table"))
+                   (thead
+                    (tr
+                     (th "")
+                     (th "Builder")
+                     (th "Arguments")))
+                   (tbody
+                    ,@(let ((base-builder (assq-ref builder 'base))
+                            (target-builder (assq-ref builder 'target))
+                            (base-args (assq-ref arguments 'base))
+                            (target-args (assq-ref arguments 'target)))
+                        `((tr
+                           (td ,base)
+                           (td ,(or base-builder
+                                    common-builder))
+                           (td (ol
+                                ,@(map (lambda (arg)
+                                         `(li ,arg))
+                                       (or common-args
+                                           base-args)))))
+                          (tr
+                           (td ,target)
+                           (td ,(or target-builder
+                                    common-builder))
+                           (td (ol
+                                ,@(map (lambda (arg)
+                                         `(li ,arg))
+                                       (or common-args
+                                           target-args))))))))))))
+        (h2 "Environment variables")
+        ,(let ((environment-variables (assq-ref data 'environment-variables)))
+           `(table
+             (@ (class "table"))
+             (thead
+              (th "Name"))
+             (tbody
+              ,@(append-map
+                 (match-lambda
+                   ((name . values)
+                    (let ((common-value (assq-ref values 'common)))
+                      (if common-value
+                          `((tr
+                             (td ,name)
+                             (td ,common-value)))
+                          (let ((base-value (assq-ref values 'base))
+                                (target-value (assq-ref values 'target)))
+                            (if (and base-value target-value)
+                                `((tr
+                                   (td (@ (rowspan 2))
+                                       ,name)
+                                   (td ,base ,base-value))
+                                  (tr
+                                   (td ,target ,target-value)))
+                                `((tr
+                                   (td ,name)
+                                   (td ,@(if base-value
+                                             (list base base-value)
+                                             (list target target-value)))))))))))
+                 environment-variables))))))))))
+
 (define (compare/derivations query-parameters
                              valid-systems
                              valid-build-statuses
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index b403890..9381b2b 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -32,6 +32,7 @@
             header
             form-horizontal-control
 
+            display-store-item
             display-store-item-short
             build-status-span
 
-- 
cgit v1.2.3