;;; Guix QA Frontpage
;;;
;;; Copyright © 2022 Christopher Baines <mail@cbaines.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
;;; as published by the Free Software Foundation, either version 3 of
;;; the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-qa-frontpage view shared)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-43)
#:use-module (ice-9 match)
#:use-module (web uri)
#:use-module ((guix-data-service web util)
#:select (uri-encode-filename))
#:use-module ((guix-data-service model utils) #:select (group-to-alist))
#:use-module (guix-qa-frontpage manage-builds)
#:use-module (guix-qa-frontpage view util)
#:export (package-changes-view
package-cross-changes-view
package-changes-summary-table
package-cross-changes-summary-table
package-reproducibility-table))
(define (builds->overall-status builds)
(if (eq? #f builds)
'not-present
(let ((build-statuses
(map
(lambda (build)
(let ((status
(assoc-ref build "status")))
(if (and (string=? status "scheduled")
(assoc-ref build "potentially_blocked"))
"blocked"
status)))
builds)))
(cond
((member "succeeded" build-statuses)
'succeeding)
((and (not (member "succeeded" build-statuses))
(member "failed" build-statuses))
'failing)
((member "blocked" build-statuses)
'blocked)
(else
'unknown)))))
(define %changes
'(broken
fixed
blocked
still-working
still-failing
still-blocked
new-working
new-failing
new-blocked
removed-working
removed-failing
removed-blocked
unknown-to-working
unknown-to-failing
unknown-to-blocked
unknown))
(define (builds->change-by-system builds-by-system)
(map
(match-lambda
((system . builds)
(let ((base-status (builds->overall-status
(assoc-ref builds "base")))
(target-status (builds->overall-status
(assoc-ref builds "target"))))
(cons
system
(cond
((and (eq? base-status 'succeeding)
(eq? target-status 'failing))
'broken)
((and (eq? base-status 'succeeding)
(eq? target-status 'blocked))
'blocked)
((and (or (eq? base-status 'failing)
(eq? base-status 'blocked))
(eq? target-status 'succeeding))
'fixed)
((and (eq? 'not-present base-status)
(eq? 'succeeding target-status))
'new-working)
((and (eq? 'not-present base-status)
(eq? 'failing target-status))
'new-failing)
((and (eq? 'not-present base-status)
(eq? 'blocked target-status))
'new-blocked)
((and (eq? 'succeeding base-status)
(eq? 'not-present target-status))
'removed-working)
((and (eq? 'failing base-status)
(eq? 'not-present target-status))
'removed-failing)
((and (eq? 'blocked base-status)
(eq? 'not-present target-status))
'removed-blocked)
((and (eq? base-status target-status 'succeeding))
'still-working)
((and (eq? base-status target-status 'failing))
'still-failing)
((and (eq? base-status target-status 'blocked))
'still-blocked)
((and (or (eq? 'unknown base-status)
(eq? 'blocked base-status))
(eq? 'succeeding target-status))
'unknown-to-working)
((and (or (eq? 'unknown base-status)
(eq? 'blocked base-status))
(eq? 'failing target-status))
'unknown-to-failing)
((and (eq? 'unknown base-status)
(eq? 'blocked target-status))
'unknown-to-blocked)
(else 'unknown))))))
builds-by-system))
(define (display-builds builds derivations change)
(define %color-for-change
'((fixed . "green")
(broken . "red")
(blocked . "yellow")
(still-working . "lightgreen")
(still-failing . "#FFCCCB")
(still-blocked . "lightyellow")
(new-working . "lightgreen")
(new-failing . "red")
(new-blocked . "lightyellow")
(removed-working . "")
(removed-failing . "")
(removed-blocked . "")
(unknown-to-working . "lightgreen")
(unknown-to-failing . "#FFCCCB")
(unknown-to-blocked . "lightyellow")
(unknown . "lightgrey")))
(if builds
(let ((base-status
(builds->overall-status
(assoc-ref builds "base")))
(target-status
(builds->overall-status
(assoc-ref builds "target"))))
(if (and
(eq? base-status 'not-present)
(eq? target-status 'not-present))
'(td)
`(td
(@ (style ,(simple-format
#f
"background-color: ~A;"
(assq-ref
%color-for-change
change))))
,(if (eq? base-status 'not-present)
`(div "was not present")
`(div
(a (@ (href ,(string-append
"https://data.qa.guix.gnu.org"
(uri-encode-filename
(assoc-ref derivations "base")))))
"was " ,base-status)))
,(if (eq? target-status 'not-present)
`(div "now not present")
`(div
(a (@ (href ,(string-append
"https://data.qa.guix.gnu.org"
(uri-encode-filename
(assoc-ref derivations "target")))))
"now " ,target-status))))))
'(td)))
(define (package-changes-view title
derivation-changes
query-parameters)
(define (derivation-for-system derivations system)
(vector-any
(lambda (derivation)
(if (string=? (assoc-ref derivation "system")
system)
derivation
#f))
derivations))
(define (builds-by-system base target)
(map
(lambda (system)
(cons
system
`(("base" . ,(and=>
(derivation-for-system base system)
(lambda (derivation)
(vector->list
(assoc-ref derivation "builds")))))
("target" . ,(and=>
(derivation-for-system target system)
(lambda (derivation)
(vector->list
(assoc-ref derivation "builds"))))))))
%systems-to-submit-builds-for))
(define (derivations-by-system base target)
(map
(lambda (system)
(cons
system
`(("base" . ,(and=>
(derivation-for-system base system)
(lambda (derivation)
(assoc-ref derivation "derivation-file-name"))))
("target" . ,(and=>
(derivation-for-system target system)
(lambda (derivation)
(assoc-ref derivation "derivation-file-name")))))))
%systems-to-submit-builds-for))
(define grouped-query-parameters
(group-to-alist
identity
query-parameters))
(define system-change
(map
(lambda (system)
(cons (string-append system "-change")
system))
%systems-to-submit-builds-for))
(define (display? package-and-version change-by-system)
(every
(match-lambda
((key . vals)
(cond
((assoc-ref system-change key)
(let ((system (assoc-ref system-change key)))
(->bool
(member (assoc-ref change-by-system system)
(map string->symbol vals)))))
(else #t))))
grouped-query-parameters))
(layout
#:title title
#:body
`((main
(@ (style "max-width: 98%;"))
(table
(form
(@ (id "filter-form")
(method "get"))
(thead
(tr
(td "Name")
(td "Version")
,@(map
(lambda (system)
`(td (span (@ (style "font-size: 1.5em; font-family: monospace;"))
,system)
(select
(@ (name
,(simple-format #f "~A-change"
system))
(style "margin-bottom: 0;")
(multiple #t))
,@(let ((system-change-selected-options
(or (assoc-ref
grouped-query-parameters
(string-append system "-change"))
'())))
(map
(match-lambda
((value . label)
`(option
(@ (value ,value)
,@(if (member (symbol->string value)
system-change-selected-options)
'((selected ""))
'()))
,label)))
(map
(lambda (change)
(cons change change))
%changes))))
(button
(@ (type "submit")
(style "padding: 0; width: 100%;"))
"Update")))
%systems-to-submit-builds-for))
(tr
(td)
(td)
,@(map
(lambda (system)
(let* ((system-change-selected-options
(or (assoc-ref
grouped-query-parameters
(string-append system "-change"))
'()))
(selected-labels
(filter-map
(match-lambda
((value . label)
(if (member (symbol->string value)
system-change-selected-options)
label
#f)))
(map
(lambda (change)
(cons change change))
%changes))))
(if (null? selected-labels)
'(td)
`(td
"Filtering for:"
(ul
(@ (style "margin: 0;"))
,@(map (lambda (label)
`(li ,label))
selected-labels))))))
%systems-to-submit-builds-for))))
(tbody
(@ (style "overflow: auto; max-height: 40em;"))
,@(vector-fold-right
(lambda (_ result package-and-version)
(let* ((builds
(builds-by-system
(assoc-ref package-and-version "base")
(assoc-ref package-and-version "target")))
(change-by-system
(builds->change-by-system builds))
(derivations
(derivations-by-system
(assoc-ref package-and-version "base")
(assoc-ref package-and-version "target"))))
(cons
`(tr
(@ ,@(if (display? package-and-version
change-by-system)
'()
'((style "display: none;"))))
(td ,(assoc-ref package-and-version "name"))
(td ,(assoc-ref package-and-version "version"))
,@(map
(lambda (system)
(display-builds (assoc-ref builds system)
(assoc-ref derivations system)
(assoc-ref change-by-system system)))
%systems-to-submit-builds-for))
result)))
'()
(assoc-ref derivation-changes "derivation_changes"))))))))
(define (package-cross-changes-view title
system
derivation-changes
query-parameters)
(define (derivation-for-target derivations target)
(vector-any
(lambda (derivation)
(if (string=? (assoc-ref derivation "target")
target)
derivation
#f))
derivations))
;; TODO This probably performs poorly when there are lots of changes
(define all-targets
(delete-duplicates!
(vector-fold-right
(lambda (_ result package-and-version)
(vector-fold-right
(lambda (_ result derivation)
(let ((target
(assoc-ref derivation "target")))
(if (string-null? target)
result
(cons target result))))
(vector-fold-right
(lambda (_ result derivation)
(let ((target
(assoc-ref derivation "target")))
(if (string-null? target)
result
(cons target result))))
result
(assoc-ref package-and-version "target"))
(assoc-ref package-and-version "base")))
'()
(assoc-ref derivation-changes "derivation_changes"))))
(define (builds-by-target base-data target-data)
(map
(lambda (target)
(cons
target
`(("base" . ,(and=>
(derivation-for-target base-data target)
(lambda (derivation)
(vector->list
(assoc-ref derivation "builds")))))
("target" . ,(and=>
(derivation-for-target target-data target)
(lambda (derivation)
(vector->list
(assoc-ref derivation "builds"))))))))
all-targets))
(define (derivations-by-target base-data target-data)
(map
(lambda (target)
(cons
target
`(("base" . ,(and=>
(derivation-for-target base-data target)
(lambda (derivation)
(assoc-ref derivation "derivation-file-name"))))
("target" . ,(and=>
(derivation-for-target target-data target)
(lambda (derivation)
(assoc-ref derivation "derivation-file-name")))))))
all-targets))
(define grouped-query-parameters
(group-to-alist
identity
query-parameters))
(define target-change
(map
(lambda (target)
(cons (string-append target "-change")
target))
all-targets))
(define (display? package-and-version change-by-target)
(every
(match-lambda
((key . vals)
(cond
((assoc-ref target-change key)
(let ((system (assoc-ref target-change key)))
(->bool
(member (assoc-ref change-by-target system)
(map string->symbol vals)))))
(else #t))))
grouped-query-parameters))
(layout
#:title title
#:body
`((main
(@ (style "max-width: 98%;"))
(table
(form
(@ (id "filter-form")
(method "get"))
(thead
(tr
(td "Name")
(td "Version")
,@(map
(lambda (target)
`(td (span (@ (style "font-size: 1.5em; font-family: monospace;"))
,target)
(select
(@ (name
,(simple-format #f "~A-change"
target))
(style "margin-bottom: 0;")
(multiple #t))
,@(let ((target-change-selected-options
(or (assoc-ref
grouped-query-parameters
(string-append target "-change"))
'())))
(map
(match-lambda
((value . label)
`(option
(@ (value ,value)
,@(if (member (symbol->string value)
target-change-selected-options)
'((selected ""))
'()))
,label)))
(map
(lambda (change)
(cons change change))
%changes))))
(button
(@ (type "submit")
(style "padding: 0; width: 100%;"))
"Update")))
all-targets))
(tr
(td)
(td)
,@(map
(lambda (target)
(let* ((target-change-selected-options
(or (assoc-ref
grouped-query-parameters
(string-append target "-change"))
'()))
(selected-labels
(filter-map
(match-lambda
((value . label)
(if (member (symbol->string value)
target-change-selected-options)
label
#f)))
(map
(lambda (change)
(cons change change))
%changes))))
(if (null? selected-labels)
'(td)
`(td
"Filtering for:"
(ul
(@ (style "margin: 0;"))
,@(map (lambda (label)
`(li ,label))
selected-labels))))))
all-targets))))
(tbody
(@ (style "overflow: auto; max-height: 40em;"))
,@(vector-fold-right
(lambda (_ result package-and-version)
(let* ((builds
(builds-by-target
(assoc-ref package-and-version "base")
(assoc-ref package-and-version "target")))
(derivations
(derivations-by-target
(assoc-ref package-and-version "base")
(assoc-ref package-and-version "target")))
(change-by-target
;; This works, even though the naming is wrong as it's
;; being used to group builds by target
(builds->change-by-system builds)))
(cons
`(tr
(@ ,@(if (display? package-and-version
change-by-target)
'()
'((style "display: none;"))))
(td ,(assoc-ref package-and-version "name"))
(td ,(assoc-ref package-and-version "version"))
,@(map
(lambda (target)
(display-builds (assoc-ref builds target)
(assoc-ref derivations target)
(assoc-ref change-by-target target)))
all-targets))
result)))
'()
(assoc-ref derivation-changes "derivation_changes"))))))))
(define (package-changes-summary-table revisions
derivation-changes-counts
package-changes-url-prefix
systems-affecting-status)
(define* (package-derivations-comparison-link system
#:key build-change)
(string-append
(simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A"
(assq-ref revisions 'base)
(assq-ref revisions 'target))
(match system
((system . target)
(simple-format #f "&system=~A&target=~A"
system
target))
(system
(simple-format #f "&system=~A&target=none"
system)))
(if build-change
(simple-format #f "&build_change=~A" build-change)
"")))
(define* (system+derivations->tr system derivations
#:key bad-highlighting)
(define (count side status)
(assoc-ref (assoc-ref
derivations
side)
status))
`(tr
(td (@ (class "monospace")) ,system)
,@(map (lambda (status)
`(td ,(count 'base status)))
'(succeeding failing blocked unknown))
(td ,@(if (and (>= (count 'target 'succeeding)
(count 'base 'succeeding))
(> (count 'target 'succeeding)
0))
`((@ (class "good")))
'())
(a (@ (href
,(string-append
package-changes-url-prefix
"/package-changes?"
system "-change=fixed&"
system "-change=still-working&"
system "-change=unknown-to-working&"
system "-change=new-working")))
,(count 'target 'succeeding)))
(td ,@(if (and bad-highlighting
(> (count 'target 'failing)
(count 'base 'failing)))
'((@ (class "bad")))
'())
(a (@ (href
,(string-append
package-changes-url-prefix
"/package-changes?"
system "-change=broken&"
system "-change=still-failing&"
system "-change=unknown-to-failing&"
system "-change=new-failing")))
,(count 'target 'failing)))
(td ,@(if (and bad-highlighting
(> (count 'target 'blocked)
(count 'base 'blocked)))
'((@ (class "bad")))
'())
(a (@ (href
,(string-append
package-changes-url-prefix
"/package-changes?"
system "-change=blocked&"
system "-change=still-blocked&"
system "-change=unknown-to-blocked&"
system "-change=new-blocked")))
,(count 'target 'blocked)))
(td (@ ,@(if (and bad-highlighting
(> (count 'target 'unknown)
(count 'base 'unknown)))
'((class "pending"))
'()))
(a (@ (href
,(string-append
package-changes-url-prefix
"/package-changes?"
system "-change=unknown")))
,(count 'target 'unknown)))
(td (a (@ (href
,(package-derivations-comparison-link system)))
"View comparison"))))
`(table
(@ (style "border-collapse: collapse;"))
(thead
(tr
(th (@ (rowspan 3)) "System")
(th (@ (colspan 8)) "Package build status")
(th))
(tr
(th (@ (colspan 4)) "Base")
(th (@ (colspan 4)
(style "border-left-width: 0.1em; border-left-style: solid; border-left-color: black"))
"With branch changes")
(th))
(tr
,@(let ((header-style
"font-size: 80%; min-width: 3.5rem;"))
`((th (@ (style ,header-style))
"Succeeding")
(th (@ (style ,header-style))
"Failing")
(th (@ (style ,header-style))
"Blocked")
(th (@ (style ,header-style))
"Unknown")
(th (@ (style
,(string-append
header-style
" border-left-width: 0.125em; border-left-style: solid; border-left-color: black;")))
"Succeeding")
(th (@ (style ,header-style))
"Failing")
(th (@ (style ,header-style))
"Blocked")
(th (@ (style ,header-style))
"Unknown")
(th)))))
(tbody
,@(if (and derivation-changes-counts
(not (assq-ref derivation-changes-counts 'exception)))
(if (null? derivation-changes-counts)
`((tr
(td (@ (colspan 7))
"No package derivation changes")))
(match (fold
(lambda (system result)
(if (member system systems-affecting-status)
(cons `(,@(car result) ,system)
(cdr result))
(cons (car result)
`(,@(cdr result) ,system))))
(cons '() '())
(map car derivation-changes-counts))
((important-systems . other-systems)
(list
(append
(map
(lambda (system)
(system+derivations->tr
system
(assoc-ref derivation-changes-counts system)
#:bad-highlighting #t))
important-systems)
(if (null? other-systems)
'()
`((tr (td (@ (colspan 10))
"Build status for the below systems doesn't affect issue status"))))
(map
(lambda (system)
(system+derivations->tr
system
(assoc-ref derivation-changes-counts system)))
other-systems))))))
`((tr
(td (@ (colspan 10)
(class "bad"))
"Comparison unavailable"
,@(cond
((eq? (assq-ref derivation-changes-counts 'exception)
'guix-data-service-invalid-parameters)
(append-map
(match-lambda
((param . details)
(let ((error
(assq-ref details 'error)))
(cond
((member param '("base_commit"
"target_commit"))
`((br)
(a
(@ (href
,(string-append
"https://data.qa.guix.gnu.org"
"/revision/"
(assq-ref
revisions
(if (string=? param "base_commit")
'base
'target)))))
,(cond
((eq? error 'unknown-commit)
(string-append
(if (string=? param "base_commit")
"Base revision "
"Target revision ")
"unknown to the data service."))
((member error
'(yet-to-process-revision
failed-to-process-revision))
(simple-format
#f "~A to process ~A"
(if (eq? error 'yet-to-process-revision)
"Yet"
"Failed")
(if (string=? param "base_commit")
"base revision (from master branch)"
"target revision")))
(else
(string-append
"Error with "
(if (string=? param "base_commit")
"base revision."
"target revision.")))))))))))
(assq-ref derivation-changes-counts
'invalid_query_parameters)))
((eq? (assq-ref derivation-changes-counts 'exception)
'guix-data-service-exception)
(let ((url
(assq-ref derivation-changes-counts 'url)))
`((br)
"Exception fetching data from "
(a (@ (href ,url))
,url))))
(else
'())))))))))
(define (package-cross-changes-summary-table revisions
cross-derivation-changes-counts
package-changes-url-prefix)
(define* (package-derivations-comparison-link system target
#:key build-change)
(string-append
(simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A"
(assq-ref revisions 'base)
(assq-ref revisions 'target))
(simple-format #f "&system=~A&target=~A"
system
target)
(if build-change
(simple-format #f "&build_change=~A" build-change)
"")))
`(table
(@ (style "border-collapse: collapse;"))
(thead
(tr
(th (@ (rowspan 3)) "Target")
(th (@ (colspan 8)) "Package build status")
(th))
(tr
(th (@ (colspan 4)) "Base")
(th (@ (colspan 4)
(style "border-left-width: 0.1em; border-left-style: solid; border-left-color: black"))
"With branch changes")
(th))
(tr
,@(let ((header-style
"font-size: 80%; min-width: 3.5rem;"))
`((th (@ (style ,header-style))
"Succeeding")
(th (@ (style ,header-style))
"Failing")
(th (@ (style ,header-style))
"Blocked")
(th (@ (style ,header-style))
"Unknown")
(th (@ (style
,(string-append
header-style
" border-left-width: 0.125em; border-left-style: solid; border-left-color: black;")))
"Succeeding")
(th (@ (style ,header-style))
"Failing")
(th (@ (style ,header-style))
"Blocked")
(th (@ (style ,header-style))
"Unknown")
(th)))))
(tbody
,@(if (and cross-derivation-changes-counts
(not (assq-ref cross-derivation-changes-counts 'exception)))
(if (null? cross-derivation-changes-counts)
`((tr
(td (@ (colspan 7))
"No package derivation changes")))
(map
(match-lambda
(((system . target) . derivations)
(define (count side status)
(assoc-ref (assoc-ref
derivations
side)
status))
`(tr
(td (@ (class "monospace")) ,target)
,@(map (lambda (status)
`(td ,(count 'base status)))
'(succeeding failing blocked unknown))
(td ,@(if (and (>= (count 'target 'succeeding)
(count 'base 'succeeding))
(> (count 'target 'succeeding)
0))
`((@ (class "good")))
'())
(a (@ (href
,(string-append
package-changes-url-prefix
"/package-cross-changes?"
target "-change=fixed&"
target "-change=still-working&"
target "-change=unknown-to-working&"
target "-change=new-working")))
,(count 'target 'succeeding)))
(td ,@(if (> (count 'target 'failing)
(count 'base 'failing))
'((@ (class "bad")))
'())
(a (@ (href
,(string-append
package-changes-url-prefix
"/package-cross-changes?"
target "-change=broken&"
target "-change=still-failing&"
target "-change=unknown-to-failing&"
target "-change=new-failing")))
,(count 'target 'failing)))
(td ,@(if (> (count 'target 'blocked)
(count 'base 'blocked))
'((@ (class "bad")))
'())
(a (@ (href
,(string-append
package-changes-url-prefix
"/package-cross-changes?"
target "-change=blocked&"
target "-change=still-blocked&"
target "-change=unknown-to-blocked&"
target "-change=new-blocked")))
,(count 'target 'blocked)))
(td (@ ,@(if (> (count 'target 'unknown)
(count 'base 'unknown))
'((class "bad"))
'()))
(a (@ (href
,(string-append
package-changes-url-prefix
"/package-cross-changes?"
target "-change=unknown")))
,(count 'target 'unknown)))
(td (a (@ (href
,(package-derivations-comparison-link system
target)))
"View comparison")))))
cross-derivation-changes-counts))
`((tr
(td (@ (colspan 10)
(class "bad"))
"Comparison unavailable"
,@(or (and=>
(assq-ref cross-derivation-changes-counts
'invalid_query_parameters)
(lambda (params)
(append-map
(match-lambda
((param . details)
(let ((error
(assq-ref details 'error)))
(cond
((member param '("base_commit"
"target_commit"))
`((br)
(a
(@ (href
,(string-append
"https://data.qa.guix.gnu.org"
"/revision/"
(assq-ref
revisions
(if (string=? param "base_commit")
'base
'target)))))
,(cond
((eq? error 'unknown-commit)
(string-append
(if (string=? param "base_commit")
"Base revision "
"Target revision ")
"unknown to the data service."))
((member error
'(yet-to-process-revision
failed-to-process-revision))
(simple-format
#f "~A to process ~A"
(if (eq? error 'yet-to-process-revision)
"Yet"
"Failed")
(if (string=? param "base_commit")
"base revision (from master branch)"
"target revision")))
(else
(string-append
"Error with "
(if (string=? param "base_commit")
"base revision."
"target revision.")))))))))))
params)))
'()))))))))
(define (package-reproducibility-table package-reproducibility)
`(table
(thead
(tr
(th (@ (rowspan 2))
"System")
(th (@ (colspan 4))
"Package reproducibility"))
(tr (th "Matching")
(th "Not matching")
(th "Unknown")
(th (@ (style "min-width: 20em;")))))
(tbody
,@(map
(match-lambda
((system . details)
(let* ((matching
(or (assoc-ref details "matching")
0))
(not-matching
(or (assoc-ref details "not-matching")
0))
(unknown
(or (assoc-ref details "unknown")
0))
(total
(+ matching not-matching unknown))
(matching-percent
(round (/ (* 100 matching) total)))
(not-matching-percent
(round (/ (* 100 not-matching) total)))
(unknown-percent
(- 100 (+ matching-percent not-matching-percent))))
`(tr
(td
(@ (style "font-family: monospace;"))
,system)
(td (a (@ (href
,(string-append
"https://data.qa.guix.gnu.org/revision/"
(assoc-ref package-reproducibility "commit")
"/package-derivation-outputs"
"?output_consistency=matching&system="
system)))
,matching))
(td (a (@ (href
,(string-append
"https://data.qa.guix.gnu.org/revision/"
(assoc-ref package-reproducibility "commit")
"/package-derivation-outputs"
"?output_consistency=not-matching&system="
system)))
,not-matching))
(td (a (@ (href
,(string-append
"https://data.qa.guix.gnu.org/revision/"
(assoc-ref package-reproducibility "commit")
"/package-derivation-outputs"
"?output_consistency=unknown&system="
system)))
,unknown))
(td
(span (@ (style ,(string-append
"display: inline-block;"
"background-color: green;"
"padding: 0.5em 0 0.5em 0;"
(simple-format #f "width: ~A%;"
matching-percent))))
"")
(span (@ (style ,(string-append
"display: inline-block;"
"background-color: red;"
"padding: 0.5em 0 0.5em 0;"
(simple-format #f "width: ~A%;"
not-matching-percent))))
"")
(span (@ (style ,(string-append
"display: inline-block;"
"background-color: grey;"
"padding: 0.5em 0 0.5em 0;"
(simple-format #f "width: ~A%;"
unknown-percent))))
""))))))
(sort
(filter
(match-lambda
((system . _)
(not (member system '("powerpc-linux" "mips64el-linux")))))
(assoc-ref package-reproducibility "systems"))
(lambda (a b)
(string<? (car a) (car b))))))))