Cache connections when talking to mumi

1 files changed, 117 insertions, 48 deletions

diff --git a/guix-qa-frontpage/mumi.scm b/guix-qa-frontpage/mumi.scm
index 94c1842..80f3646 100644
--- a/guix-qa-frontpage/mumi.scm
+++ b/guix-qa-frontpage/mumi.scm
@@ -18,6 +18,7 @@
 
 (define-module (guix-qa-frontpage mumi)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:use-module (json)
   #:use-module (kolam http)
@@ -33,6 +34,75 @@
 
             mumi-bulk-issues))
 
+(define (at-most max-length lst)
+  "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
+return its MAX-LENGTH first elements and its tail."
+  (let loop ((len 0)
+             (lst lst)
+             (result '()))
+    (match lst
+      (()
+       (values (reverse result) '()))
+      ((head . tail)
+       (if (>= len max-length)
+           (values (reverse result) lst)
+           (loop (+ 1 len) tail (cons head result)))))))
+
+(define %max-cached-connections
+  ;; Maximum number of connections kept in cache by
+  ;; 'open-connection-for-uri/cached'.
+  16)
+
+(define open-socket-for-uri/cached
+  (let ((cache '()))
+    (lambda* (uri #:key fresh? verify-certificate?)
+      "Return a connection for URI, possibly reusing a cached connection.
+When FRESH? is true, delete any cached connections for URI and open a new one.
+Return #f if URI's scheme is 'file' or #f.
+
+When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
+      (define host (uri-host uri))
+      (define scheme (uri-scheme uri))
+      (define key (list host scheme (uri-port uri)))
+
+      (and (not (memq scheme '(file #f)))
+           (match (assoc-ref cache key)
+             (#f
+              ;; Open a new connection to URI and evict old entries from
+              ;; CACHE, if any.
+              (let ((socket
+                     (open-socket-for-uri
+                      uri
+                      #:verify-certificate? verify-certificate?))
+                    (new-cache evicted
+                               (at-most (- %max-cached-connections 1) cache)))
+                (for-each (match-lambda
+                            ((_ . port)
+                             (false-if-exception (close-port port))))
+                          evicted)
+                (set! cache (alist-cons key socket new-cache))
+                socket))
+             (socket
+              (if (or fresh? (port-closed? socket))
+                  (begin
+                    (false-if-exception (close-port socket))
+                    (set! cache (alist-delete key cache))
+                    (open-socket-for-uri/cached uri
+                                                    #:verify-certificate?
+                                                    verify-certificate?))
+                  (begin
+                    ;; Drain input left from the previous use.
+                    (drain-input socket)
+                    socket))))))))
+
+(define (call-with-cached-connection uri proc)
+  (let ((port (open-socket-for-uri/cached uri)))
+    (with-throw-handler #t
+      (lambda ()
+        (proc port))
+      (lambda _
+        (close-port port)))))
+
 (define* (graphql-http-get*
           uri document
           #:key (verify-certificate? #t)
@@ -43,22 +113,25 @@
           (variables '()))
   (call-with-values
       (lambda ()
-        (http-get
-         (string-append uri
-                        "?query="
-                        (uri-encode (scm->graphql-string document))
-                        "&"
-                        "variables="
-                        (uri-encode (scm->json-string
-                                     ((@@ (kolam http) variables->alist)
-                                      variables))))
-         #:streaming? #t
-         #:keep-alive? keep-alive?
-         #:verify-certificate? verify-certificate?
-         #:port port))
+        (let ((response
+               body
+               (http-get
+                (string-append uri
+                               "?query="
+                               (uri-encode (scm->graphql-string document))
+                               "&"
+                               "variables="
+                               (uri-encode (scm->json-string
+                                            ((@@ (kolam http) variables->alist)
+                                             variables))))
+                #:streaming? #t
+                #:keep-alive? keep-alive?
+                #:verify-certificate? verify-certificate?
+                #:port port)))
+          (values response
+                  body)))
     (@@ (kolam http) graphql-http-response)))
 
-
 (define (mumi-search-issues query)
   (let ((response
          (graphql-http-get "https://issues.guix.gnu.org/graphql"
@@ -80,17 +153,14 @@
   (let ((number-to-data
          (make-hash-table)))
 
-    (let loop ((chunks (chunk! (list-copy numbers)
-                               30))
-               (port
-                (open-socket-for-uri
-                 (string->uri url)
-                 #:verify-certificate? #t)))
-      (if (null? chunks)
-          (close-port port)
-          (let ((response
-                 (retry-on-error
-                  (lambda ()
+    (for-each
+     (lambda (chunk)
+       (let ((response
+              (retry-on-error
+               (lambda ()
+                 (call-with-cached-connection
+                  (string->uri url)
+                  (lambda (port)
                     (graphql-http-get*
                      url
                      `(document
@@ -98,30 +168,29 @@
                                 `(query (#(issue #:number ,number)
                                          number title open severity tags
                                          (merged_with number))))
-                              (car chunks)))
+                              chunk))
                      #:keep-alive? #t
-                     #:port port))
-                  #:times 1
-                  #:delay 0)))
-
-            (for-each
-             (lambda (res)
-               (let ((data (cdr res)))
-                 (hash-set! number-to-data
-                            (assoc-ref data "number")
-                            `((title . ,(assoc-ref data "title"))
-                              (open? . ,(assoc-ref data "open"))
-                              (tags . ,(vector->list
-                                        (assoc-ref data "tags")))
-                              (merged-with . ,(map
-                                               (lambda (data)
-                                                 (assoc-ref data "number"))
-                                               (vector->list
-                                                (assoc-ref data "merged_with"))))
-                              (severity . ,(assoc-ref data "severity"))))))
-             response)
-
-            (loop (cdr chunks) port))))
+                     #:port port))))
+               #:times 1
+               #:delay 0)))
+
+         (for-each
+          (lambda (res)
+            (let ((data (cdr res)))
+              (hash-set! number-to-data
+                         (assoc-ref data "number")
+                         `((title . ,(assoc-ref data "title"))
+                           (open? . ,(assoc-ref data "open"))
+                           (tags . ,(vector->list
+                                     (assoc-ref data "tags")))
+                           (merged-with . ,(map
+                                            (lambda (data)
+                                              (assoc-ref data "number"))
+                                            (vector->list
+                                             (assoc-ref data "merged_with"))))
+                           (severity . ,(assoc-ref data "severity"))))))
+          response)))
+     (chunk! (list-copy numbers) 30))
 
     (map (lambda (number)
            (hash-ref number-to-data number))