02/11: substitute: Don't send more than 1000 requests in a row.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit d213cc8c7f085428e3c64243b0d163423e4bb5f6
Author: Ludovic Courtès <address@hidden>
Date:   Wed Oct 25 20:57:06 2017 -0700

    substitute: Don't send more than 1000 requests in a row.
    
    Fixes <https://bugs.gnu.org/28731>.
    Reported by Jan Nieuwenhuizen <address@hidden>.
    
    * guix/scripts/substitute.scm (at-most): New procedure.
    (http-multiple-get): Use it to send at most 1000 requests at once.
---
 guix/scripts/substitute.scm | 19 +++++++++++++++++--
 1 file changed, 17 insertions(+), 2 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 1fbeed7..2fd2bf8 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -533,6 +533,20 @@ indicates that PATH is unavailable at CACHE-URL."
         (headers '((User-Agent . "GNU Guile"))))
     (build-request (string->uri url) #:method 'GET #:headers headers)))
 
+(define (at-most max-length lst)
+  "If LST is shorter than MAX-LENGTH, return it; otherwise return its
+MAX-LENGTH first elements."
+  (let loop ((len 0)
+             (lst lst)
+             (result '()))
+    (match lst
+      (()
+       (reverse result))
+      ((head . tail)
+       (if (>= len max-length)
+           (reverse result)
+           (loop (+ 1 len) tail (cons head result)))))))
+
 (define* (http-multiple-get base-uri proc seed requests
                             #:key port (verify-certificate? #t))
   "Send all of REQUESTS to the server at BASE-URI.  Call PROC for each
@@ -553,7 +567,7 @@ initial connection on which HTTP requests are sent."
       (when (file-port? p)
         (setvbuf p _IOFBF (expt 2 16)))
 
-      ;; Send all of REQUESTS in a row.
+      ;; Send REQUESTS, up to a certain number, in a row.
       ;; XXX: Do our own caching to work around inefficiencies when
       ;; communicating over TLS: <http://bugs.gnu.org/22966>.
       (let-values (((buffer get) (open-bytevector-output-port)))
@@ -562,7 +576,8 @@ initial connection on which HTTP requests are sent."
                                'http-proxy-port?)
           (set-http-proxy-port?! buffer (http-proxy-port? p)))
 
-        (for-each (cut write-request <> buffer) requests)
+        (for-each (cut write-request <> buffer)
+                  (at-most 1000 requests))
         (put-bytevector p (get))
         (force-output p))