[Emacs-diffs] netsec 87484dc 5/6: Full certificate chain details for NSM

[Jimmy Yuen Ho Wong]

branch: netsec
commit 87484dc27ec7a6e708c7e0ceaf96bff1ee064174
Author: Jimmy Yuen Ho Wong <address@hidden>
Commit: Jimmy Yuen Ho Wong <address@hidden>

    Full certificate chain details for NSM
    
    * lisp/net/nsm.el (nsm-check-tls-connection): Fix issue with plural
      problems in message.  Prefix every problem with a bullet.
      (nsm-query-user): Add new view the full certificate chain by
      pressing d.
      (nsm-format-certificate): Improve basic certificate and session info
      formatting.
    
    * src/gnutls.c (emacs_gnutls_certificate_export_pem): New function.
      (gnutls_certificate_details): Rename to
      emacs_gnutls_certificate_details.  Add :pem to result list.
      (Fgnutls_format_certificate):  New function for formatting a PEM to
      human-readable text.
---
 lisp/net/nsm.el | 129 +++++++++++++++++++++++++++++++++++++++++---------------
 src/gnutls.c    |  94 ++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 187 insertions(+), 36 deletions(-)

diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
index e4c52bc..a1798a8 100644
--- a/lisp/net/nsm.el
+++ b/lisp/net/nsm.el
@@ -298,9 +298,15 @@ See also: `nsm-tls-checks' and `nsm-noninteractive'"
                                  (format-message
                                  "The TLS connection to %s:%s is insecure for 
the following reason%s:\n\n%s"
                                  host port
-                                 (if (> (length results) 1)
+                                 (if (> (length problems) 1)
                                      "s" "")
-                                 (string-join (map-values results) "\n"))))
+                                 (concat "* " (string-join
+                                                (split-string
+                                                 (string-join
+                                                  (map-values results)
+                                                  "\n")
+                                                 "\n")
+                                                "\n* ")))))
                  (delete-process process)
                  (setq process nil)))
       (run-hook-with-args 'nsm-tls-post-check-functions
@@ -805,6 +811,8 @@ protocol."
 (set-advertised-calling-convention
  'nsm-query '(host port status what problems message) "27.1")
 
+(declare-function gnutls-format-certificate "gnutls.c" (cert))
+
 (defun nsm-query-user (message status)
   (let ((buffer (get-buffer-create "*Network Security Manager*"))
         (cert-buffer (get-buffer-create "*Certificate Details*"))
@@ -823,9 +831,69 @@ protocol."
       (unwind-protect
           (let* ((accept-choices '((?a "always" "Accept this certificate this 
session and for all future sessions.")
                                    (?s "session only" "Accept this certificate 
this session only.")
-                                   (?n "no" "Refuse to use this certificate, 
and close the connection.")))
-                 (answer (read-multiple-choice "Continue connecting?" 
accept-choices)))
+                                   (?n "no" "Refuse to use this certificate, 
and close the connection.")
+                                   (?d "details" "See certificate details")))
+                 (details-choices '((?b "backward page" "See previous page")
+                                    (?f "forward page" "See next page")
+                                    (?n "next" "Next certificate")
+                                    (?p "previous" "Previous certificate")
+                                    (?q "quit" "Quit details view")))
+                 (answer (read-multiple-choice "Continue connecting?" 
accept-choices))
+                 (show-details (char-equal (car answer) ?d))
+                 (pems (cl-loop for cert in certs
+                                collect (gnutls-format-certificate (plist-get 
cert :pem))))
+                 (cert-index 0))
+            (while show-details
+              (unless (get-buffer-window cert-buffer)
+                (set-window-buffer (get-buffer-window buffer) cert-buffer)
+                (with-current-buffer cert-buffer
+                  (read-only-mode -1)
+                  (insert (nth cert-index pems))
+                  (goto-char (point-min))
+                  (read-only-mode)))
+
+              (setq answer (read-multiple-choice "Viewing certificate:" 
details-choices))
+
+              (cond
+               ((char-equal (car answer) ?q)
+                (setq show-details (not show-details))
+                (set-window-buffer (get-buffer-window cert-buffer) buffer)
+                (setq show-details (char-equal
+                                    (car (setq answer
+                                               (read-multiple-choice
+                                                "Continue connecting?"
+                                                accept-choices)))
+                                    ?d)))
+
+               ((char-equal (car answer) ?b)
+                (with-selected-window (get-buffer-window cert-buffer)
+                  (with-current-buffer cert-buffer
+                    (ignore-errors (scroll-down)))))
+
+               ((char-equal (car answer) ?f)
+                (with-selected-window (get-buffer-window cert-buffer)
+                  (with-current-buffer cert-buffer
+                    (ignore-errors (scroll-up)))))
+
+               ((char-equal (car answer) ?n)
+                (with-current-buffer cert-buffer
+                  (read-only-mode -1)
+                  (erase-buffer)
+                  (setq cert-index (mod (1+ cert-index) (length pems)))
+                  (insert (nth cert-index pems))
+                  (goto-char (point-min))
+                  (read-only-mode)))
+
+               ((char-equal (car answer) ?p)
+                (with-current-buffer cert-buffer
+                  (read-only-mode -1)
+                  (erase-buffer)
+                  (setq cert-index (mod (1- cert-index) (length pems)))
+                  (insert (nth cert-index pems))
+                  (goto-char (point-min))
+                  (read-only-mode)))))
             (cadr answer))
+        (kill-buffer cert-buffer)
         (kill-buffer buffer)))))
 
 (set-advertised-calling-convention 'nsm-query-user '(message status) "27.1")
@@ -931,49 +999,42 @@ protocol."
   (let ((cert (plist-get status :certificate)))
     (when cert
       (with-temp-buffer
-       (insert
-        "Certificate information\n"
-        "Issued by:"
+        (insert
+        (propertize "Certificate information" 'face 'underline) "\n"
+        "  Issued by:"
         (nsm-certificate-part (plist-get cert :issuer) "CN" t) "\n"
-        "Issued to:"
+        "  Issued to:"
         (or (nsm-certificate-part (plist-get cert :subject) "O")
             (nsm-certificate-part (plist-get cert :subject) "OU" t))
         "\n"
-        "Hostname:"
+        "  Hostname:"
         (nsm-certificate-part (plist-get cert :subject) "CN" t) "\n")
        (when (and (plist-get cert :public-key-algorithm)
                   (plist-get cert :signature-algorithm))
+         (insert "  Public key:" (plist-get cert :public-key-algorithm) "\n")
+          (insert "  Signature:" (plist-get cert :signature-algorithm) "\n"))
+        (when (plist-get cert :certificate-security-level)
          (insert
-          "Public key:" (plist-get cert :public-key-algorithm)
-          ", signature: " (plist-get cert :signature-algorithm) "\n"))
-       (when (and (plist-get status :key-exchange)
-                  (plist-get status :cipher)
-                  (plist-get status :mac)
-                   (plist-get status :protocol)
-                   (plist-get status :compression))
-         (insert
-          "Protocol:" (plist-get status :protocol)
-           ", safe renegotiation: " (if (plist-get status :safe-renegotiation) 
"YES" "NO")
-          ", compression: " (plist-get status :compression)
-          ", encrypt-then-MAC: " (if (plist-get status :encrypt-then-mac) 
"YES" "NO")
-          ", key: " (plist-get status :key-exchange)
-           (if (string-match "^\\bDHE\\b" (plist-get status :key-exchange))
-               (concat ", prime bits: " (format "%s" (plist-get status 
:diffie-hellman-prime-bits)))
-             "")
-          ", cipher: " (plist-get status :cipher)
-          ", mac: " (plist-get status :mac) "\n"))
-       (when (plist-get cert :certificate-security-level)
-         (insert
-          "Security level:"
+          "  Security level:"
           (propertize (plist-get cert :certificate-security-level)
                       'face 'bold)
           "\n"))
        (insert
-        "Valid:From " (plist-get cert :valid-from)
-        " to " (plist-get cert :valid-to) "\n\n")
-       (goto-char (point-min))
+        "  Valid:From " (plist-get cert :valid-from)
+        " to " (plist-get cert :valid-to) "\n")
+        ;; Handshake parameters
+        (insert (propertize "Session information" 'face 'underline) "\n")
+       (insert "  Version:" (plist-get status :protocol) "\n")
+        (insert "  Safe renegotiation:" (if (plist-get status 
:safe-renegotiation) "Yes" "No") "\n")
+       (insert "  Compression:" (plist-get status :compression) "\n")
+       (insert "  Encrypt-then-MAC:" (if (plist-get status :encrypt-then-mac) 
"Yes" "No") "\n")
+        (insert "  Cipher suite:" (nsm-cipher-suite status) "\n")
+        (if (string-match "^\\bDHE\\b" (plist-get status :key-exchange))
+            (insert "  DH prime bits:" (format "%d" (plist-get status 
:diffie-hellman-prime-bits)) "\n")
+          (insert "\n"))
+        (goto-char (point-min))
        (while (re-search-forward "^[^:]+:" nil t)
-         (insert (make-string (- 20 (current-column)) ? )))
+         (insert (make-string (- 22 (current-column)) ? )))
        (buffer-string)))))
 
 (defun nsm-certificate-part (string part &optional full)
diff --git a/src/gnutls.c b/src/gnutls.c
index 448f673..117278d 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -152,6 +152,8 @@ DEF_DLL_FN (int, gnutls_x509_crt_check_hostname,
 DEF_DLL_FN (int, gnutls_x509_crt_check_issuer,
               (gnutls_x509_crt_t, gnutls_x509_crt_t));
 DEF_DLL_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t));
