[Emacs-diffs] master 8608c10 01/02: Use a simple list of symbols in GnuTLS peer verification.

[Teodor Zlatanov]

branch: master
commit 8608c1009dafa7bf657e8835087bb8ad81357202
Author: Ted Zlatanov <address@hidden>
Date:   Tue Nov 25 09:07:13 2014 -0500

    Use a simple list of symbols in GnuTLS peer verification.
    
    * gnutls.c (Fgnutls_peer_status_warning_describe): Add function to describe 
a
    peer verification warning symbol.
    (Fgnutls_peer_status): Use it.
    (Fgnutls_boot): Use it.
---
 src/ChangeLog |    4 ++
 src/gnutls.c  |  120 +++++++++++++++++++++++++++++++--------------------------
 2 files changed, 69 insertions(+), 55 deletions(-)

diff --git a/src/ChangeLog b/src/ChangeLog
index 220c2bf..922b61a 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,6 +1,10 @@
 2014-11-25  Teodor Zlatanov  <address@hidden>
 
        * gnutls.c (Fgnutls_peer_status): Check GNUTLS_INITSTAGE, not gnutls_p.
+       (Fgnutls_peer_status_warning_describe): Add function to describe a
+       peer verification warning symbol.
+       (Fgnutls_peer_status): Use it.
+       (Fgnutls_boot): Use it.
 
 2014-11-24  Lars Magne Ingebrigtsen  <address@hidden>
 
diff --git a/src/gnutls.c b/src/gnutls.c
index bfa6078..604c595 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -968,9 +968,44 @@ gnutls_certificate_details (gnutls_x509_crt_t cert)
   return res;
 }
 
+DEFUN ("gnutls-peer-status-warning-describe", 
Fgnutls_peer_status_warning_describe, Sgnutls_peer_status_warning_describe, 1, 
1, 0,
+       doc: /* Describe the warning of a GnuTLS peer status from 
`gnutls-peer-status'.*/)
+  (Lisp_Object status_symbol)
+{
+  CHECK_SYMBOL (status_symbol);
+
+  if ( EQ (status_symbol, intern (":invalid")))
+    return build_string ("certificate could not be verified");
+
+  if ( EQ (status_symbol, intern (":revoked")) )
+    return build_string ("certificate was revoked (CRL)");
+
+  if ( EQ (status_symbol, intern (":self-signed")) )
+    return build_string ("certificate signer was not found (self-signed)");
+
+  if ( EQ (status_symbol, intern (":not-ca")) )
+    return build_string ("certificate signer is not a CA");
+
+  if ( EQ (status_symbol, intern (":insecure")) )
+    return build_string ("certificate was signed with an insecure algorithm");
+
+  if ( EQ (status_symbol, intern (":not-activated")) )
+    return build_string ("certificate is not yet activated");
+
+  if ( EQ (status_symbol, intern (":expired")) )
+    return build_string ("certificate has expired");
+
+  if ( EQ (status_symbol, intern (":no-host-match")) )
+    return build_string ("certificate host does not match hostname");
+
+  return Qnil;
+}
+
 DEFUN ("gnutls-peer-status", Fgnutls_peer_status, Sgnutls_peer_status, 1, 1, 0,
-       doc: /* Return the status of the gnutls PROC peer certificate.
-The return value is a property list.  */)
+       doc: /* Describe a GnuTLS PROC peer certificate and any warnings about 
it.
+The return value is a property list with top-level keys :warnings and
+:certificate.  The :warnings entry is a list of symbols you can describe with
+`gnutls-peer-status-warning-describe'. */)
   (Lisp_Object proc)
 {
   Lisp_Object warnings = Qnil, result = Qnil;
@@ -985,52 +1020,39 @@ The return value is a property list.  */)
   verification = XPROCESS (proc)->gnutls_peer_verification;
 
   if (verification & GNUTLS_CERT_INVALID)
-    warnings = Fcons (list2 (intern (":invalid"),
-                            build_string("certificate could not be verified")),
-                     warnings);
+    warnings = Fcons (intern (":invalid"), warnings);
 
   if (verification & GNUTLS_CERT_REVOKED)
