From efbbac50990daa29432440979e83a736b13a42bf Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 11 Oct 2020 16:53:29 +0100
Subject: [PATCH] Add a very rough JSON output for the package derivation
 outputs page

---
 guix-data-service/web/revision/controller.scm | 45 ++++++++++++++++++-
 guix-data-service/web/revision/html.scm       | 13 ++++++
 2 files changed, 57 insertions(+), 1 deletion(-)

diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm
index d5049e0..f6fef86 100644
--- a/guix-data-service/web/revision/controller.scm
+++ b/guix-data-service/web/revision/controller.scm
@@ -1113,7 +1113,50 @@
                    mime-types)
               ((application/json)
                (render-json
-                `()))
+                `((store_paths
+                   . ,(list->vector
+                       (map (match-lambda
+                              ((path hash-algorithm hash recursive
+                                     nars)
+                               `((path . ,path)
+                                 (data
+                                  . ,(if (null? hash-algorithm)
+                                         (list->vector
+                                          (map
+                                           (match-lambda
+                                             ((hash . nars)
+                                              `((hash . ,hash)
+                                                (nars . ,(list->vector nars)))))
+                                           (group-to-alist
+                                            (lambda (nar)
+                                              (cons (assoc-ref nar "hash")
+                                                    nar))
+                                            (vector->list nars))))
+                                         hash))
+                                 (output_consistency
+                                  . ,(let* ((hashes
+                                             (delete-duplicates
+                                              (map (lambda (nar)
+                                                     (assoc-ref nar "hash"))
+                                                   (vector->list nars))))
+                                            (build-servers
+                                             (delete-duplicates
+                                              (map (lambda (nar)
+                                                     (assoc-ref nar "build_server_id"))
+                                                   (vector->list nars))))
+                                            (hash-count
+                                             (length hashes))
+                                            (build-server-count
+                                             (length build-servers)))
+                                       (cond
+                                        ((or (eq? hash-count 0)
+                                             (eq? build-server-count 1))
+                                         "unknown")
+                                        ((eq? hash-count 1)
+                                         "matching")
+                                        ((> hash-count 1)
+                                         "not-matching")))))))
+                            derivation-outputs))))))
               (else
                (letpar& ((systems
                           (with-thread-postgresql-connection valid-systems))
diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm
index 77a3e13..bb0e72c 100644
--- a/guix-data-service/web/revision/html.scm
+++ b/guix-data-service/web/revision/html.scm
@@ -1756,6 +1756,19 @@ figure {
                     (button (@ (type "submit")
                                (class "btn btn-lg btn-primary"))
                             "Update results")))))))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (a (@ (class "btn btn-default btn-lg pull-right")
+              (href ,(let ((query-parameter-string
+                            (query-parameters->string query-parameters)))
+                       (string-append
+                        path-base ".json"
+                        (if (string-null? query-parameter-string)
+                            ""
+                            (string-append "?" query-parameter-string))))))
+           "View JSON")))
       (div
        (@ (class "row"))
        (div