Add GnuTLS support for W32 and certificate and hostname verification in GnuTLS.

* src/gnutls.c: Renamed global_initialized to
gnutls_global_initialized.  Added internals for the
:verify-hostname-error, :verify-error, and :verify-flags
parameters of `gnutls-boot' and documented those parameters in the
docstring.  Start callback support.
(emacs_gnutls_handshake): Add Woe32 support. Retry handshake
unless a fatal error occured. Call gnutls_alert_send_appropriate
on error. Return error code.
(emacs_gnutls_write): Call emacs_gnutls_handle_error.
(emacs_gnutls_read): Likewise.
(Fgnutls_boot): Return handshake error code.
(emacs_gnutls_handle_error): New function.
(wsaerror_to_errno): Likewise.

* src/gnutls.h: Add GNUTLS_STAGE_CALLBACKS enum to denote we're in the
callbacks stage.

* src/w32.c (emacs_gnutls_pull): New function for GnuTLS on Woe32.
(emacs_gnutls_push): Likewise.

* src/w32.h (emacs_gnutls_pull): Add prototype.
(emacs_gnutls_push): Likewise.

1 files changed, 321 insertions, 39 deletions

diff --git a/src/gnutls.c b/src/gnutls.c
index f4f2b9bbd35..18ceb79193b 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -26,11 +26,20 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 #ifdef HAVE_GNUTLS
 #include <gnutls/gnutls.h>
 
+#ifdef WINDOWSNT
+#include <windows.h>
+#include "w32.h"
+#endif
+
+static int
+emacs_gnutls_handle_error (gnutls_session_t, int err);
+
+Lisp_Object Qgnutls_log_level;
 Lisp_Object Qgnutls_code;
 Lisp_Object Qgnutls_anon, Qgnutls_x509pki;
 Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again,
   Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake;
-int global_initialized;
+int gnutls_global_initialized;
 
 /* The following are for the property list of `gnutls-boot'.  */
 Lisp_Object Qgnutls_bootprop_priority;
@@ -38,8 +47,27 @@ Lisp_Object Qgnutls_bootprop_trustfiles;
 Lisp_Object Qgnutls_bootprop_keyfiles;
 Lisp_Object Qgnutls_bootprop_callbacks;
 Lisp_Object Qgnutls_bootprop_loglevel;
+Lisp_Object Qgnutls_bootprop_hostname;
+Lisp_Object Qgnutls_bootprop_verify_flags;
+Lisp_Object Qgnutls_bootprop_verify_error;
+Lisp_Object Qgnutls_bootprop_verify_hostname_error;
+
+/* Callback keys for `gnutls-boot'.  Unused currently.  */
+Lisp_Object Qgnutls_bootprop_callbacks_verify;
 
 static void
+gnutls_log_function (int level, const char* string)
+{
+  message ("gnutls.c: [%d] %s", level, string);
+}
+
+static void
+gnutls_log_function2 (int level, const char* string, const char* extra)
+{
+  message ("gnutls.c: [%d] %s %s", level, string, extra);
+}
+
+static int
 emacs_gnutls_handshake (struct Lisp_Process *proc)
 {
   gnutls_session_t state = proc->gnutls_state;
@@ -50,24 +78,55 @@ emacs_gnutls_handshake (struct Lisp_Process *proc)
 
   if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
     {
+#ifdef WINDOWSNT
+      /* On W32 we cannot transfer socket handles between different runtime
+         libraries, so we tell GnuTLS to use our special push/pull
+         functions.  */
+      gnutls_transport_set_ptr2 (state,
+                                 (gnutls_transport_ptr_t) proc,
+                                 (gnutls_transport_ptr_t) proc);
+      gnutls_transport_set_push_function (state, &emacs_gnutls_push);
+      gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
+
+      /* For non blocking sockets or other custom made pull/push
+         functions the gnutls_transport_set_lowat must be called, with
+         a zero low water mark value. (GnuTLS 2.10.4 documentation)
+
+         (Note: this is probably not strictly necessary as the lowat
+          value is only used when no custom pull/push functions are
+          set.)  */
+      gnutls_transport_set_lowat (state, 0);
+#else
       /* This is how GnuTLS takes sockets: as file descriptors passed
          in.  For an Emacs process socket, infd and outfd are the
          same but we use this two-argument version for clarity.  */
       gnutls_transport_set_ptr2 (state,
-				 (gnutls_transport_ptr_t) (long) proc->infd,
-				 (gnutls_transport_ptr_t) (long) proc->outfd);
+        			 (gnutls_transport_ptr_t) proc->infd,
+        			 (gnutls_transport_ptr_t) proc->outfd);
+#endif
 
       proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
     }
 
