diff options
| -rw-r--r-- | guix/build/download.scm | 41 | ||||
| -rw-r--r-- | guix/download.scm | 55 |
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 |