From 483f11589efe7f9bfab561dc48f26b01096e7996 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 20 Jan 2013 22:28:38 +0100
Subject: download: Add HTTPS support.

* guix/build/download.scm: Autoload (gnutls).
  (tls-wrap): New procedure.
  (open-connection-for-uri): Add support for `https'.  Wrap the socket
  with `tls-wrap' in that case.
  (url-fetch): Add `https'.
* guix/download.scm (gnutls-derivation): New procedure.
  (url-fetch)[need-gnutls?]: New variable.
  Call `gnutls-derivation' when NEED-GNUTLS? is true, and add its output
  to the `GUILE_LOAD_PATH' env. var. in that case.
---
 guix/build/download.scm | 41 ++++++++++++++++++++++++++++++++++++++---
 1 file changed, 38 insertions(+), 3 deletions(-)

(limited to 'guix/build')

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 09c62541de..a04e781480 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -90,6 +90,35 @@ (define (ftp-fetch uri file)
     (newline)
   file)
 
+;; Autoload GnuTLS so that this module can be used even when GnuTLS is
+;; not available.  At compile time, this yields "possibly unbound
+;; variable" warnings, but these are OK: we know that the variables will
+;; be bound if we need them, because (guix download) adds GnuTLS as an
+;; input in that case.
+
+;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
+;; See <http://bugs.gnu.org/12202>.
+(module-autoload! (current-module)
+                  '(gnutls) '(make-session connection-end/client))
+
+(define (tls-wrap port)
+  "Return PORT wrapped in a TLS connection."
+  (define (log level str)
+    (format (current-error-port)
+            "gnutls: [~a|~a] ~a" (getpid) level str))
+
+  (let ((session (make-session connection-end/client)))
+    (set-session-transport-fd! session (fileno port))
+    (set-session-default-priority! session)
+    (set-session-credentials! session (make-certificate-credentials))
+
+    ;; Uncomment the following lines in case of debugging emergency.
+    ;;(set-log-level! 10)
+    ;;(set-log-procedure! log)
+
+    (handshake session)
+    (session-record-port session)))
+
 (define (open-connection-for-uri uri)
   "Return an open input/output port for a connection to URI.
 
@@ -100,6 +129,7 @@ (define addresses
     (let ((port (or (uri-port uri)
                     (case (uri-scheme uri)
                       ((http) 80)           ; /etc/services, not for me!
+                      ((https) 443)
                       (else
                        (error "unsupported URI scheme" uri))))))
       (delete-duplicates (getaddrinfo (uri-host uri)
@@ -122,7 +152,10 @@ (define addresses
           (setvbuf s _IOFBF)
           ;; Enlarge the receive buffer.
           (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
-          s)
+
+          (if (eq? 'https (uri-scheme uri))
+              (tls-wrap s)
+              s))
         (lambda args
           ;; Connection failed, so try one of the other addresses.
           (close s)
@@ -229,8 +262,10 @@ (define (fetch uri file)
     (format #t "starting download of `~a' from `~a'...~%"
             file (uri->string uri))
     (case (uri-scheme uri)
-      ((http)  (false-if-exception* (http-fetch uri file)))
-      ((ftp)   (false-if-exception* (ftp-fetch uri file)))
+      ((http https)
+       (false-if-exception* (http-fetch uri file)))
+      ((ftp)
+       (false-if-exception* (ftp-fetch uri file)))
       (else
        (format #t "skipping URI with unsupported scheme: ~s~%"
                uri)
-- 
cgit v1.2.3