;;; 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)

  (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)
         "")))

  `(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")))
               (map
                (match-lambda
                  ((system . derivations)

                   (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 (> (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 (> (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 (> (count 'target 'unknown)
                                     (count 'base 'unknown))
                                  '((class "bad"))
                                  '()))
                         (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")))))
                derivation-changes-counts))
           `((tr
              (td (@ (colspan 10)
                     (class "bad"))
                  "Comparison unavailable"
                  ,@(or (and=>
                         (assq-ref 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-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))))))))