futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

download: Verify TLS certificates unless asked not to.

Browse Source 
Fixes <http://bugs.gnu.org/24466>.
Reported by Leo Famulari <leo@famulari.name>.

* guix/build/download.scm (%x509-certificate-directory): New variable.
(make-credendials-with-ca-trust-files, peer-certificate)
(assert-valid-server-certificate, print-tls-certificate-error): New
procedures.  Add 'print-tls-certificate-error' as an exception printer
for 'tls-certificate-error'.
(tls-wrap): Add #:verify-certificate? parameter and honor it.
(open-connection-for-uri): Likewise.
(http-fetch): Likewise.
(url-fetch): Likewise.
* guix/download.scm (url-fetch)[builder]: Pass #:verify-certificate? #f.
* guix/scripts/lint.scm (probe-uri): Add case for 'tls-certificate-error'.
(validate-uri): Likewise.
* doc/guix.texi (Invoking guix download): Mention 'SSL_CERT_DIR'.
This commit is contained in:
Ludovic Courtès 2016-11-07 23:07:08 +01:00
parent a00fbe8adf
commit bc3c41ce36
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 132 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
doc/guix.texi
View File

@ -4768,6 +4768,11 @@ they are not available, an error is raised. @xref{Guile Preparations,
how to install the GnuTLS bindings for Guile,, gnutls-guile,
GnuTLS-Guile}, for more information.
@command{guix download} verifies HTTPS server certificates by loading
the certificates of X.509 authorities from the directory pointed to by
the @code{SSL_CERT_DIR} environment variable (@pxref{X.509
Certificates}).
The following option is available:
@table @code

125
guix/build/download.scm
View File