-  ret = gnutls_handshake (state);
+  do
+    {
+      ret = gnutls_handshake (state);
+      emacs_gnutls_handle_error (state, ret);
+    }
+  while (ret < 0 && gnutls_error_is_fatal (ret) == 0);
+
   proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
 
   if (ret == GNUTLS_E_SUCCESS)
     {
-      /* here we're finally done.  */
+      /* Here we're finally done.  */
       proc->gnutls_initstage = GNUTLS_STAGE_READY;
     }
+  else
+    {
+        gnutls_alert_send_appropriate (state, ret);
+    }
+  return ret;
 }
 
 EMACS_INT
@@ -107,6 +166,7 @@ emacs_gnutls_write (int fildes, struct Lisp_Process *proc, const char *buf,
       bytes_written += rtnval;
     }
 
+  emacs_gnutls_handle_error (state, rtnval);
   return (bytes_written);
 }
 
@@ -122,19 +182,68 @@ emacs_gnutls_read (int fildes, struct Lisp_Process *proc, char *buf,
       emacs_gnutls_handshake (proc);
       return -1;
     }
-
   rtnval = gnutls_read (state, buf, nbyte);
   if (rtnval >= 0)
     return rtnval;
+  else if (emacs_gnutls_handle_error (state, rtnval) == 0)
+    /* non-fatal error */
+    return -1;
   else {
-    if (rtnval == GNUTLS_E_AGAIN ||
-	rtnval == GNUTLS_E_INTERRUPTED)
-      return -1;
-    else
-      return 0;
+    /* a fatal error occured */
+    return 0;
   }
 }
 
+/* report a GnuTLS error to the user.
+   Returns zero if the error code was successfully handled. */
+static int
+emacs_gnutls_handle_error (gnutls_session_t session, int err)
+{
+  Lisp_Object gnutls_log_level = Fsymbol_value (Qgnutls_log_level);
+  int max_log_level = 0;
+
+  int alert, ret;
+  const char *str;
+
+  /* TODO: use a Lisp_Object generated by gnutls_make_error?  */
+  if (err >= 0)
+    return 0;
+
+  if (NUMBERP (gnutls_log_level))
+    max_log_level = XINT (gnutls_log_level);
+
+  /* TODO: use gnutls-error-fatalp and gnutls-error-string.  */
+
+  str = gnutls_strerror (err);
+  if (!str)
+    str = "unknown";
+
+  if (gnutls_error_is_fatal (err))
+    {
+      ret = err;
+      GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
+    }
+  else
+    {
+      ret = 0;
+      GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str);
+      /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2.  */
+    }
+
+  if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
+      || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
+    {
+      int alert = gnutls_alert_get (session);
+      int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
+      str = gnutls_alert_get_name (alert);
+      if (!str)
+	str = "unknown";
+
+      GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
+    }
+  return ret;
+}
+
 /* convert an integer error to a Lisp_Object; it will be either a
    known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
    simply the integer value of the error.  GNUTLS_E_SUCCESS is mapped
@@ -262,14 +371,14 @@ See also `gnutls-init'.  */)
 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
 Returns zero on success.  */
 static Lisp_Object
