Avoid potentially sharing cached connections

Don't use a single alist for the cache.

1 files changed, 44 insertions, 40 deletions

diff --git a/guix-qa-frontpage/mumi.scm b/guix-qa-frontpage/mumi.scm
index 1f63348..4885058 100644
--- a/guix-qa-frontpage/mumi.scm
+++ b/guix-qa-frontpage/mumi.scm
@@ -54,50 +54,51 @@ return its MAX-LENGTH first elements and its tail."
   ;; '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.
+(define* (open-socket-for-uri/cached
+          uri #:key fresh? verify-certificate? (cache '()))
+  "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)))
+  (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
-                     (non-blocking-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))))))))
+  (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
+                 (non-blocking-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?
+                                            #:cache cache))
+              (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)))
+(define* (call-with-cached-connection uri proc #:key cache)
+  (let ((port (open-socket-for-uri/cached uri #:cache cache)))
     (with-exception-handler
         (lambda (exn)
           (close-port port)
@@ -153,7 +154,9 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
     "https://issues.guix.gnu.org/graphql")
 
   (let ((number-to-data
-         (make-hash-table)))
+         (make-hash-table))
+        (connection-cache
+         '()))
 
     (for-each
      (lambda (chunk)
@@ -172,7 +175,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
                                          (merged_with number))))
                               chunk))
                      #:keep-alive? #t
-                     #:port port))))
+                     #:port port))
+                  #:cache connection-cache))
                #:times 1
                #:delay 0)))