[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] /srv/bzr/emacs/trunk r101625: Set up GnuTLS support.
|
From: |
Ted Zlatanov |
|
Subject: |
[Emacs-diffs] /srv/bzr/emacs/trunk r101625: Set up GnuTLS support. |
|
Date: |
Sun, 26 Sep 2010 01:06:28 -0500 |
|
User-agent: |
Bazaar (2.0.3) |
------------------------------------------------------------
revno: 101625
committer: Ted Zlatanov <address@hidden>
branch nick: quickfixes
timestamp: Sun 2010-09-26 01:06:28 -0500
message:
Set up GnuTLS support.
* configure.in: Set up GnuTLS.
* lisp/net/gnutls.el: GnuTLS glue code to set up a connection.
* src/Makefile.in (LIBGNUTLS_LIBS, LIBGNUTLS_CFLAGS, ALL_CFLAGS)
(obj, LIBES): Set up GnuTLS support.
* src/config.in: Set up GnuTLS support.
* src/emacs.c: Set up GnuTLS support and call syms_of_gnutls.
* src/gnutls.c: The source code for GnuTLS support in Emacs.
* src/gnutls.h: The GnuTLS glue for Emacs, macros and enums.
* src/process.c (make_process, Fstart_process)
(read_process_output, send_process): Set up GnuTLS support for
process input/output file descriptors.
* src/process.h: Set up GnuTLS support.
added:
lisp/net/gnutls.el
src/gnutls.c
src/gnutls.h
modified:
ChangeLog
configure.in
lisp/ChangeLog
src/ChangeLog
src/Makefile.in
src/config.in
src/emacs.c
src/process.c
src/process.h
=== modified file 'ChangeLog'
--- a/ChangeLog 2010-09-22 03:10:16 +0000
+++ b/ChangeLog 2010-09-26 06:06:28 +0000
@@ -1,3 +1,7 @@
+2010-09-26 Teodor Zlatanov <address@hidden>
+
+ * configure.in: Set up GnuTLS.
+
2010-09-22 Chong Yidong <address@hidden>
* configure.in: Announce whether libxml2 is linked to.
=== modified file 'configure.in'
--- a/configure.in 2010-09-22 03:10:16 +0000
+++ b/configure.in 2010-09-26 06:06:28 +0000
@@ -171,6 +171,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.
@@ -1999,6 +2000,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
@@ -3701,6 +3709,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 (BROKEN)? ${HAVE_GNUTLS}"
echo " Does Emacs use -lxml2?
${HAVE_LIBXML2}"
echo " Does Emacs use -lfreetype?
${HAVE_FREETYPE}"
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2010-09-25 21:57:02 +0000
+++ b/lisp/ChangeLog 2010-09-26 06:06:28 +0000
@@ -1,3 +1,7 @@
+2010-09-26 Teodor Zlatanov <address@hidden>
+
+ * net/gnutls.el: GnuTLS glue code to set up a connection.
+
2010-09-25 Julien Danjou <address@hidden>
* notifications.el: Call dbus-register-signal only if it is bound.
=== added file 'lisp/net/gnutls.el'
--- a/lisp/net/gnutls.el 1970-01-01 00:00:00 +0000
+++ b/lisp/net/gnutls.el 2010-09-26 06:06:28 +0000
@@ -0,0 +1,128 @@
+;;; gnutls.el --- Support SSL and TLS connections through GnuTLS
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Ted Zlatanov <address@hidden>
+;; 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:
+
+(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 nil 'gnutls-x509pki)))
+
+;; (open-ssl-stream "tls" "tls-buffer" "yourserver.com" "https")
+(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' or `gnutls-anon'.
+CREDENTIALS-FILE is a filename with meaning dependent on CREDENTIALS."
+ (let* ((credentials (or credentials 'gnutls-x509pki))
+ (credentials-file (or credentials-file
+ "/etc/ssl/certs/ca-certificates.crt"
+ ;"/etc/ssl/certs/ca.pem"
+ ))
+
+ (priority-string (or priority-string
+ (cond
+ ((eq credentials 'gnutls-anon)
+ "NORMAL:+ANON-DH:!ARCFOUR-128")
+ ((eq credentials 'gnutls-x509pki)
+ "NORMAL"))))
+ ret)
+
+ (gnutls-message-maybe
+ (setq ret (gnutls-boot proc priority-string credentials
credentials-file))
+ "boot: %s")
+
+ (when (gnutls-errorp ret)
+ (error "Could not boot GnuTLS for this process"));
+
+ (let ((ret 'gnutls-e-again)
+ (n 25000))
+ (while (and (not (gnutls-error-fatalp ret))
+ (> n 0))
+ (decf n)
+ (gnutls-message-maybe
+ (setq ret (gnutls-handshake proc))
+ "handshake: %s")
+ ;(debug "handshake ret" ret (gnutls-error-string ret)))
+ )
+ (if (gnutls-errorp ret)
+ (progn
+ (message "Ouch, error return %s (%s)"
+ ret (gnutls-error-string ret))
+ (setq proc nil))
+ (message "Handshake complete %s." 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."
+ ;; (apply 'debug format (or params '(nil)))
+ (when (gnutls-errorp doit)
+ (message "%s: (err=[%s] %s) %s"
+ "gnutls.el"
+ doit (gnutls-error-string doit)
+ (apply 'format format (or params '(nil))))))
+
+(provide 'ssl)
+(provide 'gnutls)
+(provide 'starttls)
+
+;;; gnutls.el ends here
=== modified file 'src/ChangeLog'
--- a/src/ChangeLog 2010-09-26 01:39:24 +0000
+++ b/src/ChangeLog 2010-09-26 06:06:28 +0000
@@ -1,3 +1,22 @@
+2010-09-26 Teodor Zlatanov <address@hidden>
+
+ * process.h: Set up GnuTLS support.
+
+ * process.c (make_process, Fstart_process)
+ (read_process_output, send_process): Set up GnuTLS support for
+ process input/output file descriptors.
+
+ * gnutls.h: The GnuTLS glue for Emacs, macros and enums.
+
+ * gnutls.c: The source code for GnuTLS support in Emacs.
+
+ * emacs.c: Set up GnuTLS support and call syms_of_gnutls.
+
+ * config.in: Set up GnuTLS support.
+
+ * Makefile.in (LIBGNUTLS_LIBS, LIBGNUTLS_CFLAGS, ALL_CFLAGS)
+ (obj, LIBES): Set up GnuTLS support.
+
2010-09-26 Juanma Barranquero <address@hidden>
* w32.c (get_emacs_configuration_options): Fix previous change.
=== modified file 'src/Makefile.in'
--- a/src/Makefile.in 2010-09-20 22:35:37 +0000
+++ b/src/Makefile.in 2010-09-26 06:06:28 +0000
@@ -286,6 +286,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@
@@ -325,6 +328,7 @@
${LIBXML2_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)
@@ -349,7 +353,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 xml.o \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ)
@@ -601,6 +605,7 @@
${LIBXML2_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'
--- a/src/config.in 2010-09-10 16:44:35 +0000
+++ b/src/config.in 2010-09-26 06:06:28 +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
@@ -1094,6 +1097,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'
--- a/src/emacs.c 2010-09-21 11:13:36 +0000
+++ b/src/emacs.c 2010-09-26 06:06:28 +0000
@@ -59,6 +59,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'
--- a/src/gnutls.c 1970-01-01 00:00:00 +0000
+++ b/src/gnutls.c 2010-09-26 06:06:28 +0000
@@ -0,0 +1,551 @@
+/* GnuTLS glue for GNU Emacs.
+ Copyright (C) 2010 Free Software Foundation, Inc.
+
+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/>. */
+
+#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_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
+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);
+}
+
+/* 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;
+ case GNUTLS_E_INVALID_SESSION:
+ return Qgnutls_e_invalid_session;
+ }
+
+ return make_number (error);
+}
+
+DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage,
1, 1, 0,
+ doc: /* Return the GnuTLS init stage of PROCESS.
+See also `gnutls-boot'. */)
+ (Lisp_Object proc)
+{
+ CHECK_PROCESS (proc);
+
+ return make_number (GNUTLS_INITSTAGE (proc));
+}
+
+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-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1,
1, 0,
+ doc: /* Checks if ERROR is fatal.
+ERROR is an integer or a symbol with an integer `gnutls-code' property. */)
+ (Lisp_Object err)
+{
+ Lisp_Object code;
+
+ if (EQ (err, Qt)) return Qnil;
+
+ if (SYMBOLP (err))
+ {
+ code = Fget (err, Qgnutls_code);
+ if (NUMBERP (code))
+ {
+ err = code;
+ }
+ else
+ {
+ error ("Symbol has no numeric gnutls-code property");
+ }
+ }
+
+ if (!NUMBERP (err))
+ error ("Not an error symbol or code");
+
+ if (0 == gnutls_error_is_fatal (XINT (err)))
+ return Qnil;
+
+ return Qt;
+}
+
+DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1,
1, 0,
+ doc: /* Returns a description of ERROR.
+ERROR is an integer or a symbol with an integer `gnutls-code' property. */)
+ (Lisp_Object err)
+{
+ Lisp_Object code;
+
+ if (EQ (err, Qt)) return build_string ("Not an error");
+
+ if (SYMBOLP (err))
+ {
+ code = Fget (err, Qgnutls_code);
+ if (NUMBERP (code))
+ {
+ err = code;
+ }
+ else
+ {
+ return build_string ("Symbol has no numeric gnutls-code property");
+ }
+ }
+
+ if (!NUMBERP (err))
+ return build_string ("Not an error symbol or code");
+
+ return build_string (gnutls_strerror (XINT (err)));
+}
+
+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)
+{
+ gnutls_session_t state;
+
+ CHECK_PROCESS (proc);
+ state = XPROCESS (proc)->gnutls_state;
+
+ if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
+ {
+ gnutls_deinit (state);
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
+ }
+
+ return Qt;
+}
+
+/* Initializes global GNU TLS state to defaults.
+Call `gnutls-global-deinit' when GNU TLS usage is no longer needed.
+Returns zero on success. */
+Lisp_Object gnutls_emacs_global_init (void)
+{
+ int ret = GNUTLS_E_SUCCESS;
+
+ if (!global_initialized)
+ ret = gnutls_global_init ();
+
+ global_initialized = 1;
+
+ return gnutls_make_error (ret);
+}
+
+/* Deinitializes global GNU TLS state.
+See also `gnutls-global-init'. */
+Lisp_Object gnutls_emacs_global_deinit (void)
+{
+ if (global_initialized)
+ gnutls_global_deinit ();
+
+ global_initialized = 0;
+
+ return gnutls_make_error (GNUTLS_E_SUCCESS);
+}
+
+DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 6, 0,
+ doc: /* Initializes client-mode GnuTLS for process PROC.
+Currently only client mode is supported. Returns a success/failure
+value you can check with `gnutls-errorp'.
+
+PRIORITY_STRING is a string describing the priority.
+TYPE is either `gnutls-anon' or `gnutls-x509pki'.
+TRUSTFILE is a PEM encoded trust file for `gnutls-x509pki'.
+KEYFILE is ... for `gnutls-x509pki' (TODO).
+CALLBACK is ... for `gnutls-x509pki' (TODO).
+
+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.
+
+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' or by calling it again.
+
+Each authentication type may need additional information in order to
+work. For X.509 PKI (`gnutls-x509pki'), you need TRUSTFILE and
+KEYFILE and optionally CALLBACK. */)
+ (Lisp_Object proc, Lisp_Object priority_string, Lisp_Object type,
+ Lisp_Object trustfile, Lisp_Object keyfile, Lisp_Object callback)
+{
+ int ret = GNUTLS_E_SUCCESS;
+
+ /* TODO: GNUTLS_X509_FMT_DER is also an option. */
+ int file_format = GNUTLS_X509_FMT_PEM;
+
+ gnutls_session_t state;
+ gnutls_certificate_credentials_t x509_cred;
+ gnutls_anon_client_credentials_t anon_cred;
+ gnutls_srp_client_credentials_t srp_cred;
+ gnutls_datum_t data;
+ Lisp_Object global_init;
+
+ CHECK_PROCESS (proc);
+ CHECK_SYMBOL (type);
+ CHECK_STRING (priority_string);
+
+ state = XPROCESS (proc)->gnutls_state;
+
+ /* always initialize globals. */
+ global_init = gnutls_emacs_global_init ();
+ if (! NILP (Fgnutls_errorp (global_init)))
+ return global_init;
+
+ /* deinit and free resources. */
+ if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_CRED_ALLOC)
+ {
+ message ("gnutls: deallocating certificates");
+
+ if (EQ (type, Qgnutls_x509pki))
+ {
+ message ("gnutls: deallocating x509 certificates");
+
+ x509_cred = XPROCESS (proc)->x509_cred;
+ gnutls_certificate_free_credentials (x509_cred);
+ }
+ else if (EQ (type, Qgnutls_anon))
+ {
+ message ("gnutls: deallocating anon certificates");
+
+ anon_cred = XPROCESS (proc)->anon_cred;
+ gnutls_anon_free_client_credentials (anon_cred);
+ }
+ else
+ {
+ error ("unknown credential type");
+ ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
+ }
+
+ if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
+ {
+ message ("gnutls: deinitializing");
+
+ Fgnutls_deinit (proc);
+ }
+ }
+
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
+
+ message ("gnutls: allocating credentials");
+
+ if (EQ (type, Qgnutls_x509pki))
+ {
+ message ("gnutls: allocating x509 credentials");
+
+ x509_cred = XPROCESS (proc)->x509_cred;
+ if (gnutls_certificate_allocate_credentials (&x509_cred) < 0)
+ memory_full ();
+ }
+ else if (EQ (type, Qgnutls_anon))
+ {
+ message ("gnutls: allocating anon credentials");
+
+ anon_cred = XPROCESS (proc)->anon_cred;
+ if (gnutls_anon_allocate_client_credentials (&anon_cred) < 0)
+ memory_full ();
+ }
+ else
+ {
+ error ("unknown credential type");
+ ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
+ }
+
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
+
+ message ("gnutls: setting the trustfile");
+
+ if (EQ (type, Qgnutls_x509pki))
+ {
+ if (STRINGP (trustfile))
+ {
+ ret = gnutls_certificate_set_x509_trust_file
+ (x509_cred,
+ XSTRING (trustfile)->data,
+ file_format);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+
+ message ("gnutls: processed %d CA certificates", ret);
+ }
+
+ message ("gnutls: setting the keyfile");
+
+ if (STRINGP (keyfile))
+ {
+ ret = gnutls_certificate_set_x509_crl_file
+ (x509_cred,
+ XSTRING (keyfile)->data,
+ file_format);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+
+ message ("gnutls: processed %d CRL(s)", ret);
+ }
+ }
+
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
+
+ message ("gnutls: gnutls_init");
+
+ ret = gnutls_init (&state, GNUTLS_CLIENT);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+
+ XPROCESS (proc)->gnutls_state = state;
+
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
+
+ message ("gnutls: setting the priority string");
+
+ ret = gnutls_priority_set_direct(state,
+ (char*) SDATA (priority_string),
+ NULL);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
+
+ message ("gnutls: setting the credentials");
+
+ if (EQ (type, Qgnutls_x509pki))
+ {
+ message ("gnutls: setting the x509 credentials");
+
+ ret = gnutls_cred_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred);
+ }
+ else if (EQ (type, Qgnutls_anon))
+ {
+ message ("gnutls: setting the anon credentials");
+
+ ret = gnutls_cred_set (state, GNUTLS_CRD_ANON, anon_cred);
+ }
+ else
+ {
+ error ("unknown credential type");
+ ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
+ }
+
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+
+ XPROCESS (proc)->anon_cred = anon_cred;
+ XPROCESS (proc)->x509_cred = x509_cred;
+ XPROCESS (proc)->gnutls_cred_type = type;
+
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
+
+ return gnutls_make_error (GNUTLS_E_SUCCESS);
+}
+
+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.
+
+If the error `gnutls-e-not-ready-for-handshake' is returned, you
+didn't call `gnutls-boot' first.
+
+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;
+
+ if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_HANDSHAKE_CANDO)
+ return Qgnutls_e_not_ready_for_handshake;
+
+
+ if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
+ {
+ /* for a network process in Emacs infd and outfd are the same
+ but this shows our intent more clearly. */
+ message ("gnutls: handshake: setting the transport pointers to %d/%d",
+ XPROCESS (proc)->infd, XPROCESS (proc)->outfd);
+
+ gnutls_transport_set_ptr2 (state, XPROCESS (proc)->infd,
+ XPROCESS (proc)->outfd);
+
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
+ }
+
+ message ("gnutls: handshake: handshaking");
+ ret = gnutls_handshake (state);
+
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_HANDSHAKE_TRIED;
+
+ if (GNUTLS_E_SUCCESS == ret)
+ {
+ /* here we're finally done. */
+ GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_READY;
+ }
+
+ return gnutls_make_error (ret);
+}
+
+void
+syms_of_gnutls (void)
+{
+ global_initialized = 0;
+
+ Qgnutls_code = intern_c_string ("gnutls-code");
+ staticpro (&Qgnutls_code);
+
+ Qgnutls_anon = intern_c_string ("gnutls-anon");
+ staticpro (&Qgnutls_anon);
+
+ Qgnutls_x509pki = intern_c_string ("gnutls-x509pki");
+ staticpro (&Qgnutls_x509pki);
+
+ Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted");
+ staticpro (&Qgnutls_e_interrupted);
+ Fput (Qgnutls_e_interrupted, Qgnutls_code,
+ make_number (GNUTLS_E_INTERRUPTED));
+
+ Qgnutls_e_again = intern_c_string ("gnutls-e-again");
+ staticpro (&Qgnutls_e_again);
+ Fput (Qgnutls_e_again, Qgnutls_code,
+ make_number (GNUTLS_E_AGAIN));
+
+ Qgnutls_e_invalid_session = intern_c_string ("gnutls-e-invalid-session");
+ staticpro (&Qgnutls_e_invalid_session);
+ Fput (Qgnutls_e_invalid_session, Qgnutls_code,
+ make_number (GNUTLS_E_INVALID_SESSION));
+
+ Qgnutls_e_not_ready_for_handshake =
+ intern_c_string ("gnutls-e-not-ready-for-handshake");
+ staticpro (&Qgnutls_e_not_ready_for_handshake);
+ Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
+ make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
+
+ defsubr (&Sgnutls_get_initstage);
+ defsubr (&Sgnutls_errorp);
+ defsubr (&Sgnutls_error_fatalp);
+ defsubr (&Sgnutls_error_string);
+ defsubr (&Sgnutls_boot);
+ defsubr (&Sgnutls_deinit);
+ defsubr (&Sgnutls_handshake);
+ defsubr (&Sgnutls_bye);
+}
+#endif
=== added file 'src/gnutls.h'
--- a/src/gnutls.h 1970-01-01 00:00:00 +0000
+++ b/src/gnutls.h 2010-09-26 06:06:28 +0000
@@ -0,0 +1,60 @@
+/* GnuTLS glue for GNU Emacs.
+ Copyright (C) 2010 Free Software Foundation, Inc.
+
+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/>. */
+
+#ifndef EMACS_GNUTLS_DEFINED
+#define EMACS_GNUTLS_DEFINED
+
+#ifdef HAVE_GNUTLS
+#include <gnutls/gnutls.h>
+
+typedef enum
+{
+ /* Initialization stages. */
+ GNUTLS_STAGE_EMPTY = 0,
+ GNUTLS_STAGE_CRED_ALLOC,
+ GNUTLS_STAGE_FILES,
+ GNUTLS_STAGE_INIT,
+ GNUTLS_STAGE_PRIORITY,
+ GNUTLS_STAGE_CRED_SET,
+
+ /* Handshake stages. */
+ GNUTLS_STAGE_HANDSHAKE_CANDO = GNUTLS_STAGE_CRED_SET,
+ GNUTLS_STAGE_TRANSPORT_POINTERS_SET,
+ GNUTLS_STAGE_HANDSHAKE_TRIED,
+
+ GNUTLS_STAGE_READY,
+} gnutls_initstage_t;
+
+#define GNUTLS_EMACS_ERROR_INVALID_TYPE GNUTLS_E_APPLICATION_ERROR_MIN
+
+#define GNUTLS_INITSTAGE(proc) (XPROCESS (proc)->gnutls_initstage)
+
+#define GNUTLS_PROCESS_USABLE(proc) (GNUTLS_INITSTAGE(proc) >=
GNUTLS_STAGE_READY)
+
+int
+emacs_gnutls_write (int fildes, gnutls_session_t state, char *buf,
+ unsigned int nbyte);
+int
+emacs_gnutls_read (int fildes, gnutls_session_t state, char *buf,
+ unsigned int nbyte);
+
+extern void syms_of_gnutls (void);
+
+#endif
+
+#endif
=== modified file 'src/process.c'
--- a/src/process.c 2010-09-25 12:31:15 +0000
+++ b/src/process.c 2010-09-26 06:06:28 +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"
@@ -583,6 +586,10 @@
p->read_output_skip = 0;
#endif
+#ifdef HAVE_GNUTLS
+ p->gnutls_initstage = GNUTLS_STAGE_EMPTY;
+#endif
+
/* If name is already in use, modify it until it is unused. */
name1 = name;
@@ -1526,6 +1533,12 @@
XPROCESS (proc)->filter = Qnil;
XPROCESS (proc)->command = Flist (nargs - 2, args + 2);
+#ifdef HAVE_GNUTLS
+ /* AKA GNUTLS_INITSTAGE(proc). */
+ XPROCESS (proc)->gnutls_initstage = GNUTLS_STAGE_EMPTY;
+ XPROCESS (proc)->gnutls_cred_type = Qnil;
+#endif
+
#ifdef ADAPTIVE_READ_BUFFERING
XPROCESS (proc)->adaptive_read_buffering
= (NILP (Vprocess_adaptive_read_buffering) ? 0
@@ -5099,7 +5112,13 @@
#endif
if (proc_buffered_char[channel] < 0)
{
- nbytes = emacs_read (channel, chars + carryover, readmax);
+#ifdef HAVE_GNUTLS
+ if (NETCONN_P(proc) && GNUTLS_PROCESS_USABLE (proc))
+ 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)
{
@@ -5132,7 +5151,13 @@
{
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) && GNUTLS_PROCESS_USABLE (proc))
+ 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
@@ -5542,7 +5567,14 @@
else
#endif
{
- rv = emacs_write (outfd, (char *) buf, this);
+#ifdef HAVE_GNUTLS
+ if (NETCONN_P(proc) && GNUTLS_PROCESS_USABLE (proc))
+ 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'
--- a/src/process.h 2010-08-11 12:34:46 +0000
+++ b/src/process.h 2010-09-26 06:06:28 +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_cred_type;
+#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,13 @@
needs to be synced to `status'. */
unsigned int raw_status_new : 1;
int raw_status;
+
+#ifdef HAVE_GNUTLS
+ gnutls_initstage_t gnutls_initstage;
+ 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
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] /srv/bzr/emacs/trunk r101625: Set up GnuTLS support.,
Ted Zlatanov <=