Query for branch changes by system

And don't store the full data in the database, just the counts. This should
avoid timeout issues with the data service and speed up storing and fetching
the data from the cache.

5 files changed, 101 insertions, 99 deletions

diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm
index 719b350..b372992 100644
--- a/guix-qa-frontpage/branch.scm
+++ b/guix-qa-frontpage/branch.scm
@@ -26,6 +26,8 @@
   #:use-module (prometheus)
   #:use-module ((guix-build-coordinator utils)
                 #:select (with-time-logging))
+  #:use-module ((guix-build-coordinator utils fibers)
+                #:select (retry-on-error))
   #:use-module ((guix build syscalls)
                 #:select (set-thread-name))
   #:use-module (fibers)
@@ -38,6 +40,7 @@
   #:use-module (guix-qa-frontpage manage-builds)
   #:export (list-non-master-branches
 
+            branch-derivation-changes-data
             branch-data
             master-branch-data
 
@@ -182,6 +185,16 @@
           (newline (current-error-port)))))
     #:unwind? #t))
 
+(define (branch-derivation-changes-data revisions system)
+  (with-exception-handler guix-data-service-error->sexp
+    (lambda ()
+      (compare-package-derivations
+       (compare-package-derivations-url
+        revisions
+        #:systems (list system))))
+    #:unwind? #t
+    #:unwind-for-type &guix-data-service-error))
+
 (define* (branch-data branch-name)
   (define branch-commit
     (get-commit
@@ -217,24 +230,16 @@
              #:unwind? #t
              #:unwind-for-type &guix-data-service-error))
 
-          (derivation-changes-data
-           (with-exception-handler guix-data-service-error->sexp
-             (lambda ()
-               (let ((data
-                      (compare-package-derivations
-                       (compare-package-derivations-url
-                        revisions
-                        #:systems %systems-to-submit-builds-for))))
-
-                 (with-throw-handler #t
-                   (lambda ()
-                     (derivation-changes
-                      data
-                      %systems-to-submit-builds-for))
-                   (lambda _
-                     (backtrace)))))
-             #:unwind? #t
-             #:unwind-for-type &guix-data-service-error))
+          (derivation-changes-counts
+           (append-map
+            (lambda (system)
+              (derivation-changes-counts
+               (retry-on-error
+                (lambda ()
+                  (branch-derivation-changes-data revisions system))
+                #:times 1)
+               (list system)))
+            %systems-to-submit-builds-for))
 
           (substitute-availability
            (with-exception-handler guix-data-service-error->sexp
@@ -250,7 +255,7 @@
             (package-reproducibility-url branch-commit))))
      (values
       revisions
-      derivation-changes-data
+      derivation-changes-counts
       substitute-availability
       package-reproducibility
       up-to-date-with-master?))
diff --git a/guix-qa-frontpage/derivation-changes.scm b/guix-qa-frontpage/derivation-changes.scm
index cda0084..eab021e 100644
--- a/guix-qa-frontpage/derivation-changes.scm
+++ b/guix-qa-frontpage/derivation-changes.scm
@@ -21,7 +21,7 @@
   #:use-module (srfi srfi-43)
   #:use-module (ice-9 match)
   #:export (categorise-packages
-            derivation-changes))
+            derivation-changes-counts))
 
 (define (categorise-packages derivation-changes side)
   (define (vector-member? s v)
@@ -82,7 +82,7 @@
    '()
    derivation-changes))
 
-(define (derivation-changes derivation-changes all-systems)
+(define (derivation-changes-counts derivation-changes all-systems)
   (define categorised-base-packages-by-system
     (categorise-packages (assoc-ref derivation-changes
                                     "derivation_changes")
@@ -93,61 +93,57 @@
                                     "derivation_changes")
                          "target"))
 
-  (define counts
-    (if (null? categorised-target-packages-by-system)
-        '()
-        (map
-         (match-lambda
-           ((system . categorised-target-builds)
-            (let ((categorised-base-builds
-                   (assoc-ref categorised-base-packages-by-system
-                              system)))
-              (cons
-               system
-               (map (lambda (side)
-                      (cons side
-                            (map (lambda (status)
-                                   (cons status
-                                         (length
-                                          (or
-                                           (assoc-ref
-                                            (if (eq? side 'base)
-                                                categorised-base-builds
-                                                categorised-target-builds)
-                                            status)
-                                           '()))))
-                                 '(succeeding failing blocked unknown))))
-                    '(base target))))))
-         (sort
-          (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)
-            (let ((a-key (car a))
-                  (b-key (car b)))
-              (cond
-               ((and (string? a-key)
-                     (string? b-key))
-                (< (or (list-index
-                        (lambda (s)
-                          (string=? (car a) s))
-                        all-systems)
-                       10)
-                   (or (list-index
-                        (lambda (s)
-                          (string=? (car b) s))
-                        all-systems)
-                       10)))
-               ((and (pair? a-key)
-                     (pair? b-key))
-                (string<? (cdr a-key)
-                          (cdr b-key)))
-               (else #f))))))))
-
-  `(,@derivation-changes
-    (counts  . ,counts)))
+  (if (null? categorised-target-packages-by-system)
+      '()
+      (map
+       (match-lambda
+         ((system . categorised-target-builds)
+          (let ((categorised-base-builds
+                 (assoc-ref categorised-base-packages-by-system
+                            system)))
+            (cons
+             system
+             (map (lambda (side)
+                    (cons side
+                          (map (lambda (status)
+                                 (cons status
+                                       (length
+                                        (or
+                                         (assoc-ref
+                                          (if (eq? side 'base)
+                                              categorised-base-builds
+                                              categorised-target-builds)
+                                          status)
+                                         '()))))
+                               '(succeeding failing blocked unknown))))
+                  '(base target))))))
+       (sort
+        (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)
+          (let ((a-key (car a))
+                (b-key (car b)))
+            (cond
+             ((and (string? a-key)
+                   (string? b-key))
+              (< (or (list-index
+                      (lambda (s)
+                        (string=? (car a) s))
+                      all-systems)
+                     10)
+                 (or (list-index
+                      (lambda (s)
+                        (string=? (car b) s))
+                      all-systems)
+                     10)))
+             ((and (pair? a-key)
+                   (pair? b-key))
+              (string<? (cdr a-key)
+                        (cdr b-key)))
+             (else #f))))))))
diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm
index dfc5587..a32574f 100644
--- a/guix-qa-frontpage/issue.scm
+++ b/guix-qa-frontpage/issue.scm
@@ -231,12 +231,15 @@
          (derivation-changes-data
           (if (and derivation-changes-raw-data
                    (not (assq-ref derivation-changes-raw-data 'exception)))
-              (call-with-delay-logging
-               derivation-changes
-               #:args
-               (list
-                derivation-changes-raw-data
-                %systems-to-submit-builds-for))
+              (cons
+               (cons 'counts
+                     (call-with-delay-logging
+                      derivation-changes-counts
+                      #:args
+                      (list
+                       derivation-changes-raw-data
+                       %systems-to-submit-builds-for)))
+               derivation-changes-raw-data)
               #f))
          (cross-derivation-changes-raw-data
           (if base-and-target-refs
@@ -253,12 +256,15 @@
          (cross-derivation-changes-data
           (if (and cross-derivation-changes-raw-data
                    (not (assq-ref cross-derivation-changes-raw-data 'exception)))
-              (call-with-delay-logging
-               derivation-changes
-               #:args
-               (list
-                cross-derivation-changes-raw-data
-                %systems-to-submit-builds-for))
+              (cons
+               (cons 'counts
+                     (call-with-delay-logging
+                      derivation-changes-counts
+                      #:args
+                      (list
+                       cross-derivation-changes-raw-data
+                       %systems-to-submit-builds-for)))
+               cross-derivation-changes-raw-data)
               #f))
          (builds-missing?
           (if derivation-changes-data
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index a46777a..fbfe29c 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -186,7 +186,7 @@
                               package-reproducibility))))
       (('GET "branch" branch)
        (let ((revisions
-              derivation-changes
+              derivation-changes-counts
               substitute-availability
               package-reproducibility
               up-to-date-with-master
@@ -211,7 +211,7 @@
           #:sxml
           (branch-view branch
                        revisions
-                       derivation-changes
+                       derivation-changes-counts
                        substitute-availability
                        package-reproducibility
                        up-to-date-with-master
diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm
index 5c7c94f..a6a6436 100644
--- a/guix-qa-frontpage/view/branch.scm
+++ b/guix-qa-frontpage/view/branch.scm
@@ -13,16 +13,11 @@
 
             master-branch-view))
 
-(define (branch-view branch revisions derivation-changes
+(define (branch-view branch revisions derivation-changes-counts
                      substitute-availability
                      package-reproducibility
                      up-to-date-with-master
                      master-branch-systems-with-low-substitute-availability)
-  (define derivation-changes-counts
-    (if (assq-ref derivation-changes 'exception)
-        derivation-changes
-        (assq-ref derivation-changes 'counts)))
-
   (layout
    #:title (simple-format #f "Branch ~A" branch)
    #:head