Update CC Mode version to 5.32.3.
[emacs.git] / src / gnutls.c
blob70eea3b0b8925964ffede9896d666f4c7f450126
1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2012 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 (const char *, gnutls_check_version, (const char *));
129 DEF_GNUTLS_FN (void, gnutls_transport_set_lowat, (gnutls_session_t, int));
130 DEF_GNUTLS_FN (void, gnutls_transport_set_ptr2,
131 (gnutls_session_t, gnutls_transport_ptr_t,
132 gnutls_transport_ptr_t));
133 DEF_GNUTLS_FN (void, gnutls_transport_set_pull_function,
134 (gnutls_session_t, gnutls_pull_func));
135 DEF_GNUTLS_FN (void, gnutls_transport_set_push_function,
136 (gnutls_session_t, gnutls_push_func));
137 DEF_GNUTLS_FN (int, gnutls_x509_crt_check_hostname,
138 (gnutls_x509_crt_t, const char *));
139 DEF_GNUTLS_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t));
140 DEF_GNUTLS_FN (int, gnutls_x509_crt_import,
141 (gnutls_x509_crt_t, const gnutls_datum_t *,
142 gnutls_x509_crt_fmt_t));
143 DEF_GNUTLS_FN (int, gnutls_x509_crt_init, (gnutls_x509_crt_t *));
145 static int
146 init_gnutls_functions (Lisp_Object libraries)
148 HMODULE library;
149 int max_log_level = 1;
151 if (!(library = w32_delayed_load (libraries, Qgnutls_dll)))
153 GNUTLS_LOG (1, max_log_level, "GnuTLS library not found");
154 return 0;
157 LOAD_GNUTLS_FN (library, gnutls_alert_get);
158 LOAD_GNUTLS_FN (library, gnutls_alert_get_name);
159 LOAD_GNUTLS_FN (library, gnutls_alert_send_appropriate);
160 LOAD_GNUTLS_FN (library, gnutls_anon_allocate_client_credentials);
161 LOAD_GNUTLS_FN (library, gnutls_anon_free_client_credentials);
162 LOAD_GNUTLS_FN (library, gnutls_bye);
163 LOAD_GNUTLS_FN (library, gnutls_certificate_allocate_credentials);
164 LOAD_GNUTLS_FN (library, gnutls_certificate_free_credentials);
165 LOAD_GNUTLS_FN (library, gnutls_certificate_get_peers);
166 LOAD_GNUTLS_FN (library, gnutls_certificate_set_verify_flags);
167 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_crl_file);
168 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_key_file);
169 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_trust_file);
170 LOAD_GNUTLS_FN (library, gnutls_certificate_type_get);
171 LOAD_GNUTLS_FN (library, gnutls_certificate_verify_peers2);
172 LOAD_GNUTLS_FN (library, gnutls_credentials_set);
173 LOAD_GNUTLS_FN (library, gnutls_deinit);
174 LOAD_GNUTLS_FN (library, gnutls_dh_set_prime_bits);
175 LOAD_GNUTLS_FN (library, gnutls_error_is_fatal);
176 LOAD_GNUTLS_FN (library, gnutls_global_init);
177 LOAD_GNUTLS_FN (library, gnutls_global_set_log_function);
178 LOAD_GNUTLS_FN (library, gnutls_global_set_log_level);
179 LOAD_GNUTLS_FN (library, gnutls_global_set_mem_functions);
180 LOAD_GNUTLS_FN (library, gnutls_handshake);
181 LOAD_GNUTLS_FN (library, gnutls_init);
182 LOAD_GNUTLS_FN (library, gnutls_priority_set_direct);
183 LOAD_GNUTLS_FN (library, gnutls_record_check_pending);
184 LOAD_GNUTLS_FN (library, gnutls_record_recv);
185 LOAD_GNUTLS_FN (library, gnutls_record_send);
186 LOAD_GNUTLS_FN (library, gnutls_strerror);
187 LOAD_GNUTLS_FN (library, gnutls_transport_set_errno);
188 LOAD_GNUTLS_FN (library, gnutls_check_version);
189 /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
190 and later, and the function was removed entirely in 3.0.0. */
191 if (!fn_gnutls_check_version ("2.11.1"))
192 LOAD_GNUTLS_FN (library, gnutls_transport_set_lowat);
193 LOAD_GNUTLS_FN (library, gnutls_transport_set_ptr2);
194 LOAD_GNUTLS_FN (library, gnutls_transport_set_pull_function);
195 LOAD_GNUTLS_FN (library, gnutls_transport_set_push_function);
196 LOAD_GNUTLS_FN (library, gnutls_x509_crt_check_hostname);
197 LOAD_GNUTLS_FN (library, gnutls_x509_crt_deinit);
198 LOAD_GNUTLS_FN (library, gnutls_x509_crt_import);
199 LOAD_GNUTLS_FN (library, gnutls_x509_crt_init);
201 max_log_level = global_gnutls_log_level;
203 GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:",
204 SDATA (Fget (Qgnutls_dll, QCloaded_from)));
205 return 1;
208 #else /* !WINDOWSNT */
210 #define fn_gnutls_alert_get gnutls_alert_get
211 #define fn_gnutls_alert_get_name gnutls_alert_get_name
212 #define fn_gnutls_alert_send_appropriate gnutls_alert_send_appropriate
213 #define fn_gnutls_anon_allocate_client_credentials gnutls_anon_allocate_client_credentials
214 #define fn_gnutls_anon_free_client_credentials gnutls_anon_free_client_credentials
215 #define fn_gnutls_bye gnutls_bye
216 #define fn_gnutls_certificate_allocate_credentials gnutls_certificate_allocate_credentials
217 #define fn_gnutls_certificate_free_credentials gnutls_certificate_free_credentials
218 #define fn_gnutls_certificate_get_peers gnutls_certificate_get_peers
219 #define fn_gnutls_certificate_set_verify_flags gnutls_certificate_set_verify_flags
220 #define fn_gnutls_certificate_set_x509_crl_file gnutls_certificate_set_x509_crl_file
221 #define fn_gnutls_certificate_set_x509_key_file gnutls_certificate_set_x509_key_file
222 #define fn_gnutls_certificate_set_x509_trust_file gnutls_certificate_set_x509_trust_file
223 #define fn_gnutls_certificate_type_get gnutls_certificate_type_get
224 #define fn_gnutls_certificate_verify_peers2 gnutls_certificate_verify_peers2
225 #define fn_gnutls_credentials_set gnutls_credentials_set
226 #define fn_gnutls_deinit gnutls_deinit
227 #define fn_gnutls_dh_set_prime_bits gnutls_dh_set_prime_bits
228 #define fn_gnutls_error_is_fatal gnutls_error_is_fatal
229 #define fn_gnutls_global_init gnutls_global_init
230 #define fn_gnutls_global_set_log_function gnutls_global_set_log_function
231 #define fn_gnutls_global_set_log_level gnutls_global_set_log_level
232 #define fn_gnutls_global_set_mem_functions gnutls_global_set_mem_functions
233 #define fn_gnutls_handshake gnutls_handshake
234 #define fn_gnutls_init gnutls_init
235 #define fn_gnutls_priority_set_direct gnutls_priority_set_direct
236 #define fn_gnutls_record_check_pending gnutls_record_check_pending
237 #define fn_gnutls_record_recv gnutls_record_recv
238 #define fn_gnutls_record_send gnutls_record_send
239 #define fn_gnutls_strerror gnutls_strerror
240 #define fn_gnutls_transport_set_errno gnutls_transport_set_errno
241 #define fn_gnutls_transport_set_ptr2 gnutls_transport_set_ptr2
242 #define fn_gnutls_x509_crt_check_hostname gnutls_x509_crt_check_hostname
243 #define fn_gnutls_x509_crt_deinit gnutls_x509_crt_deinit
244 #define fn_gnutls_x509_crt_import gnutls_x509_crt_import
245 #define fn_gnutls_x509_crt_init gnutls_x509_crt_init
247 #endif /* !WINDOWSNT */
250 /* Function to log a simple message. */
251 static void
252 gnutls_log_function (int level, const char* string)
254 message ("gnutls.c: [%d] %s", level, string);
257 /* Function to log a message and a string. */
258 static void
259 gnutls_log_function2 (int level, const char* string, const char* extra)
261 message ("gnutls.c: [%d] %s %s", level, string, extra);
264 /* Function to log a message and an integer. */
265 static void
266 gnutls_log_function2i (int level, const char* string, int extra)
268 message ("gnutls.c: [%d] %s %d", level, string, extra);
271 static int
272 emacs_gnutls_handshake (struct Lisp_Process *proc)
274 gnutls_session_t state = proc->gnutls_state;
275 int ret;
277 if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
278 return -1;
280 if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
282 #ifdef WINDOWSNT
283 /* On W32 we cannot transfer socket handles between different runtime
284 libraries, so we tell GnuTLS to use our special push/pull
285 functions. */
286 fn_gnutls_transport_set_ptr2 (state,
287 (gnutls_transport_ptr_t) proc,
288 (gnutls_transport_ptr_t) proc);
289 fn_gnutls_transport_set_push_function (state, &emacs_gnutls_push);
290 fn_gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
292 /* For non blocking sockets or other custom made pull/push
293 functions the gnutls_transport_set_lowat must be called, with
294 a zero low water mark value. (GnuTLS 2.10.4 documentation)
296 (Note: this is probably not strictly necessary as the lowat
297 value is only used when no custom pull/push functions are
298 set.) */
299 /* According to GnuTLS NEWS file, lowat level has been set to
300 zero by default in version 2.11.1, and the function
301 gnutls_transport_set_lowat was removed from the library in
302 version 2.99.0. */
303 if (!fn_gnutls_check_version ("2.11.1"))
304 fn_gnutls_transport_set_lowat (state, 0);
305 #else
306 /* This is how GnuTLS takes sockets: as file descriptors passed
307 in. For an Emacs process socket, infd and outfd are the
308 same but we use this two-argument version for clarity. */
309 fn_gnutls_transport_set_ptr2 (state,
310 (gnutls_transport_ptr_t) (long) proc->infd,
311 (gnutls_transport_ptr_t) (long) proc->outfd);
312 #endif
314 proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
319 ret = fn_gnutls_handshake (state);
320 emacs_gnutls_handle_error (state, ret);
322 while (ret < 0 && fn_gnutls_error_is_fatal (ret) == 0);
324 proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
326 if (ret == GNUTLS_E_SUCCESS)
328 /* Here we're finally done. */
329 proc->gnutls_initstage = GNUTLS_STAGE_READY;
331 else
333 fn_gnutls_alert_send_appropriate (state, ret);
335 return ret;
339 emacs_gnutls_record_check_pending (gnutls_session_t state)
341 return fn_gnutls_record_check_pending (state);
344 void
345 emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
347 fn_gnutls_transport_set_errno (state, err);
350 EMACS_INT
351 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, EMACS_INT nbyte)
353 ssize_t rtnval = 0;
354 EMACS_INT bytes_written;
355 gnutls_session_t state = proc->gnutls_state;
357 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
359 #ifdef EWOULDBLOCK
360 errno = EWOULDBLOCK;
361 #endif
362 #ifdef EAGAIN
363 errno = EAGAIN;
364 #endif
365 return 0;
368 bytes_written = 0;
370 while (nbyte > 0)
372 rtnval = fn_gnutls_record_send (state, buf, nbyte);
374 if (rtnval < 0)
376 if (rtnval == GNUTLS_E_INTERRUPTED)
377 continue;
378 else
380 /* If we get GNUTLS_E_AGAIN, then set errno
381 appropriately so that send_process retries the
382 correct way instead of erroring out. */
383 if (rtnval == GNUTLS_E_AGAIN)
385 #ifdef EWOULDBLOCK
386 errno = EWOULDBLOCK;
387 #endif
388 #ifdef EAGAIN
389 errno = EAGAIN;
390 #endif
392 break;
396 buf += rtnval;
397 nbyte -= rtnval;
398 bytes_written += rtnval;
401 emacs_gnutls_handle_error (state, rtnval);
402 return (bytes_written);
405 EMACS_INT
406 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, EMACS_INT nbyte)
408 ssize_t rtnval;
409 gnutls_session_t state = proc->gnutls_state;
411 int log_level = proc->gnutls_log_level;
413 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
415 /* If the handshake count is under the limit, try the handshake
416 again and increment the handshake count. This count is kept
417 per process (connection), not globally. */
418 if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT)
420 proc->gnutls_handshakes_tried++;
421 emacs_gnutls_handshake (proc);
422 GNUTLS_LOG2i (5, log_level, "Retried handshake",
423 proc->gnutls_handshakes_tried);
424 return -1;
427 GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
428 proc->gnutls_handshakes_tried = 0;
429 return 0;
431 rtnval = fn_gnutls_record_recv (state, buf, nbyte);
432 if (rtnval >= 0)
433 return rtnval;
434 else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
435 /* The peer closed the connection. */
436 return 0;
437 else if (emacs_gnutls_handle_error (state, rtnval) == 0)
438 /* non-fatal error */
439 return -1;
440 else {
441 /* a fatal error occurred */
442 return 0;
446 /* report a GnuTLS error to the user.
447 Returns zero if the error code was successfully handled. */
448 static int
449 emacs_gnutls_handle_error (gnutls_session_t session, int err)
451 int max_log_level = 0;
453 int ret;
454 const char *str;
456 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
457 if (err >= 0)
458 return 0;
460 max_log_level = global_gnutls_log_level;
462 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
464 str = fn_gnutls_strerror (err);
465 if (!str)
466 str = "unknown";
468 if (fn_gnutls_error_is_fatal (err))
470 ret = err;
471 GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
473 else
475 ret = 0;
476 GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str);
477 /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2. */
480 if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
481 || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
483 int alert = fn_gnutls_alert_get (session);
484 int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
485 str = fn_gnutls_alert_get_name (alert);
486 if (!str)
487 str = "unknown";
489 GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
491 return ret;
494 /* convert an integer error to a Lisp_Object; it will be either a
495 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
496 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
497 to Qt. */
498 static Lisp_Object
499 gnutls_make_error (int err)
501 switch (err)
503 case GNUTLS_E_SUCCESS:
504 return Qt;
505 case GNUTLS_E_AGAIN:
506 return Qgnutls_e_again;
507 case GNUTLS_E_INTERRUPTED:
508 return Qgnutls_e_interrupted;
509 case GNUTLS_E_INVALID_SESSION:
510 return Qgnutls_e_invalid_session;
513 return make_number (err);
516 Lisp_Object
517 emacs_gnutls_deinit (Lisp_Object proc)
519 int log_level;
521 CHECK_PROCESS (proc);
523 if (XPROCESS (proc)->gnutls_p == 0)
524 return Qnil;
526 log_level = XPROCESS (proc)->gnutls_log_level;
528 if (XPROCESS (proc)->gnutls_x509_cred)
530 GNUTLS_LOG (2, log_level, "Deallocating x509 credentials");
531 fn_gnutls_certificate_free_credentials (XPROCESS (proc)->gnutls_x509_cred);
532 XPROCESS (proc)->gnutls_x509_cred = NULL;
535 if (XPROCESS (proc)->gnutls_anon_cred)
537 GNUTLS_LOG (2, log_level, "Deallocating anon credentials");
538 fn_gnutls_anon_free_client_credentials (XPROCESS (proc)->gnutls_anon_cred);
539 XPROCESS (proc)->gnutls_anon_cred = NULL;
542 if (XPROCESS (proc)->gnutls_state)
544 fn_gnutls_deinit (XPROCESS (proc)->gnutls_state);
545 XPROCESS (proc)->gnutls_state = NULL;
546 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
547 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
550 XPROCESS (proc)->gnutls_p = 0;
551 return Qt;
554 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
555 doc: /* Return the GnuTLS init stage of process PROC.
556 See also `gnutls-boot'. */)
557 (Lisp_Object proc)
559 CHECK_PROCESS (proc);
561 return make_number (GNUTLS_INITSTAGE (proc));
564 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
565 doc: /* Return t if ERROR indicates a GnuTLS problem.
566 ERROR is an integer or a symbol with an integer `gnutls-code' property.
567 usage: (gnutls-errorp ERROR) */)
568 (Lisp_Object err)
570 if (EQ (err, Qt)) return Qnil;
572 return Qt;
575 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
576 doc: /* Check if ERROR is fatal.
577 ERROR is an integer or a symbol with an integer `gnutls-code' property.
578 usage: (gnutls-error-fatalp ERROR) */)
579 (Lisp_Object err)
581 Lisp_Object code;
583 if (EQ (err, Qt)) return Qnil;
585 if (SYMBOLP (err))
587 code = Fget (err, Qgnutls_code);
588 if (NUMBERP (code))
590 err = code;
592 else
594 error ("Symbol has no numeric gnutls-code property");
598 if (!NUMBERP (err))
599 error ("Not an error symbol or code");
601 if (0 == fn_gnutls_error_is_fatal (XINT (err)))
602 return Qnil;
604 return Qt;
607 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
608 doc: /* Return a description of ERROR.
609 ERROR is an integer or a symbol with an integer `gnutls-code' property.
610 usage: (gnutls-error-string ERROR) */)
611 (Lisp_Object err)
613 Lisp_Object code;
615 if (EQ (err, Qt)) return build_string ("Not an error");
617 if (SYMBOLP (err))
619 code = Fget (err, Qgnutls_code);
620 if (NUMBERP (code))
622 err = code;
624 else
626 return build_string ("Symbol has no numeric gnutls-code property");
630 if (!NUMBERP (err))
631 return build_string ("Not an error symbol or code");
633 return build_string (fn_gnutls_strerror (XINT (err)));
636 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
637 doc: /* Deallocate GnuTLS resources associated with process PROC.
638 See also `gnutls-init'. */)
639 (Lisp_Object proc)
641 return emacs_gnutls_deinit (proc);
644 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
645 doc: /* Return t if GnuTLS is available in this instance of Emacs. */)
646 (void)
648 #ifdef WINDOWSNT
649 Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
650 if (CONSP (found))
651 return XCDR (found);
652 else
654 Lisp_Object status;
655 status = init_gnutls_functions (Vdynamic_library_alist) ? Qt : Qnil;
656 Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
657 return status;
659 #else
660 return Qt;
661 #endif
665 /* Initializes global GnuTLS state to defaults.
666 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
667 Returns zero on success. */
668 static Lisp_Object
669 emacs_gnutls_global_init (void)
671 int ret = GNUTLS_E_SUCCESS;
673 if (!gnutls_global_initialized)
675 fn_gnutls_global_set_mem_functions (xmalloc, xmalloc, NULL,
676 xrealloc, xfree);
677 ret = fn_gnutls_global_init ();
679 gnutls_global_initialized = 1;
681 return gnutls_make_error (ret);
684 #if 0
685 /* Deinitializes global GnuTLS state.
686 See also `gnutls-global-init'. */
687 static Lisp_Object
688 emacs_gnutls_global_deinit (void)
690 if (gnutls_global_initialized)
691 gnutls_global_deinit ();
693 gnutls_global_initialized = 0;
695 return gnutls_make_error (GNUTLS_E_SUCCESS);
697 #endif
699 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
700 doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
701 Currently only client mode is supported. Return a success/failure
702 value you can check with `gnutls-errorp'.
704 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
705 PROPLIST is a property list with the following keys:
707 :hostname is a string naming the remote host.
709 :priority is a GnuTLS priority string, defaults to "NORMAL".
711 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
713 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
715 :keylist is an alist of PEM-encoded key files and PEM-encoded
716 certificates for `gnutls-x509pki'.
718 :callbacks is an alist of callback functions, see below.
720 :loglevel is the debug level requested from GnuTLS, try 4.
722 :verify-flags is a bitset as per GnuTLS'
723 gnutls_certificate_set_verify_flags.
725 :verify-hostname-error, if non-nil, makes a hostname mismatch an
726 error. Otherwise it will be just a warning.
728 :min-prime-bits is the minimum accepted number of bits the client will
729 accept in Diffie-Hellman key exchange.
731 The debug level will be set for this process AND globally for GnuTLS.
732 So if you set it higher or lower at any point, it affects global
733 debugging.
735 Note that the priority is set on the client. The server does not use
736 the protocols's priority except for disabling protocols that were not
737 specified.
739 Processes must be initialized with this function before other GnuTLS
740 functions are used. This function allocates resources which can only
741 be deallocated by calling `gnutls-deinit' or by calling it again.
743 The callbacks alist can have a `verify' key, associated with a
744 verification function (UNUSED).
746 Each authentication type may need additional information in order to
747 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
748 one trustfile (usually a CA bundle). */)
749 (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
751 int ret = GNUTLS_E_SUCCESS;
752 int max_log_level = 0;
754 gnutls_session_t state;
755 gnutls_certificate_credentials_t x509_cred = NULL;
756 gnutls_anon_client_credentials_t anon_cred = NULL;
757 Lisp_Object global_init;
758 char const *priority_string_ptr = "NORMAL"; /* default priority string. */
759 unsigned int peer_verification;
760 char* c_hostname;
762 /* Placeholders for the property list elements. */
763 Lisp_Object priority_string;
764 Lisp_Object trustfiles;
765 Lisp_Object crlfiles;
766 Lisp_Object keylist;
767 /* Lisp_Object callbacks; */
768 Lisp_Object loglevel;
769 Lisp_Object hostname;
770 /* Lisp_Object verify_error; */
771 Lisp_Object verify_hostname_error;
772 Lisp_Object prime_bits;
774 CHECK_PROCESS (proc);
775 CHECK_SYMBOL (type);
776 CHECK_LIST (proplist);
778 if (NILP (Fgnutls_available_p ()))
780 error ("GnuTLS not available");
781 return gnutls_make_error (GNUTLS_EMACS_ERROR_NOT_LOADED);
784 if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
786 error ("Invalid GnuTLS credential type");
787 return gnutls_make_error (GNUTLS_EMACS_ERROR_INVALID_TYPE);
790 hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
791 priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority);
792 trustfiles = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
793 keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist);
794 crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
795 loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
796 verify_hostname_error = Fplist_get (proplist, QCgnutls_bootprop_verify_hostname_error);
797 prime_bits = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
799 if (!STRINGP (hostname))
800 error ("gnutls-boot: invalid :hostname parameter");
801 c_hostname = SSDATA (hostname);
803 if (NUMBERP (loglevel))
805 fn_gnutls_global_set_log_function (gnutls_log_function);
806 fn_gnutls_global_set_log_level (XINT (loglevel));
807 max_log_level = XINT (loglevel);
808 XPROCESS (proc)->gnutls_log_level = max_log_level;
811 /* always initialize globals. */
812 global_init = emacs_gnutls_global_init ();
813 if (! NILP (Fgnutls_errorp (global_init)))
814 return global_init;
816 /* Before allocating new credentials, deallocate any credentials
817 that PROC might already have. */
818 emacs_gnutls_deinit (proc);
820 /* Mark PROC as a GnuTLS process. */
821 XPROCESS (proc)->gnutls_p = 1;
822 XPROCESS (proc)->gnutls_state = NULL;
823 XPROCESS (proc)->gnutls_x509_cred = NULL;
824 XPROCESS (proc)->gnutls_anon_cred = NULL;
825 XPROCESS (proc)->gnutls_cred_type = type;
826 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
828 GNUTLS_LOG (1, max_log_level, "allocating credentials");
829 if (EQ (type, Qgnutls_x509pki))
831 Lisp_Object verify_flags;
832 unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
834 GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
835 fn_gnutls_certificate_allocate_credentials (&x509_cred);
836 XPROCESS (proc)->gnutls_x509_cred = x509_cred;
838 verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
839 if (NUMBERP (verify_flags))
841 gnutls_verify_flags = XINT (verify_flags);
842 GNUTLS_LOG (2, max_log_level, "setting verification flags");
844 else if (NILP (verify_flags))
845 GNUTLS_LOG (2, max_log_level, "using default verification flags");
846 else
847 GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
849 fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
851 else /* Qgnutls_anon: */
853 GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
854 fn_gnutls_anon_allocate_client_credentials (&anon_cred);
855 XPROCESS (proc)->gnutls_anon_cred = anon_cred;
858 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
860 if (EQ (type, Qgnutls_x509pki))
862 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
863 int file_format = GNUTLS_X509_FMT_PEM;
864 Lisp_Object tail;
866 for (tail = trustfiles; !NILP (tail); tail = Fcdr (tail))
868 Lisp_Object trustfile = Fcar (tail);
869 if (STRINGP (trustfile))
871 GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
872 SSDATA (trustfile));
873 ret = fn_gnutls_certificate_set_x509_trust_file
874 (x509_cred,
875 SSDATA (trustfile),
876 file_format);
878 if (ret < GNUTLS_E_SUCCESS)
879 return gnutls_make_error (ret);
881 else
883 emacs_gnutls_deinit (proc);
884 error ("Invalid trustfile");
888 for (tail = crlfiles; !NILP (tail); tail = Fcdr (tail))
890 Lisp_Object crlfile = Fcar (tail);
891 if (STRINGP (crlfile))
893 GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
894 SSDATA (crlfile));
895 ret = fn_gnutls_certificate_set_x509_crl_file
896 (x509_cred, SSDATA (crlfile), file_format);
898 if (ret < GNUTLS_E_SUCCESS)
899 return gnutls_make_error (ret);
901 else
903 emacs_gnutls_deinit (proc);
904 error ("Invalid CRL file");
908 for (tail = keylist; !NILP (tail); tail = Fcdr (tail))
910 Lisp_Object keyfile = Fcar (Fcar (tail));
911 Lisp_Object certfile = Fcar (Fcdr (tail));
912 if (STRINGP (keyfile) && STRINGP (certfile))
914 GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
915 SSDATA (keyfile));
916 GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
917 SSDATA (certfile));
918 ret = fn_gnutls_certificate_set_x509_key_file
919 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
921 if (ret < GNUTLS_E_SUCCESS)
922 return gnutls_make_error (ret);
924 else
926 emacs_gnutls_deinit (proc);
927 error (STRINGP (keyfile) ? "Invalid client cert file"
928 : "Invalid client key file");
933 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
934 GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
935 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
937 /* Call gnutls_init here: */
939 GNUTLS_LOG (1, max_log_level, "gnutls_init");
940 ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
941 XPROCESS (proc)->gnutls_state = state;
942 if (ret < GNUTLS_E_SUCCESS)
943 return gnutls_make_error (ret);
944 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
946 if (STRINGP (priority_string))
948 priority_string_ptr = SSDATA (priority_string);
949 GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
950 priority_string_ptr);
952 else
954 GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
955 priority_string_ptr);
958 GNUTLS_LOG (1, max_log_level, "setting the priority string");
959 ret = fn_gnutls_priority_set_direct (state,
960 priority_string_ptr,
961 NULL);
962 if (ret < GNUTLS_E_SUCCESS)
963 return gnutls_make_error (ret);
965 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
967 if (INTEGERP (prime_bits))
968 fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
970 ret = EQ (type, Qgnutls_x509pki)
971 ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
972 : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
973 if (ret < GNUTLS_E_SUCCESS)
974 return gnutls_make_error (ret);
976 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
977 ret = emacs_gnutls_handshake (XPROCESS (proc));
978 if (ret < GNUTLS_E_SUCCESS)
979 return gnutls_make_error (ret);
981 /* Now verify the peer, following
982 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
983 The peer should present at least one certificate in the chain; do a
984 check of the certificate's hostname with
985 gnutls_x509_crt_check_hostname() against :hostname. */
987 ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
988 if (ret < GNUTLS_E_SUCCESS)
989 return gnutls_make_error (ret);
991 if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
992 message ("%s certificate could not be verified.", c_hostname);
994 if (peer_verification & GNUTLS_CERT_REVOKED)
995 GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
996 c_hostname);
998 if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
999 GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
1000 c_hostname);
1002 if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
1003 GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
1004 c_hostname);
1006 if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1007 GNUTLS_LOG2 (1, max_log_level,
1008 "certificate was signed with an insecure algorithm:",
1009 c_hostname);
1011 if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
1012 GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
1013 c_hostname);
1015 if (peer_verification & GNUTLS_CERT_EXPIRED)
1016 GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
1017 c_hostname);
1019 if (peer_verification != 0)
1021 if (NILP (verify_hostname_error))
1022 GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1023 c_hostname);
1024 else
1026 emacs_gnutls_deinit (proc);
1027 error ("Certificate validation failed %s, verification code %d",
1028 c_hostname, peer_verification);
1032 /* Up to here the process is the same for X.509 certificates and
1033 OpenPGP keys. From now on X.509 certificates are assumed. This
1034 can be easily extended to work with openpgp keys as well. */
1035 if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1037 gnutls_x509_crt_t gnutls_verify_cert;
1038 const gnutls_datum_t *gnutls_verify_cert_list;
1039 unsigned int gnutls_verify_cert_list_size;
1041 ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
1042 if (ret < GNUTLS_E_SUCCESS)
1043 return gnutls_make_error (ret);
1045 gnutls_verify_cert_list =
1046 fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1048 if (gnutls_verify_cert_list == NULL)
1050 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1051 emacs_gnutls_deinit (proc);
1052 error ("No x509 certificate was found\n");
1055 /* We only check the first certificate in the given chain. */
1056 ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1057 &gnutls_verify_cert_list[0],
1058 GNUTLS_X509_FMT_DER);
1060 if (ret < GNUTLS_E_SUCCESS)
1062 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1063 return gnutls_make_error (ret);
1066 if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1068 if (NILP (verify_hostname_error))
1069 GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1070 c_hostname);
1071 else
1073 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1074 emacs_gnutls_deinit (proc);
1075 error ("The x509 certificate does not match \"%s\"", c_hostname);
1078 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1081 return gnutls_make_error (ret);
1084 DEFUN ("gnutls-bye", Fgnutls_bye,
1085 Sgnutls_bye, 2, 2, 0,
1086 doc: /* Terminate current GnuTLS connection for process PROC.
1087 The connection should have been initiated using `gnutls-handshake'.
1089 If CONT is not nil the TLS connection gets terminated and further
1090 receives and sends will be disallowed. If the return value is zero you
1091 may continue using the connection. If CONT is nil, GnuTLS actually
1092 sends an alert containing a close request and waits for the peer to
1093 reply with the same message. In order to reuse the connection you
1094 should wait for an EOF from the peer.
1096 This function may also return `gnutls-e-again', or
1097 `gnutls-e-interrupted'. */)
1098 (Lisp_Object proc, Lisp_Object cont)
1100 gnutls_session_t state;
1101 int ret;
1103 CHECK_PROCESS (proc);
1105 state = XPROCESS (proc)->gnutls_state;
1107 ret = fn_gnutls_bye (state,
1108 NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1110 return gnutls_make_error (ret);
1113 void
1114 syms_of_gnutls (void)
1116 gnutls_global_initialized = 0;
1118 DEFSYM (Qgnutls_dll, "gnutls");
1119 DEFSYM (Qgnutls_code, "gnutls-code");
1120 DEFSYM (Qgnutls_anon, "gnutls-anon");
1121 DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1122 DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1123 DEFSYM (QCgnutls_bootprop_priority, ":priority");
1124 DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1125 DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1126 DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1127 DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1128 DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1129 DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1130 DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1131 DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1132 DEFSYM (QCgnutls_bootprop_verify_hostname_error, ":verify-hostname-error");
1134 DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1135 Fput (Qgnutls_e_interrupted, Qgnutls_code,
1136 make_number (GNUTLS_E_INTERRUPTED));
1138 DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1139 Fput (Qgnutls_e_again, Qgnutls_code,
1140 make_number (GNUTLS_E_AGAIN));
1142 DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1143 Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1144 make_number (GNUTLS_E_INVALID_SESSION));
1146 DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1147 Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1148 make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1150 defsubr (&Sgnutls_get_initstage);
1151 defsubr (&Sgnutls_errorp);
1152 defsubr (&Sgnutls_error_fatalp);
1153 defsubr (&Sgnutls_error_string);
1154 defsubr (&Sgnutls_boot);
1155 defsubr (&Sgnutls_deinit);
1156 defsubr (&Sgnutls_bye);
1157 defsubr (&Sgnutls_available_p);
1159 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1160 doc: /* Logging level used by the GnuTLS functions.
1161 Set this larger than 0 to get debug output in the *Messages* buffer.
1162 1 is for important messages, 2 is for debug data, and higher numbers
1163 are as per the GnuTLS logging conventions. */);
1164 global_gnutls_log_level = 0;
1167 #endif /* HAVE_GNUTLS */