02/03: Add JSON representation for the store item page

[Christopher Baines]

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

commit 50d2e4e15844514702eba1c7d19a65061557b002
Author: Danjela Lura <danielaluraa@gmail.com>
AuthorDate: Wed Aug 26 14:03:08 2020 +0200

    Add JSON representation for the store item page
    
    Signed-off-by: Christopher Baines <mail@cbaines.net>
---
 guix-data-service/web/controller.scm | 55 +++++++++++++++++++++++++++++++++++-
 guix-data-service/web/view/html.scm  | 13 +++++++--
 2 files changed, 64 insertions(+), 4 deletions(-)

diff --git a/guix-data-service/web/controller.scm 
b/guix-data-service/web/controller.scm
index 3c47125..683ace1 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -227,6 +227,59 @@
                                 
(select-builds-with-context-by-derivation-output
                                  conn filename)))))))
 
+(define (render-json-store-item conn filename)
+  (let ((derivation (select-derivation-by-output-filename conn filename)))
+    (match derivation
+      (()
+       (match (select-derivation-source-file-by-store-path conn filename)
+         (()
+          (render-json '((error . "store item not found"))))
+         ((id)
+          (render-json
+           `((derivation-source-file
+              . ,(list->vector
+                  (map
+                   (match-lambda
+                     ((key . value)
+                      `((,key . ,value))))
+                   (select-derivation-source-file-nar-details-by-file-name
+                    conn
+                    filename)))))))))
+      (derivations
+       (render-json
+        `((nars . ,(list->vector
+                    (map
+                     (match-lambda
+                       ((_ hash _ urls signatures)
+                        `((hash . ,hash)
+                          (urls
+                           . ,(list->vector
+                               (map
+                                (lambda (url-data)
+                                  `((size . ,(assoc-ref url-data "size"))
+                                    (compression . ,(assoc-ref url-data 
"compression"))
+                                    (url . ,(assoc-ref url-data "url"))))
+                                urls)))
+                          (signatures
+                           . ,(list->vector
+                               (map
+                                (lambda (signature)
+                                  `((version . ,(assoc-ref signature 
"version"))
+                                    (host-name . ,(assoc-ref signature 
"host_name"))))
+                                signatures))))))
+                     (select-nars-for-output conn filename))))
+          (derivations
+           . ,(list->vector
+               (map
+                (match-lambda
+                  ((filename output-id)
+                   `((filename . ,filename)
+                     (derivations-using-store-item
+                      . ,(list->vector
+                          (map car (select-derivations-using-output
+                                    conn output-id)))))))
+                derivations)))))))))
+
 (define handle-static-assets
   (if assets-dir-in-store?
       (static-asset-from-store-renderer)
@@ -388,7 +441,7 @@
      (if (string-suffix? ".drv" filename)
          (render-json-derivation conn
                                  (string-append "/gnu/store/" filename))
-         '()))
+         (render-json-store-item conn (string-append "/gnu/store/" filename))))
     (('GET "build-servers")
      (delegate-to-with-secret-key-base build-server-controller))
     (('GET "dumps" _ ...)
diff --git a/guix-data-service/web/view/html.scm 
b/guix-data-service/web/view/html.scm
index 405babe..4b11f76 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -456,9 +456,16 @@ time."
        (div
         (@ (class "col-sm-12"))
         (h2 "Nars")
-        (a (@ (class "btn btn-default btn-lg pull-right")
-              (href ,(string-append filename "/narinfos")))
-           "View narinfo details")
+        (div
+         (@ (class "btn-group pull-right")
+            (role group))
+         (a (@ (class "btn btn-default btn-lg")
+               (href ,(string-append filename "/narinfos")))
+            "View narinfo details")
+         (a (@ (class "btn btn-lg btn-default")
+               (href ,(string-append filename "/json"))
+               (role "button"))
+            "View JSON"))
         ,@(map
            (match-lambda
              ((hash-algorithm hash size urls signatures)