guix: Move http-multiple-get to (guix http-client).

From (guix scripts substitute). This will make it easier to reuse this code.

* guix/scripts/substitute.scm (http-multiple-get): Remove, and move to…
* guix/http-client.scm (http-multiple-get): …here.

1 files changed, 76 insertions, 0 deletions

diff --git a/guix/http-client.scm b/guix/http-client.scm
index 553640fe9e..7ead493633 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -21,8 +21,11 @@
 
 (define-module (guix http-client)
   #:use-module (web uri)
+  #:use-module (web http)
   #:use-module ((web client) #:hide (open-socket-for-uri))
+  #:use-module (web request)
   #:use-module (web response)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -50,6 +53,7 @@
             http-get-error-reason
 
             http-fetch
+            http-multiple-get
 
             %http-cache-ttl
             http-fetch/cached))
@@ -138,6 +142,78 @@ Raise an '&http-get-error' condition if downloading fails."
                                 (uri->string uri) code
                                 (response-reason-phrase resp))))))))))))
 
+(define* (http-multiple-get base-uri proc seed requests
+                            #:key port (verify-certificate? #t)
+                            (open-connection guix:open-connection-for-uri)
+                            (keep-alive? #t)
+                            (batch-size 1000))
+  "Send all of REQUESTS to the server at BASE-URI.  Call PROC for each
+response, passing it the request object, the response, a port from which to
+read the response body, and the previous result, starting with SEED, à la
+'fold'.  Return the final result.
+
+When PORT is specified, use it as the initial connection on which HTTP
+requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
+a URI.  When KEEP-ALIVE? is false, close the connection port before
+returning."
+  (let connect ((port     port)
+                (requests requests)
+                (result   seed))
+    (define batch
+      (if (>= batch-size (length requests))
+          requests
+          (take requests batch-size)))
+
+    ;; (format (current-error-port) "connecting (~a requests left)..."
+    ;;         (length requests))
+    (let ((p (or port (open-connection base-uri
+                                       #:verify-certificate?
+                                       verify-certificate?))))
+      ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
+      (when (file-port? p)
+        (setvbuf p 'block (expt 2 16)))
+
+      ;; Send BATCH 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)))
+        ;; Inherit the HTTP proxying property from P.
+        (set-http-proxy-port?! buffer (http-proxy-port? p))
+
+        (for-each (cut write-request <> buffer)
+                  batch)
+        (put-bytevector p (get))
+        (force-output p))
+
+      ;; Now start processing responses.
+      (let loop ((sent      batch)
+                 (processed 0)
+                 (result    result))
+        (match sent
+          (()
+           (match (drop requests processed)
+             (()
+              (unless keep-alive?
+                (close-port p))
+              (reverse result))
+             (remainder
+              (connect p remainder result))))
+          ((head tail ...)
+           (let* ((resp   (read-response p))
+                  (body   (response-body-port resp))
+                  (result (proc head resp body result)))
+             ;; The server can choose to stop responding at any time, in which
+             ;; case we have to try again.  Check whether that is the case.
+             ;; Note that even upon "Connection: close", we can read from BODY.
+             (match (assq 'connection (response-headers resp))
+               (('connection 'close)
+                (close-port p)
+                (connect #f                       ;try again
+                         (drop requests (+ 1 processed))
+                         result))
+               (_
+                (loop tail (+ 1 processed) result)))))))))) ;keep going
+
 
 ;;;
 ;;; Caching.