aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-01-20 22:28:38 +0100
committerLudovic Courtès <ludo@gnu.org>2013-01-20 22:54:36 +0100
commit483f11589efe7f9bfab561dc48f26b01096e7996 (patch)
tree26c6cf1d3410033063753bc1c73029e1f1995921
parente509d1527d231b6460a20762e13b57cba2e43485 (diff)
downloadguix-483f11589efe7f9bfab561dc48f26b01096e7996.tar
guix-483f11589efe7f9bfab561dc48f26b01096e7996.tar.gz
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.
-rw-r--r--guix/build/download.scm41
-rw-r--r--guix/download.scm55
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