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'.

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

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
+<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)
+(define* (open-socket-for-uri uri-or-string
-  "Return an open input/output port for a connection to URI."
+                              #: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