Merge from emacs-23; up to 2010-06-22T07:41:10Z!rgm@gnu.org
[emacs.git] / src / gnutls.c
blob500f09432b1a1f6369a755aa711dac23392b1065
1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2011 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
19 #include <config.h>
20 #include <errno.h>
21 #include <setjmp.h>
23 #include "lisp.h"
24 #include "process.h"
26 #ifdef HAVE_GNUTLS
27 #include <gnutls/gnutls.h>
29 #ifdef WINDOWSNT
30 #include <windows.h>
31 #include "w32.h"
32 #endif
34 static int
35 emacs_gnutls_handle_error (gnutls_session_t, int err);
37 static Lisp_Object Qgnutls_dll;
38 static Lisp_Object Qgnutls_code;
39 static Lisp_Object Qgnutls_anon, Qgnutls_x509pki;
40 static Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again,
41 Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake;
42 static int gnutls_global_initialized;
44 /* The following are for the property list of `gnutls-boot'. */
45 static Lisp_Object QCgnutls_bootprop_priority;
46 static Lisp_Object QCgnutls_bootprop_trustfiles;
47 static Lisp_Object QCgnutls_bootprop_keylist;
48 static Lisp_Object QCgnutls_bootprop_crlfiles;
49 static Lisp_Object QCgnutls_bootprop_callbacks;
50 static Lisp_Object QCgnutls_bootprop_loglevel;
51 static Lisp_Object QCgnutls_bootprop_hostname;
52 static Lisp_Object QCgnutls_bootprop_min_prime_bits;
53 static Lisp_Object QCgnutls_bootprop_verify_flags;
54 static Lisp_Object QCgnutls_bootprop_verify_hostname_error;
56 /* Callback keys for `gnutls-boot'. Unused currently. */
57 static Lisp_Object QCgnutls_bootprop_callbacks_verify;
59 static void gnutls_log_function (int, const char *);
60 static void gnutls_log_function2 (int, const char*, const char*);
63 #ifdef WINDOWSNT
65 /* Macro for defining functions that will be loaded from the GnuTLS DLL. */
66 #define DEF_GNUTLS_FN(rettype,func,args) static rettype (FAR CDECL *fn_##func)args
68 /* Macro for loading GnuTLS functions from the library. */
69 #define LOAD_GNUTLS_FN(lib,func) { \
70 fn_##func = (void *) GetProcAddress (lib, #func); \
71 if (!fn_##func) return 0; \
74 DEF_GNUTLS_FN (gnutls_alert_description_t, gnutls_alert_get,
75 (gnutls_session_t));
76 DEF_GNUTLS_FN (const char *, gnutls_alert_get_name,
77 (gnutls_alert_description_t));
78 DEF_GNUTLS_FN (int, gnutls_alert_send_appropriate, (gnutls_session_t, int));
79 DEF_GNUTLS_FN (int, gnutls_anon_allocate_client_credentials,
80 (gnutls_anon_client_credentials_t *));
81 DEF_GNUTLS_FN (void, gnutls_anon_free_client_credentials,
82 (gnutls_anon_client_credentials_t));
83 DEF_GNUTLS_FN (int, gnutls_bye, (gnutls_session_t, gnutls_close_request_t));
84 DEF_GNUTLS_FN (int, gnutls_certificate_allocate_credentials,
85 (gnutls_certificate_credentials_t *));
86 DEF_GNUTLS_FN (void, gnutls_certificate_free_credentials,
87 (gnutls_certificate_credentials_t));
88 DEF_GNUTLS_FN (const gnutls_datum_t *, gnutls_certificate_get_peers,
89 (gnutls_session_t, unsigned int *));
90 DEF_GNUTLS_FN (void, gnutls_certificate_set_verify_flags,
91 (gnutls_certificate_credentials_t, unsigned int));
92 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_crl_file,
93 (gnutls_certificate_credentials_t, const char *,
94 gnutls_x509_crt_fmt_t));
95 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_key_file,
96 (gnutls_certificate_credentials_t, const char *, const char *,
97 gnutls_x509_crt_fmt_t));
98 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_trust_file,
99 (gnutls_certificate_credentials_t, const char *,
100 gnutls_x509_crt_fmt_t));
101 DEF_GNUTLS_FN (gnutls_certificate_type_t, gnutls_certificate_type_get,
102 (gnutls_session_t));
103 DEF_GNUTLS_FN (int, gnutls_certificate_verify_peers2,
104 (gnutls_session_t, unsigned int *));
105 DEF_GNUTLS_FN (int, gnutls_credentials_set,
106 (gnutls_session_t, gnutls_credentials_type_t, void *));
107 DEF_GNUTLS_FN (void, gnutls_deinit, (gnutls_session_t));
108 DEF_GNUTLS_FN (void, gnutls_dh_set_prime_bits,
109 (gnutls_session_t, unsigned int));
110 DEF_GNUTLS_FN (int, gnutls_error_is_fatal, (int));
111 DEF_GNUTLS_FN (int, gnutls_global_init, (void));
112 DEF_GNUTLS_FN (void, gnutls_global_set_log_function, (gnutls_log_func));
113 DEF_GNUTLS_FN (void, gnutls_global_set_log_level, (int));
114 DEF_GNUTLS_FN (void, gnutls_global_set_mem_functions,
115 (gnutls_alloc_function, gnutls_alloc_function,
116 gnutls_is_secure_function, gnutls_realloc_function,
117 gnutls_free_function));
118 DEF_GNUTLS_FN (int, gnutls_handshake, (gnutls_session_t));
119 DEF_GNUTLS_FN (int, gnutls_init, (gnutls_session_t *, gnutls_connection_end_t));
120 DEF_GNUTLS_FN (int, gnutls_priority_set_direct,
121 (gnutls_session_t, const char *, const char **));
122 DEF_GNUTLS_FN (size_t, gnutls_record_check_pending, (gnutls_session_t));
123 DEF_GNUTLS_FN (ssize_t, gnutls_record_recv, (gnutls_session_t, void *, size_t));
124 DEF_GNUTLS_FN (ssize_t, gnutls_record_send,
125 (gnutls_session_t, const void *, size_t));
126 DEF_GNUTLS_FN (const char *, gnutls_strerror, (int));
127 DEF_GNUTLS_FN (void, gnutls_transport_set_errno, (gnutls_session_t, int));
128 DEF_GNUTLS_FN (void, gnutls_transport_set_lowat, (gnutls_session_t, int));
129 DEF_GNUTLS_FN (void, gnutls_transport_set_ptr2,
130 (gnutls_session_t, gnutls_transport_ptr_t,
131 gnutls_transport_ptr_t));
132 DEF_GNUTLS_FN (void, gnutls_transport_set_pull_function,
133 (gnutls_session_t, gnutls_pull_func));
134 DEF_GNUTLS_FN (void, gnutls_transport_set_push_function,
135 (gnutls_session_t, gnutls_push_func));
136 DEF_GNUTLS_FN (int, gnutls_x509_crt_check_hostname,
137 (gnutls_x509_crt_t, const char *));
138 DEF_GNUTLS_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t));
139 DEF_GNUTLS_FN (int, gnutls_x509_crt_import,
140 (gnutls_x509_crt_t, const gnutls_datum_t *,
141 gnutls_x509_crt_fmt_t));
142 DEF_GNUTLS_FN (int, gnutls_x509_crt_init, (gnutls_x509_crt_t *));
144 static int
145 init_gnutls_functions (Lisp_Object libraries)
147 HMODULE library;
148 int max_log_level = 1;
150 if (!(library = w32_delayed_load (libraries, Qgnutls_dll)))
152 GNUTLS_LOG (1, max_log_level, "GnuTLS library not found");
153 return 0;
156 LOAD_GNUTLS_FN (library, gnutls_alert_get);
157 LOAD_GNUTLS_FN (library, gnutls_alert_get_name);
158 LOAD_GNUTLS_FN (library, gnutls_alert_send_appropriate);
159 LOAD_GNUTLS_FN (library, gnutls_anon_allocate_client_credentials);
160 LOAD_GNUTLS_FN (library, gnutls_anon_free_client_credentials);
161 LOAD_GNUTLS_FN (library, gnutls_bye);
162 LOAD_GNUTLS_FN (library, gnutls_certificate_allocate_credentials);
163 LOAD_GNUTLS_FN (library, gnutls_certificate_free_credentials);
164 LOAD_GNUTLS_FN (library, gnutls_certificate_get_peers);
165 LOAD_GNUTLS_FN (library, gnutls_certificate_set_verify_flags);
166 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_crl_file);
167 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_key_file);
168 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_trust_file);
169 LOAD_GNUTLS_FN (library, gnutls_certificate_type_get);
170 LOAD_GNUTLS_FN (library, gnutls_certificate_verify_peers2);
171 LOAD_GNUTLS_FN (library, gnutls_credentials_set);
172 LOAD_GNUTLS_FN (library, gnutls_deinit);
173 LOAD_GNUTLS_FN (library, gnutls_dh_set_prime_bits);
174 LOAD_GNUTLS_FN (library, gnutls_error_is_fatal);
175 LOAD_GNUTLS_FN (library, gnutls_global_init);
176 LOAD_GNUTLS_FN (library, gnutls_global_set_log_function);
177 LOAD_GNUTLS_FN (library, gnutls_global_set_log_level);
178 LOAD_GNUTLS_FN (library, gnutls_global_set_mem_functions);
179 LOAD_GNUTLS_FN (library, gnutls_handshake);
180 LOAD_GNUTLS_FN (library, gnutls_init);
181 LOAD_GNUTLS_FN (library, gnutls_priority_set_direct);
182 LOAD_GNUTLS_FN (library, gnutls_record_check_pending);
183 LOAD_GNUTLS_FN (library, gnutls_record_recv);
184 LOAD_GNUTLS_FN (library, gnutls_record_send);
185 LOAD_GNUTLS_FN (library, gnutls_strerror);
186 LOAD_GNUTLS_FN (library, gnutls_transport_set_errno);
187 LOAD_GNUTLS_FN (library, gnutls_transport_set_lowat);
188 LOAD_GNUTLS_FN (library, gnutls_transport_set_ptr2);
189 LOAD_GNUTLS_FN (library, gnutls_transport_set_pull_function);
190 LOAD_GNUTLS_FN (library, gnutls_transport_set_push_function);
191 LOAD_GNUTLS_FN (library, gnutls_x509_crt_check_hostname);
192 LOAD_GNUTLS_FN (library, gnutls_x509_crt_deinit);
193 LOAD_GNUTLS_FN (library, gnutls_x509_crt_import);
194 LOAD_GNUTLS_FN (library, gnutls_x509_crt_init);
196 max_log_level = global_gnutls_log_level;
198 GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:",
199 SDATA (Fget (Qgnutls_dll, QCloaded_from)));
200 return 1;
203 #else /* !WINDOWSNT */
205 #define fn_gnutls_alert_get gnutls_alert_get
206 #define fn_gnutls_alert_get_name gnutls_alert_get_name
207 #define fn_gnutls_alert_send_appropriate gnutls_alert_send_appropriate
208 #define fn_gnutls_anon_allocate_client_credentials gnutls_anon_allocate_client_credentials
209 #define fn_gnutls_anon_free_client_credentials gnutls_anon_free_client_credentials
210 #define fn_gnutls_bye gnutls_bye
211 #define fn_gnutls_certificate_allocate_credentials gnutls_certificate_allocate_credentials
212 #define fn_gnutls_certificate_free_credentials gnutls_certificate_free_credentials
213 #define fn_gnutls_certificate_get_peers gnutls_certificate_get_peers
214 #define fn_gnutls_certificate_set_verify_flags gnutls_certificate_set_verify_flags
215 #define fn_gnutls_certificate_set_x509_crl_file gnutls_certificate_set_x509_crl_file
216 #define fn_gnutls_certificate_set_x509_key_file gnutls_certificate_set_x509_key_file
217 #define fn_gnutls_certificate_set_x509_trust_file gnutls_certificate_set_x509_trust_file
218 #define fn_gnutls_certificate_type_get gnutls_certificate_type_get
219 #define fn_gnutls_certificate_verify_peers2 gnutls_certificate_verify_peers2
220 #define fn_gnutls_credentials_set gnutls_credentials_set
221 #define fn_gnutls_deinit gnutls_deinit
222 #define fn_gnutls_dh_set_prime_bits gnutls_dh_set_prime_bits
223 #define fn_gnutls_error_is_fatal gnutls_error_is_fatal
224 #define fn_gnutls_global_init gnutls_global_init
225 #define fn_gnutls_global_set_log_function gnutls_global_set_log_function
226 #define fn_gnutls_global_set_log_level gnutls_global_set_log_level
227 #define fn_gnutls_global_set_mem_functions gnutls_global_set_mem_functions
228 #define fn_gnutls_handshake gnutls_handshake
229 #define fn_gnutls_init gnutls_init
230 #define fn_gnutls_priority_set_direct gnutls_priority_set_direct
231 #define fn_gnutls_record_check_pending gnutls_record_check_pending
232 #define fn_gnutls_record_recv gnutls_record_recv
233 #define fn_gnutls_record_send gnutls_record_send
234 #define fn_gnutls_strerror gnutls_strerror
235 #define fn_gnutls_transport_set_errno gnutls_transport_set_errno
236 #define fn_gnutls_transport_set_ptr2 gnutls_transport_set_ptr2
237 #define fn_gnutls_x509_crt_check_hostname gnutls_x509_crt_check_hostname
238 #define fn_gnutls_x509_crt_deinit gnutls_x509_crt_deinit
239 #define fn_gnutls_x509_crt_import gnutls_x509_crt_import
240 #define fn_gnutls_x509_crt_init gnutls_x509_crt_init
242 #endif /* !WINDOWSNT */
245 static void
246 gnutls_log_function (int level, const char* string)
248 message ("gnutls.c: [%d] %s", level, string);
251 static void
252 gnutls_log_function2 (int level, const char* string, const char* extra)
254 message ("gnutls.c: [%d] %s %s", level, string, extra);
257 static int
258 emacs_gnutls_handshake (struct Lisp_Process *proc)
260 gnutls_session_t state = proc->gnutls_state;
261 int ret;
263 if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
264 return -1;
266 if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
268 #ifdef WINDOWSNT
269 /* On W32 we cannot transfer socket handles between different runtime
270 libraries, so we tell GnuTLS to use our special push/pull
271 functions. */
272 fn_gnutls_transport_set_ptr2 (state,
273 (gnutls_transport_ptr_t) proc,
274 (gnutls_transport_ptr_t) proc);
275 fn_gnutls_transport_set_push_function (state, &emacs_gnutls_push);
276 fn_gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
278 /* For non blocking sockets or other custom made pull/push
279 functions the gnutls_transport_set_lowat must be called, with
280 a zero low water mark value. (GnuTLS 2.10.4 documentation)
282 (Note: this is probably not strictly necessary as the lowat
283 value is only used when no custom pull/push functions are
284 set.) */
285 fn_gnutls_transport_set_lowat (state, 0);
286 #else
287 /* This is how GnuTLS takes sockets: as file descriptors passed
288 in. For an Emacs process socket, infd and outfd are the
289 same but we use this two-argument version for clarity. */
290 fn_gnutls_transport_set_ptr2 (state,
291 (gnutls_transport_ptr_t) (long) proc->infd,
292 (gnutls_transport_ptr_t) (long) proc->outfd);
293 #endif
295 proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
300 ret = fn_gnutls_handshake (state);
301 emacs_gnutls_handle_error (state, ret);
303 while (ret < 0 && fn_gnutls_error_is_fatal (ret) == 0);
305 proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
307 if (ret == GNUTLS_E_SUCCESS)
309 /* Here we're finally done. */
310 proc->gnutls_initstage = GNUTLS_STAGE_READY;
312 else
314 fn_gnutls_alert_send_appropriate (state, ret);
316 return ret;
320 emacs_gnutls_record_check_pending (gnutls_session_t state)
322 return fn_gnutls_record_check_pending (state);
325 void
326 emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
328 fn_gnutls_transport_set_errno (state, err);
331 EMACS_INT
332 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, EMACS_INT nbyte)
334 ssize_t rtnval = 0;
335 EMACS_INT bytes_written;
336 gnutls_session_t state = proc->gnutls_state;
338 if (proc->gnutls_initstage != GNUTLS_STAGE_READY) {
339 #ifdef EWOULDBLOCK
340 errno = EWOULDBLOCK;
341 #endif
342 #ifdef EAGAIN
343 errno = EAGAIN;
344 #endif
345 return 0;
348 bytes_written = 0;
350 while (nbyte > 0)
352 rtnval = fn_gnutls_record_send (state, buf, nbyte);
354 if (rtnval < 0)
356 if (rtnval == GNUTLS_E_AGAIN || rtnval == GNUTLS_E_INTERRUPTED)
357 continue;
358 else
359 break;
362 buf += rtnval;
363 nbyte -= rtnval;
364 bytes_written += rtnval;
367 emacs_gnutls_handle_error (state, rtnval);
368 return (bytes_written);
371 EMACS_INT
372 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, EMACS_INT nbyte)
374 ssize_t rtnval;
375 gnutls_session_t state = proc->gnutls_state;
377 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
379 emacs_gnutls_handshake (proc);
380 return -1;
382 rtnval = fn_gnutls_record_recv (state, buf, nbyte);
383 if (rtnval >= 0)
384 return rtnval;
385 else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
386 /* The peer closed the connection. */
387 return 0;
388 else if (emacs_gnutls_handle_error (state, rtnval) == 0)
389 /* non-fatal error */
390 return -1;
391 else {
392 /* a fatal error occurred */
393 return 0;
397 /* report a GnuTLS error to the user.
398 Returns zero if the error code was successfully handled. */
399 static int
400 emacs_gnutls_handle_error (gnutls_session_t session, int err)
402 int max_log_level = 0;
404 int ret;
405 const char *str;
407 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
408 if (err >= 0)
409 return 0;
411 max_log_level = global_gnutls_log_level;
413 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
415 str = fn_gnutls_strerror (err);
416 if (!str)
417 str = "unknown";
419 if (fn_gnutls_error_is_fatal (err))
421 ret = err;
422 GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
424 else
426 ret = 0;
427 GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str);
428 /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2. */
431 if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
432 || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
434 int alert = fn_gnutls_alert_get (session);
435 int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
436 str = fn_gnutls_alert_get_name (alert);
437 if (!str)
438 str = "unknown";
440 GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
442 return ret;
445 /* convert an integer error to a Lisp_Object; it will be either a
446 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
447 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
448 to Qt. */
449 static Lisp_Object
450 gnutls_make_error (int err)
452 switch (err)
454 case GNUTLS_E_SUCCESS:
455 return Qt;
456 case GNUTLS_E_AGAIN:
457 return Qgnutls_e_again;
458 case GNUTLS_E_INTERRUPTED:
459 return Qgnutls_e_interrupted;
460 case GNUTLS_E_INVALID_SESSION:
461 return Qgnutls_e_invalid_session;
464 return make_number (err);
467 Lisp_Object
468 emacs_gnutls_deinit (Lisp_Object proc)
470 int log_level;
472 CHECK_PROCESS (proc);
474 if (XPROCESS (proc)->gnutls_p == 0)
475 return Qnil;
477 log_level = XPROCESS (proc)->gnutls_log_level;
479 if (XPROCESS (proc)->gnutls_x509_cred)
481 GNUTLS_LOG (2, log_level, "Deallocating x509 credentials");
482 fn_gnutls_certificate_free_credentials (XPROCESS (proc)->gnutls_x509_cred);
483 XPROCESS (proc)->gnutls_x509_cred = NULL;
486 if (XPROCESS (proc)->gnutls_anon_cred)
488 GNUTLS_LOG (2, log_level, "Deallocating anon credentials");
489 fn_gnutls_anon_free_client_credentials (XPROCESS (proc)->gnutls_anon_cred);
490 XPROCESS (proc)->gnutls_anon_cred = NULL;
493 if (XPROCESS (proc)->gnutls_state)
495 fn_gnutls_deinit (XPROCESS (proc)->gnutls_state);
496 XPROCESS (proc)->gnutls_state = NULL;
497 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
498 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
501 XPROCESS (proc)->gnutls_p = 0;
502 return Qt;
505 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
506 doc: /* Return the GnuTLS init stage of process PROC.
507 See also `gnutls-boot'. */)
508 (Lisp_Object proc)
510 CHECK_PROCESS (proc);
512 return make_number (GNUTLS_INITSTAGE (proc));
515 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
516 doc: /* Return t if ERROR indicates a GnuTLS problem.
517 ERROR is an integer or a symbol with an integer `gnutls-code' property.
518 usage: (gnutls-errorp ERROR) */)
519 (Lisp_Object err)
521 if (EQ (err, Qt)) return Qnil;
523 return Qt;
526 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
527 doc: /* Check if ERROR is fatal.
528 ERROR is an integer or a symbol with an integer `gnutls-code' property.
529 usage: (gnutls-error-fatalp ERROR) */)
530 (Lisp_Object err)
532 Lisp_Object code;
534 if (EQ (err, Qt)) return Qnil;
536 if (SYMBOLP (err))
538 code = Fget (err, Qgnutls_code);
539 if (NUMBERP (code))
541 err = code;
543 else
545 error ("Symbol has no numeric gnutls-code property");
549 if (!NUMBERP (err))
550 error ("Not an error symbol or code");
552 if (0 == fn_gnutls_error_is_fatal (XINT (err)))
553 return Qnil;
555 return Qt;
558 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
559 doc: /* Return a description of ERROR.
560 ERROR is an integer or a symbol with an integer `gnutls-code' property.
561 usage: (gnutls-error-string ERROR) */)
562 (Lisp_Object err)
564 Lisp_Object code;
566 if (EQ (err, Qt)) return build_string ("Not an error");
568 if (SYMBOLP (err))
570 code = Fget (err, Qgnutls_code);
571 if (NUMBERP (code))
573 err = code;
575 else
577 return build_string ("Symbol has no numeric gnutls-code property");
581 if (!NUMBERP (err))
582 return build_string ("Not an error symbol or code");
584 return build_string (fn_gnutls_strerror (XINT (err)));
587 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
588 doc: /* Deallocate GnuTLS resources associated with process PROC.
589 See also `gnutls-init'. */)
590 (Lisp_Object proc)
592 return emacs_gnutls_deinit (proc);
595 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
596 doc: /* Return t if GnuTLS is available in this instance of Emacs. */)
597 (void)
599 #ifdef WINDOWSNT
600 Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
601 if (CONSP (found))
602 return XCDR (found);
603 else
605 Lisp_Object status;
606 status = init_gnutls_functions (Vdynamic_library_alist) ? Qt : Qnil;
607 Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
608 return status;
610 #else
611 return Qt;
612 #endif
616 /* Initializes global GnuTLS state to defaults.
617 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
618 Returns zero on success. */
619 static Lisp_Object
620 emacs_gnutls_global_init (void)
622 int ret = GNUTLS_E_SUCCESS;
624 if (!gnutls_global_initialized)
626 fn_gnutls_global_set_mem_functions (xmalloc, xmalloc, NULL,
627 xrealloc, xfree);
628 ret = fn_gnutls_global_init ();
630 gnutls_global_initialized = 1;
632 return gnutls_make_error (ret);
635 #if 0
636 /* Deinitializes global GnuTLS state.
637 See also `gnutls-global-init'. */
638 static Lisp_Object
639 emacs_gnutls_global_deinit (void)
641 if (gnutls_global_initialized)
642 gnutls_global_deinit ();
644 gnutls_global_initialized = 0;
646 return gnutls_make_error (GNUTLS_E_SUCCESS);
648 #endif
650 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
651 doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
652 Currently only client mode is supported. Return a success/failure
653 value you can check with `gnutls-errorp'.
655 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
656 PROPLIST is a property list with the following keys:
658 :hostname is a string naming the remote host.
660 :priority is a GnuTLS priority string, defaults to "NORMAL".
662 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
664 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
666 :keylist is an alist of PEM-encoded key files and PEM-encoded
667 certificates for `gnutls-x509pki'.
669 :callbacks is an alist of callback functions, see below.
671 :loglevel is the debug level requested from GnuTLS, try 4.
673 :verify-flags is a bitset as per GnuTLS'
674 gnutls_certificate_set_verify_flags.
676 :verify-hostname-error, if non-nil, makes a hostname mismatch an
677 error. Otherwise it will be just a warning.
679 :min-prime-bits is the minimum accepted number of bits the client will
680 accept in Diffie-Hellman key exchange.
682 The debug level will be set for this process AND globally for GnuTLS.
683 So if you set it higher or lower at any point, it affects global
684 debugging.
686 Note that the priority is set on the client. The server does not use
687 the protocols's priority except for disabling protocols that were not
688 specified.
690 Processes must be initialized with this function before other GnuTLS
691 functions are used. This function allocates resources which can only
692 be deallocated by calling `gnutls-deinit' or by calling it again.
694 The callbacks alist can have a `verify' key, associated with a
695 verification function (UNUSED).
697 Each authentication type may need additional information in order to
698 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
699 one trustfile (usually a CA bundle). */)
700 (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
702 int ret = GNUTLS_E_SUCCESS;
703 int max_log_level = 0;
705 gnutls_session_t state;
706 gnutls_certificate_credentials_t x509_cred = NULL;
707 gnutls_anon_client_credentials_t anon_cred = NULL;
708 Lisp_Object global_init;
709 char const *priority_string_ptr = "NORMAL"; /* default priority string. */
710 unsigned int peer_verification;
711 char* c_hostname;
713 /* Placeholders for the property list elements. */
714 Lisp_Object priority_string;
715 Lisp_Object trustfiles;
716 Lisp_Object crlfiles;
717 Lisp_Object keylist;
718 /* Lisp_Object callbacks; */
719 Lisp_Object loglevel;
720 Lisp_Object hostname;
721 /* Lisp_Object verify_error; */
722 Lisp_Object verify_hostname_error;
723 Lisp_Object prime_bits;
725 CHECK_PROCESS (proc);
726 CHECK_SYMBOL (type);
727 CHECK_LIST (proplist);
729 if (NILP (Fgnutls_available_p ()))
731 error ("GnuTLS not available");
732 return gnutls_make_error (GNUTLS_EMACS_ERROR_NOT_LOADED);
735 if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
737 error ("Invalid GnuTLS credential type");
738 return gnutls_make_error (GNUTLS_EMACS_ERROR_INVALID_TYPE);
741 hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
742 priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority);
743 trustfiles = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
744 keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist);
745 crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
746 loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
747 verify_hostname_error = Fplist_get (proplist, QCgnutls_bootprop_verify_hostname_error);
748 prime_bits = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
750 if (!STRINGP (hostname))
751 error ("gnutls-boot: invalid :hostname parameter");
752 c_hostname = SSDATA (hostname);
754 if (NUMBERP (loglevel))
756 fn_gnutls_global_set_log_function (gnutls_log_function);
757 fn_gnutls_global_set_log_level (XINT (loglevel));
758 max_log_level = XINT (loglevel);
759 XPROCESS (proc)->gnutls_log_level = max_log_level;
762 /* always initialize globals. */
763 global_init = emacs_gnutls_global_init ();
764 if (! NILP (Fgnutls_errorp (global_init)))
765 return global_init;
767 /* Before allocating new credentials, deallocate any credentials
768 that PROC might already have. */
769 emacs_gnutls_deinit (proc);
771 /* Mark PROC as a GnuTLS process. */
772 XPROCESS (proc)->gnutls_p = 1;
773 XPROCESS (proc)->gnutls_state = NULL;
774 XPROCESS (proc)->gnutls_x509_cred = NULL;
775 XPROCESS (proc)->gnutls_anon_cred = NULL;
776 XPROCESS (proc)->gnutls_cred_type = type;
777 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
779 GNUTLS_LOG (1, max_log_level, "allocating credentials");
780 if (EQ (type, Qgnutls_x509pki))
782 Lisp_Object verify_flags;
783 unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
785 GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
786 fn_gnutls_certificate_allocate_credentials (&x509_cred);
787 XPROCESS (proc)->gnutls_x509_cred = x509_cred;
789 verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
790 if (NUMBERP (verify_flags))
792 gnutls_verify_flags = XINT (verify_flags);
793 GNUTLS_LOG (2, max_log_level, "setting verification flags");
795 else if (NILP (verify_flags))
796 GNUTLS_LOG (2, max_log_level, "using default verification flags");
797 else
798 GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
800 fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
802 else /* Qgnutls_anon: */
804 GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
805 fn_gnutls_anon_allocate_client_credentials (&anon_cred);
806 XPROCESS (proc)->gnutls_anon_cred = anon_cred;
809 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
811 if (EQ (type, Qgnutls_x509pki))
813 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
814 int file_format = GNUTLS_X509_FMT_PEM;
815 Lisp_Object tail;
817 for (tail = trustfiles; !NILP (tail); tail = Fcdr (tail))
819 Lisp_Object trustfile = Fcar (tail);
820 if (STRINGP (trustfile))
822 GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
823 SSDATA (trustfile));
824 ret = fn_gnutls_certificate_set_x509_trust_file
825 (x509_cred,
826 SSDATA (trustfile),
827 file_format);
829 if (ret < GNUTLS_E_SUCCESS)
830 return gnutls_make_error (ret);
832 else
834 emacs_gnutls_deinit (proc);
835 error ("Invalid trustfile");
839 for (tail = crlfiles; !NILP (tail); tail = Fcdr (tail))
841 Lisp_Object crlfile = Fcar (tail);
842 if (STRINGP (crlfile))
844 GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
845 SSDATA (crlfile));
846 ret = fn_gnutls_certificate_set_x509_crl_file
847 (x509_cred, SSDATA (crlfile), file_format);
849 if (ret < GNUTLS_E_SUCCESS)
850 return gnutls_make_error (ret);
852 else
854 emacs_gnutls_deinit (proc);
855 error ("Invalid CRL file");
859 for (tail = keylist; !NILP (tail); tail = Fcdr (tail))
861 Lisp_Object keyfile = Fcar (Fcar (tail));
862 Lisp_Object certfile = Fcar (Fcdr (tail));
863 if (STRINGP (keyfile) && STRINGP (certfile))
865 GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
866 SSDATA (keyfile));
867 GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
868 SSDATA (certfile));
869 ret = fn_gnutls_certificate_set_x509_key_file
870 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
872 if (ret < GNUTLS_E_SUCCESS)
873 return gnutls_make_error (ret);
875 else
877 emacs_gnutls_deinit (proc);
878 error (STRINGP (keyfile) ? "Invalid client cert file"
879 : "Invalid client key file");
884 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
885 GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
886 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
888 /* Call gnutls_init here: */
890 GNUTLS_LOG (1, max_log_level, "gnutls_init");
891 ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
892 XPROCESS (proc)->gnutls_state = state;
893 if (ret < GNUTLS_E_SUCCESS)
894 return gnutls_make_error (ret);
895 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
897 if (STRINGP (priority_string))
899 priority_string_ptr = SSDATA (priority_string);
900 GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
901 priority_string_ptr);
903 else
905 GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
906 priority_string_ptr);
909 GNUTLS_LOG (1, max_log_level, "setting the priority string");
910 ret = fn_gnutls_priority_set_direct (state,
911 priority_string_ptr,
912 NULL);
913 if (ret < GNUTLS_E_SUCCESS)
914 return gnutls_make_error (ret);
916 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
918 if (INTEGERP (prime_bits))
919 fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
921 ret = EQ (type, Qgnutls_x509pki)
922 ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
923 : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
924 if (ret < GNUTLS_E_SUCCESS)
925 return gnutls_make_error (ret);
927 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
928 ret = emacs_gnutls_handshake (XPROCESS (proc));
929 if (ret < GNUTLS_E_SUCCESS)
930 return gnutls_make_error (ret);
932 /* Now verify the peer, following
933 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
934 The peer should present at least one certificate in the chain; do a
935 check of the certificate's hostname with
936 gnutls_x509_crt_check_hostname() against :hostname. */
938 ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
939 if (ret < GNUTLS_E_SUCCESS)
940 return gnutls_make_error (ret);
942 if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
943 message ("%s certificate could not be verified.", c_hostname);
945 if (peer_verification & GNUTLS_CERT_REVOKED)
946 GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
947 c_hostname);
949 if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
950 GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
951 c_hostname);
953 if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
954 GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
955 c_hostname);
957 if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
958 GNUTLS_LOG2 (1, max_log_level,
959 "certificate was signed with an insecure algorithm:",
960 c_hostname);
962 if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
963 GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
964 c_hostname);
966 if (peer_verification & GNUTLS_CERT_EXPIRED)
967 GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
968 c_hostname);
970 if (peer_verification != 0)
972 if (NILP (verify_hostname_error))
973 GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
974 c_hostname);
975 else
977 emacs_gnutls_deinit (proc);
978 error ("Certificate validation failed %s, verification code %d",
979 c_hostname, peer_verification);
983 /* Up to here the process is the same for X.509 certificates and
984 OpenPGP keys. From now on X.509 certificates are assumed. This
985 can be easily extended to work with openpgp keys as well. */
986 if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
988 gnutls_x509_crt_t gnutls_verify_cert;
989 const gnutls_datum_t *gnutls_verify_cert_list;
990 unsigned int gnutls_verify_cert_list_size;
992 ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
993 if (ret < GNUTLS_E_SUCCESS)
994 return gnutls_make_error (ret);
996 gnutls_verify_cert_list =
997 fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
999 if (gnutls_verify_cert_list == NULL)
1001 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1002 emacs_gnutls_deinit (proc);
1003 error ("No x509 certificate was found\n");
1006 /* We only check the first certificate in the given chain. */
1007 ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1008 &gnutls_verify_cert_list[0],
1009 GNUTLS_X509_FMT_DER);
1011 if (ret < GNUTLS_E_SUCCESS)
1013 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1014 return gnutls_make_error (ret);
1017 if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1019 if (NILP (verify_hostname_error))
1020 GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1021 c_hostname);
1022 else
1024 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1025 emacs_gnutls_deinit (proc);
1026 error ("The x509 certificate does not match \"%s\"", c_hostname);
1029 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1032 return gnutls_make_error (ret);
1035 DEFUN ("gnutls-bye", Fgnutls_bye,
1036 Sgnutls_bye, 2, 2, 0,
1037 doc: /* Terminate current GnuTLS connection for process PROC.
1038 The connection should have been initiated using `gnutls-handshake'.
1040 If CONT is not nil the TLS connection gets terminated and further
1041 receives and sends will be disallowed. If the return value is zero you
1042 may continue using the connection. If CONT is nil, GnuTLS actually
1043 sends an alert containing a close request and waits for the peer to
1044 reply with the same message. In order to reuse the connection you
1045 should wait for an EOF from the peer.
1047 This function may also return `gnutls-e-again', or
1048 `gnutls-e-interrupted'. */)
1049 (Lisp_Object proc, Lisp_Object cont)
1051 gnutls_session_t state;
1052 int ret;
1054 CHECK_PROCESS (proc);
1056 state = XPROCESS (proc)->gnutls_state;
1058 ret = fn_gnutls_bye (state,
1059 NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1061 return gnutls_make_error (ret);
1064 void
1065 syms_of_gnutls (void)
1067 gnutls_global_initialized = 0;
1069 DEFSYM (Qgnutls_dll, "gnutls");
1070 DEFSYM (Qgnutls_code, "gnutls-code");
1071 DEFSYM (Qgnutls_anon, "gnutls-anon");
1072 DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1073 DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1074 DEFSYM (QCgnutls_bootprop_priority, ":priority");
1075 DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1076 DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1077 DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1078 DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1079 DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1080 DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1081 DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1082 DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1083 DEFSYM (QCgnutls_bootprop_verify_hostname_error, ":verify-hostname-error");
1085 DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1086 Fput (Qgnutls_e_interrupted, Qgnutls_code,
1087 make_number (GNUTLS_E_INTERRUPTED));
1089 DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1090 Fput (Qgnutls_e_again, Qgnutls_code,
1091 make_number (GNUTLS_E_AGAIN));
1093 DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1094 Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1095 make_number (GNUTLS_E_INVALID_SESSION));
1097 DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1098 Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1099 make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1101 defsubr (&Sgnutls_get_initstage);
1102 defsubr (&Sgnutls_errorp);
1103 defsubr (&Sgnutls_error_fatalp);
1104 defsubr (&Sgnutls_error_string);
1105 defsubr (&Sgnutls_boot);
1106 defsubr (&Sgnutls_deinit);
1107 defsubr (&Sgnutls_bye);
1108 defsubr (&Sgnutls_available_p);
1110 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1111 doc: /* Logging level used by the GnuTLS functions. */);
1112 global_gnutls_log_level = 0;
1115 #endif /* HAVE_GNUTLS */