WIPwip-reproducibility-pie-chart

3 files changed, 327 insertions, 0 deletions

diff --git a/guix-data-service/model/nar.scm b/guix-data-service/model/nar.scm
index b8e39e1..f3b94f0 100644
--- a/guix-data-service/model/nar.scm
+++ b/guix-data-service/model/nar.scm
@@ -13,6 +13,8 @@
             select-nars-for-output
             select-signing-key
 
+            select-reproducibility-status-for-revision
+
             record-narinfo-details-and-return-ids))
 
 (define narinfo-contents
@@ -217,6 +219,67 @@ VALUES ($1, $2)")
       (list (list (cons "jsonb"
                         public-key-json-string)))))))
 
+(define (select-reproducibility-status-for-revision conn revision-commit)
+  (define query
+    "
+SELECT system, target, reproducible, COUNT(*)
+FROM (
+  SELECT derivation_output_details.path,
+         package_derivations.system,
+         package_derivations.target,
+         JSON_AGG(
+           json_build_object(
+             'hash', nars.hash,
+             'build_server_id', narinfo_fetch_records.build_server_id
+           )
+         ),
+         CASE
+           WHEN (COUNT(DISTINCT narinfo_fetch_records.build_server_id) <= 1) THEN NULL
+           ELSE (COUNT(DISTINCT nars.hash) = 1)
+         END AS reproducible
+  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
+  LEFT JOIN nars
+    ON derivation_output_details.path = nars.store_path
+  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
+  WHERE derivation_output_details.hash IS NULL AND
+        guix_revisions.commit = $1 AND
+        package_derivations.system = package_derivations.target -- Exclude cross builds
+  GROUP BY derivation_output_details.path,
+           package_derivations.system,
+           package_derivations.target
+) data
+GROUP BY system, target, reproducible
+ORDER BY COUNT(*) DESC")
+
+  (group-to-alist
+   (match-lambda
+     ((system status count)
+      (cons system
+            (cons status count))))
+   (map (match-lambda
+          ((system target status count)
+           (list system
+                 (match status
+                   ("t" 'reproducible)
+                   ("f" 'unreproducible)
+                   ("" 'unknown))
+                 (string->number count))))
+        (exec-query conn query (list revision-commit)))))
+
 (define (select-outputs-for-successful-builds-without-known-nar-entries
          conn
          build-server-id
diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm
index bc49703..5cb9623 100644
--- a/guix-data-service/web/revision/controller.scm
+++ b/guix-data-service/web/revision/controller.scm
@@ -43,6 +43,7 @@
   #:use-module (guix-data-service model lint-checker)
   #:use-module (guix-data-service model lint-warning)
   #:use-module (guix-data-service model guix-revision)
+  #:use-module (guix-data-service model nar)
   #:use-module (guix-data-service web revision html)
   #:export (revision-controller
 
@@ -216,6 +217,15 @@
          (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
+                                                 conn
+                                                 commit-hash
+                                                 #:path-base path)
+         (render-unknown-revision mime-types
+                                  conn
+                                  commit-hash)))
     (('GET "revision" commit-hash "builds")
      (if (guix-commit-exists? conn commit-hash)
          (let ((parsed-query-parameters
@@ -330,6 +340,25 @@
                 #:header-text header-text)
         #:extra-headers http-headers-for-unchanging-content)))))
 
+(define* (render-revision-package-reproduciblity mime-types
+                                                 conn
+                                                 commit-hash
+                                                 #:key path-base)
+  (let ((reproducibility-status
+         (peek (select-reproducibility-status-for-revision conn commit-hash))))
+    (case (most-appropriate-mime-type
+           '(application/json text/html)
+           mime-types)
+      ((application/json)
+       (render-json
+        '()))
+      (else
+       (render-html
+        #:sxml (view-revision-package-reproducibility
+                commit-hash
+                reproducibility-status
+                #:header-text '("Package reproducibility status")))))))
+
 (define (render-revision-news mime-types
                               conn
                               commit-hash
diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm
index ce79f52..b13ebf2 100644
--- a/guix-data-service/web/revision/html.scm
+++ b/guix-data-service/web/revision/html.scm
@@ -18,6 +18,7 @@
 (define-module (guix-data-service web revision html)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (texinfo)
   #:use-module (texinfo html)
   #:use-module (json)
@@ -28,6 +29,7 @@
   #:use-module (guix-data-service web view html)
   #:export (view-revision-news
             view-revision-package
+            view-revision-package-reproducibility
             view-revision-package-and-version
             view-revision
             view-revision-packages
@@ -622,6 +624,239 @@
                   "Next page")))
             '())))))
 
+(define* (view-revision-package-reproducibility revision-commit-hash
+                                                reproducibility-status
+                                                #:key path-base
+                                                header-text header-link)
+  (layout
+   #:body
+   `(,(header)
+     (style "
+.chart-text {
+  fill: #000;
+  -moz-transform: translateY(0.25em);
+  -ms-transform: translateY(0.25em);
+  -webkit-transform: translateY(0.25em);
+  transform: translateY(0.25em);
+}
+.chart-number {
+  font-size: 0.6em;
+  line-height: 1;
+  text-anchor: middle;
+  -moz-transform: translateY(-0.25em);
+  -ms-transform: translateY(-0.25em);
+  -webkit-transform: translateY(-0.25em);
+  transform: translateY(-0.25em);
+}
+.chart-label {
+  font-size: 0.2em;
+  text-anchor: middle;
+  -moz-transform: translateY(0.7em);
+  -ms-transform: translateY(0.7em);
+  -webkit-transform: translateY(0.7em);
+  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;
+  -webkit-border-radius: 50%;
+     -moz-border-radius: 50%;
+          border-radius: 50%;
+}")
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (h3 (a (@ (style "white-space: nowrap;")
+                  (href ,header-link))
+               ,@header-text))))
+      (div
+       (@ (class "row"))
+
+       ;; Inspired by
+       ;; https://medium.com/@heyoka/scratch-made-svg-donut-pie-charts-in-html5-2c587e935d72
+
+       ,@(map
+           (match-lambda
+             ((system . reproducibility-status)
+
+              (define total
+                (apply + (map cdr reproducibility-status)))
+
+              (define keys
+                '(reproducible unreproducible unknown))
+
+              (define reproducibility-status-percentages
+                (map (lambda (key)
+                       (exact->inexact
+                        (* 100 (/ (or (assq-ref reproducibility-status key)
+                                      0)
+                                  total))))
+                     keys))
+
+
+              (peek system)
+              (peek reproducibility-status)
+
+              `(div
+                (@ (class "col-sm-6"))
+                (h2 (@ (style "font-family: monospace;"))
+                    ,system)
+                (figure
+                 (div
+                  (@ (class "figure-content"))
+                  (svg
+                   (@ (width "100%") (height "100%") (viewBox "0 0 42 42") (class "donut")
+                      (aria-labelledby "beers-title beers-desc") (role "img"))
+                   (title
+                    (@ (id "beers-title"))
+                    "Beers in My Cellar")
+                   (desc
+                    (@ (id "beers-desc"))
+                    "Donut chart showing 10 total beers. Two beers are Imperial India Pale Ales, four beers are Belgian Quadrupels, and three are Russian Imperial Stouts. The last remaining beer is unlabeled.")
+                   (circle
+                    (@ (class "donut-hole")
+                       (cx "21")
+                       (cy "21")
+                       (r "15.91549430918954")
+                       (fill "#fff")
+                       (role "presentation")))
+                   ;; (circle
+                   ;;  (@ (class "donut-ring")
+                   ;;     (cx "21")
+                   ;;     (cy "21")
+                   ;;     (r "15.91549430918954")
+                   ;;     (fill "transparent")
+                   ;;     (stroke "#000")
+                   ;;     (stroke-width "3")
+                   ;;     (role "presentation")))
+
+                   ,@(map
+                      (lambda (key 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 "donut-segment-1-title donut-segment-1-desc"))
+                          (title
+                           (@ (id "donut-segment-1-title"))
+                           "Belgian Quadrupels")
+                          (desc
+                           (@ (id "donut-segment-1-desc"))
+                           "Pink chart segment spanning 40% of the whole, which is 4 Belgian Quadrupels out of 10 total")))
+                      '(reproducible unreproducible unknown)
+                      '("green" "red" "#d2d3d4")
+                      reproducibility-status-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 reproducibility-status-percentages))
+                                        (cdr reproducibility-status-percentages))))))
+                   (g
+                    (@ (class "chart-text"))
+                    ,@(if (and (eq? (or (assq-ref reproducibility-status 'reproducible)
+                                        0)
+                                    0)
+                               (eq? (or (assq-ref reproducibility-status 'unreproducible)
+                                        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 reproducibility-status-percentages)))))
+                            (text
+                             (@ (x "50%") (y "50%") (class "chart-label"))
+                             "Reproducible"))))))
+                 (figcaption
+                  (@ (class "figure-key"))
+                  (p (@ (class "sr-only"))
+                     "Donut chart showing 10 total beers. Two beers are Imperial India
+Pale Ales, four beers are Belgian Quadrupels, and three are Russian Imperial
+Stouts. The last remaining beer is unlabeled.")
+
+                  (ul
+                   (@ (class "figure-key-list")
+                      (aria-hidden "true")
+                      (role "presentation"))
+                   ,@(map (lambda (label count percentage colour)
+                            `(li
+                              (span (@ (class "shape-circle")
+                                       (style
+                                           ,(string-append "background-color: " colour ";"))))
+                              ,(format #f "~a (~d, ~2,2f%)"
+                                       label
+                                       (or count 0)
+                                       (or percentage 0))))
+                          '("Reproducible" "Unreproducible" "Unknown")
+                          (map (lambda (key)
+                                 (assq-ref reproducibility-status key))
+                               keys)
+                          reproducibility-status-percentages
+                          '("green" "red" "#d2d3d4"))))))))
+           reproducibility-status))))))
+
 (define* (view-revision-derivations commit-hash
                                     query-parameters
                                     valid-systems