Re: [PATCH] GnuTLS support on Woe32

[Ted Zlatanov <tzz@lifelogs.com>]

[-- Attachment #1: Type: text/plain, Size: 1874 bytes --]

On Sun, 20 Mar 2011 22:41:23 +0100 claudio.bley@gmail.com (Claudio Bley) wrote: 
CB> I made some minor changes and integrated your patch into my branch.

CB> Basically, the changes are in correspondence to what Eli requested.

Looks OK.  I adjusted the patch against the recent configure changes and
today's Emacs trunk, added ChangeLog entries for my changes, and fixed
the `gnutls-hostname' verification.  I added verify-hostname-error and
verify-error parameters to `gnutls-negotiate' in addition to
verify-flags and I added a usage example to `open-gnutls-stream'.

I tested it all.  Seems to work OK on Linux, can you take a look?
Especially on W32, which I couldn't test?

Also I'd like the patch to be reviewed by Stefan or Chong.  It's not
huge but it's not tiny anymore either.

CB> Additionally, I reverted the change to gnutls-negotiate where I signal
CB> an error now instead of returning an error value since I had realized
CB> that some more code depended upon returning the given process. As the
CB> GnuTLS functionality should be almost transparent to other libraries
CB> making network connections I think this is the better solution. What
CB> do you think about that?

Looks OK, except there's 5000+ messages about retrying now.  Is that
necessary?

CB> Otherwise, your patch looks good so far. Except that I always got
CB> hostname mismatches for www.google.no and www.google.com.

I think that's fixed.  The explicit call to Fsymbol_value is kind of
weird, I'm sure there's a better way.

CB> Btw, I could not reproduce the problem reported by Lars Magne
CB> Ingebrigsten, ie. this

CB> (progn
CB>   (require 'gnutls)
CB>   (url-retrieve "https://www.google.no" #'ignore)
CB>   (url-retrieve "https://www.google.no" #'ignore))

CB> works flawlessly and does not hang (tested on Windows and Linux).

Let's cross our fingers :)  Lars, can you check?

Ted


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: callbacks.patch --]
[-- Type: text/x-diff, Size: 35094 bytes --]

=== modified file 'configure.in'
--- configure.in	2011-03-20 23:58:23 +0000
+++ configure.in	2011-03-21 03:32:08 +0000
@@ -1973,12 +1973,22 @@
 AC_SUBST(LIBSELINUX_LIBS)
 
 HAVE_GNUTLS=no
+HAVE_GNUTLS_CALLBACK_CERTIFICATE_VERIFY=no
 if test "${with_gnutls}" = "yes" ; then
   PKG_CHECK_MODULES([LIBGNUTLS], [gnutls >= 2.2.4], HAVE_GNUTLS=yes, HAVE_GNUTLS=no)
   if test "${HAVE_GNUTLS}" = "yes"; then
     AC_DEFINE(HAVE_GNUTLS, 1, [Define if using GnuTLS.])
   fi
+
+  CFLAGS="$CFLAGS $LIBGNUTLS_CFLAGS"
+  LIBS="$LIBGNUTLS_LIBS $LIBS"
+  AC_CHECK_FUNCS(gnutls_certificate_set_verify_function, HAVE_GNUTLS_CALLBACK_CERTIFICATE_VERIFY=yes)
+
+  if test "${HAVE_GNUTLS_CALLBACK_CERTIFICATE_VERIFY}" = "yes"; then
+    AC_DEFINE(HAVE_GNUTLS_CALLBACK_CERTIFICATE_VERIFY, 1, [Define if using GnuTLS certificate verification callbacks.])
+  fi
 fi
+
 AC_SUBST(LIBGNUTLS_LIBS)
 AC_SUBST(LIBGNUTLS_CFLAGS)
 
@@ -3667,6 +3677,7 @@
 echo "  Does Emacs use -lgconf?                                 ${HAVE_GCONF}"
 echo "  Does Emacs use -lselinux?                               ${HAVE_LIBSELINUX}"
 echo "  Does Emacs use -lgnutls?                                ${HAVE_GNUTLS}"
+echo "  Does Emacs use -lgnutls certificate verify callbacks?   ${HAVE_GNUTLS_CALLBACK_CERTIFICATE_VERIFY}"
 echo "  Does Emacs use -lxml2?                                  ${HAVE_LIBXML2}"
 
 echo "  Does Emacs use -lfreetype?                              ${HAVE_FREETYPE}"

=== modified file 'lib-src/ChangeLog'
--- lib-src/ChangeLog	2011-03-12 19:19:47 +0000
+++ lib-src/ChangeLog	2011-03-21 03:32:08 +0000
@@ -1,3 +1,7 @@
+2011-03-06  Claudio Bley  <claudio.bley@gmail.com>
+
+	* makefile.w32-in (obj): Added gnutls.o.
+
 2011-03-03  Drake Wilson  <drake@begriffli.ch>  (tiny change)
 
 	* emacsclient.c (longopts): Add quiet.

=== modified file 'lib-src/makefile.w32-in'
--- lib-src/makefile.w32-in	2011-03-12 19:19:47 +0000
+++ lib-src/makefile.w32-in	2011-03-21 03:32:08 +0000
@@ -142,7 +142,8 @@
 	syntax.o bytecode.o \
 	process.o callproc.o unexw32.o \
 	region-cache.o sound.o atimer.o \
-	doprnt.o intervals.o textprop.o composite.o
+	doprnt.o intervals.o textprop.o composite.o \
+	gnutls.o
 
 #
 # These are the lisp files that are loaded up in loadup.el

=== modified file 'lisp/ChangeLog'
--- lisp/ChangeLog	2011-03-22 00:30:23 +0000
+++ lisp/ChangeLog	2011-03-22 03:15:19 +0000
@@ -1,3 +1,17 @@
+2011-03-22  Teodor Zlatanov  <tzz@lifelogs.com>
+
+	* net/gnutls.el (gnutls-hostname): New buffer-local variable for
+	hostname verification.
+	(gnutls-negotiate): Add verify-flags, verify-error, and
+	verify-hostname-error.
+	(open-gnutls-stream): Add usage example.
+
+2011-03-22  Claudio Bley  <claudio.bley@gmail.com>
+
+	* net/gnutls.el (gnutls-negotiate): Check whether default
+	trustfile exists before going to use it. Add missing argument to
+	gnutls-message-maybe call. Return return value.
+
 2011-03-22  Chong Yidong  <cyd@stupidchicken.com>
 
 	* custom.el (custom--inhibit-theme-enable): Make it affect only

=== modified file 'lisp/net/gnutls.el'
--- lisp/net/gnutls.el	2011-01-25 04:08:28 +0000
+++ lisp/net/gnutls.el	2011-03-22 03:10:24 +0000
@@ -44,6 +44,10 @@
   :type 'integer
   :group 'gnutls)
 
+(defvar gnutls-hostname nil
+  "Remote hostname.  Always buffer-local.")
+(make-variable-buffer-local 'gnutls-hostname)
+
 (defun open-gnutls-stream (name buffer host service)
   "Open a SSL/TLS connection for a service to a host.
 Returns a subprocess-object to represent the connection.
@@ -59,26 +63,77 @@
 Fourth arg SERVICE is name of the service desired, or an integer
 specifying a port number to connect to.
 
+Usage example:
+
+  \(with-temp-buffer
+    \(open-gnutls-stream \"tls\"
+                        \(current-buffer)
+                        \"your server goes here\"
+                        \"imaps\"))
+
 This is a very simple wrapper around `gnutls-negotiate'.  See its
 documentation for the specific parameters you can use to open a
 GnuTLS connection, including specifying the credential type,
 trust and key files, and priority string."
-  (let ((proc (open-network-stream name buffer host service)))
-    (gnutls-negotiate proc 'gnutls-x509pki)))
+  ;; remember the hostname associated with this buffer
+  (with-current-buffer buffer
+    (setq gnutls-hostname host))
+  (gnutls-negotiate (open-network-stream name buffer host service)
+                    'gnutls-x509pki))
+
+(put 'gnutls-error
+     'error-conditions
+     '(error gnutls-error))
+(put 'gnutls-error
+     'error-message "GnuTLS error")
 
 (declare-function gnutls-boot "gnutls.c" (proc type proplist))
 
 (defun gnutls-negotiate (proc type &optional priority-string
-                              trustfiles keyfiles)
-  "Negotiate a SSL/TLS connection.
+                              trustfiles keyfiles verify-flags
+                              verify-error verify-hostname-error)
+  "Negotiate a SSL/TLS connection.  Returns proc. Signals gnutls-error.
 TYPE is `gnutls-x509pki' (default) or `gnutls-anon'.  Use nil for the default.
 PROC is a process returned by `open-network-stream'.
 PRIORITY-STRING is as per the GnuTLS docs, default is \"NORMAL\".
 TRUSTFILES is a list of CA bundles.
-KEYFILES is a list of client keys."
+KEYFILES is a list of client keys.
+
+When VERIFY-HOSTNAME-ERROR is not nil, an error will be raised
+when the hostname does not match the presented certificate's host
+name.  The exact verification algorithm is a basic implementation
+of the matching described in RFC2818 (HTTPS), which takes into
+account wildcards, and the DNSName/IPAddress subject alternative
+name PKIX extension.  See gnutls_x509_crt_check_hostname() for
+details.  When VERIFY-HOSTNAME-ERROR is nil, only a warning will
+be issued.
+
+When VERIFY-ERROR is not nil, an error will be raised when the
+peer certificate verification fails as per
+gnutls_certificate_verify_peers2().  Otherwise, only warnings
+will be shown about the verification failure.
+
+VERIFY-FLAGS is a numeric OR of verification flags only for
+`gnutls-x509pki' connections.  See GnuTLS' x509.h for details;
+here's a recent version of the list.
+
+    GNUTLS_VERIFY_DISABLE_CA_SIGN = 1,
+    GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT = 2,
+    GNUTLS_VERIFY_DO_NOT_ALLOW_SAME = 4,
+    GNUTLS_VERIFY_ALLOW_ANY_X509_V1_CA_CRT = 8,
+    GNUTLS_VERIFY_ALLOW_SIGN_RSA_MD2 = 16,
+    GNUTLS_VERIFY_ALLOW_SIGN_RSA_MD5 = 32,
+    GNUTLS_VERIFY_DISABLE_TIME_CHECKS = 64,
+    GNUTLS_VERIFY_DISABLE_TRUSTED_TIME_CHECKS = 128,
+    GNUTLS_VERIFY_DO_NOT_ALLOW_X509_V1_CA_CRT = 256
+
+It must be omitted, a number, or nil; if omitted or nil it
+defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
   (let* ((type (or type 'gnutls-x509pki))
+         (default-trustfile "/etc/ssl/certs/ca-certificates.crt")
          (trustfiles (or trustfiles
-                        '("/etc/ssl/certs/ca-certificates.crt")))
+                         (when (file-exists-p default-trustfile)
+                           (list default-trustfile))))
          (priority-string (or priority-string
                               (cond
                                ((eq type 'gnutls-anon)
@@ -89,12 +144,18 @@
                              :loglevel ,gnutls-log-level
                              :trustfiles ,trustfiles
                              :keyfiles ,keyfiles
+                             :verify-flags ,verify-flags
+                             :verify-error ,verify-error
+                             :verify-hostname-error ,verify-hostname-error
                              :callbacks nil))
          ret)
 
     (gnutls-message-maybe
      (setq ret (gnutls-boot proc type params))
-     "boot: %s")
+     "boot: %s" params)
+
+    (when (gnutls-errorp ret)
+      (signal 'gnutls-error (list proc ret)))
 
     proc))
 

=== modified file 'nt/ChangeLog'
--- nt/ChangeLog	2011-03-12 19:19:47 +0000
+++ nt/ChangeLog	2011-03-21 03:32:08 +0000
@@ -1,3 +1,10 @@
+2011-03-06  Claudio Bley  <claudio.bley@gmail.com>
+
+	* configure.bat: New options --without-gnutls and --lib, new build
+	variable USER_LIBS, automatically detect GnuTLS.
+	* INSTALL: Add instructions for GnuTLS support.
+	* gmake.defs: Prefix USER_LIB's with -l.
+
 2011-02-27  Eli Zaretskii  <eliz@gnu.org>
 
 	* inc/unistd.h (readlink, symlink): Declare prototypes.

=== modified file 'nt/INSTALL'
--- nt/INSTALL	2011-01-26 08:36:39 +0000
+++ nt/INSTALL	2011-03-21 03:32:08 +0000
@@ -306,6 +306,16 @@
   `dynamic-library-alist' and the value of `libpng-version', and
   download compatible DLLs if needed.
 
+* Optional GnuTLS support
+
+  To build Emacs with GnuTLS support, make sure that the
+  gnutls/gnutls.h header file can be found in the include path and
+  link to the appropriate libraries (e.g. gnutls.dll and gcrypt.dll)
+  using the --lib option.
+
+  Pre-built binaries and an installer can be found at
+  http://josefsson.org/gnutls4win/.
+
 * Experimental SVG support
 
   SVG support is currently experimental, and not built by default.

=== modified file 'nt/configure.bat'
--- nt/configure.bat	2011-01-29 12:36:11 +0000
+++ nt/configure.bat	2011-03-21 03:32:08 +0000
@@ -86,10 +86,13 @@
 set usercflags=
 set docflags=
 set userldflags=
+set userlibs=
 set doldflags=
+set dolibs=
 set sep1=
 set sep2=
 set sep3=
+set sep4=
 set distfiles=
 
 rem ----------------------------------------------------------------------
@@ -107,10 +110,12 @@
 if "%1" == "--no-cygwin" goto nocygwin
 if "%1" == "--cflags" goto usercflags
 if "%1" == "--ldflags" goto userldflags
+if "%1" == "--lib" goto userlibs
 if "%1" == "--without-png" goto withoutpng
 if "%1" == "--without-jpeg" goto withoutjpeg
 if "%1" == "--without-gif" goto withoutgif
 if "%1" == "--without-tiff" goto withouttiff
+if "%1" == "--without-gnutls" goto withoutgnutls
 if "%1" == "--without-xpm" goto withoutxpm
 if "%1" == "--with-svg" goto withsvg
 if "%1" == "--distfiles" goto distfiles
@@ -129,11 +134,13 @@
 echo.   --no-cygwin             use -mno-cygwin option with GCC
 echo.   --cflags FLAG           pass FLAG to compiler
 echo.   --ldflags FLAG          pass FLAG to compiler when linking
+echo.   --lib LIB               link to auxiliary library LIB
 echo.   --without-png           do not use PNG library even if it is installed
 echo.   --without-jpeg          do not use JPEG library even if it is installed
 echo.   --without-gif           do not use GIF library even if it is installed
 echo.   --without-tiff          do not use TIFF library even if it is installed
 echo.   --without-xpm           do not use XPM library even if it is installed
+echo.   --without-gnutls        do not use GNUTLS library even if it is installed
 echo.   --with-svg              use the RSVG library (experimental)
 echo.   --distfiles             path to files for make dist, e.g. libXpm.dll
 goto end
@@ -204,6 +211,14 @@
 shift
 goto again
 
+:userlibs
+shift
+echo. userlibs: %userlibs%
+set userlibs=%userlibs%%sep4%%1
+set sep4= %nothing%
+shift
+goto again
+
 rem ----------------------------------------------------------------------
 
 :userldflags
@@ -239,6 +254,14 @@
 
 rem ----------------------------------------------------------------------
 
+:withoutgnutls
+set tlssupport=N
+set HAVE_GNUTLS=
+shift
+goto again
+
+rem ----------------------------------------------------------------------
+
 :withouttiff
 set tiffsupport=N
 set HAVE_TIFF=
@@ -467,6 +490,29 @@
 :pngDone
 rm -f junk.c junk.obj
 
+if (%tlssupport%) == (N) goto tlsDone
+
+echo Checking for libgnutls...
+echo #include "gnutls/gnutls.h" >junk.c
+echo main (){} >>junk.c
+rem   -o option is ignored with cl, but allows result to be consistent.
+echo %COMPILER% %usercflags% %mingwflag% -c junk.c -o junk.obj >>config.log
+%COMPILER% %usercflags% %mingwflag% -c junk.c -o junk.obj >junk.out 2>>config.log
+if exist junk.obj goto haveTls
+
+echo ...gnutls.h not found, building without TLS support.
+echo The failed program was: >>config.log
+type junk.c >>config.log
+set HAVE_GNUTLS=
+goto :tlsDone
+
+:haveTls
+echo ...GNUTLS header available, building with GNUTLS support.
+set HAVE_GNUTLS=1
+
+:tlsDone
+rm -f junk.c junk.obj
+
 if (%jpegsupport%) == (N) goto jpegDone
 
 echo Checking for jpeg-6b...
@@ -639,6 +685,8 @@
 if (%docflags%)==(Y) echo USER_CFLAGS=%usercflags%>>config.settings
 for %%v in (%userldflags%) do if not (%%v)==() set doldflags=Y
 if (%doldflags%)==(Y) echo USER_LDFLAGS=%userldflags%>>config.settings
+for %%v in (%userlibs%) do if not (%%v)==() set dolibs=Y
+if (%dolibs%)==(Y) echo USER_LIBS=%userlibs%>>config.settings
 echo # End of settings from configure.bat>>config.settings
 echo. >>config.settings
 
@@ -651,6 +699,7 @@
 if (%doldflags%) == (Y) echo #define USER_LDFLAGS " %userldflags%">>config.tmp
 if (%profile%) == (Y) echo #define PROFILING 1 >>config.tmp
 if not "(%HAVE_PNG%)" == "()" echo #define HAVE_PNG 1 >>config.tmp
+if not "(%HAVE_GNUTLS%)" == "()" echo #define HAVE_GNUTLS 1 >>config.tmp
 if not "(%HAVE_JPEG%)" == "()" echo #define HAVE_JPEG 1 >>config.tmp
 if not "(%HAVE_GIF%)" == "()" echo #define HAVE_GIF 1 >>config.tmp
 if not "(%HAVE_TIFF%)" == "()" echo #define HAVE_TIFF 1 >>config.tmp
@@ -789,6 +838,7 @@
 set HAVE_DISTFILES=
 set distFilesOk=
 set pngsupport=
+set tlssupport=
 set jpegsupport=
 set gifsupport=
 set tiffsupport=

=== modified file 'nt/gmake.defs'
--- nt/gmake.defs	2011-01-25 04:08:28 +0000
+++ nt/gmake.defs	2011-03-21 03:32:08 +0000
@@ -279,6 +279,10 @@
 NOCYGWIN = -mno-cygwin
 endif
 
+ifdef USER_LIBS
+USER_LIBS := $(patsubst %,-l%,$(USER_LIBS))
+endif
+
 ifeq "$(ARCH)" "i386"
 ifdef NOOPT
 ARCH_CFLAGS     = -c $(DEBUG_FLAG) $(NOCYGWIN)

=== modified file 'src/ChangeLog'
--- src/ChangeLog	2011-03-20 23:58:23 +0000
+++ src/ChangeLog	2011-03-22 03:16:05 +0000
@@ -1,3 +1,37 @@
+2011-03-22  Teodor Zlatanov  <tzz@lifelogs.com>
+
+	* 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.
+
+2011-03-20  Claudio Bley  <claudio.bley@gmail.com>
+
+	* w32.h: (emacs_gnutls_pull): Add prototype.
+	(emacs_gnutls_push): Likewise.
+
+	* w32.c: (emacs_gnutls_pull): New function for GnuTLS on Woe32.
+	(emacs_gnutls_push): Likewise.
+
+	* process.c (wait_reading_process_output): Check if GnuTLS
+	buffered some data internally if no FDs are set for TLS
+	connections.
+
+	* makefile.w32-in (OBJ2): Add gnutls.$(O).
+	(LIBS): Link to USER_LIBS.
+	($(BLD)/gnutls.$(0)): New target.
+
+	* gnutls.c (emacs_gnutls_handle_error): New function.
+	(wsaerror_to_errno): Likewise.
+	(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.
+
+
 2011-03-20  Glenn Morris  <rgm@gnu.org>
 
 	* config.in: Remove file.

=== modified file 'src/gnutls.c'
--- src/gnutls.c	2011-01-25 04:08:28 +0000
+++ src/gnutls.c	2011-03-22 03:12:24 +0000
@@ -26,11 +26,21 @@
 #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_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;
+
+Lisp_Object Qgnutls_hostname;
 
 /* The following are for the property list of `gnutls-boot'.  */
 Lisp_Object Qgnutls_bootprop_priority;
@@ -38,8 +48,14 @@
 Lisp_Object Qgnutls_bootprop_keyfiles;
 Lisp_Object Qgnutls_bootprop_callbacks;
 Lisp_Object Qgnutls_bootprop_loglevel;
-
-static void
+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 int
 emacs_gnutls_handshake (struct Lisp_Process *proc)
 {
   gnutls_session_t state = proc->gnutls_state;
@@ -50,17 +66,44 @@
 
   if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
     {
+#ifdef WINDOWSNT
+      /* On Windows we cannot transfer socket handles between
+         different runtime libraries.
+
+         We must handle reading / writing ourselves. */
+      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)
@@ -68,6 +111,11 @@
       /* here we're finally done.  */
       proc->gnutls_initstage = GNUTLS_STAGE_READY;
     }
+  else
+    {
+        gnutls_alert_send_appropriate (state, ret);
+    }
+  return ret;
 }
 
 int
@@ -98,7 +146,11 @@
           if (rtnval == GNUTLS_E_AGAIN || rtnval == GNUTLS_E_INTERRUPTED)
             continue;
           else
-            return (bytes_written ? bytes_written : -1);
+            {
+              emacs_gnutls_handle_error (state, rtnval);
+
+              return (bytes_written ? bytes_written : -1);
+            }
         }
 
       buf += rtnval;
@@ -121,19 +173,57 @@
       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)
+{
+  int alert, ret;
+  const char *err_type, *str;
+
+  if (err >= 0)
+    return 0;
+
+  if (gnutls_error_is_fatal (err) == 0)
+    {
+      ret = 0;
+      err_type = "Non fatal";
+    }
+  else
+    {
+      ret = err;
+      err_type = "Fatal";
+    }
+
+  str = gnutls_strerror (err);
+  if (str == NULL)
+    str = "unknown";
+  message ("gnutls.c *** %s error: %s", err_type, str);
+
+  if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
+      || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
+    {
+      int alert = gnutls_alert_get (session);
+      str = gnutls_alert_get_name (alert);
+      if (str == NULL)
+	str = "unknown";
+      message ("gnutls.c *** Received alert [%d]: %s", 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
@@ -265,10 +355,10 @@
 {
   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);
 }
@@ -278,10 +368,10 @@
 static Lisp_Object
 gnutls_emacs_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);
 }
@@ -307,11 +397,20 @@
 PROPLIST is a property list with the following keys:
 
 :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_certificate_set_verify_flags().
+
+:verify-hostname-error determines if a hostname mismatch is a warning
+or an error.
+
 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.
@@ -324,6 +423,9 @@
 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).  */)
@@ -336,12 +438,19 @@
   /* 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;
+  char* hostname;
+  int peer_verification;
 
   /* Placeholders for the property list elements.  */
   Lisp_Object priority_string;
@@ -349,16 +458,24 @@
   Lisp_Object keyfiles;
   Lisp_Object callbacks;
   Lisp_Object loglevel;
+  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);
+  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);
+
+  hostname = SSDATA (Fsymbol_value (intern_c_string ("gnutls-hostname")));
 
   state = XPROCESS (proc)->gnutls_state;
   XPROCESS (proc)->gnutls_p = 1;
@@ -416,6 +533,23 @@
       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))
     {
@@ -484,6 +618,14 @@
 
   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);
@@ -541,9 +683,120 @@
 
   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
 
-  emacs_gnutls_handshake (XPROCESS (proc));
-
-  return gnutls_make_error (GNUTLS_E_SUCCESS);
+  ret = emacs_gnutls_handshake (XPROCESS (proc));
+
+  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 gnutls-hostname (which is
+     buffer-local and set by `open-gnutls-stream'.  */
+
+  ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
+
+  if (ret < GNUTLS_E_SUCCESS)
+    return gnutls_make_error (ret);
+  
+  if (peer_verification & GNUTLS_CERT_INVALID)
+  {
+    message ("%s certificate could not be verified.", 
+             hostname);
+  }
+ 
+ if (peer_verification & GNUTLS_CERT_REVOKED)
+  {
+    message ("%s certificate was revoked (CRL).",
+              hostname);
+  }
+ 
+ if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
+   {
+     message ("%s certificate's signer was not found.",
+              hostname);
+   }
+
+ if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
+   {
+     message ("%s certificate's signer is not a CA.",
+              hostname);
+   }
+
+ if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
+   {
+     message ("%s certificate was signed with an insecure algorithm.",
+              hostname);
+   }
+
+ if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
+   {
+     message ("%s certificate is not yet activated.");
+   }
+
+ if (peer_verification & GNUTLS_CERT_EXPIRED)
+   {
+     message ("%s certificate has expired.");
+   }
+
+ if (peer_verification != 0)
+   {
+     if (NILP (verify_hostname_error))
+       {
+         message ("Certificate validation failed for %s, verification code %d",
+                  hostname, peer_verification);
+       }
+     else
+       {
+         error ("Certificate validation failed for %s, verification code %d",
+                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 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, hostname))
+        {
+          if (NILP (verify_hostname_error))
+            {
+              message ("GnuTLS warning: the certificate's hostname does not match gnutls-hostname \"%s\"", hostname);
+            }
+          else
+            {
+              gnutls_x509_crt_deinit (gnutls_verify_cert);
+              error ("The certificate's hostname does not match gnutls-hostname \"%s\"", hostname);
+            }
+        }
+
+      gnutls_x509_crt_deinit (gnutls_verify_cert);
+    }
+
+  return gnutls_make_error (ret);
 }
 
 DEFUN ("gnutls-bye", Fgnutls_bye,
@@ -578,7 +831,7 @@
 void
 syms_of_gnutls (void)
 {
-  global_initialized = 0;
+  gnutls_global_initialized = 0;
 
   Qgnutls_code = intern_c_string ("gnutls-code");
   staticpro (&Qgnutls_code);
@@ -589,6 +842,9 @@
   Qgnutls_x509pki = intern_c_string ("gnutls-x509pki");
   staticpro (&Qgnutls_x509pki);
 
+  Qgnutls_hostname = intern_c_string ("gnutls-hostname");
+  staticpro (&Qgnutls_hostname);
+
   Qgnutls_bootprop_priority = intern_c_string (":priority");
   staticpro (&Qgnutls_bootprop_priority);
 
@@ -601,9 +857,21 @@
   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,

=== modified file 'src/gnutls.h'
--- src/gnutls.h	2011-01-25 04:08:28 +0000
+++ src/gnutls.h	2011-03-21 03:32:08 +0000
@@ -21,6 +21,7 @@
 
 #ifdef HAVE_GNUTLS
 #include <gnutls/gnutls.h>
+#include <gnutls/x509.h>
 
 typedef enum
 {
@@ -28,6 +29,7 @@
   GNUTLS_STAGE_EMPTY = 0,
   GNUTLS_STAGE_CRED_ALLOC,
   GNUTLS_STAGE_FILES,
+  GNUTLS_STAGE_CALLBACKS,
   GNUTLS_STAGE_INIT,
   GNUTLS_STAGE_PRIORITY,
   GNUTLS_STAGE_CRED_SET,

=== modified file 'src/makefile.w32-in'
--- src/makefile.w32-in	2011-03-19 03:22:14 +0000
+++ src/makefile.w32-in	2011-03-21 03:32:08 +0000
@@ -105,6 +105,7 @@
 	$(BLD)/floatfns.$(O)		\
 	$(BLD)/frame.$(O)		\
 	$(BLD)/gmalloc.$(O)		\
+	$(BLD)/gnutls.$(O)		\
 	$(BLD)/intervals.$(O)		\
 	$(BLD)/composite.$(O)		\
 	$(BLD)/ralloc.$(O)		\
@@ -150,6 +151,7 @@
 	$(OLE32)	\
 	$(COMCTL32)	\
 	$(UNISCRIBE)    \
+	$(USER_LIBS)    \
 	$(libc)
 
 #
@@ -948,6 +950,14 @@
 	$(EMACS_ROOT)/nt/inc/unistd.h \
 	$(SRC)/getpagesize.h
 
+$(BLD)/gnutls.$(O) : \
+	$(SRC)/gnutls.h \
+	$(SRC)/gnutls.c \
+	$(CONFIG_H) \
+	$(EMACS_ROOT)/nt/inc/sys/socket.h \
+	$(SRC)/lisp.h \
+	$(SRC)/process.h
+
 $(BLD)/image.$(O) : \
 	$(SRC)/image.c \
 	$(CONFIG_H) \

=== modified file 'src/process.c'
--- src/process.c	2011-03-17 05:18:33 +0000
+++ src/process.c	2011-03-21 03:32:08 +0000
@@ -4780,6 +4780,19 @@
              &Available,
              (check_write ? &Writeok : (SELECT_TYPE *)0),
              (SELECT_TYPE *)0, &timeout);
+
+#ifdef HAVE_GNUTLS
+          /* GnuTLS buffers data internally. In lowat mode it leaves some data
+             in the TCP buffers so that select works, but with custom pull/push
+             functions we need to check if some data is available in the buffers
+             manually. */
+          if (nfds == 0 && wait_proc && wait_proc->gnutls_p
+              && gnutls_record_check_pending(wait_proc->gnutls_state) > 0)
+          {
+              FD_SET (wait_proc->infd, &Available);
+              nfds = 1;
+          }
+#endif
 	}
 
       xerrno = errno;

=== modified file 'src/w32.c'
--- src/w32.c	2011-03-14 17:07:53 +0000
+++ src/w32.c	2011-03-21 03:32:08 +0000
@@ -6084,5 +6084,74 @@
   p->childp = childp2;
 }
 
+#ifdef HAVE_GNUTLS
+
+ssize_t
+emacs_gnutls_pull(gnutls_transport_ptr_t p, void* buf, size_t sz)
+{
+  int n, sc;
+  SELECT_TYPE fdset;
+  EMACS_TIME timeout;
+  struct Lisp_Process *proc = (struct Lisp_Process *)p;
+  int fd = proc->infd;
+
+  for (;;)
+    {
+      n = sys_read(fd, (char*)buf, sz);
+
+      if (n >= 0)
+        return n;
+      else
+        {
+          int err = errno;
+
+          if (err == EWOULDBLOCK)
+            {
+              EMACS_SET_SECS_USECS(timeout, 1, 0);
+              FD_ZERO (&fdset);
+              FD_SET ((int)fd, &fdset);
+
+              sc = select (fd + 1, &fdset, (SELECT_TYPE *)0, (SELECT_TYPE *)0, &timeout);
+
+              if (sc > 0)
+                continue;
+              else if (sc == 0 || errno == EWOULDBLOCK)
+                /* we have to translate WSAEWOULDBLOCK alias
+		   EWOULDBLOCK to EAGAIN for GnuTLS */
+                err = EAGAIN;
+              else
+                err = errno;
+            }
+          gnutls_transport_set_errno (proc->gnutls_state, err);
+
+          return -1;
+        }
+    }
+}
+
+ssize_t
+emacs_gnutls_push(gnutls_transport_ptr_t p, const void* buf, size_t sz)
+{
+  struct Lisp_Process *proc = (struct Lisp_Process *)p;
+  int fd = proc->outfd;
+  ssize_t n = sys_write((int)fd, buf, sz);
+
+  if (n >= 0)
+    return n;
+  else
+    {
+      gnutls_transport_set_errno (proc->gnutls_state,
+                                  /* translate WSAEWOULDBLOCK alias
+                                     EWOULDBLOCK to EAGAIN for
+                                     GnuTLS */
+                                  errno == EWOULDBLOCK
+                                  ? EAGAIN
+                                  : errno);
+
+      return -1;
+    }
+}
+#endif /* HAVE_GNUTLS */
+
 /* end of w32.c */
 

=== modified file 'src/w32.h'
--- src/w32.h	2011-01-25 04:08:28 +0000
+++ src/w32.h	2011-03-21 03:32:08 +0000
@@ -143,5 +143,14 @@
 extern int _sys_read_ahead (int fd);
 extern int _sys_wait_accept (int fd);
 
+#ifdef HAVE_GNUTLS
+#include <gnutls/gnutls.h>
+
+extern ssize_t emacs_gnutls_pull(gnutls_transport_ptr_t p,
+				 void* buf, size_t sz);
+extern ssize_t emacs_gnutls_push(gnutls_transport_ptr_t p,
+				 const void* buf, size_t sz);
+#endif /* HAVE_GNUTLS */
+
 #endif /* EMACS_W32_H */