Re: Emacs core TLS support

[Ted Zlatanov <tzz@lifelogs.com>]

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

On Mon, 06 Sep 2010 23:00:51 +0200 Stefan Monnier <monnier@iro.umontreal.ca> wrote: 

>> In this case I think that's the right approach actually so we
>> shouldn't have defconsts.  See new definition, it uses two local
>> Lisp_Objects for the symbol names.  Where should I allocate those
>> constant Lisp_Objects globally properly?

SM> It's typically declared as global (static or not, depending on whether
SM> it's used in other files) and initialized in syms_of_<foo>.
SM> Look at other syms_of_<foo> to see what it looks like.

Done, thanks.

>> And should I default to anonymous?

SM> I don't know what that means.

If the user passes an unknown symbol to `gnutls-cred-set', should it be
treated as `gnutls_anon' or generate an error?  It could work either
way.  I'm leaning towards an error but it seems kind of rude to the
user.  OTOH it could be a serious problem to use encryption the user did
not intend because of a typo.

SM> the slots you add at the end are ignored by the GC (which is what
SM> you want in your case, since they're not Lisp objects and hence the
SM> GC wouldn't know what to do with them) and can be of any type.  So
SM> just use the types you need here such that casts aren't needed.

OK.  I introduced a new field `gnutls_state_usable' to indicate the
session has been initialized.  I could have made it a byte but it may be
useful to hold Lisp-related state for this patch as it evolves.  It's
before the GC marker field "pid" so it will be noticed by alloc.c.

SM> BTW, if it makes the code simpler, you can use the following trick: use
SM> symbols, but associate an integer to each symbol by way of
SM> symbol properties.

I don't like the properties because they are loosely bound to the symbol
(for errors I think it's better to bind meaning to value tightly).  Is
it OK to do the current approach, where I have the function
`gnutls_make_error' to return the right thing, whether it's a known
integer-as-symbol or a generic integer?  I think it's the right approach
and it seems semantically sensible.  Plus it's easy to extend
`gnutls_make_error' as we need more errors by name.

SM> The type you declare should correspond to the type of the objects you
SM> store there.  Always.  If you stick to this principle and avoid freeing
SM> live objects (and stay within array bounds, and a few more such things)
SM> your code will be more portable and won't dump core (hence will be
SM> generally easier to debug).

Got it.  I think I'm doing it more correctly now and there will be no GC
issues, as I mentioned above.

On Mon, 06 Sep 2010 19:18:01 +0200 Andreas Schwab <schwab@linux-m68k.org> wrote: 

AS> Ted Zlatanov <tzz@lifelogs.com> writes:

>> +HAVE_GNUTLS=no
>> +if test "${with_gnutls}" = "yes" ; then
>> +  PKG_CHECK_MODULES([LIBGNUTLS], [gnutls >= 2.2.4])

AS> Are you sure you want to make gnutls a required dependency of Emacs?

>> +  AC_DEFINE(HAVE_GNUTLS)

AS> $ autoreconf
AS> autoheader: warning: missing template: HAVE_GNUTLS
AS> autoheader: Use AC_DEFINE([HAVE_GNUTLS], [], [Description])
AS> autoreconf: /usr/bin/autoheader failed with exit status: 1

No.  What would you suggest?

On Mon, 06 Sep 2010 17:53:46 +0200 Andreas Schwab <schwab@linux-m68k.org> wrote: 

AS> Ted Zlatanov <tzz@lifelogs.com> writes:
>>>> +DEFUN ("gnutls-init", Fgnutls_init, Sgnutls_init, 2, 2, 0,
>> ...
>>>> +  ret = gnutls_init((gnutls_session_t*)&(XPROCESS(proc)->gnutls_state), 
>> 
AS> Aliasing violation.
>> 
>> Can you explain please?

AS> The function wants to store a value of one type into an object of a
AS> different type.  BAD.  The compiler is allowed to assume the object was
AS> never changed.

OK, you mean the cast is wrong.  I fixed that.  That leaves only the
transport cast from int in gnutls_{handshake,rehandshake} which I
believe is right from the original patch.

AS> IMHO all your functions should return t on success and either some error
AS> symbol on failure or even raise an error.
>> 
>> Yes, but I'm not sure which one.  Can you recommend?

AS> Take your pick.  I don't know anything about gnutls.

Well, none of the failures are fatal and there's a lot of ways to retry
the connection.  I think it's better to return the integer error value
or t to simplify the usage.  I changed the patch accordingly.

>>>> === modified file 'src/process.h'
>>>> +
>>>> +#ifdef HAVE_GNUTLS
>>>> +    /* XXX Store GNU TLS state and auth mechanisms in Lisp_Objects. */
>>>> +    Lisp_Object gnutls_state;
>>>> +    Lisp_Object x509_cred, x509_callback;
>>>> +    Lisp_Object anon_cred;
>>>> +    Lisp_Object srp_cred;
>>>> +#endif
>> 
AS> None of them should be Lisp_Objects.  Also make sure the resources are
AS> properly released when the process object is deleted.
>> 
>> I don't know enough (the choice of using Lisp_Objects was in the
>> original patch) to know what to do instead of using Lisp_Objects.  Why
>> not, first of all?

AS> You never store Lisp_Object values in there, so what's the point?
AS> x509_callback is never used, btw.

Fixed (also see my response above to Stefan Monnier).  I've attached the
patch as it stands.

Thanks again for all your comments.  Getting there...

Ted


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

=== modified file 'configure.in'
--- configure.in	2010-08-23 12:54:09 +0000
+++ configure.in	2010-09-06 23:12:37 +0000
@@ -170,6 +170,7 @@
 OPTION_DEFAULT_ON([dbus],[don't compile with D-Bus support])
 OPTION_DEFAULT_ON([gconf],[don't compile with GConf support])
 OPTION_DEFAULT_ON([selinux],[don't compile with SELinux support])
+OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support])
 
 ## For the times when you want to build Emacs but don't have
 ## a suitable makeinfo, and can live without the manuals.
@@ -1998,6 +1999,13 @@
 fi
 AC_SUBST(LIBSELINUX_LIBS)
 
+HAVE_GNUTLS=no
+if test "${with_gnutls}" = "yes" ; then
+  PKG_CHECK_MODULES([LIBGNUTLS], [gnutls >= 2.2.4])
+  AC_DEFINE(HAVE_GNUTLS)
+  HAVE_GNUTLS=yes
+fi
+
 dnl Do not put whitespace before the #include statements below.
 dnl Older compilers (eg sunos4 cc) choke on it.
 HAVE_XAW3D=no
@@ -3682,6 +3690,7 @@
 echo "  Does Emacs use -ldbus?                                  ${HAVE_DBUS}"
 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 -lfreetype?                              ${HAVE_FREETYPE}"
 echo "  Does Emacs use -lm17n-flt?                              ${HAVE_M17N_FLT}"

=== added file 'lisp/net/gnutls.el'
--- lisp/net/gnutls.el	1970-01-01 00:00:00 +0000
+++ lisp/net/gnutls.el	2010-09-06 23:12:37 +0000
@@ -0,0 +1,131 @@
+;;; gnutls.el --- Support SSL and TLS connections through GnuTLS
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Ted Zlatanov <tzz@lifelogs.com>
+;; Keywords: comm, tls, ssl, encryption
+;; Originally-By: Simon Josefsson (See http://josefsson.org/emacs-security/)
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides language bindings for the GnuTLS library
+;; using the corresponding core functions in gnutls.c.
+
+;; Simple test:
+;;
+;; (setq jas (open-ssl-stream "ssl" (current-buffer) "www.pdc.kth.se" 443))
+;; (process-send-string jas "GET /\r\n\r\n")
+
+;;; Code:
+
+(defconst gnutls-version "0.3.1")
+
+(defun open-ssl-stream (name buffer host service)
+  "Open a SSL connection for a service to a host.
+Returns a subprocess-object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+Args are NAME BUFFER HOST SERVICE.
+NAME is name for process.  It is modified if necessary to make it unique.
+BUFFER is the buffer (or `buffer-name') to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+Third arg is name of the host to connect to, or its IP address.
+Fourth arg SERVICE is name of the service desired, or an integer
+specifying a port number to connect to."
+  (let ((proc (open-network-stream name buffer host service)))
+    (starttls-negotiate proc)))
+
+(defun starttls-negotiate (proc &optional priority-string
+                                credentials credentials-file)
+  "Negotiate a SSL or TLS connection.
+PROC is the process returned by `starttls-open-stream'.
+PRIORITY-STRING is as per the GnuTLS docs.
+CREDENTIALS is `gnutls-x509pki', `gnutls-anon', or `gnutls-srp'.
+CREDENTIALS-FILE is a filename with meaning dependent on CREDENTIALS."
+  (let* ((credentials (or credentials 'gnutls-anon))
+         (priority-string (or priority-string
+                              (cond
+                               ((eq credentials 'gnutls-anon)
+                                "PERFORMANCE:+ANON-DH:!ARCFOUR-128")
+                               ((eq credentials 'gnutls-x509pki)
+                               "PERFORMANCE")))))
+    (gnutls-message-maybe
+     (gnutls-global-init)
+     "global_init: err=%s")
+
+    (gnutls-message-maybe
+     (gnutls-init proc)
+     "init: err=%s")
+
+    (gnutls-message-maybe
+     (gnutls-priority-set-direct proc priority-string)
+     "priority_set: err=%s")
+
+    (gnutls-message-maybe
+     (gnutls-cred-set proc credentials)
+     "credential_set: err=%s")
+
+    (cond
+     ((eq credentials 'gnutls-x509pki)
+      (gnutls-message-maybe
+       (gnutls-cert-set-x509-trust-file proc credentials-file)
+       "x509_trustfile: err=%s")))
+
+    (let ((ret 'gnutls-e-again))
+      (while (or (eq ret 'gnutls-e-again)
+                 (eq ret 'gnutls-e-interrupted))
+        (gnutls-message-maybe
+         (setq ret (gnutls-handshake proc))
+         "handshake: err=%s"))
+      (if (gnutls-errorp (ret))
+          (progn
+            (message "Ouch, error return %d" ret)
+            (setq proc nil))
+        (message "Handshake complete %d." ret)))
+     proc))
+
+(defun starttls-open-stream (name buffer host service)
+  "Open a TLS connection for a service to a host.
+Returns a subprocess-object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+Args are NAME BUFFER HOST SERVICE.
+NAME is name for process.  It is modified if necessary to make it unique.
+BUFFER is the buffer (or `buffer-name') to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+Third arg is name of the host to connect to, or its IP address.
+Fourth arg SERVICE is name of the service desired, or an integer
+specifying a port number to connect to."
+  (open-network-stream name buffer host service))
+
+(defun gnutls-message-maybe (doit format &rest params)
+  "When DOIT, message with the caller name followed by FORMAT on PARAMS."
+  (when doit
+    (message "%s: (err=%s) %s"
+             (nth 1 (backtrace-frame 4))
+             doit
+             (apply 'format format params))))
+
+(provide 'ssl)
+(provide 'gnutls)
+(provide 'starttls)
+
+;;; gnutls.el ends here

=== modified file 'src/Makefile.in'
--- src/Makefile.in	2010-08-17 21:19:11 +0000
+++ src/Makefile.in	2010-09-06 23:12:37 +0000
@@ -285,6 +285,9 @@
 
 LIBSELINUX_LIBS = @LIBSELINUX_LIBS@
 
+LIBGNUTLS_LIBS = @LIBGNUTLS_LIBS@
+LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@
+
 INTERVALS_H = dispextern.h intervals.h composite.h
 
 GETLOADAVG_LIBS = @GETLOADAVG_LIBS@
@@ -323,6 +326,7 @@
   ${C_SWITCH_X_SYSTEM} ${CFLAGS_SOUND} ${RSVG_CFLAGS} ${IMAGEMAGICK_CFLAGS} ${DBUS_CFLAGS} \
   ${GCONF_CFLAGS} ${FREETYPE_CFLAGS} ${FONTCONFIG_CFLAGS} \
   ${LIBOTF_CFLAGS} ${M17N_FLT_CFLAGS} ${DEPFLAGS} ${PROFILING_CFLAGS} \
+  $(LIBGNUTLS_CFLAGS) \
   ${C_WARNINGS_SWITCH} ${CFLAGS}
 ALL_OBJC_CFLAGS=$(ALL_CFLAGS) $(GNU_OBJC_CFLAGS)
 
@@ -347,7 +351,7 @@
 	alloc.o data.o doc.o editfns.o callint.o \
 	eval.o floatfns.o fns.o font.o print.o lread.o \
 	syntax.o $(UNEXEC_OBJ) bytecode.o \
-	process.o callproc.o \
+	process.o gnutls.o callproc.o \
 	region-cache.o sound.o atimer.o \
 	doprnt.o strftime.o intervals.o textprop.o composite.o md5.o \
 	$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ)
@@ -598,6 +602,7 @@
    $(RSVG_LIBS) ${IMAGEMAGICK_LIBS}  $(DBUS_LIBS) $(LIBGPM) $(LIBRESOLV) $(LIBS_SYSTEM) \
    $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) ${GCONF_LIBS} ${LIBSELINUX_LIBS} \
    $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
+   $(LIBGNUTLS_LIBS) \
    $(LIB_GCC) $(LIB_MATH) $(LIB_STANDARD) $(LIB_GCC)
 
 all: emacs${EXEEXT} $(OTHER_FILES)

=== modified file 'src/config.in'
--- src/config.in	2010-08-17 21:19:11 +0000
+++ src/config.in	2010-09-06 23:12:37 +0000
@@ -255,6 +255,9 @@
 /* Define to 1 if you have a gif (or ungif) library. */
 #undef HAVE_GIF
 
+/* Define if we have the GNU TLS library.  */
+#undef HAVE_GNUTLS
+
 /* Define to 1 if you have the gpm library (-lgpm). */
 #undef HAVE_GPM
 
@@ -1091,6 +1094,12 @@
 #include config_opsysfile
 #include config_machfile
 
+#if HAVE_GNUTLS
+#define LIBGNUTLS $(LIBGNUTLS_LIBS)
+#else /* not HAVE_GNUTLS */
+#define LIBGNUTLS
+#endif /* not HAVE_GNUTLS */
+
 /* Set up some defines, C and LD flags for NeXTstep interface on GNUstep.
   (There is probably a better place to do this, but right now the Cocoa
    side does this in s/darwin.h and we cannot

=== modified file 'src/emacs.c'
--- src/emacs.c	2010-08-22 21:15:20 +0000
+++ src/emacs.c	2010-09-06 23:12:37 +0000
@@ -63,6 +63,10 @@
 #include "keyboard.h"
 #include "keymap.h"
 
+#ifdef HAVE_GNUTLS
+#include "gnutls.h"
+#endif
+
 #ifdef HAVE_NS
 #include "nsterm.h"
 #endif
@@ -1569,6 +1573,10 @@
       syms_of_fontset ();
 #endif /* HAVE_NS */
 
+#ifdef HAVE_GNUTLS
+      syms_of_gnutls ();
+#endif
+
 #ifdef HAVE_DBUS
       syms_of_dbusbind ();
 #endif /* HAVE_DBUS */

=== added file 'src/gnutls.c'
--- src/gnutls.c	1970-01-01 00:00:00 +0000
+++ src/gnutls.c	2010-09-06 23:12:37 +0000
@@ -0,0 +1,373 @@
+#include <config.h>
+#include <errno.h>
+#include <setjmp.h>
+
+#include "lisp.h"
+#include "process.h"
+
+#ifdef HAVE_GNUTLS
+#include <gnutls/gnutls.h>
+
+Lisp_Object Qgnutls_anon, Qgnutls_x509pki;
+Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again;
+
+int
+emacs_gnutls_write (int fildes, gnutls_session_t state, char *buf,
+                    unsigned int nbyte)
+{
+  register int rtnval, bytes_written;
+
+  bytes_written = 0;
+
+  while (nbyte > 0)
+    {
+      rtnval = gnutls_write (state, buf, nbyte);
+
+      if (rtnval == -1)
+	{
+	  if (errno == EINTR)
+	    continue;
+	  else
+	    return (bytes_written ? bytes_written : -1);
+	}
+
+      buf += rtnval;
+      nbyte -= rtnval;
+      bytes_written += rtnval;
+    }
+  fsync (STDOUT_FILENO);
+
+  return (bytes_written);
+}
+
+int
+emacs_gnutls_read (int fildes, gnutls_session_t state, char *buf,
+                   unsigned int nbyte)
+{
+  register int rtnval;
+
+  do {
+    rtnval = gnutls_read (state, buf, nbyte);
+  } while( rtnval==GNUTLS_E_INTERRUPTED || rtnval==GNUTLS_E_AGAIN);
+  fsync(STDOUT_FILENO);
+
+  return (rtnval);
+}
+
+int gnutls_callback (gnutls_session_t state, const gnutls_datum *client_certs,
+                     int ncerts, const gnutls_datum* req_ca_cert, int nreqs)
+{
+  if (client_certs == NULL) {
+    /* means the we will only be called again if the library cannot
+     * determine which certificate to send
+     */
+    return 0;
+  }
+
+  return -1; /* send no certificate to the peer */
+}
+
+/* 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
+   to Qt.
+*/
+
+Lisp_Object gnutls_make_error (int error)
+{
+  switch (error)
+  {
+  case GNUTLS_E_SUCCESS:
+    return Qt;
+  case GNUTLS_E_AGAIN:
+    return Qgnutls_e_again;
+  case GNUTLS_E_INTERRUPTED:
+    return Qgnutls_e_interrupted;
+  }
+  
+  return make_number (error);
+}
+
+DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
+       doc: /* Returns t if ERROR (as generated by gnutls_make_error)
+indicates a GnuTLS problem.*/)
+    (Lisp_Object error)
+{
+  if (EQ (error, Qt)) return Qnil;
+
+  return Qt;
+}
+
+DEFUN ("gnutls-init", Fgnutls_init, Sgnutls_init, 1, 1, 0,
+       doc: /* Initializes client-mode GnuTLS for process PROC.
+Currently only client mode is supported.
+
+Processes must be initialized with this function before other GNU TLS
+functions are used.  This function allocates resources which can only
+be deallocated by calling `gnutls-deinit'. Returns zero on success. */)
+    (Lisp_Object proc)
+{
+  int ret;
+  
+  CHECK_PROCESS (proc);
+
+  ret = gnutls_init (&(XPROCESS (proc)->gnutls_state), 
+                     GNUTLS_CLIENT);
+
+  XPROCESS (proc)->gnutls_state_usable = Qt;
+  
+  return gnutls_make_error (ret);
+}
+
+DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
+       doc: /* Deallocate GNU TLS resources associated with PROCESS.
+See also `gnutls-init'. */)
+    (Lisp_Object proc)
+{
+  int ret;
+  gnutls_session_t state;
+
+  CHECK_PROCESS (proc);
+  state = XPROCESS (proc)->gnutls_state;
+
+  gnutls_deinit (state);
+  XPROCESS (proc)->gnutls_state_usable = Qnil;
+
+  return Qnil;
+}
+
+DEFUN ("gnutls-global-init", Fgnutls_global_init, 
+       Sgnutls_global_init, 0, 0, 0,
+       doc: /* Initializes global GNU TLS state to defaults.
+Call `gnutls-global-deinit' when GNU TLS usage is no longer needed.
+Returns zero on success. */)
+     (void)
+{
+  int ret = gnutls_global_init ();
+
+  return gnutls_make_error (ret);
+}
+
+DEFUN ("gnutls-global-deinit", Fgnutls_global_deinit, 
+       Sgnutls_global_deinit, 0, 0, 0,
+       doc: /* Deinitializes global GNU TLS state.
+See also `gnutls-global-init'. */)
+     (void)
+{
+  gnutls_global_deinit ();
+
+  return Qnil;
+}
+
+Lisp_Object
+generic_set_priority (int (*func)( gnutls_session_t state, const char*, const char**),
+                      Lisp_Object proc, Lisp_Object priority_string)
+{
+  gnutls_session_t state;
+  int ret;
+  
+  CHECK_PROCESS (proc);
+  CHECK_STRING (priority_string);
+  
+  state = XPROCESS (proc)->gnutls_state;
+
+  ret = (*func) (state, (char*) SDATA (priority_string), NULL);
+
+  return gnutls_make_error (ret);
+}
+
+DEFUN ("gnutls-priority-set-direct", Fgnutls_priority_set_direct, 
+       Sgnutls_priority_set_direct, 2, 2, 0,
+       doc: /* Sets the priority on the protocol versions supported by GNU TLS for PROCESS.
+
+The first parameter must be a process. Second parameter is a string
+describing the priority.  Note that the priority is set on the client.
+The server does not use the protocols's priority except for disabling
+protocols that were not specified. */)
+    (Lisp_Object process, Lisp_Object priority_string)
+{
+  Lisp_Object ret = generic_set_priority (&gnutls_priority_set_direct,
+                                          process, priority_string);
+  
+  return ret;
+}
+
+DEFUN ("gnutls-cert-set-x509-trust-file", 
+       Fgnutls_cert_set_x509_trust_file,
+       Sgnutls_cert_set_x509_trust_file, 2, 2, 0,
+       doc: /* Set X.509 client trust file for PROCESS
+CERTFILE is a PEM encoded file.  Returns zero on success. */)
+    (Lisp_Object proc, Lisp_Object certfile)
+{
+  gnutls_session_t state;
+  gnutls_certificate_credentials_t x509_cred;
+  int ret;
+
+  CHECK_STRING (certfile);
+  CHECK_PROCESS (proc);
+  
+  state = XPROCESS (proc)->gnutls_state;
+
+  x509_cred = (gnutls_certificate_credentials_t) XPROCESS (proc)->x509_cred;
+
+  ret = gnutls_certificate_set_x509_trust_file (x509_cred,
+                                                XSTRING (certfile)->data,
+                                                GNUTLS_X509_FMT_PEM);
+
+  return gnutls_make_error (ret);
+}
+
+DEFUN ("gnutls-cred-set", Fgnutls_cred_set, 
+       Sgnutls_cred_set, 2, 2, 0,
+       doc: /* Enables GNU TLS authentication for PROCESS.
+TYPE is either `gnutls-anon' or `gnutls-x509pki'.
+
+Each authentication type may need additional information in order to
+work.  For anonymous (`gnutls-anon'), see also
+`gnutls-anon-set-client-cred'. For X.509 PKI (`gnutls-x509pki'), see
+also `gnutls-x509pki-set-client-trust-file',
+`gnutls-x509pki-set-client-key-file', and
+`gnutls-x509pki-set-cert-callback'. */)
+    (Lisp_Object proc, Lisp_Object type)
+{
+  gnutls_session_t state;
+  gnutls_certificate_credentials_t x509_cred;
+  gnutls_anon_client_credentials_t anon_cred;
+  gnutls_srp_client_credentials_t srp_cred;
+  int ret;
+
+  CHECK_PROCESS (proc);
+  
+  state = XPROCESS (proc)->gnutls_state;
+
+  if (EQ (type, Qgnutls_x509pki))
+  {
+      x509_cred = XPROCESS (proc)->x509_cred;
+      if (gnutls_certificate_allocate_credentials (&x509_cred) < 0)
+	memory_full ();
+      ret = gnutls_cred_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred);
+  }
+  else if (EQ (type, Qgnutls_anon))
+  {
+      anon_cred = XPROCESS (proc)->anon_cred;
+      if (gnutls_anon_allocate_client_credentials (&anon_cred) < 0)
+	memory_full ();
+      ret = gnutls_cred_set (state, GNUTLS_CRD_ANON, anon_cred);
+  }
+  else
+  {
+   /* should this be an error or fold to gnutls-anon? */
+  }
+
+  return gnutls_make_error (ret);
+}
+
+DEFUN ("gnutls-bye", Fgnutls_bye, 
+       Sgnutls_bye, 2, 2, 0,
+       doc: /* Terminate current GNU TLS connection for PROCESS.
+The connection should have been initiated using gnutls_handshake().
+
+If CONT is not nil the TLS connection gets terminated and further
+receives and sends will be disallowed. If the return value is zero you
+may continue using the connection.  If CONT is nil, GnuTLS actually
+sends an alert containing a close request and waits for the peer to
+reply with the same message.  In order to reuse the connection you
+should wait for an EOF from the peer.
+  
+This function may also return `gnutls-e-again', or
+`gnutls-e-interrupted'. */)
+    (Lisp_Object proc, Lisp_Object cont)
+{
+  gnutls_session_t state;
+  int ret;
+
+  CHECK_PROCESS (proc);
+
+  state = XPROCESS (proc)->gnutls_state;
+
+  ret = gnutls_bye (state,
+                    NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
+  
+  return gnutls_make_error (ret);
+}
+
+DEFUN ("gnutls-handshake", Fgnutls_handshake, 
+       Sgnutls_handshake, 1, 1, 0,
+       doc: /* Perform GNU TLS handshake for PROCESS.
+The identity of the peer is checked automatically.  This function will
+fail if any problem is encountered, and will return a negative error
+code. In case of a client, if it has been asked to resume a session,
+but the server didn't, then a full handshake will be performed.
+  
+This function may also return the non-fatal errors `gnutls-e-again',
+or `gnutls-e-interrupted'. In that case you may resume the handshake
+(by calling this function again). */)
+    (Lisp_Object proc)
+{
+  gnutls_session_t state;
+  int ret;
+
+  CHECK_PROCESS (proc);
+  state = XPROCESS (proc)->gnutls_state;
+
+  gnutls_transport_set_ptr (state, XPROCESS (proc)->infd);
+  ret = gnutls_handshake (state);
+
+  return gnutls_make_error (ret);
+}
+
+DEFUN ("gnutls-rehandshake", Fgnutls_rehandshake, 
+       Sgnutls_rehandshake, 1, 1, 0,
+       doc: /* Renegotiate GNU TLS security parameters for PROCESS.
+This function will renegotiate security parameters with the
+client. This should only be called in case of a server.
+
+This message informs the peer that we want to renegotiate parameters
+\(perform a handshake).
+  
+If this function succeeds (returns 0), you must call the
+gnutls_handshake() function in order to negotiate the new parameters.
+  
+If the client does not wish to renegotiate parameters he will reply
+with an alert message, thus the return code will be
+`gnutls-e-warning-alert-received' and the alert will be
+`gnutls-e-no-renegotiation'. */)
+    (Lisp_Object proc)
+{
+  gnutls_session_t state;
+  int ret;
+
+  CHECK_PROCESS (proc);
+  state = XPROCESS (proc)->gnutls_state;
+
+  gnutls_transport_set_ptr (state, XPROCESS (proc)->infd);
+  ret = gnutls_rehandshake (state);
+
+  return gnutls_make_error (ret);
+}
+
+void
+syms_of_gnutls (void)
+{
+  Qgnutls_anon = intern_c_string ("gnutls-anon");
+  staticpro (&Qgnutls_anon);
+  Qgnutls_x509pki = intern_c_string ("gnutls-x509pki");
+  staticpro (&Qgnutls_x509pki);
+  Qgnutls_e_interrupted = make_number(GNUTLS_E_INTERRUPTED);
+  staticpro (&Qgnutls_e_interrupted);
+  Qgnutls_e_again = make_number(GNUTLS_E_AGAIN);
+  staticpro (&Qgnutls_e_again);
+
+  defsubr (&Sgnutls_errorp);
+  defsubr (&Sgnutls_global_init);
+  defsubr (&Sgnutls_global_deinit);
+  defsubr (&Sgnutls_init);
+  defsubr (&Sgnutls_deinit);
+  defsubr (&Sgnutls_priority_set_direct);
+  defsubr (&Sgnutls_cred_set);
+  defsubr (&Sgnutls_handshake);
+  defsubr (&Sgnutls_rehandshake);
+  defsubr (&Sgnutls_cert_set_x509_trust_file);
+  defsubr (&Sgnutls_bye);
+}
+#endif

=== added file 'src/gnutls.h'
--- src/gnutls.h	1970-01-01 00:00:00 +0000
+++ src/gnutls.h	2010-09-06 23:12:37 +0000
@@ -0,0 +1,4 @@
+#ifdef HAVE_GNUTLS
+#include <gnutls/gnutls.h>
+
+#endif

=== modified file 'src/lisp.h'
--- src/lisp.h	2010-08-09 19:25:41 +0000
+++ src/lisp.h	2010-09-06 23:12:37 +0000
@@ -3350,6 +3350,7 @@
 extern void syms_of_process (void);
 extern void setup_process_coding_systems (Lisp_Object);
 
+
 /* Defined in callproc.c */
 extern Lisp_Object Vexec_path, Vexec_suffixes,
                    Vexec_directory, Vdata_directory;
@@ -3589,6 +3590,11 @@
 void syms_of_dbusbind (void);
 #endif
 
+#ifdef HAVE_GNUTLS
+/* Defined in gnutls.c */
+extern void syms_of_gnutls (void);
+#endif
+
 #ifdef DOS_NT
 /* Defined in msdos.c, w32.c */
 extern char *emacs_root_dir (void);

=== modified file 'src/process.c'
--- src/process.c	2010-08-22 15:14:37 +0000
+++ src/process.c	2010-09-06 23:12:37 +0000
@@ -105,6 +105,9 @@
 #include "sysselect.h"
 #include "syssignal.h"
 #include "syswait.h"
+#ifdef HAVE_GNUTLS
+#include "gnutls.h"
+#endif
 
 #if defined (USE_GTK) || defined (HAVE_GCONF)
 #include "xgselect.h"
@@ -1526,6 +1529,10 @@
   XPROCESS (proc)->filter = Qnil;
   XPROCESS (proc)->command = Flist (nargs - 2, args + 2);
 
+#ifdef HAVE_GNUTLS
+  XPROCESS (proc)->gnutls_state_usable = Qnil;
+#endif
+
 #ifdef ADAPTIVE_READ_BUFFERING
   XPROCESS (proc)->adaptive_read_buffering
     = (NILP (Vprocess_adaptive_read_buffering) ? 0
@@ -5097,7 +5104,12 @@
 #endif
   if (proc_buffered_char[channel] < 0)
     {
-      nbytes = emacs_read (channel, chars + carryover, readmax);
+#ifdef HAVE_GNUTLS
+      if (NETCONN_P(proc) && !NILP (XPROCESS(proc)->gnutls_state_usable))
+	nbytes = emacs_gnutls_read (channel, XPROCESS(proc)->gnutls_state, chars + carryover, readmax);
+      else
+#endif
+	nbytes = emacs_read (channel, chars + carryover, readmax);
 #ifdef ADAPTIVE_READ_BUFFERING
       if (nbytes > 0 && p->adaptive_read_buffering)
 	{
@@ -5130,7 +5142,12 @@
     {
       chars[carryover] = proc_buffered_char[channel];
       proc_buffered_char[channel] = -1;
-      nbytes = emacs_read (channel, chars + carryover + 1,  readmax - 1);
+#ifdef HAVE_GNUTLS
+      if (NETCONN_P(proc) && !NILP (XPROCESS(proc)->gnutls_state_usable))
+	nbytes = emacs_gnutls_read (channel, XPROCESS(proc)->gnutls_state, chars + carryover + 1, readmax - 1);
+      else
+#endif
+	nbytes = emacs_read (channel, chars + carryover + 1,  readmax - 1);
       if (nbytes < 0)
 	nbytes = 1;
       else
@@ -5540,7 +5557,14 @@
 	      else
 #endif
 		{
-		  rv = emacs_write (outfd, (char *) buf, this);
+#ifdef HAVE_GNUTLS
+		  if (NETCONN_P(proc) && !NILP (XPROCESS(proc)->gnutls_state_usable))
+		    rv = emacs_gnutls_write (outfd,
+					     XPROCESS(proc)->gnutls_state, 
+					     (char *) buf, this);
+		  else
+#endif
+		    rv = emacs_write (outfd, (char *) buf, this);
 #ifdef ADAPTIVE_READ_BUFFERING
 		  if (p->read_output_delay > 0
 		      && p->adaptive_read_buffering == 1)

=== modified file 'src/process.h'
--- src/process.h	2010-08-11 12:34:46 +0000
+++ src/process.h	2010-09-06 23:12:37 +0000
@@ -24,6 +24,10 @@
 #include <unistd.h>
 #endif
 
+#ifdef HAVE_GNUTLS
+#include "gnutls.h"
+#endif
+
 /* This structure records information about a subprocess
    or network connection.
 
@@ -76,6 +80,10 @@
     /* Working buffer for encoding.  */
     Lisp_Object encoding_buf;
 
+#ifdef HAVE_GNUTLS
+    Lisp_Object gnutls_state_usable;
+#endif
+
     /* After this point, there are no Lisp_Objects any more.  */
     /* alloc.c assumes that `pid' is the first such non-Lisp slot.  */
 
@@ -121,6 +129,12 @@
        needs to be synced to `status'.  */
     unsigned int raw_status_new : 1;
     int raw_status;
+
+#ifdef HAVE_GNUTLS
+    gnutls_session_t gnutls_state;
+    gnutls_certificate_client_credentials x509_cred;
+    gnutls_anon_client_credentials_t anon_cred;
+#endif
 };
 
 /* Every field in the preceding structure except for the first two


[-- Attachment #3: Type: text/plain, Size: 146 bytes --]

_______________________________________________
Gnutls-devel mailing list
Gnutls-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/gnutls-devel