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.

2 files changed, 84 insertions, 12 deletions

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 @@ abbreviation of URI showing the scheme, host, and basename of the 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 @@ which is not available during bootstrap."
     (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 @@ which is not available during bootstrap."
           (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 @@ on success."
     (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)
diff --git a/guix/download.scm b/guix/download.scm
index cf68ade74b..316bee97db 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +22,8 @@
   #:use-module (guix packages)
   #:use-module ((guix store) #:select (derivation-path?))
   #:use-module (guix utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:export (%mirrors
             url-fetch))
@@ -91,6 +93,11 @@
        "http://kernel.osuosl.org/pub/"
        "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/"))))
 
+(define (gnutls-derivation store system)
+  "Return the GnuTLS derivation for SYSTEM."
+  (let* ((module (resolve-interface '(gnu packages gnutls)))
+         (gnutls (module-ref module 'gnutls)))
+    (package-derivation store gnutls system)))
 
 (define* (url-fetch store url hash-algo hash
                     #:optional name
@@ -129,13 +136,43 @@ must be a list of symbol/URL-list pairs."
       (_
        (basename url))))
 
-  (build-expression->derivation store (or name file-name) system
-                                builder '()
-                                #:hash-algo hash-algo
-                                #:hash hash
-                                #:modules '((guix build download)
-                                            (guix build utils)
-                                            (guix ftp-client))
-                                #:guile-for-build guile-for-build))
+  (define need-gnutls?
+    ;; True if any of the URLs need TLS support.
+    (let ((https? (cut string-prefix? "https://" <>)))
+      (match url
+        ((? string?)
+         (https? url))
+        ((url ...)
+         (any https? url)))))
+
+  (let*-values (((gnutls-drv-path gnutls-drv)
+                 (if need-gnutls?
+                     (gnutls-derivation store system)
+                     (values #f #f)))
+                ((gnutls)
+                 (and gnutls-drv
+                      (derivation-output-path
+                       (assoc-ref (derivation-outputs gnutls-drv)
+                                  "out"))))
+                ((env-vars)
+                 (if gnutls
+                     (let ((dir (string-append gnutls "/share/guile/site")))
+                       ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden
+                       ;; by `build-expression->derivation', so we can't
+                       ;; set it here.
+                       `(("GUILE_LOAD_PATH" . ,dir)))
+                     '())))
+    (build-expression->derivation store (or name file-name) system
+                                  builder
+                                  (if gnutls-drv
+                                      `(("gnutls" ,gnutls-drv-path))
+                                      '())
+                                  #:hash-algo hash-algo
+                                  #:hash hash
+                                  #:modules '((guix build download)
+                                              (guix build utils)
+                                              (guix ftp-client))
+                                  #:guile-for-build guile-for-build
+                                  #:env-vars env-vars)))
 
 ;;; download.scm ends here