/* GnuTLS glue for GNU Emacs.
- Copyright (C) 2010 Free Software Foundation, Inc.
+ Copyright (C) 2010-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake;
int global_initialized;
-void
+/* The following are for the property list of `gnutls-boot'. */
+Lisp_Object Qgnutls_bootprop_priority;
+Lisp_Object Qgnutls_bootprop_trustfiles;
+Lisp_Object Qgnutls_bootprop_keyfiles;
+Lisp_Object Qgnutls_bootprop_callbacks;
+Lisp_Object Qgnutls_bootprop_loglevel;
+
+static void
emacs_gnutls_handshake (struct Lisp_Process *proc)
{
gnutls_session_t state = proc->gnutls_state;
return;
if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
- {
- /* FIXME: This can't be right: infd and outfd are integers (file handles)
- whereas the function expects args of type gnutls_transport_ptr_t. */
- gnutls_transport_set_ptr2 (state, proc->infd, proc->outfd);
-
- proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
- }
+ {
+ /* 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);
+
+ proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
+ }
ret = gnutls_handshake (state);
proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
if (ret == GNUTLS_E_SUCCESS)
- {
- /* here we're finally done. */
- proc->gnutls_initstage = GNUTLS_STAGE_READY;
- }
+ {
+ /* here we're finally done. */
+ proc->gnutls_initstage = GNUTLS_STAGE_READY;
+ }
}
-int
-emacs_gnutls_write (int fildes, struct Lisp_Process *proc, char *buf,
- unsigned int nbyte)
+EMACS_INT
+emacs_gnutls_write (int fildes, struct Lisp_Process *proc, const char *buf,
+ EMACS_INT nbyte)
{
- register int rtnval, bytes_written;
+ ssize_t rtnval;
+ EMACS_INT bytes_written;
gnutls_session_t state = proc->gnutls_state;
- if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
+ if (proc->gnutls_initstage != GNUTLS_STAGE_READY) {
+#ifdef EWOULDBLOCK
+ errno = EWOULDBLOCK;
+#endif
+#ifdef EAGAIN
+ errno = EAGAIN;
+#endif
return 0;
+ }
bytes_written = 0;
{
rtnval = gnutls_write (state, buf, nbyte);
- if (rtnval == -1)
+ if (rtnval < 0)
{
- if (errno == EINTR)
+ if (rtnval == GNUTLS_E_AGAIN || rtnval == GNUTLS_E_INTERRUPTED)
continue;
else
- return (bytes_written ? bytes_written : -1);
+ break;
}
buf += rtnval;
nbyte -= rtnval;
bytes_written += rtnval;
}
- fsync (STDOUT_FILENO);
return (bytes_written);
}
-int
+EMACS_INT
emacs_gnutls_read (int fildes, struct Lisp_Process *proc, char *buf,
- unsigned int nbyte)
+ EMACS_INT nbyte)
{
- register int rtnval;
+ ssize_t rtnval;
gnutls_session_t state = proc->gnutls_state;
- if (proc->gnutls_initstage != GNUTLS_STAGE_READY) {
- emacs_gnutls_handshake (proc);
- return -1;
- }
+ if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
+ {
+ emacs_gnutls_handshake (proc);
+ return -1;
+ }
rtnval = gnutls_read (state, buf, nbyte);
if (rtnval >= 0)
return rtnval;
- else
- return 0;
+ else {
+ if (rtnval == GNUTLS_E_AGAIN ||
+ rtnval == GNUTLS_E_INTERRUPTED)
+ return -1;
+ else
+ return 0;
+ }
}
/* 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)
+static Lisp_Object
+gnutls_make_error (int err)
{
- 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;
- }
+ switch (err)
+ {
+ 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);
+ return make_number (err);
}
DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
- doc: /* Return the GnuTLS init stage of PROCESS.
+ doc: /* Return the GnuTLS init stage of process PROC.
See also `gnutls-boot'. */)
- (Lisp_Object proc)
+ (Lisp_Object proc)
{
CHECK_PROCESS (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)
+ doc: /* Return t if ERROR indicates a GnuTLS problem.
+ERROR is an integer or a symbol with an integer `gnutls-code' property.
+usage: (gnutls-errorp ERROR) */)
+ (Lisp_Object err)
{
- if (EQ (error, Qt)) return Qnil;
+ if (EQ (err, 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)
+ doc: /* Check if ERROR is fatal.
+ERROR is an integer or a symbol with an integer `gnutls-code' property.
+usage: (gnutls-error-fatalp ERROR) */)
+ (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");
+ 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");
}
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)
+ doc: /* Return a description of ERROR.
+ERROR is an integer or a symbol with an integer `gnutls-code' property.
+usage: (gnutls-error-string ERROR) */)
+ (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");
+ 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");
}
DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
- doc: /* Deallocate GNU TLS resources associated with PROCESS.
+ doc: /* Deallocate GnuTLS resources associated with process PROC.
See also `gnutls-init'. */)
- (Lisp_Object proc)
+ (Lisp_Object proc)
{
gnutls_session_t state;
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.
+/* Initializes global GnuTLS state to defaults.
+Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
Returns zero on success. */
-Lisp_Object gnutls_emacs_global_init (void)
+static Lisp_Object
+gnutls_emacs_global_init (void)
{
int ret = GNUTLS_E_SUCCESS;
return gnutls_make_error (ret);
}
-/* Deinitializes global GNU TLS state.
+#if 0
+/* Deinitializes global GnuTLS state.
See also `gnutls-global-init'. */
-Lisp_Object gnutls_emacs_global_deinit (void)
+static Lisp_Object
+gnutls_emacs_global_deinit (void)
{
if (global_initialized)
gnutls_global_deinit ();
return gnutls_make_error (GNUTLS_E_SUCCESS);
}
+#endif
-static void gnutls_log_function (int level, const char* string)
+static void
+gnutls_log_function (int level, const char* string)
{
- message("gnutls.c: [%d] %s", level, string);
+ message ("gnutls.c: [%d] %s", level, string);
}
-DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 7, 0,
- doc: /* Initializes client-mode GnuTLS for process PROC.
+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
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).
-LOGLEVEL is the debug level requested from GnuTLS, try 4.
+TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
+PROPLIST is a property list with the following keys:
+
+:priority is a GnuTLS priority string, defaults to "NORMAL".
+:trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
+:keyfiles is a list of PEM-encoded key files for `gnutls-x509pki'.
+:callbacks is an alist of callback functions (TODO).
+:loglevel is the debug level requested from GnuTLS, try 4.
-LOGLEVEL 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.
+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.
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
+Processes must be initialized with this function before other GnuTLS
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,
- Lisp_Object loglevel)
+work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
+one trustfile (usually a CA bundle). */)
+ (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
{
int ret = GNUTLS_E_SUCCESS;
gnutls_certificate_credentials_t x509_cred;
gnutls_anon_client_credentials_t anon_cred;
Lisp_Object global_init;
+ char const *priority_string_ptr = "NORMAL"; /* default priority string. */
+ Lisp_Object tail;
+
+ /* Placeholders for the property list elements. */
+ Lisp_Object priority_string;
+ Lisp_Object trustfiles;
+ Lisp_Object keyfiles;
+ /* Lisp_Object callbacks; */
+ Lisp_Object loglevel;
CHECK_PROCESS (proc);
CHECK_SYMBOL (type);
- CHECK_STRING (priority_string);
+ 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);
state = XPROCESS (proc)->gnutls_state;
XPROCESS (proc)->gnutls_p = 1;
if (NUMBERP (loglevel))
{
- message ("setting up log level %d", XINT (loglevel));
gnutls_global_set_log_function (gnutls_log_function);
gnutls_global_set_log_level (XINT (loglevel));
max_log_level = XINT (loglevel);
/* deinit and free resources. */
if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_CRED_ALLOC)
- {
+ {
GNUTLS_LOG (1, max_log_level, "deallocating credentials");
if (EQ (type, Qgnutls_x509pki))
- {
+ {
GNUTLS_LOG (2, max_log_level, "deallocating x509 credentials");
x509_cred = XPROCESS (proc)->gnutls_x509_cred;
gnutls_certificate_free_credentials (x509_cred);
- }
+ }
else if (EQ (type, Qgnutls_anon))
- {
+ {
GNUTLS_LOG (2, max_log_level, "deallocating anon credentials");
anon_cred = XPROCESS (proc)->gnutls_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)
- {
+ {
GNUTLS_LOG (1, max_log_level, "deallocating x509 credentials");
Fgnutls_deinit (proc);
- }
- }
+ }
+ }
GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
GNUTLS_LOG (1, max_log_level, "allocating credentials");
if (EQ (type, Qgnutls_x509pki))
- {
+ {
GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
x509_cred = XPROCESS (proc)->gnutls_x509_cred;
if (gnutls_certificate_allocate_credentials (&x509_cred) < 0)
memory_full ();
- }
+ }
else if (EQ (type, Qgnutls_anon))
- {
+ {
GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
anon_cred = XPROCESS (proc)->gnutls_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);
+ return gnutls_make_error (ret);
GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
if (EQ (type, Qgnutls_x509pki))
- {
- if (STRINGP (trustfile))
- {
- GNUTLS_LOG (1, max_log_level, "setting the trustfile");
- ret = gnutls_certificate_set_x509_trust_file
- (x509_cred,
- SDATA (trustfile),
- file_format);
-
- if (ret < GNUTLS_E_SUCCESS)
- return gnutls_make_error (ret);
- }
-
- if (STRINGP (keyfile))
- {
- GNUTLS_LOG (1, max_log_level, "setting the keyfile");
- ret = gnutls_certificate_set_x509_crl_file
- (x509_cred,
- SDATA (keyfile),
- file_format);
-
- if (ret < GNUTLS_E_SUCCESS)
- return gnutls_make_error (ret);
- }
- }
+ {
+ for (tail = trustfiles; !NILP (tail); tail = Fcdr (tail))
+ {
+ Lisp_Object trustfile = Fcar (tail);
+ if (STRINGP (trustfile))
+ {
+ GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
+ SSDATA (trustfile));
+ ret = gnutls_certificate_set_x509_trust_file
+ (x509_cred,
+ SSDATA (trustfile),
+ file_format);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+ }
+ else
+ {
+ error ("Sorry, GnuTLS can't use non-string trustfile %s",
+ SDATA (trustfile));
+ }
+ }
+
+ for (tail = keyfiles; !NILP (tail); tail = Fcdr (tail))
+ {
+ Lisp_Object keyfile = Fcar (tail);
+ if (STRINGP (keyfile))
+ {
+ GNUTLS_LOG2 (1, max_log_level, "setting the keyfile: ",
+ SSDATA (keyfile));
+ ret = gnutls_certificate_set_x509_crl_file
+ (x509_cred,
+ SSDATA (keyfile),
+ file_format);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ return gnutls_make_error (ret);
+ }
+ else
+ {
+ error ("Sorry, GnuTLS can't use non-string keyfile %s",
+ SDATA (keyfile));
+ }
+ }
+ }
GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
ret = gnutls_init (&state, GNUTLS_CLIENT);
if (ret < GNUTLS_E_SUCCESS)
- return gnutls_make_error (ret);
+ return gnutls_make_error (ret);
XPROCESS (proc)->gnutls_state = state;
GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
+ if (STRINGP (priority_string))
+ {
+ priority_string_ptr = SSDATA (priority_string);
+ GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
+ priority_string_ptr);
+ }
+ else
+ {
+ GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
+ priority_string_ptr);
+ }
+
GNUTLS_LOG (1, max_log_level, "setting the priority string");
- ret = gnutls_priority_set_direct(state,
- (char*) SDATA (priority_string),
- NULL);
+ ret = gnutls_priority_set_direct (state,
+ priority_string_ptr,
+ NULL);
if (ret < GNUTLS_E_SUCCESS)
- return gnutls_make_error (ret);
+ 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);
+ return gnutls_make_error (ret);
XPROCESS (proc)->gnutls_anon_cred = anon_cred;
XPROCESS (proc)->gnutls_x509_cred = x509_cred;
DEFUN ("gnutls-bye", Fgnutls_bye,
Sgnutls_bye, 2, 2, 0,
- doc: /* Terminate current GNU TLS connection for PROCESS.
+ doc: /* Terminate current GnuTLS connection for process PROC.
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
+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
Qgnutls_x509pki = intern_c_string ("gnutls-x509pki");
staticpro (&Qgnutls_x509pki);
+ Qgnutls_bootprop_priority = intern_c_string (":priority");
+ staticpro (&Qgnutls_bootprop_priority);
+
+ Qgnutls_bootprop_trustfiles = intern_c_string (":trustfiles");
+ staticpro (&Qgnutls_bootprop_trustfiles);
+
+ Qgnutls_bootprop_keyfiles = intern_c_string (":keyfiles");
+ staticpro (&Qgnutls_bootprop_keyfiles);
+
+ Qgnutls_bootprop_callbacks = intern_c_string (":callbacks");
+ staticpro (&Qgnutls_bootprop_callbacks);
+
+ Qgnutls_bootprop_loglevel = intern_c_string (":loglevel");
+ staticpro (&Qgnutls_bootprop_loglevel);
+
Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted");
staticpro (&Qgnutls_e_interrupted);
Fput (Qgnutls_e_interrupted, Qgnutls_code,