From 077bd18d223c2934fb52b7ab134271e1b574c481 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 22 Sep 2014 21:06:39 +0200
Subject: [PATCH] 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.
---
 guix/build/download.scm | 18 +++++++++++++++---
 1 file 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.