+DEF_DLL_DN (int, gnutls_x509_crt_export,
+            (gnutls_x509_crt_t, gnutls_x509_crt_fmt_t, void *, size_t *));
 DEF_DLL_FN (int, gnutls_x509_crt_import,
            (gnutls_x509_crt_t, const gnutls_datum_t *,
             gnutls_x509_crt_fmt_t));
@@ -173,6 +175,9 @@ DEF_DLL_FN (int, gnutls_x509_crt_get_dn,
            (gnutls_x509_crt_t, char *, size_t *));
 DEF_DLL_FN (int, gnutls_x509_crt_get_pk_algorithm,
            (gnutls_x509_crt_t, unsigned int *));
+DEF_DLL_FN (int, gnutls_x509_crt_print,
+            (gnutls_x509_crt_t, gnutls_certificate_print_formats_t,
+             gnutls_datum_t *));
 DEF_DLL_FN (const char *, gnutls_pk_algorithm_get_name,
            (gnutls_pk_algorithm_t));
 DEF_DLL_FN (int, gnutls_pk_bits_to_sec_param,
@@ -317,6 +322,7 @@ init_gnutls_functions (void)
   LOAD_DLL_FN (library, gnutls_x509_crt_check_hostname);
   LOAD_DLL_FN (library, gnutls_x509_crt_check_issuer);
   LOAD_DLL_FN (library, gnutls_x509_crt_deinit);
+  LOAD_DLL_FN (library, gnutls_x509_crt_export);
   LOAD_DLL_FN (library, gnutls_x509_crt_import);
   LOAD_DLL_FN (library, gnutls_x509_crt_init);
   LOAD_DLL_FN (library, gnutls_x509_crt_get_fingerprint);
@@ -327,6 +333,7 @@ init_gnutls_functions (void)
   LOAD_DLL_FN (library, gnutls_x509_crt_get_expiration_time);
   LOAD_DLL_FN (library, gnutls_x509_crt_get_dn);
   LOAD_DLL_FN (library, gnutls_x509_crt_get_pk_algorithm);
+  LOAD_DLL_FN (library, gnutls_x509_crt_print)
   LOAD_DLL_FN (library, gnutls_pk_algorithm_get_name);
   LOAD_DLL_FN (library, gnutls_pk_bits_to_sec_param);
   LOAD_DLL_FN (library, gnutls_x509_crt_get_issuer_unique_id);
@@ -455,6 +462,7 @@ init_gnutls_functions (void)
 #  define gnutls_x509_crt_check_hostname fn_gnutls_x509_crt_check_hostname
 #  define gnutls_x509_crt_check_issuer fn_gnutls_x509_crt_check_issuer
 #  define gnutls_x509_crt_deinit fn_gnutls_x509_crt_deinit
+#  define gnutls_x509_crt_export fn_gnutls_x509_crt_export
 #  define gnutls_x509_crt_get_activation_time 
fn_gnutls_x509_crt_get_activation_time
 #  define gnutls_x509_crt_get_dn fn_gnutls_x509_crt_get_dn
 #  define gnutls_x509_crt_get_expiration_time 
fn_gnutls_x509_crt_get_expiration_time
@@ -463,6 +471,7 @@ init_gnutls_functions (void)
 #  define gnutls_x509_crt_get_issuer_unique_id 
fn_gnutls_x509_crt_get_issuer_unique_id
 #  define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id
 #  define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm
+#  define gnutls_x509_crt_print fn_gnutls_x509_crt_print
 #  define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial
 #  define gnutls_x509_crt_get_signature_algorithm 
fn_gnutls_x509_crt_get_signature_algorithm
 #  define gnutls_x509_crt_get_subject_unique_id 
fn_gnutls_x509_crt_get_subject_unique_id
@@ -1024,7 +1033,34 @@ gnutls_hex_string (unsigned char *buf, ptrdiff_t 
buf_size, const char *prefix)
 }
 
 static Lisp_Object
