download: Verify TLS certificates unless asked not to.

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

4 files changed, 132 insertions, 16 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index b8cb01f48a..349c4816a1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 4259f52b7a..8e32b3d7ff 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -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)
diff --git a/guix/download.scm b/guix/download.scm
index 80507f952a..d94051951c 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -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))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index d6281eae64..049c297224 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -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)