Refactor fetching data from patchwork

Fetch pages one at a time until the required number of patch series has been
fetched.

This commit also changes the ordering from issue number to the series ID,
which will mean that series associated with older issues will be prefered over
newer issues with older series.

7 files changed, 181 insertions, 175 deletions

diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm
index e0da210..8563105 100644
--- a/guix-qa-frontpage/issue.scm
+++ b/guix-qa-frontpage/issue.scm
@@ -285,8 +285,7 @@
 (define* (start-refresh-patch-branches-data-thread
           database
           metrics-registry
-          #:key
-          (number-of-series-to-refresh 250))
+          #:key number-of-series-to-refresh)
   (define frequency
     (* 15 60))
 
@@ -298,7 +297,8 @@
              database
              'latest-patchwork-series-by-issue
              latest-patchwork-series-by-issue
-             #:ttl (/ frequency 2)))
+             #:ttl (/ frequency 2)
+             #:args `(#:count ,number-of-series-to-refresh)))
            (series-to-refresh
             (if (> (length latest-series)
                    number-of-series-to-refresh)
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index 3dca456..e1d175f 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -131,7 +131,7 @@
                                           build-coordinator
                                           guix-data-service
                                           metrics-registry
-                                          #:key (series-count 200))
+                                          #:key series-count)
   (define (priority-for-change change)
     (if (member (assoc-ref change "system")
                 '("x86_64-linux" "aarch64-linux"))
@@ -144,7 +144,8 @@
              database
              'latest-patchwork-series-by-issue
              latest-patchwork-series-by-issue
-             #:ttl 3000))
+             #:ttl 3000
+             #:args `(#:count ,series-count)))
            (first-n-series
             (take all-series series-count))
            (first-n-series-issue-numbers
diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm
index 56155f5..fd7188a 100644
--- a/guix-qa-frontpage/manage-patch-branches.scm
+++ b/guix-qa-frontpage/manage-patch-branches.scm
@@ -160,17 +160,6 @@
                                 'issue-patches-overall-status
                                 #:args (list issue-number)))
 
-    (define series-data
-      (call-with-values
-          (lambda ()
-            (http-get (string->uri
-                       (string-append
-                        (%patchwork-instance) "/api/1.0"
-                        "/series/" patchwork-series "/"))
-                      #:streaming? #t))
-        (lambda (response body)
-          (json->scm body))))
-
     (define (insert-log results)
       (define log
         (string-join
@@ -182,14 +171,14 @@
 
       (insert-create-branch-for-issue-log database issue-number log))
 
-    (if (assoc-ref series-data "received_all")
+    (if (assoc-ref patchwork-series "received_all")
         (begin
           (simple-format #t "all patches have been received\n")
           (create-base-tag)
 
           (let loop ((patch-data
                       (vector->list
-                       (assoc-ref series-data "patches")))
+                       (assoc-ref patchwork-series "patches")))
                      (results '()))
             (if (null? patch-data)
                 (begin
@@ -291,7 +280,7 @@
 
 (define* (start-manage-patch-branches-thread database
                                              metrics-registry
-                                             #:key (series-count 200))
+                                             #:key series-count)
   (define (dig alist . parts)
     (if (pair? alist)
         (match parts
@@ -401,6 +390,7 @@
              database
              'latest-patchwork-series-by-issue
              latest-patchwork-series-by-issue
+             #:args `(#:count ,series-count)
              #:ttl 120))
            (issue-numbers
             (map string->number
diff --git a/guix-qa-frontpage/patchwork.scm b/guix-qa-frontpage/patchwork.scm
index 7f2de19..42ddfb7 100644
--- a/guix-qa-frontpage/patchwork.scm
+++ b/guix-qa-frontpage/patchwork.scm
@@ -1,6 +1,8 @@
 (define-module (guix-qa-frontpage patchwork)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-43)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
@@ -14,7 +16,6 @@
   #:use-module (guix-qa-frontpage debbugs)
   #:export (%patchwork-instance
 
-            patchwork-patches
             latest-patchwork-series-by-issue))
 
 (define %patchwork-instance
@@ -47,12 +48,17 @@
          (string-split (match:substring link-match 2)
                        #\;)))))
 
-(define* (patchwork-patches
-          #:key patchwork
-          (archived? #f)
-          (order "-id")
-          (states '("1" "2" "7" "11"))
-          pages)
+(define* (patchwork-series-uri #:key patchwork
+                               (per-page 200)
+                               (order "-id"))
+  (string->uri
+   (string-append (or patchwork
+                      (%patchwork-instance))
+                  "/api/series/?"
+                  "per_page=" (number->string per-page) "&"
+                  "order=" order "&")))
+
+(define (request-patchwork-series uri)
   (define (set-uri-scheme uri scheme)
     (string->uri
      (simple-format
@@ -63,147 +69,155 @@
        (drop (string-split (uri->string uri) #\:) 1)
        ":"))))
 
-  (define initial-uri
-    (string->uri
-     (string-append (or patchwork
-                        (%patchwork-instance))
-                    "/api/patches/?"
-                    "per_page=500&"
-                    "order=" order "&"
-                    "archived=" (if archived? "true" "false") "&"
-                    (string-join
-                     (map (lambda (state)
-                            (string-append "state=" state))
-                          states)
-                     "&"))))
-
-  (define (make-request uri page-count)
-    (let-values (((response body)
-                  (retry-on-error
-                   (lambda ()
-                     (http-request uri
-                                   #:decode-body? #f))
-                   #:times 2
-                   #:delay 3)))
-      (append!
-       (vector->list
-        (json-string->scm (utf8->string body)))
-       (or
-        (and=> (if (and pages
-                        (> page-count pages))
-                   #f
-                   (assq-ref (response-headers response)
-                             'link))
-               (lambda (link-header)
-                 (and=>
-                  (find (lambda (link)
-                          (let ((link-details (parse-link link)))
-                            (string=?
-                             (assq-ref link-details 'rel)
-                             "next")))
-                        (string-split link-header #\,))
-                  (lambda (next-link)
-                    (let ((link-details (parse-link next-link)))
-                      (make-request
-                       ;; The link headers don't use https, so to
-                       ;; avoid the redirect, modify the URI
-                       (set-uri-scheme
-                        (assq-ref link-details 'uri)
-                        (uri-scheme uri))
-                       (+ 1 page-count)))))))
-        '()))))
-
-  (make-request initial-uri 1))
+  (let ((response
+         body
+         (retry-on-error
+          (lambda ()
+            (http-request uri
+                          #:decode-body? #f))
+          #:times 2
+          #:delay 3)))
+
+    (values
+     (json-string->scm (utf8->string body))
+     (and=> (assq-ref (response-headers response) 'link)
+            (lambda (link-header)
+              (and=>
+               (find (lambda (link)
+                       (let ((link-details (parse-link link)))
+                         (string=?
+                          (assq-ref link-details 'rel)
+                          "next")))
+                     (string-split link-header #\,))
+               (lambda (next-link)
+                 (let ((link-details (parse-link next-link)))
+                   (set-uri-scheme
+                    (assq-ref link-details 'uri)
+                    (uri-scheme uri))))))))))
 
 (define* (latest-patchwork-series-by-issue
-          #:key patchwork)
-  (define (patch->issue-number patch)
+          #:key patchwork
+          count)
+  (define (string->issue-number str)
     (string->number
      (match:substring
-      (string-match "\\[?bug#([0-9]*)(,|:|\\])"
-                    (assoc-ref patch "name"))
+      (string-match "\\[?bug#([0-9]*)(,|:|\\])" str)
       1)))
 
-  (let ((result
-         (make-hash-table 2048)))
-
-    (for-each
-     (lambda (patch)
-       (let ((issue-number
-              (patch->issue-number patch))
-             (patch-series
-              (assoc-ref patch "series")))
-
-         ;; Some patches are missing series when patchwork has trouble
-         ;; processing them
-         (when (not (eq? (vector-length patch-series) 0))
-           (or (and=>
-                (hash-ref result issue-number)
-                (lambda (series)
-                  (let ((patch-series-number
-                         (assoc-ref (vector-ref patch-series 0)
-                                    "id")))
-                    (when (eq? (assoc-ref series "id")
-                               patch-series-number)
-                      (hash-set!
-                       result
-                       issue-number
-                       `(,@(alist-delete "patches" series)
-                         ("patches" . (,@(assoc-ref series "patches")
-                                       ,patch))))))))
-               (hash-set!
-                result
-                issue-number
-                `(,@(vector-ref patch-series 0)
-                  ("patches" . (,patch))))))))
-     (patchwork-patches #:patchwork patchwork
-                        #:pages 10))
-
-    (let* ((data (hash-map->list cons result))
-           (mumi-data
-            (call-with-delay-logging mumi-bulk-issues
-                                     #:args
-                                     (list
-                                      (map first data))))
-           (debbugs-guix-usertag-data
-            (call-with-delay-logging debbugs-get-issues-with-guix-usertag))
-           (usertag-lookup
-            (let ((hash-table (make-hash-table)))
-              (for-each
-               (match-lambda
-                 ((tag . issues)
+  (define issue-number-to-series-hash-table
+    (make-hash-table))
+
+  (let loop ((patchwork-uri
+              (patchwork-series-uri
+               #:patchwork patchwork
+               #:per-page 200))
+
+             (result '()))
+
+    (if (> (peek "LEN" (length result)) count)
+        (let* ((count-items
+                rest
+                (split-at! result count))
+
+               (debbugs-guix-usertag-data
+                (call-with-delay-logging debbugs-get-issues-with-guix-usertag))
+               (usertag-lookup
+                (let ((hash-table (make-hash-table)))
                   (for-each
-                   (lambda (issue)
-                     (hash-set! hash-table
-                                issue
-                                (cons tag
-                                      (or (hash-ref hash-table issue)
-                                          '()))))
-                   (if (pair? issues)
-                       issues
-                       (list issues)))))
-               debbugs-guix-usertag-data)
-              hash-table)))
-      (sort!
-       (filter-map (lambda (data mumi)
-                     (let ((issue-number (car data)))
-                       (if (and (assq-ref mumi 'open?)
-                                (every
-                                 (lambda (merged-issue-number)
-                                   (if (< merged-issue-number
-                                          issue-number)
-                                       (not (hash-ref result merged-issue-number))
-                                       #t))
-                                 (assq-ref mumi 'merged-with)))
-                           `(,@data
-                             (mumi . ,mumi)
-                             (usertags . ,(or (hash-ref usertag-lookup
-                                                        (car data))
-                                              '())))
-                           #f)))
-                   data
-                   mumi-data)
-       (lambda (a b)
-         ;; Sort by issue number
-         (> (first a)
-            (first b)))))))
+                   (match-lambda
+                     ((tag . issues)
+                      (for-each
+                       (lambda (issue)
+                         (hash-set! hash-table
+                                    issue
+                                    (cons tag
+                                          (or (hash-ref hash-table issue)
+                                              '()))))
+                       (if (pair? issues)
+                           issues
+                           (list issues)))))
+                   debbugs-guix-usertag-data)
+                  hash-table)))
+
+          (map!
+           (lambda (data)
+             `(,@data
+               (usertags . ,(or (hash-ref usertag-lookup
+                                          (car data))
+                                '()))))
+           count-items))
+
+        ;; Need more series, so keep going
+        (let* ((series-batch
+                next-page-uri
+                (request-patchwork-series patchwork-uri))
+
+               (batch-hash-table
+                (make-hash-table)))
+
+          (vector-for-each
+           (lambda (_ series-data)
+             (let* ((patches
+                     (assoc-ref series-data "patches"))
+                    (issue-number
+                     (if (= 0 (vector-length patches))
+                         (let ((cover-letter
+                                (assoc-ref series-data "cover_letter")))
+                           (and cover-letter
+                                (not (eq? 'null cover-letter))
+                                (string->issue-number
+                                 (assoc-ref cover-letter "name"))))
+                         (string->issue-number
+                          (assoc-ref
+                           (vector-ref (assoc-ref series-data "patches")
+                                       0)
+                           "name")))))
+
+               (when (and issue-number
+                          (not (hash-ref issue-number-to-series-hash-table
+                                         issue-number)))
+                 (hash-set! issue-number-to-series-hash-table
+                            issue-number
+                            series-data)
+                 (hash-set! batch-hash-table
+                            issue-number
+                            series-data))))
+           series-batch)
+
+          (let* ((series-by-issue-number
+                  (hash-map->list
+                   cons
+                   batch-hash-table))
+
+                 (mumi-data
+                  (call-with-delay-logging mumi-bulk-issues
+                                           #:args
+                                           (list
+                                            (map first series-by-issue-number)))))
+            (loop
+             next-page-uri
+             (fold
+              (lambda (data mumi result)
+                (let ((issue-number (car data)))
+                  (if (and (assq-ref mumi 'open?)
+                           (every
+                            (lambda (merged-issue-number)
+                              (if (< merged-issue-number
+                                     issue-number)
+                                  (not (hash-ref
+                                        issue-number-to-series-hash-table
+                                        merged-issue-number))
+                                  #t))
+                            (assq-ref mumi 'merged-with)))
+                      (cons
+                       `(,@data
+                         (mumi . ,mumi))
+                       result)
+                      result)))
+              result
+              series-by-issue-number
+              mumi-data)))))))
+
+
+
+
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index f397011..85e760f 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -78,7 +78,7 @@
           branches)))
 
 (define* (make-controller assets-directory database metrics-registry
-                          #:key (patch-issues-to-show 200)
+                          #:key patch-issues-to-show
                           doc-dir)
 
   (define handle-static-assets
@@ -215,6 +215,7 @@
                 database
                 'latest-patchwork-series-by-issue
                 latest-patchwork-series-by-issue
+                #:args `(#:count ,patch-issues-to-show)
                 #:ttl 1800))
               (query-params
                (or (and=>
@@ -295,10 +296,7 @@
                  %systems-with-expected-low-substitute-availability))))
          (render-html
           #:sxml
-          (patches-view (if (> (length sorted-latest-series)
-                               patch-issues-to-show)
-                            (take sorted-latest-series patch-issues-to-show)
-                            sorted-latest-series)
+          (patches-view sorted-latest-series
                         filtered-statuses
                         systems-with-low-substitute-availability))))
       (('GET "issue" (? (lambda (s) (string-suffix? ".svg" s)) number.svg))
@@ -504,6 +502,7 @@
                                 database
                                 'latest-patchwork-series-by-issue
                                 latest-patchwork-series-by-issue
+                                #:args `(#:count ,patch-issues-to-show)
                                 #:ttl 1800)
                                (string->number number))))
          (if series
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm
index e149cc4..55f0193 100644
--- a/guix-qa-frontpage/view/issue.scm
+++ b/guix-qa-frontpage/view/issue.scm
@@ -354,7 +354,8 @@ div.bad {
        ,@(map
           (lambda (patch)
             `(li ,(assoc-ref patch "name")))
-          (assoc-ref series "patches")))
+          (vector->list
+           (assoc-ref series "patches"))))
 
       ,@(if base-and-target-refs
             `(,lint-warnings-div
@@ -364,7 +365,8 @@ div.bad {
                    (@ (class "bad")
                       (style "width: fit-content;"))
                    (h3 "Unable to apply "
-                       ,(if (= 0 (length (assoc-ref series "patches")))
+                       ,(if (= 0 (vector-length
+                                  (assoc-ref series "patches")))
                             "patch"
                             "patches"))
                    (pre ,create-branch-for-issue-log)))
diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in
index 256164a..8be8a7a 100644
--- a/scripts/guix-qa-frontpage.in
+++ b/scripts/guix-qa-frontpage.in
@@ -151,6 +151,8 @@
      (error "extraneous argument" arg))
    defaults))
 
+(define patch-issues-to-show 200)
+
 (setvbuf (current-output-port) 'line)
 (setvbuf (current-error-port) 'line)
 
@@ -228,6 +230,7 @@
               database
               'latest-patchwork-series-by-issue
               latest-patchwork-series-by-issue
+              #:args `(#:count ,patch-issues-to-show)
               #:ttl 600)))
 
        (create-branch-for-issue
@@ -271,15 +274,12 @@
                                  "guixqafrontpage"))
               (database
                (setup-database (assq-ref opts 'database)
-                               metrics-registry))
-
-              (patch-issues-to-show 250))
+                               metrics-registry)))
 
          (start-refresh-patch-branches-data-thread
           database
           metrics-registry
-          #:number-of-series-to-refresh
-          (+ patch-issues-to-show 50))
+          #:number-of-series-to-refresh patch-issues-to-show)
          (start-refresh-non-patch-branches-data-thread database
                                                        metrics-registry)