=== modified file 'configure.in' --- configure.in 2010-09-13 19:50:30 +0000 +++ configure.in 2010-09-15 09:13:07 +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? ${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-15 10:38:20 +0000 @@ -0,0 +1,131 @@ +;;; gnutls.el --- Support SSL and TLS connections through GnuTLS +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Ted Zlatanov +;; 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 . + +;;; 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 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" + "/tmp/ca.pem" + )) + + (priority-string (or priority-string + (cond + ((eq credentials 'gnutls-anon) + "PERFORMANCE:+ANON-DH:!ARCFOUR-128") + ((eq credentials 'gnutls-x509pki) + "PERFORMANCE")))) + 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/Makefile.in' --- src/Makefile.in 2010-09-10 16:44:35 +0000 +++ src/Makefile.in 2010-09-15 09:13:07 +0000 @@ -287,6 +287,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@ @@ -326,6 +329,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) @@ -350,7 +354,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) @@ -602,6 +606,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' --- src/config.in 2010-09-10 16:44:35 +0000 +++ src/config.in 2010-09-15 09:13:07 +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' --- src/emacs.c 2010-09-10 16:44:35 +0000 +++ src/emacs.c 2010-09-15 09:13:07 +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 @@ -1573,6 +1577,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-15 10:29:28 +0000 @@ -0,0 +1,546 @@ +/* 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 . */ + +#include +#include +#include + +#include "lisp.h" +#include "process.h" + +#ifdef HAVE_GNUTLS +#include + +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; +} + +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_E_SUCCESS; + + if (!global_initialized) + ret = gnutls_global_init (); + + global_initialized = 1; + + 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) +{ + 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 = Fgnutls_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; + + /* for a network process in Emacs infd and outfd are the same + but this shows our intent more clearly. */ + gnutls_transport_set_ptr2 (state, XPROCESS (proc)->infd, + XPROCESS (proc)->outfd); + ret = gnutls_handshake (state); + + GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_HANDSHAKE_DONE; + + 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_global_init); + defsubr (&Sgnutls_global_deinit); + defsubr (&Sgnutls_boot); + defsubr (&Sgnutls_deinit); + defsubr (&Sgnutls_handshake); + defsubr (&Sgnutls_bye); +} +#endif === added file 'src/gnutls.h' --- src/gnutls.h 1970-01-01 00:00:00 +0000 +++ src/gnutls.h 2010-09-15 01:29:34 +0000 @@ -0,0 +1,57 @@ +/* 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 . */ + +#ifndef EMACS_GNUTLS_DEFINED +#define EMACS_GNUTLS_DEFINED + +#ifdef HAVE_GNUTLS +#include + +typedef enum +{ + GNUTLS_STAGE_EMPTY = 0, + GNUTLS_STAGE_CRED_ALLOC, + GNUTLS_STAGE_FILES, + GNUTLS_STAGE_INIT, + GNUTLS_STAGE_PRIORITY, + GNUTLS_STAGE_CRED_SET, + + GNUTLS_STAGE_HANDSHAKE_CANDO = GNUTLS_STAGE_CRED_SET, + GNUTLS_STAGE_HANDSHAKE_DONE, + + 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' --- src/process.c 2010-08-22 15:14:37 +0000 +++ src/process.c 2010-09-15 01:29:34 +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 @@ -5097,7 +5110,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) { @@ -5130,7 +5149,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 @@ -5540,7 +5565,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' --- src/process.h 2010-08-11 12:34:46 +0000 +++ src/process.h 2010-09-15 01:29:34 +0000 @@ -24,6 +24,10 @@ #include #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