diff options
Diffstat (limited to 'guix/http-client.scm')
| -rw-r--r-- | guix/http-client.scm | 76 |
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. |