From c5a5684f1db3e4936acd672bf69874f55ff978b5 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 3 May 2020 21:25:45 +0100 Subject: [PATCH] Add a new package substitute availability page --- guix-data-service/model/nar.scm | 73 +++++ guix-data-service/web/revision/controller.scm | 34 +++ guix-data-service/web/revision/html.scm | 268 ++++++++++++++++++ 3 files changed, 375 insertions(+) diff --git a/guix-data-service/model/nar.scm b/guix-data-service/model/nar.scm index b9bde80..2dde327 100644 --- a/guix-data-service/model/nar.scm +++ b/guix-data-service/model/nar.scm @@ -30,6 +30,7 @@ select-nars-for-output select-signing-key + select-package-output-availability-for-revision select-output-consistency-for-revision record-narinfo-details-and-return-ids)) @@ -237,6 +238,78 @@ VALUES ($1, $2)") (list (list (cons "jsonb" public-key-json-string))))))) +(define (select-package-output-availability-for-revision conn revision-commit) + (define query + " +SELECT build_server_id, system, target, substitute_known, COUNT(*) +FROM ( + SELECT build_servers.id AS build_server_id, + derivation_output_details.path, + package_derivations.system, + package_derivations.target, + nar_data.build_server_id IS NOT NULL AS substitute_known + FROM derivation_output_details + INNER JOIN derivation_outputs + ON derivation_outputs.derivation_output_details_id = + derivation_output_details.id + INNER JOIN package_derivations + ON derivation_outputs.derivation_id = package_derivations.derivation_id + INNER JOIN guix_revision_package_derivations + ON package_derivations.id = + guix_revision_package_derivations.package_derivation_id + INNER JOIN guix_revisions + ON guix_revision_package_derivations.revision_id = guix_revisions.id + CROSS JOIN build_servers + INNER JOIN build_servers_build_config + ON build_servers.id = build_servers_build_config.build_server_id + AND package_derivations.system = build_servers_build_config.system + AND package_derivations.target = build_servers_build_config.target + LEFT JOIN ( + SELECT nars.store_path, narinfo_fetch_records.build_server_id + FROM nars + LEFT JOIN narinfo_signatures + ON narinfo_signatures.nar_id = nars.id + LEFT JOIN narinfo_signature_data + ON narinfo_signatures.narinfo_signature_data_id = narinfo_signature_data.id + LEFT JOIN narinfo_fetch_records + ON narinfo_fetch_records.narinfo_signature_data_id = narinfo_signature_data.id + ) AS nar_data + ON nar_data.store_path = derivation_output_details.path + AND nar_data.build_server_id = build_servers.id + WHERE derivation_output_details.hash IS NULL AND + guix_revisions.commit = $1 +) data +GROUP BY build_server_id, system, target, substitute_known +ORDER BY build_server_id DESC, system, target, build_server_id, substitute_known") + + (map + (match-lambda + ((build-server-id . rest) + (cons build-server-id + (group-to-alist + (match-lambda + ((system target substitute-known? count) + (cons `((system . ,system) + (target . ,target)) + (cons (if substitute-known? + 'known + 'unknown) + count)))) + rest)))) + (group-to-alist + (match-lambda + ((build-server-id system target substitute-known? count) + (cons build-server-id + (list system target substitute-known? count)))) + (map (match-lambda + ((build_server_id system target substitutes_known count) + (list (string->number build_server_id) + system + target + (string=? substitutes_known "t") + (string->number count)))) + (exec-query conn query (list revision-commit)))))) + (define (select-output-consistency-for-revision conn revision-commit) (define query " diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 9a253cc..0dc6eb4 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -244,6 +244,15 @@ (render-unknown-revision mime-types conn commit-hash))) + (('GET "revision" commit-hash "package-substitute-availability") + (if (guix-commit-exists? conn commit-hash) + (render-revision-package-substitute-availability mime-types + conn + commit-hash + #:path-base path) + (render-unknown-revision mime-types + conn + commit-hash))) (('GET "revision" commit-hash "package-reproducibility") (if (guix-commit-exists? conn commit-hash) (render-revision-package-reproduciblity mime-types @@ -438,6 +447,31 @@ #:header-text header-text #:header-link header-link)))))) +(define* (render-revision-package-substitute-availability mime-types + conn + commit-hash + #:key path-base) + (let ((substitute-availability + (select-package-output-availability-for-revision conn commit-hash)) + (build-server-urls + (group-to-alist + (match-lambda + ((id url lookup-all-derivations) + (cons id url))) + (select-build-servers conn)))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + '())) ; TODO + (else + (render-html + #:sxml (view-revision-package-substitute-availability + commit-hash + substitute-availability + build-server-urls)))))) + (define* (render-revision-package-reproduciblity mime-types conn commit-hash diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm index ebcf645..f131aa4 100644 --- a/guix-data-service/web/revision/html.scm +++ b/guix-data-service/web/revision/html.scm @@ -29,6 +29,7 @@ #:use-module (guix-data-service web view html) #:export (view-revision-news view-revision-package + view-revision-package-substitute-availability view-revision-package-reproducibility view-revision-package-and-version view-revision @@ -802,6 +803,273 @@ builds))))) channel-instances))))))))) +(define* (view-revision-package-substitute-availability revision-commit-hash + substitute-availability + build-server-urls) + (define chart-css + " +.chart-text { + fill: #000; + transform: translateY(0.25em); +} +.chart-number { + font-size: 0.6em; + line-height: 1; + text-anchor: middle; + transform: translateY(-0.25em); +} +.chart-label { + font-size: 0.2em; + text-anchor: middle; + transform: translateY(0.7em); +} +figure { + display: flex; + justify-content: space-around; + flex-direction: column; + margin-left: -15px; + margin-right: -15px; +} +@media (min-width: 768px) { + figure { + flex-direction: row; + } +} +.figure-content, +.figure-key { + flex: 1; + padding-left: 15px; + padding-right: 15px; + align-self: center; +} +.figure-content svg { + height: auto; +} +.figure-key { + min-width: calc(8 / 12); +} +.figure-key [class*=\"shape-\"] { + margin-right: 6px; +} +.figure-key-list { + margin: 0; + padding: 0; + list-style: none; +} +.figure-key-list li { + margin: 0 0 8px; + padding: 0; +} +.shape-circle { + display: inline-block; + vertical-align: middle; + margin-right: 0.8em; + width: 32px; + height: 32px; + border-radius: 50%; +}") + + (define (chart build-server-id system target data) + ;; Inspired by + ;; https://medium.com/@heyoka/scratch-made-svg-donut-pie-charts-in-html5-2c587e935d72 + + (define total + (apply + (map cdr data))) + + (define keys '(known unknown)) + + (define data-percentages + (map (lambda (key) + (exact->inexact + (* 100 (/ (or (assq-ref data key) + 0) + total)))) + keys)) + + (define labels + '("Known" "Unknown")) + + (define colours + '("green" "#d2d3d4")) + + (define center-label + "Available") + + `(div + (@ (class "col-sm-6")) + (h3 (@ (style "font-family: monospace;")) + ,system ,target) + (figure + (div + (@ (class "figure-content")) + (svg + (@ (width "100%") + (height "100%") + (viewBox "0 0 42 42") + (class "donut") + (aria-labelledby ,(string-append system "-chart-title " system "-chart-desc")) + (role "img")) + (title + (@ (id ,(string-append system "-chart-title"))) + ,(string-append "Package reproducibility for " system)) + (desc + (@ (id ,(string-append system "-chart-desc"))) + ,(string-append + "Donut chart breaking down Guix package substitute availability for " + system + ".")) ; TODO Describe the data on the chart + (circle + (@ (class "donut-hole") + (cx "21") + (cy "21") + (r "15.91549430918954") + (fill "#fff") + (role "presentation"))) + + ,@(map + (lambda (key label colour percentage offset) + `(circle + (@ (class "donut-segment") + (cx "21") + (cy "21") + (r "15.91549430918954") + (fill "transparent") + (stroke ,colour) + (stroke-width "4") + (stroke-dasharray ,(simple-format #f "~A ~A" + percentage + (- 100 percentage))) + (stroke-dashoffset ,offset) + (aria-labelledby + ,(simple-format #f "donut-segment-~A-title donut-segment-~A-desc" + key key))) + (title + (@ (id ,(simple-format #f "donut-segment-~A-title" + key))) + ,label) + (desc + (@ (id ,(simple-format #f "donut-segment-~A-desc" + key))) + ;; TODO Improve this description by stating the + ;; colour and count + ,(format #f "~2,2f%" + (or percentage 0))))) + keys + labels + colours + data-percentages + (cons 25 + (map (lambda (cumalative-percentage) + (+ (- 100 + cumalative-percentage) + ;; Start at 25, as this will position + ;; the segment at the top of the chart + 25)) + (reverse + (fold + (lambda (val result) + (cons (+ val (first result)) + result)) + (list + (first data-percentages)) + (cdr data-percentages)))))) + (g + (@ (class "chart-text")) + ,@(if (and (eq? (or (assq-ref data 'known) + 0) + 0) + (eq? (or (assq-ref data 'unknown) + 0) + 0)) + `((text + (@ (x "50%") + (y "50%") + (class "chart-label")) + "No data")) + `((text + (@ (x "50%") + (y "50%") + (class "chart-number")) + ,(simple-format + #f "~~~A%" + (inexact->exact + (round (car data-percentages))))) + (text + (@ (x "50%") + (y "50%") + (class "chart-label")) + ,center-label)))))) + (figcaption + (@ (class "figure-key")) + (p (@ (class "sr-only")) + ,(string-append + "Donut chart breaking down Guix package substitute availability for " + system + ".")) ; TODO Describe the data on the chart + (ul + (@ (class "figure-key-list") + (aria-hidden "true") + (role "presentation")) + ,@(map (lambda (key label count percentage colour) + `(li + (span (@ (class "shape-circle") + (style + ,(string-append "background-color: " + colour ";")))) + (a (@ (href + ,(string-append + "/revision/" revision-commit-hash + "/package-derivation-outputs?" + (if (eq? key 'known) + "substitutes_available_from=" + "substitutes_not_available_from=") + (number->string build-server-id) + "&system=" system))) + ,(format #f "~a (~d, ~2,2f%)" + label + (or count 0) + (or percentage 0))))) + keys + labels + (map (lambda (key) + (assq-ref data key)) + keys) + data-percentages + colours)))))) + + (layout + #:body + `(,(header) + (style ,chart-css) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 (a (@ (style "white-space: nowrap;") + (href ,(string-append "/revision/" revision-commit-hash))) + "Revision " (samp ,revision-commit-hash))) + (h1 "Package substitute availability"))) + ,@(append-map + (match-lambda + ((build-server-id . data) + `((div + (@ (class "row")) + (div (@ (class "col-md-12")) + (h2 ,(assoc-ref build-server-urls + build-server-id)))) + (div + (@ (class "row")) + ,@(map (match-lambda + ((system-and-target . data) + (chart build-server-id + (assq-ref system-and-target 'system) + (assq-ref system-and-target 'target) + data))) + data))))) + substitute-availability))))) + (define* (view-revision-package-reproducibility revision-commit-hash output-consistency) (layout