Start requesting all the pages of Patchwork patch series

1 files changed, 64 insertions, 5 deletions

diff --git a/guix-qa-frontpage/patchwork.scm b/guix-qa-frontpage/patchwork.scm
index 0910566..7d2da7d 100644
--- a/guix-qa-frontpage/patchwork.scm
+++ b/guix-qa-frontpage/patchwork.scm
@@ -1,5 +1,7 @@
 (define-module (guix-qa-frontpage patchwork)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (ice-9 regex)
   #:use-module (rnrs bytevectors)
   #:use-module (json)
   #:use-module (web uri)
@@ -14,17 +16,54 @@
 (define %patchwork-instance
   (make-parameter "https://patches.guix-patches.cbaines.net"))
 
+(define %link-regex
+  (make-regexp "<(.*?)>;?(.*)"))
+(define %link-param-regex
+  (make-regexp "\\s*(.*)=(.*)"))
+
+(define (parse-link link)
+  (define (strip-quotes s)
+    (if (and (string-suffix? "\"" s)
+             (string-prefix? "\"" s))
+        (string-drop-right
+         (string-drop s 1)
+         1)
+        s))
+
+  (let ((link-match (regexp-exec %link-regex link)))
+    `((uri    . ,(string->uri (match:substring link-match 1)))
+      ,@(map
+         (lambda (param)
+           (let ((param-match
+                  (regexp-exec %link-param-regex param)))
+             (cons (string->symbol
+                    (match:substring param-match 1))
+                   (strip-quotes
+                    (match:substring param-match 2)))))
+         (string-split (match:substring link-match 2)
+                       #\;)))))
+
 (define* (patchwork-patches
           #:key patchwork
           (archived? #f)
           (order "-id")
           (states '("1" "2" "7" "11")))
+  (define (set-uri-scheme uri scheme)
+    (string->uri
+     (simple-format
+      #f
+      "~A:~A"
+      scheme
+      (string-join
+       (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
@@ -37,10 +76,30 @@
     (let-values (((response body)
                   (http-request uri
                                 #:decode-body? #f)))
-      (values
-       (and body (json-string->scm (utf8->string body)))
-       response)))
+      (append!
+       (vector->list
+        (json-string->scm (utf8->string body)))
+       (or
+        (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)))
+                      (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))))))))
+        '()))))
 
   (retry-on-error (lambda () (make-request initial-uri))
-                  #:times 9
-                  #:delay 10))
+                  #:times 10
+                  #:delay 5))