From 1405509e0332656ed5f9388d67312a4fa7b8fee0 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 2 Dec 2019 13:30:36 +0100 Subject: WIP add a new page for the narinfos associated with an output --- guix-data-service/model/nar.scm | 50 ++++++++++++++++++++++++++++ guix-data-service/web/controller.scm | 17 ++++++++++ guix-data-service/web/view/html.scm | 63 ++++++++++++++++++++++++++++++++++++ 3 files changed, 130 insertions(+) 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 -- cgit v1.2.3