mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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. <top level>: 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'.
This commit is contained in:
Ludovic Courtès
parent
bcba213284
commit
38f14ce65d
2 changed files with 178 additions and 9 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26948#17>."
|
||||
(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."
|
|||
;; <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 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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue