diff options
Diffstat (limited to 'guix/build/download.scm')
| -rw-r--r-- | guix/build/download.scm | 82 |
1 files changed, 61 insertions, 21 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index 240e79ee8d..8843804c40 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -20,6 +20,7 @@ (define-module (guix build download) #:use-module (web uri) + #:use-module (web http) #:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module (web response) #:use-module (guix ftp-client) @@ -277,26 +278,65 @@ host name without trailing dot." (add-weak-reference record port) record))) -(define (open-socket-for-uri uri) - "Return an open port for URI. This variant works around -<http://bugs.gnu.org/15368> which affects Guile's 'open-socket-for-uri' up to -2.0.11 included." - (define rmem-max - ;; The maximum size for a receive buffer on Linux, see socket(7). - "/proc/sys/net/core/rmem_max") - - (define buffer-size - (if (file-exists? rmem-max) - (call-with-input-file rmem-max read) - 126976)) ;the default for Linux, per 'rmem_default' - - (let ((s ((@ (web client) open-socket-for-uri) uri))) - ;; Work around <http://bugs.gnu.org/15368> by restoring a decent - ;; buffer size. - (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) - s)) - -(define (open-connection-for-uri uri) +(define (ensure-uri uri-or-string) ;XXX: copied from (web http) + (cond + ((string? uri-or-string) (string->uri uri-or-string)) + ((uri? uri-or-string) uri-or-string) + (else (error "Invalid URI" uri-or-string)))) + +(define current-http-proxy + ;; XXX: Add a dummy definition for Guile < 2.0.10; this is used in + ;; 'open-socket-for-uri'. + (or (and=> (module-variable (resolve-interface '(web client)) + 'current-http-proxy) + variable-ref) + (const #f))) + +(define* (open-socket-for-uri uri-or-string #:key timeout) + "Return an open input/output port for a connection to URI. When TIMEOUT is +not #f, it must be a (possibly inexact) number denoting the maximum duration +in seconds to wait for the connection to complete; passed TIMEOUT, an +ETIMEDOUT error is raised." + ;; Includes a fix for <http://bugs.gnu.org/15368> which affects Guile's + ;; 'open-socket-for-uri' up to 2.0.11 included, uses 'connect*' instead + ;; of 'connect', and uses AI_ADDRCONFIG. + + (define http-proxy (current-http-proxy)) + (define uri (ensure-uri (or http-proxy uri-or-string))) + (define addresses + (let ((port (uri-port uri))) + (delete-duplicates + (getaddrinfo (uri-host uri) + (cond (port => number->string) + (else (symbol->string (uri-scheme uri)))) + (if (number? port) + (logior AI_ADDRCONFIG AI_NUMERICSERV) + AI_ADDRCONFIG)) + (lambda (ai1 ai2) + (equal? (addrinfo:addr ai1) (addrinfo:addr ai2)))))) + + (let loop ((addresses addresses)) + (let* ((ai (car addresses)) + (s (with-fluids ((%default-port-encoding #f)) + ;; Restrict ourselves to TCP. + (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP)))) + (catch 'system-error + (lambda () + (connect* s (addrinfo:addr ai) timeout) + + ;; Buffer input and output on this port. + (setvbuf s _IOFBF) + ;; If we're using a proxy, make a note of that. + (when http-proxy (set-http-proxy-port?! s #t)) + s) + (lambda args + ;; Connection failed, so try one of the other addresses. + (close s) + (if (null? (cdr addresses)) + (apply throw args) + (loop (cdr addresses)))))))) + +(define* (open-connection-for-uri uri #:key timeout) "Like 'open-socket-for-uri', but also handle HTTPS connections." (define https? (eq? 'https (uri-scheme uri))) @@ -319,7 +359,7 @@ host name without trailing dot." (thunk)) (thunk))))))) (with-https-proxy - (let ((s (open-socket-for-uri uri))) + (let ((s (open-socket-for-uri uri #:timeout timeout))) ;; Buffer input and output on this port. (setvbuf s _IOFBF %http-receive-buffer-size) |