path: root/guix-qa-frontpage/view/shared.scm

;;; 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 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-changes-summary-table))

(define (package-changes-view title
                              derivation-changes
                              query-parameters)
  (define (derivation-for-system side system)
    (vector-any
     (lambda (derivation)
       (if (string=? (assoc-ref derivation "system")
                     system)
           derivation
           #f))
     side))

  (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 (builds->overall-status side-builds)
    (if (eq? #f side-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)))
                side-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
                                      (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
                                      (assoc-ref derivations "target")))))
                          "now " ,target-status))))))
        '(td)))

  (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-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&system=~A&target=none"
                    (assq-ref revisions 'base)
                    (assq-ref revisions 'target)
                    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
                                        ((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")))))))))))
                            params)))
                        '()))))))))