-    warnings = Fcons (list2 (intern (":revoked"),
-                            build_string("certificate was revoked (CRL)")),
-                     warnings);
+    warnings = Fcons (intern (":revoked"), warnings);
 
   if (verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
-    warnings = Fcons (list2 (intern (":self-signed"),
-                            build_string("certificate signer was not found 
(self-signed)")),
-                     warnings);
+    warnings = Fcons (intern (":self-signed"), warnings);
 
   if (verification & GNUTLS_CERT_SIGNER_NOT_CA)
-    warnings = Fcons (list2 (intern (":not-ca"),
-                            build_string("certificate signer is not a CA")),
-                     warnings);
+    warnings = Fcons (intern (":not-ca"), warnings);
 
   if (verification & GNUTLS_CERT_INSECURE_ALGORITHM)
-    warnings = Fcons (list2 (intern (":insecure"),
-                            build_string("certificate was signed with an 
insecure algorithm")),
-                     warnings);
+    warnings = Fcons (intern (":insecure"), warnings);
 
   if (verification & GNUTLS_CERT_NOT_ACTIVATED)
-    warnings = Fcons (list2 (intern (":not-activated"),
-                            build_string("certificate is not yet activated")),
-                     warnings);
+    warnings = Fcons (intern (":not-activated"), warnings);
 
   if (verification & GNUTLS_CERT_EXPIRED)
-    warnings = Fcons (list2 (intern (":expired"),
-                            build_string("certificate has expired")),
-                     warnings);
+    warnings = Fcons (intern (":expired"), warnings);
 
   if (XPROCESS (proc)->gnutls_extra_peer_verification &
       CERTIFICATE_NOT_MATCHING)
-    warnings = Fcons (list2 (intern (":no-host-match"),
-                            build_string("certificate host does not match 
hostname")),
-                     warnings);
+    warnings = Fcons (intern (":no-host-match"), warnings);
 
   if (!NILP (warnings))
     result = list2 (intern (":warnings"), warnings);
 
-  result = nconc2 (result, list2
-                  (intern (":certificate"),
-                   gnutls_certificate_details(XPROCESS 
(proc)->gnutls_certificate)));
+  /* This could get called in the INIT stage, when the certificate is
+     not yet set. */
+  if ( XPROCESS (proc)->gnutls_certificate != NULL )
+    result = nconc2 (result, list2
+                     (intern (":certificate"),
+                      gnutls_certificate_details (XPROCESS 
(proc)->gnutls_certificate)));
 
   return result;
 }
@@ -1148,6 +1170,8 @@ one trustfile (usually a CA bundle).  */)
   Lisp_Object hostname;
   Lisp_Object verify_error;
   Lisp_Object prime_bits;
+  Lisp_Object warnings;
+  Lisp_Object warning;
 
   CHECK_PROCESS (proc);
   CHECK_SYMBOL (type);
@@ -1392,33 +1416,19 @@ one trustfile (usually a CA bundle).  */)
 
   XPROCESS (proc)->gnutls_peer_verification = peer_verification;
 
-  if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
-    message ("%s certificate could not be verified.", c_hostname);
-
-  if (peer_verification & GNUTLS_CERT_REVOKED)
-    GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
-                c_hostname);
-
-  if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
-    GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
-                c_hostname);
-
-  if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
-    GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
-                c_hostname);
-
-  if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
-    GNUTLS_LOG2 (1, max_log_level,
-                "certificate was signed with an insecure algorithm:",
-                c_hostname);
-
-  if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
-    GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
-                c_hostname);
+  warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
+  if ( !NILP (warnings) )
+    {
+      Lisp_Object tail;
 
-  if (peer_verification & GNUTLS_CERT_EXPIRED)
-    GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
-                c_hostname);
+      for (tail = warnings; CONSP (tail); tail = XCDR (tail))
+        {
+          Lisp_Object warning = XCAR (tail);
+          Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
+          if ( !NILP (message) )
+            GNUTLS_LOG2 (1, max_log_level, "verification: %s", SDATA(message));
+        }
+    }
 
   if (peer_verification != 0)
     {