WIP add a new page for the narinfos associated with an output

3 files changed, 130 insertions, 0 deletions

diff --git a/guix-data-service/model/nar.scm b/guix-data-service/model/nar.scm
index d511658..92c4d11 100644
--- a/guix-data-service/model/nar.scm
+++ b/guix-data-service/model/nar.scm
@@ -10,6 +10,7 @@
   #:use-module (guix scripts substitute)
   #:use-module (guix-data-service model utils)
   #:export (select-outputs-for-successful-builds-without-known-nar-entries
+            select-nars-for-output
             select-signing-key
 
             record-narinfo-details-and-return-ids))
@@ -247,6 +248,55 @@ LIMIT 1500"))
   (map car (exec-query conn query (list (number->string
                                          build-server-id)))))
 
+(define (select-nars-for-output conn output-file-name)
+  (define query
+    "
+SELECT hash_algorithm, hash, size,
+       (
+         SELECT JSON_AGG(
+           json_build_object('url', url, 'compression', compression, 'size', file_size)
+         )
+         FROM nar_urls
+         WHERE nar_id = nars.id
+       ) AS urls,
+       (
+         SELECT JSON_AGG(
+           json_build_object(
+             'version', version,
+             'host_name', host_name,
+             'data_hash', data_hash,
+             'data_hash_algorithm', data_hash_algorithm,
+             'data', data_json,
+             'sig_val', sig_val_json,
+             'narinfo_signature_public_key', (
+               SELECT sexp_json
+               FROM narinfo_signature_public_keys
+               WHERE narinfo_signature_public_keys.id = narinfo_signature_public_key_id
+             ),
+             'body', narinfo_body,
+             'signature_line', narinfo_signature_line
+           )
+         )
+         FROM narinfo_signature_data
+         INNER JOIN narinfo_signatures
+           ON narinfo_signature_data.id = narinfo_signatures.narinfo_signature_data_id
+         WHERE narinfo_signatures.nar_id = nars.id
+       )
+FROM nars
+WHERE store_path = $1")
+
+  (map
+   (match-lambda
+     ((hash-algorithm hash size urls-json signatures-json)
+      (list hash-algorithm
+            hash
+            (string->number size)
+            (vector->list
+             (json-string->scm urls-json))
+            (vector->list
+             (json-string->scm signatures-json)))))
+   (exec-query conn query (list output-file-name))))
+
 (define (select-signing-key conn id)
   (define query
     "
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 638c870..433e34c 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -38,6 +38,7 @@
   #:use-module (guix-data-service model git-branch)
   #:use-module (guix-data-service model git-repository)
   #:use-module (guix-data-service model guix-revision)
+  #:use-module (guix-data-service model nar)
   #:use-module (guix-data-service model package)
   #:use-module (guix-data-service model package-derivation)
   #:use-module (guix-data-service model package-metadata)
@@ -148,6 +149,20 @@
                  "No derivation found with this file name.")
          #:code 404))))
 
+(define (render-narinfos conn filename)
+  (let ((narinfos (select-nars-for-output
+                   conn
+                   (string-append "/gnu/store/" filename))))
+    (if (null? narinfos)
+        (render-html
+         #:sxml (general-not-found
+                 "No nars found"
+                 "No nars found for this output name.")
+         #:code 404)
+
+        (render-html
+         #:sxml (view-narinfos narinfos)))))
+
 (define (render-store-item conn filename)
   (let ((derivation (select-derivation-by-output-filename conn filename)))
     (match derivation
@@ -290,6 +305,8 @@
          (render-formatted-derivation conn
                                       (string-append "/gnu/store/" filename))
          (not-found (request-uri request))))
+    (('GET "gnu" "store" filename "narinfos")
+     (render-narinfos conn filename))
     (((or 'GET 'POST) "build-server" _ ...)
      (delegate-to-with-secret-key-base build-server-controller))
     (('GET "compare" _ ...)             (delegate-to compare-controller))
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 2b0b484..84c35b8 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -48,6 +48,7 @@
             view-builds
             view-derivation
             view-formatted-derivation
+            view-narinfos
             view-store-item
             view-derivation-source-file
             error-page))
@@ -804,6 +805,68 @@
                   (style "font-family: monospace; font-size: 1.5em;"))
                ")")))))))))
 
+(define (view-narinfos narinfos)
+  (layout
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      ,@(map
+         (match-lambda
+           ((hash-algorithm hash size urls signatures)
+            `((div
+               (@ (class "row"))
+               (div
+                (@ (class "col-sm-6"))
+                (h4 (@ (style "font-family: monospace;"))
+                    ,hash)
+                (table
+                 (@ (class "table")
+                    (style "table-layout: fixed;"))
+                 (thead
+                  (tr
+                   (th (@ (class "col-sm-1")) "Size")
+                   (th (@ (class "col-sm-4")) "Urls")))
+                 (tbody
+                  (td ,size)
+                  (td
+                   (ul
+                    ,@(map
+                       (lambda (url-details)
+                         `(li
+                           "Size: " ,(assoc-ref url-details "size")
+                           " Compression: " ,(assoc-ref url-details "compression")
+                           " "
+                           (a (@ (href ,(assoc-ref url-details "url")))
+                              ,(assoc-ref url-details "url"))))
+                       urls)))))))
+              ,@(map
+                 (lambda (signature)
+                   `(div
+                     (@ (class "row"))
+                     (div
+                      (@ (class "col-sm-6"))
+                      (dl
+                       (@ (class "dl-horizontal"))
+                       (dt "Version")
+                       (dd ,(assoc-ref signature "version"))
+                       (dt "Host name")
+                       (dd ,(assoc-ref signature "host_name")))
+
+                      "data"
+                      ,(sexp-div (assoc-ref signature "data"))
+                      "sig_val"
+                      ,(sexp-div (assoc-ref signature "sig_val"))
+                      "public_key"
+                      ,(sexp-div
+                        (assoc-ref signature "narinfo_signature_public_key")))
+                     (div
+                      (@ (class "col-sm-6"))
+                      (pre ,(assoc-ref signature "body"))
+                      (pre ,(assoc-ref signature "signature_line")))))
+                 signatures))))
+         narinfos)))))
+
 (define (general-not-found header-text body)
   (layout
    #:body