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.
This commit is contained in:
Ludovic Courtès
parent
e509d1527d
commit
483f11589e
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue