Re: [PATCH] GnuTLS support on Woe32

[Ted Zlatanov <tzz@lifelogs.com>]

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

On Mon, 04 Apr 2011 04:58:17 -0500 Ted Zlatanov <tzz@lifelogs.com> wrote: 

TZ> On Thu, 24 Mar 2011 14:27:55 -0500 Ted Zlatanov <tzz@lifelogs.com> wrote: 
TZ> On Wed, 23 Mar 2011 21:57:56 +0100 claudio.bley@gmail.com (Claudio Bley) wrote: 
CB> I requested the papers, but I'm still waiting for receipt. So, this
CB> will probably take some time...

TZ> Any news?  If you still don't have the papers I will separate our work
TZ> so I don't have to keep rebasing the patch.

*sigh* one more rebase...

Ted


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 2011-04-15 --]
[-- Type: text/x-diff, Size: 38739 bytes --]

=== modified file 'configure.in'
--- configure.in	2011-04-12 03:55:07 +0000
+++ configure.in	2011-04-15 17:15:39 +0000
@@ -1972,12 +1972,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)
 
@@ -3675,6 +3685,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-04-06 12:18:10 +0000
+++ lib-src/ChangeLog	2011-04-15 17:28:09 +0000
@@ -1,3 +1,7 @@
+2011-04-15  Claudio Bley  <claudio.bley@gmail.com>
+
+	* makefile.w32-in (obj): Added gnutls.o.
+
 2011-04-06  Paul Eggert  <eggert@cs.ucla.edu>
 
 	Fix more problems found by GCC 4.6.0's static checks.

=== 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-04-15 17:15:39 +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-04-15 13:50:04 +0000
+++ lisp/ChangeLog	2011-04-15 17:28:55 +0000
@@ -1,3 +1,19 @@
+2011-04-15  Teodor Zlatanov  <tzz@lifelogs.com>
+
+	* net/gnutls.el (gnutls-negotiate): Add hostname, verify-flags,
+	verify-error, and verify-hostname-error parameters.
+	(open-gnutls-stream): Add usage example.
+
+	* net/network-stream.el (network-stream-open-starttls): Give host
+	parameter to `gnutls-negotiate'.
+	(gnutls-negotiate): Adjust `gnutls-negotiate' declaration.
+
+2011-04-15  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-04-15  Stefan Monnier  <monnier@iro.umontreal.ca>
 
 	* mail/sendmail.el (mail-mode-map): Use completion-at-point.

=== modified file 'lisp/net/gnutls.el'
--- lisp/net/gnutls.el	2011-01-25 04:08:28 +0000
+++ lisp/net/gnutls.el	2011-04-15 17:15:39 +0000
@@ -25,7 +25,8 @@
 ;;; Commentary:
 
 ;; This package provides language bindings for the GnuTLS library
-;; using the corresponding core functions in gnutls.c.
+;; using the corresponding core functions in gnutls.c.  It should NOT
+;; be used directly, only through open-protocol-stream.
 
 ;; Simple test:
 ;;
@@ -59,26 +60,76 @@
 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)))
+  (gnutls-negotiate (open-network-stream name buffer host service)
+                    'gnutls-x509pki
+                    host))
+
+(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.
+(defun gnutls-negotiate (proc type hostname &optional priority-string
+                              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'.
+HOSTNAME is the remote hostname.  It must be a valid string.
 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' 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'
+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)
@@ -86,15 +137,22 @@
                                ((eq type 'gnutls-x509pki)
                                 "NORMAL"))))
          (params `(:priority ,priority-string
+                             :hostname ,hostname
                              :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 'lisp/net/network-stream.el'
--- lisp/net/network-stream.el	2011-04-12 22:18:02 +0000
+++ lisp/net/network-stream.el	2011-04-15 17:15:39 +0000
@@ -46,7 +46,8 @@
 (require 'starttls)
 
 (declare-function gnutls-negotiate "gnutls"
-		  (proc type &optional priority-string trustfiles keyfiles))
+                  (proc type host &optional priority-string trustfiles keyfiles
+                        verify-flags verify-error verify-hostname-error))
 
 ;;;###autoload
 (defun open-network-stream (name buffer host service &rest parameters)
@@ -197,7 +198,7 @@
 			  (network-stream-command stream starttls-command eoc))
 	;; The server said it was OK to begin STARTTLS negotiations.
 	(if (fboundp 'open-gnutls-stream)
-	    (gnutls-negotiate stream nil)
+	    (gnutls-negotiate stream nil host)
 	  (unless (starttls-negotiate stream)
 	    (delete-process stream)))
 	(if (memq (process-status stream) '(open run))

=== modified file 'nt/ChangeLog'
--- nt/ChangeLog	2011-04-06 15:44:32 +0000
+++ nt/ChangeLog	2011-04-15 17:29:37 +0000
@@ -1,3 +1,10 @@
+2011-04-15  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-04-06  Eli Zaretskii  <eliz@gnu.org>
 
 	* config.nt (NO_INLINE, ATTRIBUTE_FORMAT)

=== modified file 'nt/INSTALL'
--- nt/INSTALL	2011-01-26 08:36:39 +0000
+++ nt/INSTALL	2011-04-15 17:15:39 +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-04-15 17:15:39 +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-04-15 17:15:39 +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-04-15 10:23:56 +0000
+++ src/ChangeLog	2011-04-15 17:30:05 +0000
@@ -1,3 +1,36 @@
+2011-04-15  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-04-15  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-04-15  Paul Eggert  <eggert@cs.ucla.edu>
 
 	* sysdep.c (emacs_read): Remove unnecessary check vs MAX_RW_COUNT.

=== modified file 'src/gnutls.c'
--- src/gnutls.c	2011-04-15 08:22:34 +0000
+++ src/gnutls.c	2011-04-15 17:18:52 +0000
@@ -26,11 +26,20 @@
 #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_keyfiles;
 Lisp_Object Qgnutls_bootprop_callbacks;
 Lisp_Object Qgnutls_bootprop_loglevel;
-
-static void
+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,56 @@
 
   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 and 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)
     {
-      /* 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 +167,7 @@
       bytes_written += rtnval;
     }
 
+  emacs_gnutls_handle_error (state, rtnval);
   return (bytes_written);
 }
 
@@ -122,19 +183,68 @@
       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 == NULL)
+    str = "unknown";
+
+  if (gnutls_error_is_fatal (err) == 0)
+    {
+      ret = 0;
+      GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str);
+      /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2.  */
+    }
+  else
+    {
+      ret = err;
+      GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
+    }
+
+  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 == NULL)
+	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 +372,14 @@
 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 +387,16 @@
 /* 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 +405,27 @@
 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 +438,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).  */)
@@ -337,12 +453,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;
+  int peer_verification;
+  char* c_hostname;
 
   /* Placeholders for the property list elements.  */
   Lisp_Object priority_string;
@@ -350,16 +473,29 @@
   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 +509,7 @@
     }
 
   /* 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 +553,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))
     {
@@ -485,6 +638,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);
@@ -542,9 +703,113 @@
 
   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 :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 +844,10 @@
 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 +858,9 @@
   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 +873,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-04-15 08:22:34 +0000
+++ src/gnutls.h	2011-04-15 17:15:40 +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-04-15 17:15:40 +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-04-15 08:35:53 +0000
+++ src/process.c	2011-04-15 17:15:40 +0000
@@ -4530,6 +4530,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-04-06 16:05:49 +0000
+++ src/w32.c	2011-04-15 17:15:40 +0000
@@ -6102,5 +6102,75 @@
   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-04-15 17:15:40 +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 */