summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-11-12 22:37:32 +0100
committerLudovic Courtès <ludo@gnu.org>2015-11-12 23:47:00 +0100
commit60fd51222f9d7ec90bdad37bca921f40f7f5b104 (patch)
treeca98d5db3e2940ed96927d32d3bac8f0107bb6dd
parent4856700698cc0a2c1a5992a82c56d5b26024ab06 (diff)
download: Add timeout parameter for connections.
* guix/build/download.scm (ensure-uri): New procedure. (current-http-proxy): New variable. (open-socket-for-uri): Copy from Guile commit aaea5b2, but add #:timeout parameter and use 'connect*' instead of 'connect'. (open-connection-for-uri): Add #:timeout parameter and pass it to 'open-socket-for-uri'.
-rw-r--r--guix/build/download.scm82
1 files changed, 61 insertions, 21 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 240e79ee8d..17e8f8cb9e 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, and uses 'connect*' instead
+ ;; of 'connect'.
+
+ (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 port
+ AI_NUMERICSERV
+ 0))
+ (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)