-gnutls_certificate_details (gnutls_x509_crt_t cert)
+emacs_gnutls_certificate_export_pem (gnutls_x509_crt_t cert)
+{
+  size_t size = 0;
+  int err = gnutls_x509_crt_export (cert, GNUTLS_X509_FMT_PEM, NULL, &size);
+  check_memory_full (err);
+
+  if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+    {
+      unsigned char *buf = xmalloc(size * sizeof (unsigned char));
+      err = gnutls_x509_crt_export (cert, GNUTLS_X509_FMT_PEM, buf, &size);
+      check_memory_full (err);
+
+      if (err < GNUTLS_E_SUCCESS)
+        {
+          xfree (buf);
+          error ("GnuTLS certificate export error: %s", emacs_gnutls_strerror 
(err));
+        }
+
+      return build_string(buf);
+    }
+  else if (err < GNUTLS_E_SUCCESS)
+    error ("GnuTLS certificate export error: %s", emacs_gnutls_strerror (err));
+
+  return Qnil;
+}
+
+static Lisp_Object
+emacs_gnutls_certificate_details (gnutls_x509_crt_t cert)
 {
   Lisp_Object res = Qnil;
   int err;
@@ -1192,6 +1228,10 @@ gnutls_certificate_details (gnutls_x509_crt_t cert)
       xfree (buf);
     }
 
