Add a new package changes page

And make some refactoring to make this easier.

1 files changed, 354 insertions, 19 deletions

diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm
index 7847360..830b5cb 100644
--- a/guix-qa-frontpage/view/branch.scm
+++ b/guix-qa-frontpage/view/branch.scm
@@ -1,15 +1,18 @@
 (define-module (guix-qa-frontpage view branch)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-43)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:use-module ((guix-data-service model utils) #:select (group-to-alist))
   #:use-module (guix-qa-frontpage manage-builds)
   #:use-module (guix-qa-frontpage derivation-changes)
   #:use-module (guix-qa-frontpage view util)
   #:export (branch-view
+            branch-package-changes-view
 
             master-branch-view))
 
-(define (branch-view branch revisions derivation-changes-counts
+(define (branch-view branch revisions derivation-changes
                      substitute-availability
                      up-to-date-with-master
                      master-branch-systems-with-low-substitute-availability)
@@ -24,6 +27,9 @@
          (simple-format #f "&build_change=~A" build-change)
          "")))
 
+  (define derivation-changes-counts
+    (assq-ref derivation-changes 'counts))
+
   (layout
    #:title (simple-format #f "Branch ~A" branch)
    #:head
@@ -230,11 +236,11 @@ td.bad {
                           "No package derivation changes")))
                    (map
                     (match-lambda
-                      ((system . counts)
+                      ((system . derivations)
 
                        (define (count side status)
                          (assoc-ref (assoc-ref
-                                     counts
+                                     derivations
                                      side)
                                     status))
                        `(tr
@@ -248,22 +254,48 @@ td.bad {
                                            0))
                                    `((@ (class "good")))
                                    '())
-                             ,(count 'target 'succeeding))
-                         ,(if (> (count 'target 'failing)
-                                 (count 'base 'failing))
-                              `(td (@ (class "bad"))
-                                   ,(count 'target 'failing))
-                              `(td ,(count 'target 'failing)))
-                         ,(if (> (count 'target 'blocked)
-                                 (count 'base 'blocked))
-                              `(td (@ (class "bad"))
-                                   ,(count 'target 'blocked))
-                              `(td ,(count 'target 'blocked)))
-                         ,(if (> (count 'target 'unknown)
-                                 (count 'base 'unknown))
-                              `(td (@ (class "bad"))
-                                   ,(count 'target 'unknown))
-                              `(td ,(count 'target 'unknown)))
+                             (a (@ (href
+                                    ,(string-append
+                                      "/branch/" branch
+                                      "/package-changes?"
+                                      system "-change=fixed&"
+                                      system "-change=still-working&"
+                                      system "-change=new-working")))
+                                ,(count 'target 'succeeding)))
+                         (td ,@(if (> (count 'target 'failing)
+                                      (count 'base 'failing))
+                                   '((@ (class "bad")))
+                                   '())
+                             (a (@ (href
+                                    ,(string-append
+                                      "/branch/" branch
+                                      "/package-changes?"
+                                      system "-change=broken&"
+                                      system "-change=still-failing&"
+                                      system "-change=new-failing")))
+                                ,(count 'target 'failing)))
+                         (td ,@(if (> (count 'target 'blocked)
+                                      (count 'base 'blocked))
+                                   '((@ (class "bad")))
+                                   '())
+                             (a (@ (href
+                                    ,(string-append
+                                      "/branch/" branch
+                                      "/package-changes?"
+                                      system "-change=blocked&"
+                                      system "-change=still-blocked&"
+                                      system "-change=new-blocked")))
+                                ,(count 'target 'blocked)))
+                         (td (@ ,@(if (> (count 'target 'unknown)
+                                         (count 'base 'unknown))
+                                      '((class "bad"))
+                                      '()))
+                             (a (@ (href
+                                    ,(string-append
+                                      "/branch/" branch
+                                      "/package-changes?"
+                                      system "-change=unknown")))
+                                ,(count 'target 'unknown)))
                          (td (a (@ (href
                                     ,(package-derivations-comparison-link system)))
                                 "View comparison")))))
@@ -312,6 +344,309 @@ td.bad {
                                 params)))
                             '()))))))))))))
 
+(define* (delete-duplicates/sort! unsorted-lst less #:key (eq eq?))
+  (if (null? unsorted-lst)
+      unsorted-lst
+      (let ((sorted-lst (sort! unsorted-lst less)))
+
+        (let loop ((lst (cdr sorted-lst))
+                   (last-element (car sorted-lst))
+                   (result (list (car sorted-lst))))
+          (if (null? lst)
+              result
+              (let ((current-element (car lst)))
+                (if (eq current-element last-element)
+                    (loop (cdr lst)
+                          last-element
+                          result)
+                    (loop (cdr lst)
+                          current-element
+                          (cons current-element
+                                result)))))))))
+
+(define (branch-package-changes-view branch
+                                     revisions
+                                     derivation-changes
+                                     up-to-date-with-master
+                                     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))
+
+  (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)
+            (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         . "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"
+                                     (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"
+                                     (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 (simple-format #f "Branch ~A" branch)
+   #:body
+   `((main
+      (table
+       (form
+        (@ (id "filter-form")
+           (method "get"))
+        (thead
+         (tr
+          (td "Name")
+          (td "Version")
+          ,@(map
+             (lambda (system)
+               `(td ,system
+                    (select
+                     (@ (name
+                         ,(simple-format #f "~A-change"
+                                         system))
+                        (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"))
+                     "Update")))
+             %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 (master-branch-view substitute-availability)
   (layout
    #:title "Branch master"