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.

1 files changed, 158 insertions, 144 deletions

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)))))))
+
+
+
+