Better manage the data for issues

Don't use the full derivation changes data when trying to render the page, as
that might be quite large. Instead, compute and cache the counts, and then use
this for rendering.

3 files changed, 220 insertions, 269 deletions

diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm
index 1c5f52d..587a070 100644
--- a/guix-qa-frontpage/issue.scm
+++ b/guix-qa-frontpage/issue.scm
@@ -46,7 +46,7 @@
   (list-ref %overall-statuses
             (apply max (map status-index statuses))))
 
-(define (issue-patches-overall-status derivation-changes mumi-tags)
+(define (issue-patches-overall-status derivation-changes-counts builds-missing? mumi-tags)
   (define %systems-to-consider
     '("x86_64-linux"
       ;; "i686-linux" disabled while resolving bordeaux build issues
@@ -54,65 +54,43 @@
       "armhf-linux"))
 
   (define builds-status
-    (let* ((base-builds
-            (builds-by-system-excluding-cross-builds
-             derivation-changes "base"))
-           (target-builds
-            (builds-by-system-excluding-cross-builds
-             derivation-changes "target"))
-
-           (all-systems
-            (delete-duplicates
-             (append (map car base-builds)
-                     (map car target-builds))))
-
-           (categorised-base-builds-by-system
-            (categorise-builds all-systems base-builds))
-           (categorised-target-builds-by-system
-            (categorise-builds all-systems target-builds)))
-
-      (if (builds-missing-for-derivation-changes? derivation-changes)
-          unknown-status
-          (if (null? target-builds)
-              good-status
-              (worst-status
-               (map
-                (match-lambda
-                  ((system . categorised-target-builds)
-                   (let ((categorised-base-builds
-                          (assoc-ref categorised-base-builds-by-system
-                                     system)))
-                     (define (count side status)
-                       (length
-                        (assoc-ref
-                         (if (eq? side 'base)
-                             categorised-base-builds
-                             categorised-target-builds)
-                         status)))
+    (if builds-missing?
+        unknown-status
+        (if (null? derivation-changes-counts)
+            good-status
+            (worst-status
+             (map
+              (match-lambda
+                ((system . counts)
+                 (define (count side status)
+                   (assoc-ref (assoc-ref
+                               counts
+                               side)
+                              status))
 
-                     (let ((base-failure-count (count 'base 'failing))
-                           (target-failure-count (count 'target 'failing)))
-                       (if (and (<= target-failure-count
-                                    base-failure-count)
-                                (= (count 'target 'unknown) 0))
-                           good-status
-                           (if (= (count 'target 'unknown) 0)
-                               (let ((unblocked-builds
-                                      (- (count 'base 'blocked)
-                                         (count 'target 'blocked)))
-                                     (new-failures
-                                      (- target-failure-count
-                                         base-failure-count)))
-                                 (if (>= unblocked-builds
-                                         new-failures)
-                                     needs-looking-at-status
-                                     bad-status))
-                               unknown-status))))))
-                (filter
-                 (lambda (builds-by-system)
-                   (member (car builds-by-system)
-                           %systems-to-consider))
-                 categorised-target-builds-by-system)))))))
+                 (let ((base-failure-count (count 'base 'failing))
+                       (target-failure-count (count 'target 'failing)))
+                   (if (and (<= target-failure-count
+                                base-failure-count)
+                            (= (count 'target 'unknown) 0))
+                       good-status
+                       (if (= (count 'target 'unknown) 0)
+                           (let ((unblocked-builds
+                                  (- (count 'base 'blocked)
+                                     (count 'target 'blocked)))
+                                 (new-failures
+                                  (- target-failure-count
+                                     base-failure-count)))
+                             (if (>= unblocked-builds
+                                     new-failures)
+                                 needs-looking-at-status
+                                 bad-status))
+                           unknown-status)))))
+              (filter
+               (lambda (builds-by-system)
+                 (member (car builds-by-system)
+                         %systems-to-consider))
+               derivation-changes-counts))))))
 
   (define tags-status
     (if (member "moreinfo" mumi-tags)
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index f770574..219f3f1 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -317,62 +317,17 @@
                                (string->number number))))
          (if series
              (let* ((base-and-target-refs
+                     derivation-changes-counts
+                     change-details
+                     builds-missing?
+                     comparison-details
                      (with-sqlite-cache
                       database
-                      'issue-branch-base-and-target-refs
-                      get-issue-branch-base-and-target-refs
-                      #:args (list (string->number number))
-                      #:ttl 1200
-                      #:store-computed-value? list?))
-                    (derivation-changes-data
-                     change-details
-                     (call-with-values
-                         (lambda ()
-                           (and
-                            base-and-target-refs
-                            (with-exception-handler
-                                (lambda (exn)
-                                  (simple-format
-                                   (current-error-port)
-                                   "exception fetching derivation changes: ~A\n"
-                                   exn)
-
-                                  (values #f #f))
-                              (lambda ()
-                                (with-sqlite-cache
-                                 database
-                                 'derivation-changes
-                                 derivation-changes
-                                 #:args
-                                 (list
-                                  (patch-series-derivation-changes-url
-                                   base-and-target-refs
-                                   #:systems %systems-to-submit-builds-for))
-                                 #:ttl 6000))
-                              #:unwind? #t)))
-                       (lambda res
-                         (match res
-                           ((#f)
-                            (values #f #f))
-                           (_ (apply values res))))))
-                    (comparison-details
-                     (and
-                      base-and-target-refs
-                      (with-exception-handler
-                          (lambda (exn)
-                            (if (guix-data-service-error? exn)
-                                exn
-                                (raise-exception exn)))
-                        (lambda ()
-                          (with-sqlite-cache
-                           database
-                           'lint-warnings
-                           patch-series-comparison
-                           #:args
-                           (list (patch-series-compare-url
-                                  base-and-target-refs))
-                           #:ttl 6000))
-                        #:unwind? #t))))
+                      'issue-data
+                      issue-data
+                      #:args
+                      (list (string->number number))
+                      #:ttl 6000)))
                (render-html
                 #:sxml (issue-view number
                                    series
@@ -382,7 +337,8 @@
                                         (patch-series-compare-url
                                          base-and-target-refs
                                          #:json? #f))
-                                   derivation-changes-data
+                                   derivation-changes-counts
+                                   builds-missing?
                                    change-details
                                    comparison-details)))
              (render-html
@@ -445,6 +401,67 @@ Check if it's already running, or whether another process is using that
 port. Also, the port used can be changed by passing the --port option.\n"
                         port)))))))
 
+(define (issue-data number)
+  (let* ((base-and-target-refs
+          (get-issue-branch-base-and-target-refs
+           number))
+         (derivation-changes-data
+          change-details
+          (call-with-values
+              (lambda ()
+                (and
+                 base-and-target-refs
+                 (with-exception-handler
+                     (lambda (exn)
+                       (simple-format
+                        (current-error-port)
+                        "exception fetching derivation changes: ~A\n"
+                        exn)
+
+                       (values #f #f))
+                   (lambda ()
+                     (derivation-changes
+                      (patch-series-derivation-changes-url
+                       base-and-target-refs
+                       #:systems %systems-to-submit-builds-for)))
+                   #:unwind? #t)))
+            (lambda res
+              (match res
+                ((#f)
+                 (values #f #f))
+                (_ (apply values res))))))
+         (derivation-changes-counts
+          (if derivation-changes-data
+              (derivation-changes-counts
+               derivation-changes-data
+               %systems-to-submit-builds-for)
+              #f))
+         (builds-missing?
+          (if derivation-changes-data
+              (builds-missing-for-derivation-changes?
+               derivation-changes-data)
+              #t))
+         (comparison-details
+          (and
+           base-and-target-refs
+           (with-exception-handler
+               (lambda (exn)
+                 (if (guix-data-service-error? exn)
+                     exn
+                     (raise-exception exn)))
+             (lambda ()
+               (patch-series-comparison
+                (patch-series-compare-url
+                 base-and-target-refs)))
+             #:unwind? #t))))
+
+    (values
+     base-and-target-refs
+     derivation-changes-counts
+     change-details
+     builds-missing?
+     comparison-details)))
+
 (define* (branch-data branch-name)
   (let* ((derivation-changes-data
           change-details
@@ -489,60 +506,53 @@ port. Also, the port used can be changed by passing the --port option.\n"
       (n-par-for-each
        4
        (lambda (series)
-         (let ((derivation-changes-data
-                (with-exception-handler
-                    (lambda (exn)
-                      (unless
-                          (and (guix-data-service-error? exn)
-                               ;; This probably just means the target
-                               ;; revision hasn't been processed yet. The
-                               ;; Guix Data Service should send a more
-                               ;; informative response though.
-                               (and=> (assoc-ref
-                                       (guix-data-service-error-response-body exn)
-                                       "error")
-                                      (lambda (error)
-                                        (string=? error
-                                                  "invalid query"))))
-                        (simple-format
-                         (current-error-port)
-                         "failed fetching derivation changes for issue ~A: ~A\n"
-                         (car series)
-                         exn))
-
-                      #f)
-                  (lambda ()
-                    (and=>
-                     (with-sqlite-cache
-                      database
-                      'issue-branch-base-and-target-refs
-                      get-issue-branch-base-and-target-refs
-                      #:args (list (car series))
-                      #:ttl 0
-                      #:store-computed-value? list?)
-                     (lambda (base-and-target-refs)
-                       (with-sqlite-cache
-                        database
-                        'derivation-changes
-                        derivation-changes
-                        #:args
-                        (list (patch-series-derivation-changes-url
-                               base-and-target-refs
-                               #:systems %systems-to-submit-builds-for))
-                        #:ttl (/ frequency 2)))))
-                  #:unwind? #t)))
-
-           (and derivation-changes-data
-                (with-sqlite-cache
-                 database
-                 'issue-patches-overall-status
-                 (lambda (id)
-                   (issue-patches-overall-status
-                    derivation-changes-data
-                    (assq-ref (assq-ref series 'mumi)
-                              'tags)))
-                 #:args (list (car series))
-                 #:ttl 0))))
+         (with-exception-handler
+             (lambda (exn)
+               (unless
+                   (and (guix-data-service-error? exn)
+                        ;; This probably just means the target
+                        ;; revision hasn't been processed yet. The
+                        ;; Guix Data Service should send a more
+                        ;; informative response though.
+                        (and=> (assoc-ref
+                                (guix-data-service-error-response-body exn)
+                                "error")
+                               (lambda (error)
+                                 (string=? error
+                                           "invalid query"))))
+                 (simple-format
+                  (current-error-port)
+                  "failed fetching derivation changes for issue ~A: ~A\n"
+                  (car series)
+                  exn))
+
+               #f)
+           (lambda ()
+             (let ((base-and-target-refs
+                    derivation-changes-counts
+                    change-details
+                    builds-missing?
+                    comparison-details
+                    (with-sqlite-cache
+                     database
+                     'issue-data
+                     issue-data
+                     #:args
+                     (list (car series))
+                     #:ttl 6000)))
+
+               (with-sqlite-cache
+                database
+                'issue-patches-overall-status
+                (lambda (id)
+                  (issue-patches-overall-status
+                   derivation-changes-counts
+                   builds-missing?
+                   (assq-ref (assq-ref series 'mumi)
+                             'tags)))
+                #:args (list (car series))
+                #:ttl 0)))
+           #:unwind? #t))
        series-to-refresh)))
 
   (call-with-new-thread
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm
index 2109f54..186797e 100644
--- a/guix-qa-frontpage/view/issue.scm
+++ b/guix-qa-frontpage/view/issue.scm
@@ -11,7 +11,8 @@
 
 (define (issue-view issue-number series mumi-tags
                     comparison-link
-                    derivation-changes
+                    derivation-changes-counts
+                    builds-missing?
                     change-details comparison-details)
 
   (define* (package-derivations-comparison-link system
@@ -235,106 +236,68 @@ td.bad {
         (tbody
          ,@(if (and comparison-details
                     (not (guix-data-service-error? comparison-details))
-                    derivation-changes
-                    (not (builds-missing-for-derivation-changes?
-                          derivation-changes)))
-               (let* ((base-builds
-                       (builds-by-system-excluding-cross-builds
-                        derivation-changes "base"))
-                      (target-builds
-                       (builds-by-system-excluding-cross-builds
-                        derivation-changes "target"))
-
-                      (all-systems
-                       (delete-duplicates
-                        (append (map car base-builds)
-                                (map car target-builds))))
-
-                      (categorised-base-builds-by-system
-                       (categorise-builds all-systems base-builds))
-                      (categorised-target-builds-by-system
-                       (categorise-builds all-systems target-builds)))
-
-                 (if (null? target-builds)
-                     `((tr
-                        (td (@ (colspan 10))
-                            "No package derivation changes"
-                            (br)
-                            (small "(for the following systems: "
-                                   ,@(drop-right
-                                      (append-map
-                                       (lambda (system)
-                                         `((span (@ (style "font-family: monospace;"))
-                                                 ,system)
-                                           ", "))
-                                       %systems-to-submit-builds-for)
-                                      1)
-                                   ")"))))
-                     (map
-                      (match-lambda
-                        ((system . categorised-target-builds)
-                         (let ((categorised-base-builds
-                                (assoc-ref categorised-base-builds-by-system
-                                           system))
-                               (highlighed-common
-                                " "))
-                           (define (count side status)
-                             (length
-                              (assoc-ref
-                               (if (eq? side 'base)
-                                   categorised-base-builds
-                                   categorised-target-builds)
-                               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")))
-                                       '())
-                                 ,(count 'target 'succeeding))
-                             ,(if (> (count 'target 'failing)
-                                     (count 'base 'failing))
-                                  `(td (@ (class "bad"))
-                                       (a (@ (href ,(package-derivations-comparison-link
-                                                     system
-                                                     #:build-change "broken")))
-                                          ,(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"))
-                                       (a (@ (href ,(package-derivations-comparison-link
-                                                     system
-                                                     #:build-change "unknown")))
-                                          ,(count 'target 'unknown)))
-                                  `(td ,(count 'target 'unknown)))
-                             (td (a (@ (href
-                                        ,(package-derivations-comparison-link system)))
-                                    "View comparison"))))))
-                      (sort
-                       categorised-target-builds-by-system
-                       (lambda (a b)
-                         (< (or (list-index
-                                 (lambda (s)
-                                   (string=? (car a) s))
-                                 %systems-to-submit-builds-for)
-                                10)
-                            (or (list-index
-                                 (lambda (s)
-                                   (string=? (car b) s))
-                                 %systems-to-submit-builds-for)
-                                10)))))))
+                    derivation-changes-counts
+                    (not builds-missing?))
+               (if (null? derivation-changes-counts)
+                   `((tr
+                      (td (@ (colspan 10))
+                          "No package derivation changes"
+                          (br)
+                          (small "(for the following systems: "
+                                 ,@(drop-right
+                                    (append-map
+                                     (lambda (system)
+                                       `((span (@ (style "font-family: monospace;"))
+                                               ,system)
+                                         ", "))
+                                     %systems-to-submit-builds-for)
+                                    1)
+                                 ")"))))
+                   (map
+                    (match-lambda
+                      ((system . counts)
+                       (define (count side status)
+                         (assoc-ref (assoc-ref
+                                     counts
+                                     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")))
+                                   '())
+                             ,(count 'target 'succeeding))
+                         ,(if (> (count 'target 'failing)
+                                 (count 'base 'failing))
+                              `(td (@ (class "bad"))
+                                   (a (@ (href ,(package-derivations-comparison-link
+                                                 system
+                                                 #:build-change "broken")))
+                                      ,(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"))
+                                   (a (@ (href ,(package-derivations-comparison-link
+                                                 system
+                                                 #:build-change "unknown")))
+                                      ,(count 'target 'unknown)))
+                              `(td ,(count 'target 'unknown)))
+                         (td (a (@ (href
+                                    ,(package-derivations-comparison-link system)))
+                                "View comparison")))))
+                    derivation-changes-counts))
                `((tr
                   (td (@ (colspan 10)
                          (class "bad"))