Fix drawing of relief rects on X and W32.
[emacs.git] / src / gnutls.c
blob03f753fa8ccfbb3e5bcca73754fe3b9f419f1f17
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>
22 #include "lisp.h"
23 #include "process.h"
25 #ifdef HAVE_GNUTLS
26 #include <gnutls/gnutls.h>
28 #ifdef WINDOWSNT
29 #include <windows.h>
30 #include "w32.h"
31 #endif
33 static bool emacs_gnutls_handle_error (gnutls_session_t, int);
35 static Lisp_Object Qgnutls_dll;
36 static Lisp_Object Qgnutls_code;
37 static Lisp_Object Qgnutls_anon, Qgnutls_x509pki;
38 static Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again,
39 Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake;
40 static bool gnutls_global_initialized;
42 /* The following are for the property list of `gnutls-boot'. */
43 static Lisp_Object QCgnutls_bootprop_priority;
44 static Lisp_Object QCgnutls_bootprop_trustfiles;
45 static Lisp_Object QCgnutls_bootprop_keylist;
46 static Lisp_Object QCgnutls_bootprop_crlfiles;
47 static Lisp_Object QCgnutls_bootprop_callbacks;
48 static Lisp_Object QCgnutls_bootprop_loglevel;
49 static Lisp_Object QCgnutls_bootprop_hostname;
50 static Lisp_Object QCgnutls_bootprop_min_prime_bits;
51 static Lisp_Object QCgnutls_bootprop_verify_flags;
52 static Lisp_Object QCgnutls_bootprop_verify_hostname_error;
54 /* Callback keys for `gnutls-boot'. Unused currently. */
55 static Lisp_Object QCgnutls_bootprop_callbacks_verify;
57 static void gnutls_log_function (int, const char *);
58 static void gnutls_log_function2 (int, const char*, const char*);
61 #ifdef WINDOWSNT
63 /* Macro for defining functions that will be loaded from the GnuTLS DLL. */
64 #define DEF_GNUTLS_FN(rettype,func,args) static rettype (FAR CDECL *fn_##func)args
66 /* Macro for loading GnuTLS functions from the library. */
67 #define LOAD_GNUTLS_FN(lib,func) { \
68 fn_##func = (void *) GetProcAddress (lib, #func); \
69 if (!fn_##func) return 0; \
72 DEF_GNUTLS_FN (gnutls_alert_description_t, gnutls_alert_get,
73 (gnutls_session_t));
74 DEF_GNUTLS_FN (const char *, gnutls_alert_get_name,
75 (gnutls_alert_description_t));
76 DEF_GNUTLS_FN (int, gnutls_alert_send_appropriate, (gnutls_session_t, int));
77 DEF_GNUTLS_FN (int, gnutls_anon_allocate_client_credentials,
78 (gnutls_anon_client_credentials_t *));
79 DEF_GNUTLS_FN (void, gnutls_anon_free_client_credentials,
80 (gnutls_anon_client_credentials_t));
81 DEF_GNUTLS_FN (int, gnutls_bye, (gnutls_session_t, gnutls_close_request_t));
82 DEF_GNUTLS_FN (int, gnutls_certificate_allocate_credentials,
83 (gnutls_certificate_credentials_t *));
84 DEF_GNUTLS_FN (void, gnutls_certificate_free_credentials,
85 (gnutls_certificate_credentials_t));
86 DEF_GNUTLS_FN (const gnutls_datum_t *, gnutls_certificate_get_peers,
87 (gnutls_session_t, unsigned int *));
88 DEF_GNUTLS_FN (void, gnutls_certificate_set_verify_flags,
89 (gnutls_certificate_credentials_t, unsigned int));
90 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_crl_file,
91 (gnutls_certificate_credentials_t, const char *,
92 gnutls_x509_crt_fmt_t));
93 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_key_file,
94 (gnutls_certificate_credentials_t, const char *, const char *,
95 gnutls_x509_crt_fmt_t));
96 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_trust_file,
97 (gnutls_certificate_credentials_t, const char *,
98 gnutls_x509_crt_fmt_t));
99 DEF_GNUTLS_FN (gnutls_certificate_type_t, gnutls_certificate_type_get,
100 (gnutls_session_t));
101 DEF_GNUTLS_FN (int, gnutls_certificate_verify_peers2,
102 (gnutls_session_t, unsigned int *));
103 DEF_GNUTLS_FN (int, gnutls_credentials_set,
104 (gnutls_session_t, gnutls_credentials_type_t, void *));
105 DEF_GNUTLS_FN (void, gnutls_deinit, (gnutls_session_t));
106 DEF_GNUTLS_FN (void, gnutls_dh_set_prime_bits,
107 (gnutls_session_t, unsigned int));
108 DEF_GNUTLS_FN (int, gnutls_error_is_fatal, (int));
109 DEF_GNUTLS_FN (int, gnutls_global_init, (void));
110 DEF_GNUTLS_FN (void, gnutls_global_set_log_function, (gnutls_log_func));
111 DEF_GNUTLS_FN (void, gnutls_global_set_log_level, (int));
112 DEF_GNUTLS_FN (void, gnutls_global_set_mem_functions,
113 (gnutls_alloc_function, gnutls_alloc_function,
114 gnutls_is_secure_function, gnutls_realloc_function,
115 gnutls_free_function));
116 DEF_GNUTLS_FN (int, gnutls_handshake, (gnutls_session_t));
117 DEF_GNUTLS_FN (int, gnutls_init, (gnutls_session_t *, gnutls_connection_end_t));
118 DEF_GNUTLS_FN (int, gnutls_priority_set_direct,
119 (gnutls_session_t, const char *, const char **));
120 DEF_GNUTLS_FN (size_t, gnutls_record_check_pending, (gnutls_session_t));
121 DEF_GNUTLS_FN (ssize_t, gnutls_record_recv, (gnutls_session_t, void *, size_t));
122 DEF_GNUTLS_FN (ssize_t, gnutls_record_send,
123 (gnutls_session_t, const void *, size_t));
124 DEF_GNUTLS_FN (const char *, gnutls_strerror, (int));
125 DEF_GNUTLS_FN (void, gnutls_transport_set_errno, (gnutls_session_t, int));
126 DEF_GNUTLS_FN (const char *, gnutls_check_version, (const char *));
127 DEF_GNUTLS_FN (void, gnutls_transport_set_lowat, (gnutls_session_t, int));
128 DEF_GNUTLS_FN (void, gnutls_transport_set_ptr2,
129 (gnutls_session_t, gnutls_transport_ptr_t,
130 gnutls_transport_ptr_t));
131 DEF_GNUTLS_FN (void, gnutls_transport_set_pull_function,
132 (gnutls_session_t, gnutls_pull_func));
133 DEF_GNUTLS_FN (void, gnutls_transport_set_push_function,
134 (gnutls_session_t, gnutls_push_func));
135 DEF_GNUTLS_FN (int, gnutls_x509_crt_check_hostname,
136 (gnutls_x509_crt_t, const char *));
137 DEF_GNUTLS_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t));
138 DEF_GNUTLS_FN (int, gnutls_x509_crt_import,
139 (gnutls_x509_crt_t, const gnutls_datum_t *,
140 gnutls_x509_crt_fmt_t));
141 DEF_GNUTLS_FN (int, gnutls_x509_crt_init, (gnutls_x509_crt_t *));
143 static bool
144 init_gnutls_functions (void)
146 HMODULE library;
147 int max_log_level = 1;
149 if (!(library = w32_delayed_load (Qgnutls_dll)))
151 GNUTLS_LOG (1, max_log_level, "GnuTLS library not found");
152 return 0;
155 LOAD_GNUTLS_FN (library, gnutls_alert_get);
156 LOAD_GNUTLS_FN (library, gnutls_alert_get_name);
157 LOAD_GNUTLS_FN (library, gnutls_alert_send_appropriate);
158 LOAD_GNUTLS_FN (library, gnutls_anon_allocate_client_credentials);
159 LOAD_GNUTLS_FN (library, gnutls_anon_free_client_credentials);
160 LOAD_GNUTLS_FN (library, gnutls_bye);
161 LOAD_GNUTLS_FN (library, gnutls_certificate_allocate_credentials);
162 LOAD_GNUTLS_FN (library, gnutls_certificate_free_credentials);
163 LOAD_GNUTLS_FN (library, gnutls_certificate_get_peers);
164 LOAD_GNUTLS_FN (library, gnutls_certificate_set_verify_flags);
165 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_crl_file);
166 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_key_file);
167 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_trust_file);
168 LOAD_GNUTLS_FN (library, gnutls_certificate_type_get);
169 LOAD_GNUTLS_FN (library, gnutls_certificate_verify_peers2);
170 LOAD_GNUTLS_FN (library, gnutls_credentials_set);
171 LOAD_GNUTLS_FN (library, gnutls_deinit);
172 LOAD_GNUTLS_FN (library, gnutls_dh_set_prime_bits);
173 LOAD_GNUTLS_FN (library, gnutls_error_is_fatal);
174 LOAD_GNUTLS_FN (library, gnutls_global_init);
175 LOAD_GNUTLS_FN (library, gnutls_global_set_log_function);
176 LOAD_GNUTLS_FN (library, gnutls_global_set_log_level);
177 LOAD_GNUTLS_FN (library, gnutls_global_set_mem_functions);
178 LOAD_GNUTLS_FN (library, gnutls_handshake);
179 LOAD_GNUTLS_FN (library, gnutls_init);
180 LOAD_GNUTLS_FN (library, gnutls_priority_set_direct);
181 LOAD_GNUTLS_FN (library, gnutls_record_check_pending);
182 LOAD_GNUTLS_FN (library, gnutls_record_recv);
183 LOAD_GNUTLS_FN (library, gnutls_record_send);
184 LOAD_GNUTLS_FN (library, gnutls_strerror);
185 LOAD_GNUTLS_FN (library, gnutls_transport_set_errno);
186 LOAD_GNUTLS_FN (library, gnutls_check_version);
187 /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
188 and later, and the function was removed entirely in 3.0.0. */
189 if (!fn_gnutls_check_version ("2.11.1"))
190 LOAD_GNUTLS_FN (library, gnutls_transport_set_lowat);
191 LOAD_GNUTLS_FN (library, gnutls_transport_set_ptr2);
192 LOAD_GNUTLS_FN (library, gnutls_transport_set_pull_function);
193 LOAD_GNUTLS_FN (library, gnutls_transport_set_push_function);
194 LOAD_GNUTLS_FN (library, gnutls_x509_crt_check_hostname);
195 LOAD_GNUTLS_FN (library, gnutls_x509_crt_deinit);
196 LOAD_GNUTLS_FN (library, gnutls_x509_crt_import);
197 LOAD_GNUTLS_FN (library, gnutls_x509_crt_init);
199 max_log_level = global_gnutls_log_level;
202 Lisp_Object name = CAR_SAFE (Fget (Qgnutls_dll, QCloaded_from));
203 GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:",
204 STRINGP (name) ? (const char *) SDATA (name) : "unknown");
207 return 1;
210 #else /* !WINDOWSNT */
212 #define fn_gnutls_alert_get gnutls_alert_get
213 #define fn_gnutls_alert_get_name gnutls_alert_get_name
214 #define fn_gnutls_alert_send_appropriate gnutls_alert_send_appropriate
215 #define fn_gnutls_anon_allocate_client_credentials gnutls_anon_allocate_client_credentials
216 #define fn_gnutls_anon_free_client_credentials gnutls_anon_free_client_credentials
217 #define fn_gnutls_bye gnutls_bye
218 #define fn_gnutls_certificate_allocate_credentials gnutls_certificate_allocate_credentials
219 #define fn_gnutls_certificate_free_credentials gnutls_certificate_free_credentials
220 #define fn_gnutls_certificate_get_peers gnutls_certificate_get_peers
221 #define fn_gnutls_certificate_set_verify_flags gnutls_certificate_set_verify_flags
222 #define fn_gnutls_certificate_set_x509_crl_file gnutls_certificate_set_x509_crl_file
223 #define fn_gnutls_certificate_set_x509_key_file gnutls_certificate_set_x509_key_file
224 #define fn_gnutls_certificate_set_x509_trust_file gnutls_certificate_set_x509_trust_file
225 #define fn_gnutls_certificate_type_get gnutls_certificate_type_get
226 #define fn_gnutls_certificate_verify_peers2 gnutls_certificate_verify_peers2
227 #define fn_gnutls_credentials_set gnutls_credentials_set
228 #define fn_gnutls_deinit gnutls_deinit
229 #define fn_gnutls_dh_set_prime_bits gnutls_dh_set_prime_bits
230 #define fn_gnutls_error_is_fatal gnutls_error_is_fatal
231 #define fn_gnutls_global_init gnutls_global_init
232 #define fn_gnutls_global_set_log_function gnutls_global_set_log_function
233 #define fn_gnutls_global_set_log_level gnutls_global_set_log_level
234 #define fn_gnutls_global_set_mem_functions gnutls_global_set_mem_functions
235 #define fn_gnutls_handshake gnutls_handshake
236 #define fn_gnutls_init gnutls_init
237 #define fn_gnutls_priority_set_direct gnutls_priority_set_direct
238 #define fn_gnutls_record_check_pending gnutls_record_check_pending
239 #define fn_gnutls_record_recv gnutls_record_recv
240 #define fn_gnutls_record_send gnutls_record_send
241 #define fn_gnutls_strerror gnutls_strerror
242 #define fn_gnutls_transport_set_errno gnutls_transport_set_errno
243 #define fn_gnutls_transport_set_ptr2 gnutls_transport_set_ptr2
244 #define fn_gnutls_x509_crt_check_hostname gnutls_x509_crt_check_hostname
245 #define fn_gnutls_x509_crt_deinit gnutls_x509_crt_deinit
246 #define fn_gnutls_x509_crt_import gnutls_x509_crt_import
247 #define fn_gnutls_x509_crt_init gnutls_x509_crt_init
249 #endif /* !WINDOWSNT */
252 /* Function to log a simple message. */
253 static void
254 gnutls_log_function (int level, const char* string)
256 message ("gnutls.c: [%d] %s", level, string);
259 /* Function to log a message and a string. */
260 static void
261 gnutls_log_function2 (int level, const char* string, const char* extra)
263 message ("gnutls.c: [%d] %s %s", level, string, extra);
266 /* Function to log a message and an integer. */
267 static void
268 gnutls_log_function2i (int level, const char* string, int extra)
270 message ("gnutls.c: [%d] %s %d", level, string, extra);
273 static int
274 emacs_gnutls_handshake (struct Lisp_Process *proc)
276 gnutls_session_t state = proc->gnutls_state;
277 int ret;
279 if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
280 return -1;
282 if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
284 #ifdef WINDOWSNT
285 /* On W32 we cannot transfer socket handles between different runtime
286 libraries, so we tell GnuTLS to use our special push/pull
287 functions. */
288 fn_gnutls_transport_set_ptr2 (state,
289 (gnutls_transport_ptr_t) proc,
290 (gnutls_transport_ptr_t) proc);
291 fn_gnutls_transport_set_push_function (state, &emacs_gnutls_push);
292 fn_gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
294 /* For non blocking sockets or other custom made pull/push
295 functions the gnutls_transport_set_lowat must be called, with
296 a zero low water mark value. (GnuTLS 2.10.4 documentation)
298 (Note: this is probably not strictly necessary as the lowat
299 value is only used when no custom pull/push functions are
300 set.) */
301 /* According to GnuTLS NEWS file, lowat level has been set to
302 zero by default in version 2.11.1, and the function
303 gnutls_transport_set_lowat was removed from the library in
304 version 2.99.0. */
305 if (!fn_gnutls_check_version ("2.11.1"))
306 fn_gnutls_transport_set_lowat (state, 0);
307 #else
308 /* This is how GnuTLS takes sockets: as file descriptors passed
309 in. For an Emacs process socket, infd and outfd are the
310 same but we use this two-argument version for clarity. */
311 fn_gnutls_transport_set_ptr2 (state,
312 (gnutls_transport_ptr_t) (long) proc->infd,
313 (gnutls_transport_ptr_t) (long) proc->outfd);
314 #endif
316 proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
321 ret = fn_gnutls_handshake (state);
322 emacs_gnutls_handle_error (state, ret);
323 QUIT;
325 while (ret < 0 && fn_gnutls_error_is_fatal (ret) == 0);
327 proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
329 if (ret == GNUTLS_E_SUCCESS)
331 /* Here we're finally done. */
332 proc->gnutls_initstage = GNUTLS_STAGE_READY;
334 else
336 fn_gnutls_alert_send_appropriate (state, ret);
338 return ret;
342 emacs_gnutls_record_check_pending (gnutls_session_t state)
344 return fn_gnutls_record_check_pending (state);
347 void
348 emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
350 fn_gnutls_transport_set_errno (state, err);
353 ptrdiff_t
354 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
356 ssize_t rtnval = 0;
357 ptrdiff_t bytes_written;
358 gnutls_session_t state = proc->gnutls_state;
360 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
362 errno = EAGAIN;
363 return 0;
366 bytes_written = 0;
368 while (nbyte > 0)
370 rtnval = fn_gnutls_record_send (state, buf, nbyte);
372 if (rtnval < 0)
374 if (rtnval == GNUTLS_E_INTERRUPTED)
375 continue;
376 else
378 /* If we get GNUTLS_E_AGAIN, then set errno
379 appropriately so that send_process retries the
380 correct way instead of erroring out. */
381 if (rtnval == GNUTLS_E_AGAIN)
382 errno = EAGAIN;
383 break;
387 buf += rtnval;
388 nbyte -= rtnval;
389 bytes_written += rtnval;
392 emacs_gnutls_handle_error (state, rtnval);
393 return (bytes_written);
396 ptrdiff_t
397 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
399 ssize_t rtnval;
400 gnutls_session_t state = proc->gnutls_state;
402 int log_level = proc->gnutls_log_level;
404 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
406 /* If the handshake count is under the limit, try the handshake
407 again and increment the handshake count. This count is kept
408 per process (connection), not globally. */
409 if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT)
411 proc->gnutls_handshakes_tried++;
412 emacs_gnutls_handshake (proc);
413 GNUTLS_LOG2i (5, log_level, "Retried handshake",
414 proc->gnutls_handshakes_tried);
415 return -1;
418 GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
419 proc->gnutls_handshakes_tried = 0;
420 return 0;
422 rtnval = fn_gnutls_record_recv (state, buf, nbyte);
423 if (rtnval >= 0)
424 return rtnval;
425 else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
426 /* The peer closed the connection. */
427 return 0;
428 else if (emacs_gnutls_handle_error (state, rtnval))
429 /* non-fatal error */
430 return -1;
431 else {
432 /* a fatal error occurred */
433 return 0;
437 /* Report a GnuTLS error to the user.
438 Return true if the error code was successfully handled. */
439 static bool
440 emacs_gnutls_handle_error (gnutls_session_t session, int err)
442 int max_log_level = 0;
444 bool ret;
445 const char *str;
447 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
448 if (err >= 0)
449 return 1;
451 max_log_level = global_gnutls_log_level;
453 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
455 str = fn_gnutls_strerror (err);
456 if (!str)
457 str = "unknown";
459 if (fn_gnutls_error_is_fatal (err))
461 ret = 0;
462 GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
464 else
466 ret = 1;
467 GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str);
468 /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2. */
471 if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
472 || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
474 int alert = fn_gnutls_alert_get (session);
475 int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
476 str = fn_gnutls_alert_get_name (alert);
477 if (!str)
478 str = "unknown";
480 GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
482 return ret;
485 /* convert an integer error to a Lisp_Object; it will be either a
486 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
487 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
488 to Qt. */
489 static Lisp_Object
490 gnutls_make_error (int err)
492 switch (err)
494 case GNUTLS_E_SUCCESS:
495 return Qt;
496 case GNUTLS_E_AGAIN:
497 return Qgnutls_e_again;
498 case GNUTLS_E_INTERRUPTED:
499 return Qgnutls_e_interrupted;
500 case GNUTLS_E_INVALID_SESSION:
501 return Qgnutls_e_invalid_session;
504 return make_number (err);
507 Lisp_Object
508 emacs_gnutls_deinit (Lisp_Object proc)
510 int log_level;
512 CHECK_PROCESS (proc);
514 if (XPROCESS (proc)->gnutls_p == 0)
515 return Qnil;
517 log_level = XPROCESS (proc)->gnutls_log_level;
519 if (XPROCESS (proc)->gnutls_x509_cred)
521 GNUTLS_LOG (2, log_level, "Deallocating x509 credentials");
522 fn_gnutls_certificate_free_credentials (XPROCESS (proc)->gnutls_x509_cred);
523 XPROCESS (proc)->gnutls_x509_cred = NULL;
526 if (XPROCESS (proc)->gnutls_anon_cred)
528 GNUTLS_LOG (2, log_level, "Deallocating anon credentials");
529 fn_gnutls_anon_free_client_credentials (XPROCESS (proc)->gnutls_anon_cred);
530 XPROCESS (proc)->gnutls_anon_cred = NULL;
533 if (XPROCESS (proc)->gnutls_state)
535 fn_gnutls_deinit (XPROCESS (proc)->gnutls_state);
536 XPROCESS (proc)->gnutls_state = NULL;
537 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
538 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
541 XPROCESS (proc)->gnutls_p = 0;
542 return Qt;
545 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
546 doc: /* Return the GnuTLS init stage of process PROC.
547 See also `gnutls-boot'. */)
548 (Lisp_Object proc)
550 CHECK_PROCESS (proc);
552 return make_number (GNUTLS_INITSTAGE (proc));
555 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
556 doc: /* Return t if ERROR indicates a GnuTLS problem.
557 ERROR is an integer or a symbol with an integer `gnutls-code' property.
558 usage: (gnutls-errorp ERROR) */)
559 (Lisp_Object err)
561 if (EQ (err, Qt)) return Qnil;
563 return Qt;
566 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
567 doc: /* Check if ERROR is fatal.
568 ERROR is an integer or a symbol with an integer `gnutls-code' property.
569 usage: (gnutls-error-fatalp ERROR) */)
570 (Lisp_Object err)
572 Lisp_Object code;
574 if (EQ (err, Qt)) return Qnil;
576 if (SYMBOLP (err))
578 code = Fget (err, Qgnutls_code);
579 if (NUMBERP (code))
581 err = code;
583 else
585 error ("Symbol has no numeric gnutls-code property");
589 if (! TYPE_RANGED_INTEGERP (int, err))
590 error ("Not an error symbol or code");
592 if (0 == fn_gnutls_error_is_fatal (XINT (err)))
593 return Qnil;
595 return Qt;
598 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
599 doc: /* Return a description of ERROR.
600 ERROR is an integer or a symbol with an integer `gnutls-code' property.
601 usage: (gnutls-error-string ERROR) */)
602 (Lisp_Object err)
604 Lisp_Object code;
606 if (EQ (err, Qt)) return build_string ("Not an error");
608 if (SYMBOLP (err))
610 code = Fget (err, Qgnutls_code);
611 if (NUMBERP (code))
613 err = code;
615 else
617 return build_string ("Symbol has no numeric gnutls-code property");
621 if (! TYPE_RANGED_INTEGERP (int, err))
622 return build_string ("Not an error symbol or code");
624 return build_string (fn_gnutls_strerror (XINT (err)));
627 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
628 doc: /* Deallocate GnuTLS resources associated with process PROC.
629 See also `gnutls-init'. */)
630 (Lisp_Object proc)
632 return emacs_gnutls_deinit (proc);
635 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
636 doc: /* Return t if GnuTLS is available in this instance of Emacs. */)
637 (void)
639 #ifdef WINDOWSNT
640 Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
641 if (CONSP (found))
642 return XCDR (found);
643 else
645 Lisp_Object status;
646 status = init_gnutls_functions () ? Qt : Qnil;
647 Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
648 return status;
650 #else
651 return Qt;
652 #endif
656 /* Initializes global GnuTLS state to defaults.
657 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
658 Returns zero on success. */
659 static Lisp_Object
660 emacs_gnutls_global_init (void)
662 int ret = GNUTLS_E_SUCCESS;
664 if (!gnutls_global_initialized)
666 fn_gnutls_global_set_mem_functions (xmalloc, xmalloc, NULL,
667 xrealloc, xfree);
668 ret = fn_gnutls_global_init ();
670 gnutls_global_initialized = 1;
672 return gnutls_make_error (ret);
675 #if 0
676 /* Deinitializes global GnuTLS state.
677 See also `gnutls-global-init'. */
678 static Lisp_Object
679 emacs_gnutls_global_deinit (void)
681 if (gnutls_global_initialized)
682 gnutls_global_deinit ();
684 gnutls_global_initialized = 0;
686 return gnutls_make_error (GNUTLS_E_SUCCESS);
688 #endif
690 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
691 doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
692 Currently only client mode is supported. Return a success/failure
693 value you can check with `gnutls-errorp'.
695 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
696 PROPLIST is a property list with the following keys:
698 :hostname is a string naming the remote host.
700 :priority is a GnuTLS priority string, defaults to "NORMAL".
702 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
704 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
706 :keylist is an alist of PEM-encoded key files and PEM-encoded
707 certificates for `gnutls-x509pki'.
709 :callbacks is an alist of callback functions, see below.
711 :loglevel is the debug level requested from GnuTLS, try 4.
713 :verify-flags is a bitset as per GnuTLS'
714 gnutls_certificate_set_verify_flags.
716 :verify-hostname-error, if non-nil, makes a hostname mismatch an
717 error. Otherwise it will be just a warning.
719 :min-prime-bits is the minimum accepted number of bits the client will
720 accept in Diffie-Hellman key exchange.
722 The debug level will be set for this process AND globally for GnuTLS.
723 So if you set it higher or lower at any point, it affects global
724 debugging.
726 Note that the priority is set on the client. The server does not use
727 the protocols's priority except for disabling protocols that were not
728 specified.
730 Processes must be initialized with this function before other GnuTLS
731 functions are used. This function allocates resources which can only
732 be deallocated by calling `gnutls-deinit' or by calling it again.
734 The callbacks alist can have a `verify' key, associated with a
735 verification function (UNUSED).
737 Each authentication type may need additional information in order to
738 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
739 one trustfile (usually a CA bundle). */)
740 (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
742 int ret = GNUTLS_E_SUCCESS;
743 int max_log_level = 0;
745 gnutls_session_t state;
746 gnutls_certificate_credentials_t x509_cred = NULL;
747 gnutls_anon_client_credentials_t anon_cred = NULL;
748 Lisp_Object global_init;
749 char const *priority_string_ptr = "NORMAL"; /* default priority string. */
750 unsigned int peer_verification;
751 char* c_hostname;
753 /* Placeholders for the property list elements. */
754 Lisp_Object priority_string;
755 Lisp_Object trustfiles;
756 Lisp_Object crlfiles;
757 Lisp_Object keylist;
758 /* Lisp_Object callbacks; */
759 Lisp_Object loglevel;
760 Lisp_Object hostname;
761 /* Lisp_Object verify_error; */
762 Lisp_Object verify_hostname_error;
763 Lisp_Object prime_bits;
765 CHECK_PROCESS (proc);
766 CHECK_SYMBOL (type);
767 CHECK_LIST (proplist);
769 if (NILP (Fgnutls_available_p ()))
771 error ("GnuTLS not available");
772 return gnutls_make_error (GNUTLS_EMACS_ERROR_NOT_LOADED);
775 if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
777 error ("Invalid GnuTLS credential type");
778 return gnutls_make_error (GNUTLS_EMACS_ERROR_INVALID_TYPE);
781 hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
782 priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority);
783 trustfiles = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
784 keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist);
785 crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
786 loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
787 verify_hostname_error = Fplist_get (proplist, QCgnutls_bootprop_verify_hostname_error);
788 prime_bits = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
790 if (!STRINGP (hostname))
791 error ("gnutls-boot: invalid :hostname parameter");
792 c_hostname = SSDATA (hostname);
794 state = XPROCESS (proc)->gnutls_state;
795 XPROCESS (proc)->gnutls_p = 1;
797 if (TYPE_RANGED_INTEGERP (int, loglevel))
799 fn_gnutls_global_set_log_function (gnutls_log_function);
800 fn_gnutls_global_set_log_level (XINT (loglevel));
801 max_log_level = XINT (loglevel);
802 XPROCESS (proc)->gnutls_log_level = max_log_level;
805 /* always initialize globals. */
806 global_init = emacs_gnutls_global_init ();
807 if (! NILP (Fgnutls_errorp (global_init)))
808 return global_init;
810 /* Before allocating new credentials, deallocate any credentials
811 that PROC might already have. */
812 emacs_gnutls_deinit (proc);
814 /* Mark PROC as a GnuTLS process. */
815 XPROCESS (proc)->gnutls_p = 1;
816 XPROCESS (proc)->gnutls_state = NULL;
817 XPROCESS (proc)->gnutls_x509_cred = NULL;
818 XPROCESS (proc)->gnutls_anon_cred = NULL;
819 pset_gnutls_cred_type (XPROCESS (proc), type);
820 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
822 GNUTLS_LOG (1, max_log_level, "allocating credentials");
823 if (EQ (type, Qgnutls_x509pki))
825 Lisp_Object verify_flags;
826 unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
828 GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
829 fn_gnutls_certificate_allocate_credentials (&x509_cred);
830 XPROCESS (proc)->gnutls_x509_cred = x509_cred;
832 verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
833 if (NUMBERP (verify_flags))
835 gnutls_verify_flags = XINT (verify_flags);
836 GNUTLS_LOG (2, max_log_level, "setting verification flags");
838 else if (NILP (verify_flags))
839 GNUTLS_LOG (2, max_log_level, "using default verification flags");
840 else
841 GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
843 fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
845 else /* Qgnutls_anon: */
847 GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
848 fn_gnutls_anon_allocate_client_credentials (&anon_cred);
849 XPROCESS (proc)->gnutls_anon_cred = anon_cred;
852 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
854 if (EQ (type, Qgnutls_x509pki))
856 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
857 int file_format = GNUTLS_X509_FMT_PEM;
858 Lisp_Object tail;
860 for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
862 Lisp_Object trustfile = XCAR (tail);
863 if (STRINGP (trustfile))
865 GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
866 SSDATA (trustfile));
867 ret = fn_gnutls_certificate_set_x509_trust_file
868 (x509_cred,
869 SSDATA (trustfile),
870 file_format);
872 if (ret < GNUTLS_E_SUCCESS)
873 return gnutls_make_error (ret);
875 else
877 emacs_gnutls_deinit (proc);
878 error ("Invalid trustfile");
882 for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
884 Lisp_Object crlfile = XCAR (tail);
885 if (STRINGP (crlfile))
887 GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
888 SSDATA (crlfile));
889 ret = fn_gnutls_certificate_set_x509_crl_file
890 (x509_cred, SSDATA (crlfile), file_format);
892 if (ret < GNUTLS_E_SUCCESS)
893 return gnutls_make_error (ret);
895 else
897 emacs_gnutls_deinit (proc);
898 error ("Invalid CRL file");
902 for (tail = keylist; CONSP (tail); tail = XCDR (tail))
904 Lisp_Object keyfile = Fcar (XCAR (tail));
905 Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
906 if (STRINGP (keyfile) && STRINGP (certfile))
908 GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
909 SSDATA (keyfile));
910 GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
911 SSDATA (certfile));
912 ret = fn_gnutls_certificate_set_x509_key_file
913 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
915 if (ret < GNUTLS_E_SUCCESS)
916 return gnutls_make_error (ret);
918 else
920 emacs_gnutls_deinit (proc);
921 error (STRINGP (keyfile) ? "Invalid client cert file"
922 : "Invalid client key file");
927 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
928 GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
929 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
931 /* Call gnutls_init here: */
933 GNUTLS_LOG (1, max_log_level, "gnutls_init");
934 ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
935 XPROCESS (proc)->gnutls_state = state;
936 if (ret < GNUTLS_E_SUCCESS)
937 return gnutls_make_error (ret);
938 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
940 if (STRINGP (priority_string))
942 priority_string_ptr = SSDATA (priority_string);
943 GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
944 priority_string_ptr);
946 else
948 GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
949 priority_string_ptr);
952 GNUTLS_LOG (1, max_log_level, "setting the priority string");
953 ret = fn_gnutls_priority_set_direct (state,
954 priority_string_ptr,
955 NULL);
956 if (ret < GNUTLS_E_SUCCESS)
957 return gnutls_make_error (ret);
959 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
961 if (INTEGERP (prime_bits))
962 fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
964 ret = EQ (type, Qgnutls_x509pki)
965 ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
966 : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
967 if (ret < GNUTLS_E_SUCCESS)
968 return gnutls_make_error (ret);
970 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
971 ret = emacs_gnutls_handshake (XPROCESS (proc));
972 if (ret < GNUTLS_E_SUCCESS)
973 return gnutls_make_error (ret);
975 /* Now verify the peer, following
976 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
977 The peer should present at least one certificate in the chain; do a
978 check of the certificate's hostname with
979 gnutls_x509_crt_check_hostname() against :hostname. */
981 ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
982 if (ret < GNUTLS_E_SUCCESS)
983 return gnutls_make_error (ret);
985 if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
986 message ("%s certificate could not be verified.", c_hostname);
988 if (peer_verification & GNUTLS_CERT_REVOKED)
989 GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
990 c_hostname);
992 if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
993 GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
994 c_hostname);
996 if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
997 GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
998 c_hostname);
1000 if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1001 GNUTLS_LOG2 (1, max_log_level,
1002 "certificate was signed with an insecure algorithm:",
1003 c_hostname);
1005 if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
1006 GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
1007 c_hostname);
1009 if (peer_verification & GNUTLS_CERT_EXPIRED)
1010 GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
1011 c_hostname);
1013 if (peer_verification != 0)
1015 if (NILP (verify_hostname_error))
1016 GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1017 c_hostname);
1018 else
1020 emacs_gnutls_deinit (proc);
1021 error ("Certificate validation failed %s, verification code %d",
1022 c_hostname, peer_verification);
1026 /* Up to here the process is the same for X.509 certificates and
1027 OpenPGP keys. From now on X.509 certificates are assumed. This
1028 can be easily extended to work with openpgp keys as well. */
1029 if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1031 gnutls_x509_crt_t gnutls_verify_cert;
1032 const gnutls_datum_t *gnutls_verify_cert_list;
1033 unsigned int gnutls_verify_cert_list_size;
1035 ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
1036 if (ret < GNUTLS_E_SUCCESS)
1037 return gnutls_make_error (ret);
1039 gnutls_verify_cert_list =
1040 fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1042 if (gnutls_verify_cert_list == NULL)
1044 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1045 emacs_gnutls_deinit (proc);
1046 error ("No x509 certificate was found\n");
1049 /* We only check the first certificate in the given chain. */
1050 ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1051 &gnutls_verify_cert_list[0],
1052 GNUTLS_X509_FMT_DER);
1054 if (ret < GNUTLS_E_SUCCESS)
1056 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1057 return gnutls_make_error (ret);
1060 if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1062 if (NILP (verify_hostname_error))
1063 GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1064 c_hostname);
1065 else
1067 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1068 emacs_gnutls_deinit (proc);
1069 error ("The x509 certificate does not match \"%s\"", c_hostname);
1072 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1075 return gnutls_make_error (ret);
1078 DEFUN ("gnutls-bye", Fgnutls_bye,
1079 Sgnutls_bye, 2, 2, 0,
1080 doc: /* Terminate current GnuTLS connection for process PROC.
1081 The connection should have been initiated using `gnutls-handshake'.
1083 If CONT is not nil the TLS connection gets terminated and further
1084 receives and sends will be disallowed. If the return value is zero you
1085 may continue using the connection. If CONT is nil, GnuTLS actually
1086 sends an alert containing a close request and waits for the peer to
1087 reply with the same message. In order to reuse the connection you
1088 should wait for an EOF from the peer.
1090 This function may also return `gnutls-e-again', or
1091 `gnutls-e-interrupted'. */)
1092 (Lisp_Object proc, Lisp_Object cont)
1094 gnutls_session_t state;
1095 int ret;
1097 CHECK_PROCESS (proc);
1099 state = XPROCESS (proc)->gnutls_state;
1101 ret = fn_gnutls_bye (state,
1102 NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1104 return gnutls_make_error (ret);
1107 void
1108 syms_of_gnutls (void)
1110 gnutls_global_initialized = 0;
1112 DEFSYM (Qgnutls_dll, "gnutls");
1113 DEFSYM (Qgnutls_code, "gnutls-code");
1114 DEFSYM (Qgnutls_anon, "gnutls-anon");
1115 DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1116 DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1117 DEFSYM (QCgnutls_bootprop_priority, ":priority");
1118 DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1119 DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1120 DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1121 DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1122 DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1123 DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1124 DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1125 DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1126 DEFSYM (QCgnutls_bootprop_verify_hostname_error, ":verify-hostname-error");
1128 DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1129 Fput (Qgnutls_e_interrupted, Qgnutls_code,
1130 make_number (GNUTLS_E_INTERRUPTED));
1132 DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1133 Fput (Qgnutls_e_again, Qgnutls_code,
1134 make_number (GNUTLS_E_AGAIN));
1136 DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1137 Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1138 make_number (GNUTLS_E_INVALID_SESSION));
1140 DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1141 Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1142 make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1144 defsubr (&Sgnutls_get_initstage);
1145 defsubr (&Sgnutls_errorp);
1146 defsubr (&Sgnutls_error_fatalp);
1147 defsubr (&Sgnutls_error_string);
1148 defsubr (&Sgnutls_boot);
1149 defsubr (&Sgnutls_deinit);
1150 defsubr (&Sgnutls_bye);
1151 defsubr (&Sgnutls_available_p);
1153 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1154 doc: /* Logging level used by the GnuTLS functions.
1155 Set this larger than 0 to get debug output in the *Messages* buffer.
1156 1 is for important messages, 2 is for debug data, and higher numbers
1157 are as per the GnuTLS logging conventions. */);
1158 global_gnutls_log_level = 0;
1161 #endif /* HAVE_GNUTLS */