@ -32,6 +32,7 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:autoload (ice-9 ftw) (scandir)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (open-socket-for-uri
@ -273,14 +274,78 @@ out if the connection could not be established in less than TIMEOUT seconds."
session record port using PORT as its underlying communication port."
(hashq-set! %tls-ports record-port port))
(define (tls-wrap port server)
(define %x509-certificate-directory
;; The directory where X.509 authority PEM certificates are stored.
(make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY")
(getenv "SSL_CERT_DIR")))) ;like OpenSSL
(define (make-credendials-with-ca-trust-files directory)
"Return certificate credentials with X.509 authority certificates read from
DIRECTORY. Those authority certificates are checked when
'peer-certificate-status' is later called."
(let ((cred (make-certificate-credentials))
(files (or (scandir directory
(lambda (file)
(string-suffix? ".pem" file)))
'())))
(for-each (lambda (file)
(set-certificate-credentials-x509-trust-file!
cred (string-append directory "/" file)
x509-certificate-format/pem))
(or files '()))
cred))
(define (peer-certificate session)
"Return the certificate of the remote peer in SESSION."
(match (session-peer-certificate-chain session)
((first _ ...)
(import-x509-certificate first x509-certificate-format/der))))
(define (assert-valid-server-certificate session server)
"Return #t if the certificate of the remote peer for SESSION is a valid
certificate for SERVER, where SERVER is the expected host name of peer."
(define cert
(peer-certificate session))
;; First check whether the server's certificate matches SERVER.
(unless (x509-certificate-matches-hostname? cert server)
(throw 'tls-certificate-error 'host-mismatch cert server))
;; Second check its validity and reachability from the set of authority
;; certificates loaded via 'set-certificate-credentials-x509-trust-file!'.
(match (peer-certificate-status session)
(() ;certificate is valid
#t)
((statuses ...)
(throw 'tls-certificate-error 'invalid-certificate cert server
statuses))))
(define (print-tls-certificate-error port key args default-printer)
"Print the TLS certificate error represented by ARGS in an intelligible
way."
(match args
(('host-mismatch cert server)
(format port
"X.509 server certificate for '~a' does not match: ~a~%"
server (x509-certificate-dn cert)))
(('invalid-certificate cert server statuses)
(format port
"X.509 certificate of '~a' could not be verified:~%~{ ~a~%~}"
server
(map certificate-status->string statuses)))))
(set-exception-printer! 'tls-certificate-error
print-tls-certificate-error)
(define* (tls-wrap port server #:key (verify-certificate? #t))
"Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS
host name without trailing dot."
(define (log level str)
(format (current-error-port)
"gnutls: [~a|~a] ~a" (getpid) level str))
(let ((session (make-session connection-end/client)))
(let ((session (make-session connection-end/client))
(ca-certs (%x509-certificate-directory)))
;; Some servers such as 'cloud.github.com' require the client to support
;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is
@ -301,13 +366,27 @@ host name without trailing dot."
;; <https://tools.ietf.org/html/rfc7568>.
(set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")
(set-session-credentials! session (make-certificate-credentials))
(set-session-credentials! session
(if (and verify-certificate? ca-certs)
(make-credendials-with-ca-trust-files
ca-certs)
(make-certificate-credentials)))
;; Uncomment the following lines in case of debugging emergency.
;;(set-log-level! 10)
;;(set-log-procedure! log)
(handshake session)
;; Verify the server's certificate if needed.
(when verify-certificate?
(catch 'tls-certificate-error
(lambda ()
(assert-valid-server-certificate session server))
(lambda args
(close-port port)
(apply throw args))))
(let ((record (session-record-port session)))
;; Since we use `fileno' above, the file descriptor behind PORT would be
;; closed when PORT is GC'd. If we used `port->fdes', it would instead
@ -374,9 +453,13 @@ ETIMEDOUT error is raised."
(apply throw args)
(loop (cdr addresses))))))))
(define* (open-connection-for-uri uri #:key timeout)
(define* (open-connection-for-uri uri
#:key
timeout
(verify-certificate? #t))
"Like 'open-socket-for-uri', but also handle HTTPS connections. The
resulting port must be closed with 'close-connection'."
resulting port must be closed with 'close-connection'. When
VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
(define https?
(eq? 'https (uri-scheme uri)))
@ -403,7 +486,8 @@ resulting port must be closed with 'close-connection'."
(setvbuf s _IOFBF %http-receive-buffer-size)
(if https?
(tls-wrap s (uri-host uri))
(tls-wrap s (uri-host uri)
#:verify-certificate? verify-certificate?)
s)))))
(define (close-connection port)
@ -588,10 +672,11 @@ Return the resulting target URI."
#:query (uri-query ref)
#:fragment (uri-fragment ref)))))
(define* (http-fetch uri file #:key timeout)
(define* (http-fetch uri file #:key timeout (verify-certificate? #t))
"Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if
the connection could not be established in less than TIMEOUT seconds. Return
FILE on success."
FILE on success. When VERIFY-CERTIFICATE? is true, verify HTTPS
certificates; otherwise simply ignore them."
(define post-2.0.7?
(or (> (string->number (major-version)) 2)
@ -618,7 +703,10 @@ FILE on success."
(_ '()))))
(let*-values (((connection)
(open-connection-for-uri uri #:timeout timeout))
(open-connection-for-uri uri
#:timeout timeout
#:verify-certificate?
verify-certificate?))
((resp bv-or-port)
;; XXX: `http-get*' was introduced in 2.0.7, and replaced by
;; #:streaming? in 2.0.8. We know we're using it within the
@ -659,7 +747,9 @@ FILE on success."
(format #t "following redirection to `~a'...~%"
(uri->string uri))
(close connection)
(http-fetch uri file #:timeout timeout)))
(http-fetch uri file
#:timeout timeout
#:verify-certificate? verify-certificate?)))
(else
(error "download failed" (uri->string uri)
code (response-reason-phrase resp))))))
@ -699,7 +789,7 @@ Return a list of URIs."
(define* (url-fetch url file
#:key
(timeout 10)
(timeout 10) (verify-certificate? #t)
(mirrors '()) (content-addressed-mirrors '())
(hashes '()))
"Fetch FILE from URL; URL may be either a single string, or a list of
@ -713,7 +803,10 @@ HASHES must be a list of algorithm/hash pairs, where each algorithm is a
symbol such as 'sha256 and each hash is a bytevector.
CONTENT-ADDRESSED-MIRRORS must be a list of procedures that, given a hash
algorithm and a hash, return a URL where the specified data can be retrieved
or #f."
or #f.
When VERIFY-CERTIFICATE? is true, validate HTTPS server certificates;
otherwise simply ignore them."
(define uri
(append-map (cut maybe-expand-mirrors <> mirrors)
(match url
@ -725,9 +818,13 @@ or #f."
file (uri->string uri))
(case (uri-scheme uri)
((http https)
(false-if-exception* (http-fetch uri file #:timeout timeout)))
(false-if-exception* (http-fetch uri file
#:verify-certificate?
verify-certificate?
#:timeout timeout)))
((ftp)
(false-if-exception* (ftp-fetch uri file #:timeout timeout)))
(false-if-exception* (ftp-fetch uri file
#:timeout timeout)))
(else
(format #t "skipping URI with unsupported scheme: ~s~%"
uri)

6
guix/download.scm
View File

@ -372,7 +372,11 @@ in the store."
#:hashes
(value-from-environment "guix download hashes")
#:content-addressed-mirrors
(primitive-load #$%content-addressed-mirror-file))))))
(primitive-load #$%content-addressed-mirror-file)
;; No need to validate certificates since we know the
;; hash of the expected result.
#:verify-certificate? #f)))))
(let ((uri (and (string? url) (string->uri url))))
(if (or (and (string? url) (not uri))

12
guix/scripts/lint.scm
View File

@ -369,7 +369,8 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
;; This can happen if the server returns an invalid HTTP header,
;; as is the case with the 'Date' header at sqlite.org.
(values 'invalid-http-response #f))
((getaddrinfo-error system-error gnutls-error)
((getaddrinfo-error system-error
gnutls-error tls-certificate-error)
(values key args))
(else
(apply throw key args))))))
@ -457,6 +458,15 @@ suspiciously small file (~a bytes)")
(cons status argument))))
field)
#f)
((tls-certificate-error)
(emit-warning package
(format #f
(_ "TLS certificate error: ~a")
(call-with-output-string
(lambda (port)
(print-exception port #f
'tls-certificate-error
argument))))))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
#f)