From e68142cf910b7a12b2eadda0c973de4541a47a29 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 24 Feb 2019 15:38:08 +0000
Subject: Add a new page comparing the derivations of two revisions

---
 guix-data-service/comparison.scm     | 10 +++-----
 guix-data-service/web/controller.scm | 37 +++++++++++++++++++++++++++
 guix-data-service/web/view/html.scm  | 49 ++++++++++++++++++++++++++++++++++++
 3 files changed, 89 insertions(+), 7 deletions(-)

diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index bd09d49..3fc6215 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -7,7 +7,7 @@
   #:use-module (guix-data-service model derivation)
   #:export (package-data->package-data-vhashes
             package-differences-data
-            package-data-vhashes->derivations
+            package-data-vhash->derivations
             package-data-vhashes->new-packages
             package-data-vhashes->removed-packages
             package-data-version-changes
@@ -47,9 +47,7 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
                (list vlist-null vlist-null)
                package-data)))
 
-(define (package-data-vhashes->derivations conn
-                                           base-packages-vhash
-                                           target-packages-vhash)
+(define (package-data-vhash->derivations conn packages-vhash)
   (define (vhash->derivation-ids vhash)
     (vhash-fold (lambda (key value result)
                   (cons (third value)
@@ -58,9 +56,7 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
                 vhash))
 
   (let* ((derivation-ids
-          (delete-duplicates
-           (append (vhash->derivation-ids base-packages-vhash)
-                   (vhash->derivation-ids target-packages-vhash))))
+          (vhash->derivation-ids packages-vhash))
          (derivation-data
           (select-derivations-by-id conn derivation-ids)))
     derivation-data))
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 0d6e2e1..5591488 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -100,5 +100,42 @@
                                removed-packages
                                version-changes
                                other-changes)))))))))
+    ((GET "compare" "derivations")
+     (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"))))
+       (let ((base-revision-id (commit->revision-id conn base-commit))
+             (target-revision-id (commit->revision-id conn target-commit)))
+         (cond
+          ((eq? base-revision-id #f)
+           (apply render-html
+                  (compare-unknown-commit base-commit)))
+          ((eq? target-revision-id #f)
+           (apply render-html
+                  (compare-unknown-commit target-commit)))
+          (else
+           (let-values
+               (((base-packages-vhash target-packages-vhash)
+                 (package-data->package-data-vhashes
+                  (package-differences-data conn
+                                            base-revision-id
+                                            target-revision-id))))
+               (apply render-html
+                      (compare/derivations
+                       base-commit
+                       target-commit
+                       (package-data-vhash->derivations
+                        conn
+                        base-packages-vhash)
+                       (package-data-vhash->derivations
+                        conn
+                        target-packages-vhash)))))))))
     ((GET path ...)
      (render-static-asset request))))
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 019aa49..6af3142 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -24,6 +24,7 @@
   #:use-module (srfi srfi-19)
   #:export (index
             compare
+            compare/derivations
             compare-unknown-commit
             error-page))
 
@@ -226,6 +227,54 @@
                        (td ,version))))
                   other-changes)))))))))
 
+(define (compare/derivations base-commit
+                              target-commit
+                              base-derivations
+                              target-derivations)
+  (layout
+   #:extra-headers
+   '((cache-control . ((max-age . 60))))
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (h1 "Comparing "
+          (samp ,(string-take base-commit 8) "…")
+          " and "
+          (samp ,(string-take target-commit 8) "…"))
+      (h3 "Base ("
+          (samp ,base-commit)
+          ")")
+      (p "Derivations found only in the base revision.")
+      (table
+       (@ (class "table"))
+       (thead
+        (tr
+         (th (@ (class "col-md-12")) "File Name")))
+       (tbody
+        ,@(map
+           (match-lambda
+             ((id file-name)
+              `(tr
+                (td ,file-name))))
+           base-derivations)))
+      (h3 "Target ("
+          (samp ,target-commit)
+          ")")
+      (p "Derivations found only in the target revision.")
+      (table
+       (@ (class "table"))
+       (thead
+        (tr
+         (th (@ (class "col-md-12")) "File Name")))
+       (tbody
+        ,@(map
+           (match-lambda
+             ((id file-name)
+              `(tr
+                (td ,file-name))))
+           target-derivations)))))))
+
 (define (compare-unknown-commit commit)
   (layout
    #:body
-- 
cgit v1.2.3