+  /* PEM */
+  res = nconc2 (res, list2 (intern (":pem"),
+                            emacs_gnutls_certificate_export_pem(cert)));
+
   return res;
 }
 
@@ -1354,7 +1394,7 @@ returned as the :certificate entry.  */)
 
       /* Return all the certificates in a list. */
       for (int i = 0; i < XPROCESS (proc)->gnutls_certificates_length; i++)
-       certs = nconc2 (certs, list1 (gnutls_certificate_details
+       certs = nconc2 (certs, list1 (emacs_gnutls_certificate_details
                                      (XPROCESS 
(proc)->gnutls_certificates[i])));
 
       result = nconc2 (result, list2 (intern (":certificates"), certs));
@@ -1480,6 +1520,55 @@ boot_error (struct Lisp_Process *p, const char *m, ...)
   va_end (ap);
 }
 
+DEFUN ("gnutls-format-certificate", Fgnutls_format_certificate, 
Sgnutls_format_certificate, 1, 1, 0,
+       doc: /* Format a X.509 certificate to a string.
+
+Given a PEM-encoded X.509 certificate CERT, returns a human-readable
+string representation.  */)
+     (Lisp_Object cert)
+{
+  CHECK_STRING (cert);
+
+  int err;
+  gnutls_x509_crt_t crt;
+
+  err = gnutls_x509_crt_init (&crt);
+  check_memory_full (err);
+  if (err < GNUTLS_E_SUCCESS)
+    error ("gnutls-format-certificate error: %s", emacs_gnutls_strerror (err));
+
+  unsigned char *crt_buf = SDATA (cert);
+  gnutls_datum_t crt_data = { crt_buf, strlen (crt_buf) };
+  err = gnutls_x509_crt_import (crt, &crt_data, GNUTLS_X509_FMT_PEM);
+  check_memory_full (err);
+  if (err < GNUTLS_E_SUCCESS)
+    {
+      gnutls_x509_crt_deinit (crt);
+      error ("gnutls-format-certificate error: %s", emacs_gnutls_strerror 
(err));
+    }
+
+  gnutls_datum_t out;
+  err = gnutls_x509_crt_print (crt, GNUTLS_CRT_PRINT_FULL, &out);
+  check_memory_full (err);
+  if (err < GNUTLS_E_SUCCESS)
+    {
+      gnutls_x509_crt_deinit (crt);
+      error ("gnutls-format-certificate error: %s", emacs_gnutls_strerror 
(err));
+    }
+
+  char *out_buf = xmalloc ((out.size + 1) * sizeof (char));
+  memset (out_buf, 0, (out.size + 1) * sizeof (char));
+  memcpy (out_buf, out.data, out.size);
+
+  xfree (out.data);
+  gnutls_x509_crt_deinit (crt);
+
+  Lisp_Object result = build_string (out_buf);
+  xfree (out_buf);
+
+  return result;
+}
+
 Lisp_Object
 gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
 {
@@ -2713,6 +2802,7 @@ syms_of_gnutls (void)
   defsubr (&Sgnutls_bye);
   defsubr (&Sgnutls_peer_status);
   defsubr (&Sgnutls_peer_status_warning_describe);
+  defsubr (&Sgnutls_format_certificate);
 
 #ifdef HAVE_GNUTLS3
   defsubr (&Sgnutls_ciphers);