futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Christopher Baines 2021-01-07 19:40:07 +00:00
parent 87734503a4
commit e2e853ddb0
No known key found for this signature in database
GPG Key ID: 5E28A33B0B84F577
2 changed files with 76 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
guix/http-client.scm
View File

@ -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.

70
guix/scripts/substitute.scm
View File

@ -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")))