Browse Source

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.
Ludovic Courtès 9 years ago
2 changed files with 84 additions and 12 deletions
  1. +38
  2. +46

+ 38
- 3
guix/build/download.scm View File

@ -90,6 +90,35 @@ abbreviation of URI showing the scheme, host, and basename of the 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 <>.
(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)
(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))
(if (eq? 'https (uri-scheme uri))
(tls-wrap 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)))
(false-if-exception* (ftp-fetch uri file)))
(format #t "skipping URI with unsupported scheme: ~s~%"

+ 46
- 9
guix/download.scm View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012 Ludovic Courtès <>
;;; Copyright © 2012, 2013 Ludovic Courtès <>
;;; 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
@ -91,6 +93,11 @@
(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)))
(and gnutls-drv
(assoc-ref (derivation-outputs gnutls-drv)
(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
(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