diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2014-09-22 21:06:39 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2014-09-22 21:06:39 +0200 |
| commit | 077bd18d223c2934fb52b7ab134271e1b574c481 (patch) | |
| tree | 64c9d446a340db4837353b6da072a14e1247a7e5 /guix/build | |
| parent | cb150ca34f5daee327867c6a647d075c8a598c37 (diff) | |
| download | gnu-guix-077bd18d223c2934fb52b7ab134271e1b574c481.tar gnu-guix-077bd18d223c2934fb52b7ab134271e1b574c481.tar.gz | |
download: Use the 'SERVER NAME' TLS extension when possible.
Fixes <http://bugs.gnu.org/18526>.
Reported by Mark H. Weaver.
* guix/build/download.scm (tls-wrap): Add 'server' parameter. Call
'set-session-server-name!' when (gnutls) defines it.
(open-connection-for-uri): Adjust 'tls-wrap' call accordingly.
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/download.scm | 18 |
1 files changed, 15 insertions, 3 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index d98933a907..c081f3b29b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -112,13 +112,25 @@ abbreviation of URI showing the scheme, host, and basename of the file." "Hold a weak reference from FROM to TO." (hashq-set! table from to)))) -(define (tls-wrap port) - "Return PORT wrapped in a TLS connection." +(define (tls-wrap port server) + "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS +host name without trailing dot." (define (log level str) (format (current-error-port) "gnutls: [~a|~a] ~a" (getpid) level str)) (let ((session (make-session connection-end/client))) + + ;; Some servers such as 'cloud.github.com' require the client to support + ;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is + ;; not available in older GnuTLS releases. See + ;; <http://bugs.gnu.org/18526> for details. + (if (module-defined? (resolve-interface '(gnutls)) + 'set-session-server-name!) + (set-session-server-name! session server-name-type/dns server) + (format (current-error-port) + "warning: TLS 'SERVER NAME' extension not supported~%")) + (set-session-transport-fd! session (fileno port)) (set-session-default-priority! session) (set-session-credentials! session (make-certificate-credentials)) @@ -169,7 +181,7 @@ which is not available during bootstrap." (setvbuf s _IOFBF) (if (eq? 'https (uri-scheme uri)) - (tls-wrap s) + (tls-wrap s (uri-host uri)) s)) (lambda args ;; Connection failed, so try one of the other addresses. |