From 38f14ce65d8d86a9a6acabc4e84df59f5eb13b04 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 10 Jan 2020 15:13:40 +0100 Subject: [PATCH] web: 'open-socket-for-uri' can verify the server's X.509 certificate. This is largely based on Guix commit bc3c41ce36349ed4ec758c70b48a7059e363043a and subsequent changes to that code. * module/web/client.scm (x509-certificate-directory): New variable. (set-certificate-credentials-x509-trust-file!*) (make-credendials-with-ca-trust-files, peer-certificate) (assert-valid-server-certificate, print-tls-certificate-error): New procedures. : Add call to 'set-exception-printer!'. (tls-wrap): Add #:verify-certificate? parameter. When it is true, call 'make-credendials-with-ca-trust-files', pass it to 'set-session-credentials!', and call 'assert-valid-server-certificate'. (open-socket-for-uri): Add #:verify-certificate? parameter and pass it to 'tls-wrap'. (http-request): Add #:verify-certificate? parameter and pass it to 'open-socket-for-uri'. (define-http-verb): Add #:verify-certificate? parameter and pass it to 'http-request'. * doc/ref/web.texi (Web Client): Update documentation of 'open-socket-for-uri' and 'http-request'. Document 'x509-certificate-directory'. --- doc/ref/web.texi | 67 ++++++++++++++++++++++- module/web/client.scm | 120 +++++++++++++++++++++++++++++++++++++++--- 2 files changed, 178 insertions(+), 9 deletions(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 91b3a4edf..2d07dd7b1 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -1455,12 +1455,40 @@ the lower-level HTTP, request, and response modules. (use-modules (web client)) @end example -@deffn {Scheme Procedure} open-socket-for-uri uri +@deffn {Scheme Procedure} open-socket-for-uri uri [#:verify-certificate? #t] Return an open input/output port for a connection to URI. Guile dynamically loads GnuTLS for HTTPS support. @xref{Guile Preparations, how to install the GnuTLS bindings for Guile,, gnutls-guile, GnuTLS-Guile}, for more information. + +@cindex certificate verification, for HTTPS +When @var{verify-certificate?} is true, verify the server's X.509 +certificates against those read from @code{x509-certificate-directory}. +When an error occurs---e.g., the server's certificate has expired, or +its host name does not match---raise a @code{tls-certificate-error} +exception. The arguments to the @code{tls-certificate-error} exception +are: + +@enumerate +@item +a symbol indicating the failure cause, @code{host-mismatch} if the +certificate's host name does not match the server's host name, and +@code{invalid-certificate} for other causes; + +@item +the server's X.509 certificate (@pxref{Guile Reference, GnuTLS Guile +reference,, gnutls-guile, GnuTLS-Guile}); + +@item +the server's host name (a string); + +@item +in the case of @code{invalid-certificate} errors, a list of GnuTLS +certificate status values---one of the @code{certificate-status/} +constants, such as @code{certificate-status/signer-not-found} or +@code{certificate-status/revoked}. +@end enumerate @end deffn @anchor{http-request}@deffn {Scheme Procedure} http-request @var{uri} @var{arg}@dots{} @@ -1476,7 +1504,8 @@ their default values. @table @code @item #:method 'GET @item #:body #f -@item #:port (open-socket-for-uri @var{uri})] +@item #:verify-certificate? #t +@item #:port (open-socket-for-uri @var{uri} #:verify-certificate? @var{verify-certificate?}) @item #:version '(1 . 1) @item #:keep-alive? #f @item #:headers '() @@ -1507,6 +1536,10 @@ read. Unless @var{keep-alive?} is true, the port will be closed after the full response body has been read. +If @var{port} is false, @var{uri} denotes an HTTPS URL, and @var{verify-certificate?} is +true, verify X.509 certificates against those available in +@code{x509-certificate-directory}. + Returns two values: the response read from the server, and the response body as a string, bytevector, #f value, or as a port (if @var{streaming?} is true). @@ -1531,6 +1564,36 @@ arguments. @end deffn +@defvr {Scheme Parameter} x509-certificate-directory +@cindex X.509 certificate directory +@cindex HTTPS, X.509 certificates +@cindex certificates, for HTTPS +This parameter gives the name of the directory where X.509 certificates +for HTTPS connections should be looked for. + +Its default value is one of: + +@itemize +@item +@vindex GUILE_TLS_CERTIFICATE_DIRECTORY +the value of the @env{GUILE_TLS_CERTIFICATE_DIRECTORY} environment +variable; + +@item +@vindex SSL_CERT_DIR +or the value of the @env{SSL_CERT_DIR} environment variable (also +honored by the OpenSSL library); + +@item +or, as a last resort, @code{"/etc/ssl/certs"}. +@end itemize + +X.509 certificates are used when authenticating the identity of a remote +site, when the @code{#:verify-certificate?} argument to +@code{open-socket-for-uri}, to @code{http-request}, or to related +procedures is true. +@end defvr + @code{http-get} is useful for making one-off requests to web sites. If you are writing a web spider or some other client that needs to handle a number of requests in parallel, it's better to build an event-driven URL diff --git a/module/web/client.scm b/module/web/client.scm index 74fc85518..3d144df41 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -43,11 +43,14 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) #:use-module ((rnrs io ports) #:prefix rnrs-ports:) #:use-module (ice-9 match) + #:autoload (ice-9 ftw) (scandir) #:export (current-http-proxy current-https-proxy + x509-certificate-directory open-socket-for-uri http-request http-get @@ -90,7 +93,84 @@ if it is unavailable." (and (not (equal? proxy "")) proxy)))) -(define (tls-wrap port server) +(define x509-certificate-directory + ;; The directory where X.509 authority PEM certificates are stored. + (make-parameter (or (getenv "GUILE_TLS_CERTIFICATE_DIRECTORY") + (getenv "SSL_CERT_DIR") ;like OpenSSL + "/etc/ssl/certs"))) + +(define (set-certificate-credentials-x509-trust-file!* cred file format) + "Like 'set-certificate-credentials-x509-trust-file!', but without the file +name decoding bug described at +." + (let ((data (call-with-input-file file get-bytevector-all))) + (set-certificate-credentials-x509-trust-data! cred data format))) + +(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 (match (scandir directory (cut string-suffix? ".pem" <>)) + ((or #f ()) + ;; Some distros provide nothing but bundles (*.crt) under + ;; /etc/ssl/certs, so look for them. + (or (scandir directory (cut string-suffix? ".crt" <>)) + '())) + (pem pem)))) + (for-each (lambda (file) + (let ((file (string-append directory "/" file))) + ;; Protect against dangling symlinks. + (when (file-exists? file) + (set-certificate-credentials-x509-trust-file!* + cred file + x509-certificate-format/pem)))) + 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 + (string-join (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) @@ -99,7 +179,8 @@ host name without trailing dot." (load-gnutls) - (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 ;; not available in older GnuTLS releases. See @@ -119,7 +200,11 @@ host name without trailing dot." ;; . (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0") - (set-session-credentials! session (make-certificate-credentials)) + (set-session-credentials! session + (if verify-certificate? + (make-credendials-with-ca-trust-files + ca-certs) + (make-certificate-credentials))) ;; Uncomment the following lines in case of debugging emergency. ;;(set-log-level! 10) @@ -141,6 +226,15 @@ host name without trailing dot." ;; provide a binding for this. (apply throw key err proc rest))))) + ;; 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)))) + ;; FIXME: It appears that session-record-port is entirely ;; sufficient; it's already a port. The only value of this code is ;; to keep a reference on "port", to keep it alive! To fix this we @@ -195,8 +289,10 @@ host name without trailing dot." (force-output port) (read-response port)) -(define (open-socket-for-uri uri-or-string) - "Return an open input/output port for a connection to URI." +(define* (open-socket-for-uri uri-or-string + #:key (verify-certificate? #t)) + "Return an open input/output port for a connection to URI-OR-STRING. +When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (define uri (ensure-uri-reference uri-or-string)) (define https? @@ -248,7 +344,8 @@ host name without trailing dot." (setup-http-tunnel s uri)) (if https? - (tls-wrap s (uri-host uri)) + (tls-wrap s (uri-host uri) + #:verify-certificate? verify-certificate?) s))) (define (extend-request r k v . additional) @@ -351,7 +448,10 @@ as is the case by default with a request returned by `build-request'." (define* (http-request uri #:key (body #f) - (port (open-socket-for-uri uri)) + (verify-certificate? #t) + (port (open-socket-for-uri uri + #:verify-certificate? + verify-certificate?)) (method 'GET) (version '(1 . 1)) (keep-alive? #f) @@ -390,6 +490,10 @@ response body will be returned as a port on which the data may be read. Unless KEEP-ALIVE? is true, the port will be closed after the full response body has been read. +If PORT is false, URI denotes an HTTPS URL, and VERIFY-CERTIFICATE? is +true, verify X.509 certificates against those available in +X509-CERTIFICATE-DIRECTORY. + Returns two values: the response read from the server, and the response body as a string, bytevector, #f value, or as a port (if STREAMING? is true)." @@ -427,12 +531,14 @@ true)." (keep-alive? #f) (headers '()) (decode-body? #t) + (verify-certificate? #t) (streaming? #f)) doc (http-request uri #:body body #:method method #:port port #:version version #:keep-alive? keep-alive? #:headers headers #:decode-body? decode-body? + #:verify-certificate? verify-certificate? #:streaming? streaming?))) (define-http-verb http-get