[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
05/06: Add a new package substitute availability page
|
From: |
Christopher Baines |
|
Subject: |
05/06: Add a new package substitute availability page |
|
Date: |
Sun, 3 May 2020 16:30:02 -0400 (EDT) |
cbaines pushed a commit to branch master
in repository data-service.
commit c5a5684f1db3e4936acd672bf69874f55ff978b5
Author: Christopher Baines <address@hidden>
AuthorDate: Sun May 3 21:25:45 2020 +0100
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
- branch master updated (b4111af -> 2e3276e), Christopher Baines, 2020/05/03
- 01/06: Split out querying of build servers and substitute servers, Christopher Baines, 2020/05/03
- 03/06: Add a couple of options to select-derivation-outputs-in-revision, Christopher Baines, 2020/05/03
- 02/06: Rename render-revision-derivation-outputs, Christopher Baines, 2020/05/03
- 04/06: Allow filtering by substitute availability for derivation outputs, Christopher Baines, 2020/05/03
- 05/06: Add a new package substitute availability page,
Christopher Baines <=
- 06/06: Tweak select-output-consistency-for-revision, Christopher Baines, 2020/05/03