@@ -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.
@@ -299,76 +299,6 @@ return its MAX-LENGTH first elements and its tail."
(values (reverse result) lst)
(loop (+ 1 len) tail (cons head result)))))))
-(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
- (at-most batch-size requests))
-
- ;; (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
-
(define (read-to-eof port)
"Read from PORT until EOF is reached. The data are discarded."
(dump-port port (%make-void-port "w")))