From 2836a848cbf06ff881c6959f466fa2d451e37e43 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 25 Feb 2019 23:44:32 +0000
Subject: [PATCH] Add a packages comparison page

The primary use I have in mind for this is producing a list of strings
suitable for building a limited Cuirass job with.
---
 guix-data-service/web/controller.scm | 69 ++++++++++++++++++++++++++++
 guix-data-service/web/view/html.scm  | 54 ++++++++++++++++++++++
 2 files changed, 123 insertions(+)

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 6052a97..7db795d 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -18,6 +18,7 @@
 
 (define-module (guix-data-service web controller)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:use-module (ice-9 pretty-print)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -163,6 +164,40 @@
               base-derivations
               target-derivations)))))))
 
+(define (render-compare/packages content-type
+                                 conn
+                                 base-commit
+                                 base-revision-id
+                                 target-commit
+                                 target-revision-id)
+  (define (package-data-vhash->json vh)
+    (vhash-fold (lambda (name data result)
+                  (cons (string-append name "@" (car data))
+                        result))
+                '()
+                vh))
+
+  (let-values
+      (((base-packages-vhash target-packages-vhash)
+        (package-data->package-data-vhashes
+         (package-differences-data conn
+                                   base-revision-id
+                                   target-revision-id))))
+    (cond
+     ((eq? content-type 'json)
+      (render-json
+       `((base . ((commit . ,base-commit)
+                  (packages . ,(package-data-vhash->json base-packages-vhash))))
+         (target . ((commit . ,target-commit)
+                    (packages . ,(package-data-vhash->json target-packages-vhash)))))))
+     (else
+      (apply render-html
+             (compare/packages
+              base-commit
+              target-commit
+              base-packages-vhash
+              target-packages-vhash))))))
+
 (define (controller request body conn)
   (match-lambda
     ((GET)
@@ -235,5 +270,39 @@
                                         base-revision-id
                                         target-commit
                                         target-revision-id)))))
+    ((GET "compare" "packages")
+     (with-base-and-target-commits
+      request 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/packages 'html
+                                     conn
+                                     base-commit
+                                     base-revision-id
+                                     target-commit
+                                     target-revision-id)))))
+    ((GET "compare" "packages.json")
+     (with-base-and-target-commits
+      request 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/packages 'json
+                                     conn
+                                     base-commit
+                                     base-revision-id
+                                     target-commit
+                                     target-revision-id)))))
     ((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 4615640..09089b3 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -19,12 +19,14 @@
 
 (define-module (guix-data-service web view html)
   #:use-module (guix-data-service config)
+  #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:export (index
             compare
             compare/derivations
+            compare/packages
             compare-unknown-commit
             error-page))
 
@@ -275,6 +277,58 @@
                 (td ,file-name))))
            target-derivations)))))))
 
+(define (compare/packages base-commit
+                          target-commit
+                          base-packages-vhash
+                          target-packages-vhash)
+  (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 "Packages found in the base revision.")
+      (table
+       (@ (class "table"))
+       (thead
+        (tr
+         (th (@ (class "col-md-6")) "Name")
+         (th (@ (class "col-md-6")) "Version")))
+       (tbody
+        ,@(map
+           (match-lambda
+             ((name version rest ...)
+              `(tr
+                (td ,name)
+                (td ,version))))
+           (vlist->list base-packages-vhash))))
+      (h3 "Target ("
+          (samp ,target-commit)
+          ")")
+      (p "Packages found in the target revision.")
+      (table
+       (@ (class "table"))
+       (thead
+        (tr
+         (th (@ (class "col-md-6")) "Name")
+         (th (@ (class "col-md-6")) "Version")))
+       (tbody
+        ,@(map
+           (match-lambda
+             ((name version rest ...)
+              `(tr
+                (td ,name)
+                (td ,version))))
+           (vlist->list target-packages-vhash))))))))
+
 (define (compare-unknown-commit base-commit target-commit
                                 base-exists? target-exists?
                                 base-job target-job)