Rework how processing the derivation comparisons happens

Focus on packages rather than builds, this fixes the unknown count when there
are missing builds.

1 files changed, 74 insertions, 121 deletions

diff --git a/guix-qa-frontpage/derivation-changes.scm b/guix-qa-frontpage/derivation-changes.scm
index fa286a3..1283082 100644
--- a/guix-qa-frontpage/derivation-changes.scm
+++ b/guix-qa-frontpage/derivation-changes.scm
@@ -19,132 +19,76 @@
 (define-module (guix-qa-frontpage derivation-changes)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
-  #:export (builds-by-system-excluding-cross-builds
-            categorise-builds
+  #:export (categorise-packages
             derivation-changes-counts))
 
-(define (builds-by-system-excluding-cross-builds derivation-changes side)
-  (fold (lambda (package result)
-          (fold
-           (lambda (change result)
-             (if (string=? (assoc-ref change "target")
-                           "")
-                 (let ((system (assoc-ref change "system")))
-                   `((,system
-                      . ,(append!
-                          (map
-                           (lambda (build)
-                             `(,@build
-                               ("package"
-                                . (("name" . ,(assoc-ref package "name"))
-                                   ("version" . ,(assoc-ref package "version"))))))
-                           (vector->list (assoc-ref change "builds")))
-                          (or (assoc-ref result system)
-                              '())))
-                     ,@(alist-delete system result)))
-                 result))
-           result
-           (vector->list
-            (assoc-ref package side))))
-        '()
-        derivation-changes))
-
-(define (categorise-builds all-systems builds-by-system)
-  (define (package-eq? a b)
-    (and
-     (string=?
-      (assoc-ref a "name")
-      (assoc-ref b "name"))
-     (string=?
-      (assoc-ref a "version")
-      (assoc-ref b "version"))))
-
-  (define (group-builds-by-package builds)
-    (let ((result (make-hash-table)))
-      (for-each
-       (lambda (build)
-         (let ((package (assoc-ref build "package")))
-           (hash-set! result
-                      package
-                      (cons build
-                            (or (hash-ref result package)
-                                '())))))
-       builds)
-
-      (hash-map->list cons result)))
+(define (categorise-packages derivation-changes side)
+  (fold
+   (match-lambda*
+     ((package result)
+      (fold
+       ;; builds for specific system and target
+       (lambda (details result)
+         (let* ((system (assoc-ref details "system"))
+                (target (assoc-ref details "target"))
+                (build-statuses
+                 ;; Invent a new status here "blocked"
+                 (map (lambda (build)
+                        (let ((status
+                               (assoc-ref build "status")))
+                          (if (and (string=? status "scheduled")
+                                   (assoc-ref build "potentially_blocked"))
+                              "blocked"
+                              status)))
+                      (vector->list
+                       (assoc-ref details "builds"))))
+                (category
+                 (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 systems
-    (map car builds-by-system))
-
-  (map
-   (match-lambda
-     ((system . builds)
-      (let ((builds-by-package
-             (group-builds-by-package builds)))
-        (cons
-         system
-         (fold
-          (match-lambda*
-            (((package . builds) result)
-             (let* ((build-statuses
-                     ;; Invent a new status here "blocked"
-                     (map (lambda (build)
-                            (let ((status
-                                   (assoc-ref build "status")))
-                              (if (and (string=? status "scheduled")
-                                       (assoc-ref build "potentially_blocked"))
-                                  "blocked"
-                                  status)))
-                          builds))
-                    (category
-                     (cond
-                      ((member "succeeded" build-statuses)
-                       'succeeding)
-                      ((and (not (member "suceeded" build-statuses))
-                            (member "failed" build-statuses))
-                       'failing)
-                      ((member "blocked" build-statuses)
-                       'blocked)
-                      (else
-                       'unknown))))
-
-               `((,category . ,(cons
-                                (cons package builds)
-                                (assq-ref result category)))
-                 ,@(alist-delete category result)))))
-          '((succeeding . ())
-            (failing . ())
-            (blocked . ())
-            (unknown . ()))
-          builds-by-package)))))
-
-   (append builds-by-system
-           (map (lambda (system)
-                  (cons system '()))
-                (filter (lambda (system)
-                          (not (member system systems)))
-                        all-systems)))))
+           (let* ((system+target
+                   (if (string-null? target)
+                       system
+                       (cons system target)))
+                  (categorised-packages
+                   (or (assoc-ref result system+target)
+                       '())))
+             `((,system+target
+                .
+                ((,category . ,(cons
+                                (cons (assoc-ref package "name")
+                                      (assoc-ref package "version"))
+                                (or (assq-ref categorised-packages category)
+                                    '())))
+                 ,@(alist-delete category categorised-packages)))
+               ,@(alist-delete system+target result)))))
+       result
+       (vector->list
+        (assoc-ref package side)))))
+   '()
+   derivation-changes))
 
 (define (derivation-changes-counts derivation-changes all-systems)
-  (let* ((base-builds
-          (builds-by-system-excluding-cross-builds
-           derivation-changes "base"))
-         (target-builds
-          (builds-by-system-excluding-cross-builds
-           derivation-changes "target"))
-
-         (categorised-base-builds-by-system
-          (categorise-builds all-systems base-builds))
-         (categorised-target-builds-by-system
-          (categorise-builds all-systems target-builds)))
+  (let* ((categorised-base-packages-by-system
+          (categorise-packages derivation-changes "base"))
+         (categorised-target-packages-by-system
+          (categorise-packages derivation-changes "target")))
 
-    (if (null? target-builds)
+    (if (null? categorised-target-packages-by-system)
         '()
         (map
          (match-lambda
            ((system . categorised-target-builds)
             (let ((categorised-base-builds
-                   (assoc-ref categorised-base-builds-by-system
+                   (assoc-ref categorised-base-packages-by-system
                               system)))
               (cons
                system
@@ -153,15 +97,24 @@
                             (map (lambda (status)
                                    (cons status
                                          (length
-                                          (assoc-ref
-                                           (if (eq? side 'base)
-                                               categorised-base-builds
-                                               categorised-target-builds)
-                                           status))))
+                                          (or
+                                           (assoc-ref
+                                            (if (eq? side 'base)
+                                                categorised-base-builds
+                                                categorised-target-builds)
+                                            status)
+                                           '()))))
                                  '(succeeding failing blocked unknown))))
                     '(base target))))))
          (sort
-          categorised-target-builds-by-system
+          (append categorised-target-packages-by-system
+                  (filter-map
+                   (lambda (system)
+                     (if (assoc-ref categorised-target-packages-by-system
+                                    system)
+                         #f
+                         (cons system '())))
+                   all-systems))
           (lambda (a b)
             (< (or (list-index
                     (lambda (s)