01/02: Add a very rough JSON output for the package derivation outputs page

[Christopher Baines]

cbaines pushed a commit to branch master
in repository data-service.

commit efbbac50990daa29432440979e83a736b13a42bf
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sun Oct 11 16:53:29 2020 +0100

    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
@@ -1759,6 +1759,19 @@ figure {
       (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
         (@ (class "col-md-12"))
         (h1 "Package derivation outputs")
         (p "Showing " ,(length derivation-outputs) " results")