-gnutls_emacs_global_init (void)
+emacs_gnutls_global_init (void)
 {
   int ret = GNUTLS_E_SUCCESS;
 
-  if (!global_initialized)
+  if (!gnutls_global_initialized)
     ret = gnutls_global_init ();
 
-  global_initialized = 1;
+  gnutls_global_initialized = 1;
 
   return gnutls_make_error (ret);
 }
@@ -277,28 +386,16 @@ gnutls_emacs_global_init (void)
 /* Deinitializes global GnuTLS state.
 See also `gnutls-global-init'.  */
 static Lisp_Object
-gnutls_emacs_global_deinit (void)
+emacs_gnutls_global_deinit (void)
 {
-  if (global_initialized)
+  if (gnutls_global_initialized)
     gnutls_global_deinit ();
 
-  global_initialized = 0;
+  gnutls_global_initialized = 0;
 
   return gnutls_make_error (GNUTLS_E_SUCCESS);
 }
 
-static void
-gnutls_log_function (int level, const char* string)
-{
-  message ("gnutls.c: [%d] %s", level, string);
-}
-
-static void
-gnutls_log_function2 (int level, const char* string, const char* extra)
-{
-  message ("gnutls.c: [%d] %s %s", level, string, extra);
-}
-
 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
 Currently only client mode is supported.  Returns a success/failure
@@ -307,12 +404,27 @@ value you can check with `gnutls-errorp'.
 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
 PROPLIST is a property list with the following keys:
 
+:hostname is a string naming the remote host.
+
 :priority is a GnuTLS priority string, defaults to "NORMAL".
+
 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
+
 :keyfiles is a list of PEM-encoded key files for `gnutls-x509pki'.
-:callbacks is an alist of callback functions (TODO).
+
+:callbacks is an alist of callback functions, see below.
+
 :loglevel is the debug level requested from GnuTLS, try 4.
 
+:verify-flags is a bitset as per GnuTLS'
+gnutls_certificate_set_verify_flags.
+
+:verify-error, if non-nil, makes failure of the certificate validation
+an error.  Otherwise it will be just a series of warnings.
+
+:verify-hostname-error, if non-nil, makes a hostname mismatch an
+error.  Otherwise it will be just a warning.
+
 The debug level will be set for this process AND globally for GnuTLS.
 So if you set it higher or lower at any point, it affects global
 debugging.
@@ -325,6 +437,9 @@ Processes must be initialized with this function before other GnuTLS
 functions are used.  This function allocates resources which can only
 be deallocated by calling `gnutls-deinit' or by calling it again.
 
+The callbacks alist can have a `verify' key, associated with a
+verification function (UNUSED).
+
 Each authentication type may need additional information in order to
 work.  For X.509 PKI (`gnutls-x509pki'), you probably need at least
 one trustfile (usually a CA bundle).  */)
@@ -337,12 +452,19 @@ one trustfile (usually a CA bundle).  */)
   /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
   int file_format = GNUTLS_X509_FMT_PEM;
 
+  unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
+  gnutls_x509_crt_t gnutls_verify_cert;
+  unsigned int gnutls_verify_cert_list_size;
+  const gnutls_datum_t *gnutls_verify_cert_list;
+
   gnutls_session_t state;
   gnutls_certificate_credentials_t x509_cred;
   gnutls_anon_client_credentials_t anon_cred;
   Lisp_Object global_init;
   char* priority_string_ptr = "NORMAL"; /* default priority string.  */
   Lisp_Object tail;
+  int peer_verification;
+  char* c_hostname;
 
   /* Placeholders for the property list elements.  */
   Lisp_Object priority_string;
@@ -350,16 +472,29 @@ one trustfile (usually a CA bundle).  */)
   Lisp_Object keyfiles;
   Lisp_Object callbacks;
   Lisp_Object loglevel;
+  Lisp_Object hostname;
+  Lisp_Object verify_flags;
+  Lisp_Object verify_error;
+  Lisp_Object verify_hostname_error;
 
   CHECK_PROCESS (proc);
   CHECK_SYMBOL (type);
   CHECK_LIST (proplist);
 
-  priority_string = Fplist_get (proplist, Qgnutls_bootprop_priority);
-  trustfiles      = Fplist_get (proplist, Qgnutls_bootprop_trustfiles);
-  keyfiles        = Fplist_get (proplist, Qgnutls_bootprop_keyfiles);
-  callbacks       = Fplist_get (proplist, Qgnutls_bootprop_callbacks);
-  loglevel        = Fplist_get (proplist, Qgnutls_bootprop_loglevel);
+  hostname              = Fplist_get (proplist, Qgnutls_bootprop_hostname);
+  priority_string       = Fplist_get (proplist, Qgnutls_bootprop_priority);
+  trustfiles            = Fplist_get (proplist, Qgnutls_bootprop_trustfiles);
+  keyfiles              = Fplist_get (proplist, Qgnutls_bootprop_keyfiles);
+  callbacks             = Fplist_get (proplist, Qgnutls_bootprop_callbacks);
+  loglevel              = Fplist_get (proplist, Qgnutls_bootprop_loglevel);
+  verify_flags          = Fplist_get (proplist, Qgnutls_bootprop_verify_flags);
+  verify_error          = Fplist_get (proplist, Qgnutls_bootprop_verify_error);
+  verify_hostname_error = Fplist_get (proplist, Qgnutls_bootprop_verify_hostname_error);
+
+  if (!STRINGP (hostname))
+    error ("gnutls-boot: invalid :hostname parameter");
+
+  c_hostname = SSDATA (hostname);
 
   state = XPROCESS (proc)->gnutls_state;
   XPROCESS (proc)->gnutls_p = 1;
@@ -373,7 +508,7 @@ one trustfile (usually a CA bundle).  */)
     }
 
   /* always initialize globals.  */
-  global_init = gnutls_emacs_global_init ();
+  global_init = emacs_gnutls_global_init ();
   if (! NILP (Fgnutls_errorp (global_init)))
     return global_init;
 
@@ -417,6 +552,23 @@ one trustfile (usually a CA bundle).  */)
       x509_cred = XPROCESS (proc)->gnutls_x509_cred;
       if (gnutls_certificate_allocate_credentials (&x509_cred) < 0)
         memory_full ();
+
+      if (NUMBERP (verify_flags))
+        {
+          gnutls_verify_flags = XINT (verify_flags);
+          GNUTLS_LOG (2, max_log_level, "setting verification flags");
+        }
+      else if (NILP (verify_flags))
+        {
+          /* The default is already GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT.  */
+          GNUTLS_LOG (2, max_log_level, "using default verification flags");
+        }
+      else
+        {
+          /* The default is already GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT.  */
+          GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
+        }
+      gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
     }
   else if (EQ (type, Qgnutls_anon))
     {
@@ -485,6 +637,14 @@ one trustfile (usually a CA bundle).  */)
 
   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 
+  GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
+
+  GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
+
+#ifdef HAVE_GNUTLS_CALLBACK_CERTIFICATE_VERIFY
+#else
+#endif
+
   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 
   ret = gnutls_init (&state, GNUTLS_CLIENT);
@@ -542,9 +702,113 @@ one trustfile (usually a CA bundle).  */)
 
   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
 
-  emacs_gnutls_handshake (XPROCESS (proc));
+  ret = emacs_gnutls_handshake (XPROCESS (proc));
 
-  return gnutls_make_error (GNUTLS_E_SUCCESS);
+  if (ret < GNUTLS_E_SUCCESS)
+    return gnutls_make_error (ret);
+
+  /* Now verify the peer, following
+     http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
+     The peer should present at least one certificate in the chain; do a
+     check of the certificate's hostname with
+     gnutls_x509_crt_check_hostname() against :hostname.  */
+
+  ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
+
+  if (ret < GNUTLS_E_SUCCESS)
+    return gnutls_make_error (ret);
+  
+  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);
+
+ if (peer_verification & GNUTLS_CERT_EXPIRED)
+   GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
+                c_hostname);
+
+ if (peer_verification != 0)
+   {
+     if (NILP (verify_hostname_error))
+       {
+         GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
+                      c_hostname);
+       }
+     else
+       {
+         error ("Certificate validation failed %s, verification code %d",
+                c_hostname, peer_verification);
+       }
+   }
+
+  /* Up to here the process is the same for X.509 certificates and
+     OpenPGP keys.  From now on X.509 certificates are assumed.  This
+     can be easily extended to work with openpgp keys as well.  */
+  if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
+    {
+      ret = gnutls_x509_crt_init (&gnutls_verify_cert);
+
+      if (ret < GNUTLS_E_SUCCESS)
+        return gnutls_make_error (ret);
+
+      gnutls_verify_cert_list = 
+        gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
+
+      if (NULL == gnutls_verify_cert_list)
+        {
+          error ("No x509 certificate was found!\n");
+        }
+
+      /* We only check the first certificate in the given chain.  */
+      ret = gnutls_x509_crt_import (gnutls_verify_cert,
+                                    &gnutls_verify_cert_list[0],
+                                    GNUTLS_X509_FMT_DER);
+
+      if (ret < GNUTLS_E_SUCCESS)
+        {
+          gnutls_x509_crt_deinit (gnutls_verify_cert);
+          return gnutls_make_error (ret);
+        }
+
+      if (!gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
+        {
+          if (NILP (verify_hostname_error))
+            {
+              GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
+                           c_hostname);
+            }
+          else
+            {
+              gnutls_x509_crt_deinit (gnutls_verify_cert);
+              error ("The x509 certificate does not match \"%s\"",
+                     c_hostname);
+            }
+        }
+
+      gnutls_x509_crt_deinit (gnutls_verify_cert);
+    }
+
+  return gnutls_make_error (ret);
 }
 
 DEFUN ("gnutls-bye", Fgnutls_bye,
@@ -579,7 +843,10 @@ This function may also return `gnutls-e-again', or
 void
 syms_of_gnutls (void)
 {
-  global_initialized = 0;
+  gnutls_global_initialized = 0;
+
+  Qgnutls_log_level = intern_c_string ("gnutls-log-level");
+  staticpro (&Qgnutls_log_level);
 
   Qgnutls_code = intern_c_string ("gnutls-code");
   staticpro (&Qgnutls_code);
@@ -590,6 +857,9 @@ syms_of_gnutls (void)
   Qgnutls_x509pki = intern_c_string ("gnutls-x509pki");
   staticpro (&Qgnutls_x509pki);
 
+  Qgnutls_bootprop_hostname = intern_c_string (":hostname");
+  staticpro (&Qgnutls_bootprop_hostname);
+
   Qgnutls_bootprop_priority = intern_c_string (":priority");
   staticpro (&Qgnutls_bootprop_priority);
 
@@ -602,9 +872,21 @@ syms_of_gnutls (void)
   Qgnutls_bootprop_callbacks = intern_c_string (":callbacks");
   staticpro (&Qgnutls_bootprop_callbacks);
 
+  Qgnutls_bootprop_callbacks_verify = intern_c_string ("verify");
+  staticpro (&Qgnutls_bootprop_callbacks_verify);
+
   Qgnutls_bootprop_loglevel = intern_c_string (":loglevel");
   staticpro (&Qgnutls_bootprop_loglevel);
 
+  Qgnutls_bootprop_verify_flags = intern_c_string (":verify-flags");
+  staticpro (&Qgnutls_bootprop_verify_flags);
+
+  Qgnutls_bootprop_verify_hostname_error = intern_c_string (":verify-error");
+  staticpro (&Qgnutls_bootprop_verify_error);
+
+  Qgnutls_bootprop_verify_hostname_error = intern_c_string (":verify-hostname-error");
+  staticpro (&Qgnutls_bootprop_verify_hostname_error);
+
   Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted");
   staticpro (&Qgnutls_e_interrupted);
   Fput (Qgnutls_e_interrupted, Qgnutls_code,