Fixes: debbugs:17865
[bpt/emacs.git] / src / gnutls.c
1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2014 Free Software Foundation, Inc.
3
4 This file is part of GNU Emacs.
5
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.
10
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.
15
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/>. */
18
19 #include <config.h>
20 #include <errno.h>
21
22 #include "lisp.h"
23 #include "process.h"
24 #include "coding.h"
25
26 #ifdef HAVE_GNUTLS
27 #include <gnutls/gnutls.h>
28
29 #ifdef WINDOWSNT
30 #include <windows.h>
31 #include "w32.h"
32 #endif
33
34 static bool emacs_gnutls_handle_error (gnutls_session_t, int);
35
36 static Lisp_Object Qgnutls_dll;
37 static Lisp_Object Qgnutls_code;
38 static Lisp_Object Qgnutls_anon, Qgnutls_x509pki;
39 static Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again,
40 Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake;
41 static bool gnutls_global_initialized;
42
43 /* The following are for the property list of `gnutls-boot'. */
44 static Lisp_Object QCgnutls_bootprop_priority;
45 static Lisp_Object QCgnutls_bootprop_trustfiles;
46 static Lisp_Object QCgnutls_bootprop_keylist;
47 static Lisp_Object QCgnutls_bootprop_crlfiles;
48 static Lisp_Object QCgnutls_bootprop_callbacks;
49 static Lisp_Object QCgnutls_bootprop_loglevel;
50 static Lisp_Object QCgnutls_bootprop_hostname;
51 static Lisp_Object QCgnutls_bootprop_min_prime_bits;
52 static Lisp_Object QCgnutls_bootprop_verify_flags;
53 static Lisp_Object QCgnutls_bootprop_verify_error;
54
55 /* Callback keys for `gnutls-boot'. Unused currently. */
56 static Lisp_Object QCgnutls_bootprop_callbacks_verify;
57
58 static void gnutls_log_function (int, const char *);
59 static void gnutls_log_function2 (int, const char*, const char*);
60 #ifdef HAVE_GNUTLS3
61 static void gnutls_audit_log_function (gnutls_session_t, const char *);
62 #endif
63
64 \f
65 #ifdef WINDOWSNT
66
67 /* Macro for defining functions that will be loaded from the GnuTLS DLL. */
68 #define DEF_GNUTLS_FN(rettype,func,args) static rettype (FAR CDECL *fn_##func)args
69
70 /* Macro for loading GnuTLS functions from the library. */
71 #define LOAD_GNUTLS_FN(lib,func) { \
72 fn_##func = (void *) GetProcAddress (lib, #func); \
73 if (!fn_##func) return 0; \
74 }
75
76 DEF_GNUTLS_FN (gnutls_alert_description_t, gnutls_alert_get,
77 (gnutls_session_t));
78 DEF_GNUTLS_FN (const char *, gnutls_alert_get_name,
79 (gnutls_alert_description_t));
80 DEF_GNUTLS_FN (int, gnutls_alert_send_appropriate, (gnutls_session_t, int));
81 DEF_GNUTLS_FN (int, gnutls_anon_allocate_client_credentials,
82 (gnutls_anon_client_credentials_t *));
83 DEF_GNUTLS_FN (void, gnutls_anon_free_client_credentials,
84 (gnutls_anon_client_credentials_t));
85 DEF_GNUTLS_FN (int, gnutls_bye, (gnutls_session_t, gnutls_close_request_t));
86 DEF_GNUTLS_FN (int, gnutls_certificate_allocate_credentials,
87 (gnutls_certificate_credentials_t *));
88 DEF_GNUTLS_FN (void, gnutls_certificate_free_credentials,
89 (gnutls_certificate_credentials_t));
90 DEF_GNUTLS_FN (const gnutls_datum_t *, gnutls_certificate_get_peers,
91 (gnutls_session_t, unsigned int *));
92 DEF_GNUTLS_FN (void, gnutls_certificate_set_verify_flags,
93 (gnutls_certificate_credentials_t, unsigned int));
94 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_crl_file,
95 (gnutls_certificate_credentials_t, const char *,
96 gnutls_x509_crt_fmt_t));
97 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_key_file,
98 (gnutls_certificate_credentials_t, const char *, const char *,
99 gnutls_x509_crt_fmt_t));
100 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_trust_file,
101 (gnutls_certificate_credentials_t, const char *,
102 gnutls_x509_crt_fmt_t));
103 DEF_GNUTLS_FN (gnutls_certificate_type_t, gnutls_certificate_type_get,
104 (gnutls_session_t));
105 DEF_GNUTLS_FN (int, gnutls_certificate_verify_peers2,
106 (gnutls_session_t, unsigned int *));
107 DEF_GNUTLS_FN (int, gnutls_credentials_set,
108 (gnutls_session_t, gnutls_credentials_type_t, void *));
109 DEF_GNUTLS_FN (void, gnutls_deinit, (gnutls_session_t));
110 DEF_GNUTLS_FN (void, gnutls_dh_set_prime_bits,
111 (gnutls_session_t, unsigned int));
112 DEF_GNUTLS_FN (int, gnutls_error_is_fatal, (int));
113 DEF_GNUTLS_FN (int, gnutls_global_init, (void));
114 DEF_GNUTLS_FN (void, gnutls_global_set_log_function, (gnutls_log_func));
115 #ifdef HAVE_GNUTLS3
116 DEF_GNUTLS_FN (void, gnutls_global_set_audit_log_function, (gnutls_audit_log_func));
117 #endif
118 DEF_GNUTLS_FN (void, gnutls_global_set_log_level, (int));
119 DEF_GNUTLS_FN (void, gnutls_global_set_mem_functions,
120 (gnutls_alloc_function, gnutls_alloc_function,
121 gnutls_is_secure_function, gnutls_realloc_function,
122 gnutls_free_function));
123 DEF_GNUTLS_FN (int, gnutls_handshake, (gnutls_session_t));
124 DEF_GNUTLS_FN (int, gnutls_init, (gnutls_session_t *, gnutls_connection_end_t));
125 DEF_GNUTLS_FN (int, gnutls_priority_set_direct,
126 (gnutls_session_t, const char *, const char **));
127 DEF_GNUTLS_FN (size_t, gnutls_record_check_pending, (gnutls_session_t));
128 DEF_GNUTLS_FN (ssize_t, gnutls_record_recv, (gnutls_session_t, void *, size_t));
129 DEF_GNUTLS_FN (ssize_t, gnutls_record_send,
130 (gnutls_session_t, const void *, size_t));
131 DEF_GNUTLS_FN (const char *, gnutls_strerror, (int));
132 DEF_GNUTLS_FN (void, gnutls_transport_set_errno, (gnutls_session_t, int));
133 DEF_GNUTLS_FN (const char *, gnutls_check_version, (const char *));
134 DEF_GNUTLS_FN (void, gnutls_transport_set_lowat, (gnutls_session_t, int));
135 DEF_GNUTLS_FN (void, gnutls_transport_set_ptr2,
136 (gnutls_session_t, gnutls_transport_ptr_t,
137 gnutls_transport_ptr_t));
138 DEF_GNUTLS_FN (void, gnutls_transport_set_pull_function,
139 (gnutls_session_t, gnutls_pull_func));
140 DEF_GNUTLS_FN (void, gnutls_transport_set_push_function,
141 (gnutls_session_t, gnutls_push_func));
142 DEF_GNUTLS_FN (int, gnutls_x509_crt_check_hostname,
143 (gnutls_x509_crt_t, const char *));
144 DEF_GNUTLS_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t));
145 DEF_GNUTLS_FN (int, gnutls_x509_crt_import,
146 (gnutls_x509_crt_t, const gnutls_datum_t *,
147 gnutls_x509_crt_fmt_t));
148 DEF_GNUTLS_FN (int, gnutls_x509_crt_init, (gnutls_x509_crt_t *));
149
150 static bool
151 init_gnutls_functions (void)
152 {
153 HMODULE library;
154 int max_log_level = 1;
155
156 if (!(library = w32_delayed_load (Qgnutls_dll)))
157 {
158 GNUTLS_LOG (1, max_log_level, "GnuTLS library not found");
159 return 0;
160 }
161
162 LOAD_GNUTLS_FN (library, gnutls_alert_get);
163 LOAD_GNUTLS_FN (library, gnutls_alert_get_name);
164 LOAD_GNUTLS_FN (library, gnutls_alert_send_appropriate);
165 LOAD_GNUTLS_FN (library, gnutls_anon_allocate_client_credentials);
166 LOAD_GNUTLS_FN (library, gnutls_anon_free_client_credentials);
167 LOAD_GNUTLS_FN (library, gnutls_bye);
168 LOAD_GNUTLS_FN (library, gnutls_certificate_allocate_credentials);
169 LOAD_GNUTLS_FN (library, gnutls_certificate_free_credentials);
170 LOAD_GNUTLS_FN (library, gnutls_certificate_get_peers);
171 LOAD_GNUTLS_FN (library, gnutls_certificate_set_verify_flags);
172 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_crl_file);
173 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_key_file);
174 LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_trust_file);
175 LOAD_GNUTLS_FN (library, gnutls_certificate_type_get);
176 LOAD_GNUTLS_FN (library, gnutls_certificate_verify_peers2);
177 LOAD_GNUTLS_FN (library, gnutls_credentials_set);
178 LOAD_GNUTLS_FN (library, gnutls_deinit);
179 LOAD_GNUTLS_FN (library, gnutls_dh_set_prime_bits);
180 LOAD_GNUTLS_FN (library, gnutls_error_is_fatal);
181 LOAD_GNUTLS_FN (library, gnutls_global_init);
182 LOAD_GNUTLS_FN (library, gnutls_global_set_log_function);
183 #ifdef HAVE_GNUTLS3
184 LOAD_GNUTLS_FN (library, gnutls_global_set_audit_log_function);
185 #endif
186 LOAD_GNUTLS_FN (library, gnutls_global_set_log_level);
187 LOAD_GNUTLS_FN (library, gnutls_global_set_mem_functions);
188 LOAD_GNUTLS_FN (library, gnutls_handshake);
189 LOAD_GNUTLS_FN (library, gnutls_init);
190 LOAD_GNUTLS_FN (library, gnutls_priority_set_direct);
191 LOAD_GNUTLS_FN (library, gnutls_record_check_pending);
192 LOAD_GNUTLS_FN (library, gnutls_record_recv);
193 LOAD_GNUTLS_FN (library, gnutls_record_send);
194 LOAD_GNUTLS_FN (library, gnutls_strerror);
195 LOAD_GNUTLS_FN (library, gnutls_transport_set_errno);
196 LOAD_GNUTLS_FN (library, gnutls_check_version);
197 /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
198 and later, and the function was removed entirely in 3.0.0. */
199 if (!fn_gnutls_check_version ("2.11.1"))
200 LOAD_GNUTLS_FN (library, gnutls_transport_set_lowat);
201 LOAD_GNUTLS_FN (library, gnutls_transport_set_ptr2);
202 LOAD_GNUTLS_FN (library, gnutls_transport_set_pull_function);
203 LOAD_GNUTLS_FN (library, gnutls_transport_set_push_function);
204 LOAD_GNUTLS_FN (library, gnutls_x509_crt_check_hostname);
205 LOAD_GNUTLS_FN (library, gnutls_x509_crt_deinit);
206 LOAD_GNUTLS_FN (library, gnutls_x509_crt_import);
207 LOAD_GNUTLS_FN (library, gnutls_x509_crt_init);
208
209 max_log_level = global_gnutls_log_level;
210
211 {
212 Lisp_Object name = CAR_SAFE (Fget (Qgnutls_dll, QCloaded_from));
213 GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:",
214 STRINGP (name) ? (const char *) SDATA (name) : "unknown");
215 }
216
217 return 1;
218 }
219
220 #else /* !WINDOWSNT */
221
222 #define fn_gnutls_alert_get gnutls_alert_get
223 #define fn_gnutls_alert_get_name gnutls_alert_get_name
224 #define fn_gnutls_alert_send_appropriate gnutls_alert_send_appropriate
225 #define fn_gnutls_anon_allocate_client_credentials gnutls_anon_allocate_client_credentials
226 #define fn_gnutls_anon_free_client_credentials gnutls_anon_free_client_credentials
227 #define fn_gnutls_bye gnutls_bye
228 #define fn_gnutls_certificate_allocate_credentials gnutls_certificate_allocate_credentials
229 #define fn_gnutls_certificate_free_credentials gnutls_certificate_free_credentials
230 #define fn_gnutls_certificate_get_peers gnutls_certificate_get_peers
231 #define fn_gnutls_certificate_set_verify_flags gnutls_certificate_set_verify_flags
232 #define fn_gnutls_certificate_set_x509_crl_file gnutls_certificate_set_x509_crl_file
233 #define fn_gnutls_certificate_set_x509_key_file gnutls_certificate_set_x509_key_file
234 #define fn_gnutls_certificate_set_x509_trust_file gnutls_certificate_set_x509_trust_file
235 #define fn_gnutls_certificate_type_get gnutls_certificate_type_get
236 #define fn_gnutls_certificate_verify_peers2 gnutls_certificate_verify_peers2
237 #define fn_gnutls_credentials_set gnutls_credentials_set
238 #define fn_gnutls_deinit gnutls_deinit
239 #define fn_gnutls_dh_set_prime_bits gnutls_dh_set_prime_bits
240 #define fn_gnutls_error_is_fatal gnutls_error_is_fatal
241 #define fn_gnutls_global_init gnutls_global_init
242 #define fn_gnutls_global_set_log_function gnutls_global_set_log_function
243 #ifdef HAVE_GNUTLS3
244 #define fn_gnutls_global_set_audit_log_function gnutls_global_set_audit_log_function
245 #endif
246 #define fn_gnutls_global_set_log_level gnutls_global_set_log_level
247 #define fn_gnutls_global_set_mem_functions gnutls_global_set_mem_functions
248 #define fn_gnutls_handshake gnutls_handshake
249 #define fn_gnutls_init gnutls_init
250 #define fn_gnutls_priority_set_direct gnutls_priority_set_direct
251 #define fn_gnutls_record_check_pending gnutls_record_check_pending
252 #define fn_gnutls_record_recv gnutls_record_recv
253 #define fn_gnutls_record_send gnutls_record_send
254 #define fn_gnutls_strerror gnutls_strerror
255 #ifdef WINDOWSNT
256 #define fn_gnutls_transport_set_errno gnutls_transport_set_errno
257 #endif
258 #define fn_gnutls_transport_set_ptr2 gnutls_transport_set_ptr2
259 #define fn_gnutls_x509_crt_check_hostname gnutls_x509_crt_check_hostname
260 #define fn_gnutls_x509_crt_deinit gnutls_x509_crt_deinit
261 #define fn_gnutls_x509_crt_import gnutls_x509_crt_import
262 #define fn_gnutls_x509_crt_init gnutls_x509_crt_init
263
264 #endif /* !WINDOWSNT */
265
266 \f
267 #ifdef HAVE_GNUTLS3
268 /* Function to log a simple audit message. */
269 static void
270 gnutls_audit_log_function (gnutls_session_t session, const char* string)
271 {
272 if (global_gnutls_log_level >= 1)
273 {
274 message ("gnutls.c: [audit] %s", string);
275 }
276 }
277 #endif
278
279 /* Function to log a simple message. */
280 static void
281 gnutls_log_function (int level, const char* string)
282 {
283 message ("gnutls.c: [%d] %s", level, string);
284 }
285
286 /* Function to log a message and a string. */
287 static void
288 gnutls_log_function2 (int level, const char* string, const char* extra)
289 {
290 message ("gnutls.c: [%d] %s %s", level, string, extra);
291 }
292
293 /* Function to log a message and an integer. */
294 static void
295 gnutls_log_function2i (int level, const char* string, int extra)
296 {
297 message ("gnutls.c: [%d] %s %d", level, string, extra);
298 }
299
300 static int
301 emacs_gnutls_handshake (struct Lisp_Process *proc)
302 {
303 gnutls_session_t state = proc->gnutls_state;
304 int ret;
305
306 if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
307 return -1;
308
309 if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
310 {
311 #ifdef WINDOWSNT
312 /* On W32 we cannot transfer socket handles between different runtime
313 libraries, so we tell GnuTLS to use our special push/pull
314 functions. */
315 fn_gnutls_transport_set_ptr2 (state,
316 (gnutls_transport_ptr_t) proc,
317 (gnutls_transport_ptr_t) proc);
318 fn_gnutls_transport_set_push_function (state, &emacs_gnutls_push);
319 fn_gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
320
321 /* For non blocking sockets or other custom made pull/push
322 functions the gnutls_transport_set_lowat must be called, with
323 a zero low water mark value. (GnuTLS 2.10.4 documentation)
324
325 (Note: this is probably not strictly necessary as the lowat
326 value is only used when no custom pull/push functions are
327 set.) */
328 /* According to GnuTLS NEWS file, lowat level has been set to
329 zero by default in version 2.11.1, and the function
330 gnutls_transport_set_lowat was removed from the library in
331 version 2.99.0. */
332 if (!fn_gnutls_check_version ("2.11.1"))
333 fn_gnutls_transport_set_lowat (state, 0);
334 #else
335 /* This is how GnuTLS takes sockets: as file descriptors passed
336 in. For an Emacs process socket, infd and outfd are the
337 same but we use this two-argument version for clarity. */
338 fn_gnutls_transport_set_ptr2 (state,
339 (gnutls_transport_ptr_t) (long) proc->infd,
340 (gnutls_transport_ptr_t) (long) proc->outfd);
341 #endif
342
343 proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
344 }
345
346 do
347 {
348 ret = fn_gnutls_handshake (state);
349 emacs_gnutls_handle_error (state, ret);
350 QUIT;
351 }
352 while (ret < 0 && fn_gnutls_error_is_fatal (ret) == 0);
353
354 proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
355
356 if (ret == GNUTLS_E_SUCCESS)
357 {
358 /* Here we're finally done. */
359 proc->gnutls_initstage = GNUTLS_STAGE_READY;
360 }
361 else
362 {
363 fn_gnutls_alert_send_appropriate (state, ret);
364 }
365 return ret;
366 }
367
368 ptrdiff_t
369 emacs_gnutls_record_check_pending (gnutls_session_t state)
370 {
371 return fn_gnutls_record_check_pending (state);
372 }
373
374 #ifdef WINDOWSNT
375 void
376 emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
377 {
378 fn_gnutls_transport_set_errno (state, err);
379 }
380 #endif
381
382 ptrdiff_t
383 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
384 {
385 ssize_t rtnval = 0;
386 ptrdiff_t bytes_written;
387 gnutls_session_t state = proc->gnutls_state;
388
389 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
390 {
391 errno = EAGAIN;
392 return 0;
393 }
394
395 bytes_written = 0;
396
397 while (nbyte > 0)
398 {
399 rtnval = fn_gnutls_record_send (state, buf, nbyte);
400
401 if (rtnval < 0)
402 {
403 if (rtnval == GNUTLS_E_INTERRUPTED)
404 continue;
405 else
406 {
407 /* If we get GNUTLS_E_AGAIN, then set errno
408 appropriately so that send_process retries the
409 correct way instead of erroring out. */
410 if (rtnval == GNUTLS_E_AGAIN)
411 errno = EAGAIN;
412 break;
413 }
414 }
415
416 buf += rtnval;
417 nbyte -= rtnval;
418 bytes_written += rtnval;
419 }
420
421 emacs_gnutls_handle_error (state, rtnval);
422 return (bytes_written);
423 }
424
425 ptrdiff_t
426 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
427 {
428 ssize_t rtnval;
429 gnutls_session_t state = proc->gnutls_state;
430
431 int log_level = proc->gnutls_log_level;
432
433 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
434 {
435 /* If the handshake count is under the limit, try the handshake
436 again and increment the handshake count. This count is kept
437 per process (connection), not globally. */
438 if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT)
439 {
440 proc->gnutls_handshakes_tried++;
441 emacs_gnutls_handshake (proc);
442 GNUTLS_LOG2i (5, log_level, "Retried handshake",
443 proc->gnutls_handshakes_tried);
444 return -1;
445 }
446
447 GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
448 proc->gnutls_handshakes_tried = 0;
449 return 0;
450 }
451 rtnval = fn_gnutls_record_recv (state, buf, nbyte);
452 if (rtnval >= 0)
453 return rtnval;
454 else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
455 /* The peer closed the connection. */
456 return 0;
457 else if (emacs_gnutls_handle_error (state, rtnval))
458 /* non-fatal error */
459 return -1;
460 else {
461 /* a fatal error occurred */
462 return 0;
463 }
464 }
465
466 /* Report a GnuTLS error to the user.
467 Return true if the error code was successfully handled. */
468 static bool
469 emacs_gnutls_handle_error (gnutls_session_t session, int err)
470 {
471 int max_log_level = 0;
472
473 bool ret;
474 const char *str;
475
476 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
477 if (err >= 0)
478 return 1;
479
480 max_log_level = global_gnutls_log_level;
481
482 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
483
484 str = fn_gnutls_strerror (err);
485 if (!str)
486 str = "unknown";
487
488 if (fn_gnutls_error_is_fatal (err))
489 {
490 ret = 0;
491 GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
492 }
493 else
494 {
495 ret = 1;
496
497 switch (err)
498 {
499 case GNUTLS_E_AGAIN:
500 GNUTLS_LOG2 (3,
501 max_log_level,
502 "retry:",
503 str);
504 default:
505 GNUTLS_LOG2 (1,
506 max_log_level,
507 "non-fatal error:",
508 str);
509 }
510 }
511
512 if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
513 || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
514 {
515 int alert = fn_gnutls_alert_get (session);
516 int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
517 str = fn_gnutls_alert_get_name (alert);
518 if (!str)
519 str = "unknown";
520
521 GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
522 }
523 return ret;
524 }
525
526 /* convert an integer error to a Lisp_Object; it will be either a
527 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
528 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
529 to Qt. */
530 static Lisp_Object
531 gnutls_make_error (int err)
532 {
533 switch (err)
534 {
535 case GNUTLS_E_SUCCESS:
536 return Qt;
537 case GNUTLS_E_AGAIN:
538 return Qgnutls_e_again;
539 case GNUTLS_E_INTERRUPTED:
540 return Qgnutls_e_interrupted;
541 case GNUTLS_E_INVALID_SESSION:
542 return Qgnutls_e_invalid_session;
543 }
544
545 return make_number (err);
546 }
547
548 Lisp_Object
549 emacs_gnutls_deinit (Lisp_Object proc)
550 {
551 int log_level;
552
553 CHECK_PROCESS (proc);
554
555 if (XPROCESS (proc)->gnutls_p == 0)
556 return Qnil;
557
558 log_level = XPROCESS (proc)->gnutls_log_level;
559
560 if (XPROCESS (proc)->gnutls_x509_cred)
561 {
562 GNUTLS_LOG (2, log_level, "Deallocating x509 credentials");
563 fn_gnutls_certificate_free_credentials (XPROCESS (proc)->gnutls_x509_cred);
564 XPROCESS (proc)->gnutls_x509_cred = NULL;
565 }
566
567 if (XPROCESS (proc)->gnutls_anon_cred)
568 {
569 GNUTLS_LOG (2, log_level, "Deallocating anon credentials");
570 fn_gnutls_anon_free_client_credentials (XPROCESS (proc)->gnutls_anon_cred);
571 XPROCESS (proc)->gnutls_anon_cred = NULL;
572 }
573
574 if (XPROCESS (proc)->gnutls_state)
575 {
576 fn_gnutls_deinit (XPROCESS (proc)->gnutls_state);
577 XPROCESS (proc)->gnutls_state = NULL;
578 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
579 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
580 }
581
582 XPROCESS (proc)->gnutls_p = 0;
583 return Qt;
584 }
585
586 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
587 doc: /* Return the GnuTLS init stage of process PROC.
588 See also `gnutls-boot'. */)
589 (Lisp_Object proc)
590 {
591 CHECK_PROCESS (proc);
592
593 return make_number (GNUTLS_INITSTAGE (proc));
594 }
595
596 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
597 doc: /* Return t if ERROR indicates a GnuTLS problem.
598 ERROR is an integer or a symbol with an integer `gnutls-code' property.
599 usage: (gnutls-errorp ERROR) */)
600 (Lisp_Object err)
601 {
602 if (EQ (err, Qt)) return Qnil;
603
604 return Qt;
605 }
606
607 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
608 doc: /* Check if ERROR is fatal.
609 ERROR is an integer or a symbol with an integer `gnutls-code' property.
610 usage: (gnutls-error-fatalp ERROR) */)
611 (Lisp_Object err)
612 {
613 Lisp_Object code;
614
615 if (EQ (err, Qt)) return Qnil;
616
617 if (SYMBOLP (err))
618 {
619 code = Fget (err, Qgnutls_code);
620 if (NUMBERP (code))
621 {
622 err = code;
623 }
624 else
625 {
626 error ("Symbol has no numeric gnutls-code property");
627 }
628 }
629
630 if (! TYPE_RANGED_INTEGERP (int, err))
631 error ("Not an error symbol or code");
632
633 if (0 == fn_gnutls_error_is_fatal (XINT (err)))
634 return Qnil;
635
636 return Qt;
637 }
638
639 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
640 doc: /* Return a description of ERROR.
641 ERROR is an integer or a symbol with an integer `gnutls-code' property.
642 usage: (gnutls-error-string ERROR) */)
643 (Lisp_Object err)
644 {
645 Lisp_Object code;
646
647 if (EQ (err, Qt)) return build_string ("Not an error");
648
649 if (SYMBOLP (err))
650 {
651 code = Fget (err, Qgnutls_code);
652 if (NUMBERP (code))
653 {
654 err = code;
655 }
656 else
657 {
658 return build_string ("Symbol has no numeric gnutls-code property");
659 }
660 }
661
662 if (! TYPE_RANGED_INTEGERP (int, err))
663 return build_string ("Not an error symbol or code");
664
665 return build_string (fn_gnutls_strerror (XINT (err)));
666 }
667
668 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
669 doc: /* Deallocate GnuTLS resources associated with process PROC.
670 See also `gnutls-init'. */)
671 (Lisp_Object proc)
672 {
673 return emacs_gnutls_deinit (proc);
674 }
675
676 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
677 doc: /* Return t if GnuTLS is available in this instance of Emacs. */)
678 (void)
679 {
680 #ifdef WINDOWSNT
681 Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
682 if (CONSP (found))
683 return XCDR (found);
684 else
685 {
686 Lisp_Object status;
687 status = init_gnutls_functions () ? Qt : Qnil;
688 Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
689 return status;
690 }
691 #else
692 return Qt;
693 #endif
694 }
695
696
697 /* Initializes global GnuTLS state to defaults.
698 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
699 Returns zero on success. */
700 static Lisp_Object
701 emacs_gnutls_global_init (void)
702 {
703 int ret = GNUTLS_E_SUCCESS;
704
705 if (!gnutls_global_initialized)
706 {
707 fn_gnutls_global_set_mem_functions (xmalloc, xmalloc, NULL,
708 xrealloc, xfree);
709 ret = fn_gnutls_global_init ();
710 }
711 gnutls_global_initialized = 1;
712
713 return gnutls_make_error (ret);
714 }
715
716 #if 0
717 /* Deinitializes global GnuTLS state.
718 See also `gnutls-global-init'. */
719 static Lisp_Object
720 emacs_gnutls_global_deinit (void)
721 {
722 if (gnutls_global_initialized)
723 gnutls_global_deinit ();
724
725 gnutls_global_initialized = 0;
726
727 return gnutls_make_error (GNUTLS_E_SUCCESS);
728 }
729 #endif
730
731 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
732 doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
733 Currently only client mode is supported. Return a success/failure
734 value you can check with `gnutls-errorp'.
735
736 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
737 PROPLIST is a property list with the following keys:
738
739 :hostname is a string naming the remote host.
740
741 :priority is a GnuTLS priority string, defaults to "NORMAL".
742
743 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
744
745 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
746
747 :keylist is an alist of PEM-encoded key files and PEM-encoded
748 certificates for `gnutls-x509pki'.
749
750 :callbacks is an alist of callback functions, see below.
751
752 :loglevel is the debug level requested from GnuTLS, try 4.
753
754 :verify-flags is a bitset as per GnuTLS'
755 gnutls_certificate_set_verify_flags.
756
757 :verify-hostname-error is ignored. Pass :hostname in :verify-error
758 instead.
759
760 :verify-error is a list of symbols to express verification checks or
761 `t' to do all checks. Currently it can contain `:trustfiles' and
762 `:hostname' to verify the certificate or the hostname respectively.
763
764 :min-prime-bits is the minimum accepted number of bits the client will
765 accept in Diffie-Hellman key exchange.
766
767 The debug level will be set for this process AND globally for GnuTLS.
768 So if you set it higher or lower at any point, it affects global
769 debugging.
770
771 Note that the priority is set on the client. The server does not use
772 the protocols's priority except for disabling protocols that were not
773 specified.
774
775 Processes must be initialized with this function before other GnuTLS
776 functions are used. This function allocates resources which can only
777 be deallocated by calling `gnutls-deinit' or by calling it again.
778
779 The callbacks alist can have a `verify' key, associated with a
780 verification function (UNUSED).
781
782 Each authentication type may need additional information in order to
783 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
784 one trustfile (usually a CA bundle). */)
785 (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
786 {
787 int ret = GNUTLS_E_SUCCESS;
788 int max_log_level = 0;
789 bool verify_error_all = 0;
790
791 gnutls_session_t state;
792 gnutls_certificate_credentials_t x509_cred = NULL;
793 gnutls_anon_client_credentials_t anon_cred = NULL;
794 Lisp_Object global_init;
795 char const *priority_string_ptr = "NORMAL"; /* default priority string. */
796 unsigned int peer_verification;
797 char* c_hostname;
798
799 /* Placeholders for the property list elements. */
800 Lisp_Object priority_string;
801 Lisp_Object trustfiles;
802 Lisp_Object crlfiles;
803 Lisp_Object keylist;
804 /* Lisp_Object callbacks; */
805 Lisp_Object loglevel;
806 Lisp_Object hostname;
807 Lisp_Object verify_error;
808 Lisp_Object prime_bits;
809
810 CHECK_PROCESS (proc);
811 CHECK_SYMBOL (type);
812 CHECK_LIST (proplist);
813
814 if (NILP (Fgnutls_available_p ()))
815 error ("GnuTLS not available");
816
817 if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
818 error ("Invalid GnuTLS credential type");
819
820 hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
821 priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority);
822 trustfiles = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
823 keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist);
824 crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
825 loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
826 verify_error = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
827 prime_bits = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
828
829 if (EQ (verify_error, Qt))
830 {
831 verify_error_all = 1;
832 }
833 else if (NILP (Flistp (verify_error)))
834 {
835 error ("gnutls-boot: invalid :verify_error parameter (not a list)");
836 }
837
838 if (!STRINGP (hostname))
839 error ("gnutls-boot: invalid :hostname parameter (not a string)");
840 c_hostname = SSDATA (hostname);
841
842 state = XPROCESS (proc)->gnutls_state;
843
844 if (TYPE_RANGED_INTEGERP (int, loglevel))
845 {
846 fn_gnutls_global_set_log_function (gnutls_log_function);
847 #ifdef HAVE_GNUTLS3
848 fn_gnutls_global_set_audit_log_function (gnutls_audit_log_function);
849 #endif
850 fn_gnutls_global_set_log_level (XINT (loglevel));
851 max_log_level = XINT (loglevel);
852 XPROCESS (proc)->gnutls_log_level = max_log_level;
853 }
854
855 /* always initialize globals. */
856 global_init = emacs_gnutls_global_init ();
857 if (! NILP (Fgnutls_errorp (global_init)))
858 return global_init;
859
860 /* Before allocating new credentials, deallocate any credentials
861 that PROC might already have. */
862 emacs_gnutls_deinit (proc);
863
864 /* Mark PROC as a GnuTLS process. */
865 XPROCESS (proc)->gnutls_state = NULL;
866 XPROCESS (proc)->gnutls_x509_cred = NULL;
867 XPROCESS (proc)->gnutls_anon_cred = NULL;
868 pset_gnutls_cred_type (XPROCESS (proc), type);
869 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
870
871 GNUTLS_LOG (1, max_log_level, "allocating credentials");
872 if (EQ (type, Qgnutls_x509pki))
873 {
874 Lisp_Object verify_flags;
875 unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
876
877 GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
878 fn_gnutls_certificate_allocate_credentials (&x509_cred);
879 XPROCESS (proc)->gnutls_x509_cred = x509_cred;
880
881 verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
882 if (NUMBERP (verify_flags))
883 {
884 gnutls_verify_flags = XINT (verify_flags);
885 GNUTLS_LOG (2, max_log_level, "setting verification flags");
886 }
887 else if (NILP (verify_flags))
888 GNUTLS_LOG (2, max_log_level, "using default verification flags");
889 else
890 GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
891
892 fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
893 }
894 else /* Qgnutls_anon: */
895 {
896 GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
897 fn_gnutls_anon_allocate_client_credentials (&anon_cred);
898 XPROCESS (proc)->gnutls_anon_cred = anon_cred;
899 }
900
901 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
902
903 if (EQ (type, Qgnutls_x509pki))
904 {
905 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
906 int file_format = GNUTLS_X509_FMT_PEM;
907 Lisp_Object tail;
908
909 for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
910 {
911 Lisp_Object trustfile = XCAR (tail);
912 if (STRINGP (trustfile))
913 {
914 GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
915 SSDATA (trustfile));
916 trustfile = ENCODE_FILE (trustfile);
917 #ifdef WINDOWSNT
918 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
919 file names on Windows, we need to re-encode the file
920 name using the current ANSI codepage. */
921 trustfile = ansi_encode_filename (trustfile);
922 #endif
923 ret = fn_gnutls_certificate_set_x509_trust_file
924 (x509_cred,
925 SSDATA (trustfile),
926 file_format);
927
928 if (ret < GNUTLS_E_SUCCESS)
929 return gnutls_make_error (ret);
930 }
931 else
932 {
933 emacs_gnutls_deinit (proc);
934 error ("Invalid trustfile");
935 }
936 }
937
938 for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
939 {
940 Lisp_Object crlfile = XCAR (tail);
941 if (STRINGP (crlfile))
942 {
943 GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
944 SSDATA (crlfile));
945 crlfile = ENCODE_FILE (crlfile);
946 #ifdef WINDOWSNT
947 crlfile = ansi_encode_filename (crlfile);
948 #endif
949 ret = fn_gnutls_certificate_set_x509_crl_file
950 (x509_cred, SSDATA (crlfile), file_format);
951
952 if (ret < GNUTLS_E_SUCCESS)
953 return gnutls_make_error (ret);
954 }
955 else
956 {
957 emacs_gnutls_deinit (proc);
958 error ("Invalid CRL file");
959 }
960 }
961
962 for (tail = keylist; CONSP (tail); tail = XCDR (tail))
963 {
964 Lisp_Object keyfile = Fcar (XCAR (tail));
965 Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
966 if (STRINGP (keyfile) && STRINGP (certfile))
967 {
968 GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
969 SSDATA (keyfile));
970 GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
971 SSDATA (certfile));
972 keyfile = ENCODE_FILE (keyfile);
973 certfile = ENCODE_FILE (certfile);
974 #ifdef WINDOWSNT
975 keyfile = ansi_encode_filename (keyfile);
976 certfile = ansi_encode_filename (certfile);
977 #endif
978 ret = fn_gnutls_certificate_set_x509_key_file
979 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
980
981 if (ret < GNUTLS_E_SUCCESS)
982 return gnutls_make_error (ret);
983 }
984 else
985 {
986 emacs_gnutls_deinit (proc);
987 error (STRINGP (keyfile) ? "Invalid client cert file"
988 : "Invalid client key file");
989 }
990 }
991 }
992
993 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
994 GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
995 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
996
997 /* Call gnutls_init here: */
998
999 GNUTLS_LOG (1, max_log_level, "gnutls_init");
1000 ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
1001 XPROCESS (proc)->gnutls_state = state;
1002 if (ret < GNUTLS_E_SUCCESS)
1003 return gnutls_make_error (ret);
1004 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
1005
1006 if (STRINGP (priority_string))
1007 {
1008 priority_string_ptr = SSDATA (priority_string);
1009 GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
1010 priority_string_ptr);
1011 }
1012 else
1013 {
1014 GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
1015 priority_string_ptr);
1016 }
1017
1018 GNUTLS_LOG (1, max_log_level, "setting the priority string");
1019 ret = fn_gnutls_priority_set_direct (state,
1020 priority_string_ptr,
1021 NULL);
1022 if (ret < GNUTLS_E_SUCCESS)
1023 return gnutls_make_error (ret);
1024
1025 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
1026
1027 if (INTEGERP (prime_bits))
1028 fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
1029
1030 ret = EQ (type, Qgnutls_x509pki)
1031 ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
1032 : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
1033 if (ret < GNUTLS_E_SUCCESS)
1034 return gnutls_make_error (ret);
1035
1036 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
1037 ret = emacs_gnutls_handshake (XPROCESS (proc));
1038 if (ret < GNUTLS_E_SUCCESS)
1039 return gnutls_make_error (ret);
1040
1041 /* Now verify the peer, following
1042 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1043 The peer should present at least one certificate in the chain; do a
1044 check of the certificate's hostname with
1045 gnutls_x509_crt_check_hostname() against :hostname. */
1046
1047 ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
1048 if (ret < GNUTLS_E_SUCCESS)
1049 return gnutls_make_error (ret);
1050
1051 if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
1052 message ("%s certificate could not be verified.", c_hostname);
1053
1054 if (peer_verification & GNUTLS_CERT_REVOKED)
1055 GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
1056 c_hostname);
1057
1058 if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
1059 GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
1060 c_hostname);
1061
1062 if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
1063 GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
1064 c_hostname);
1065
1066 if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1067 GNUTLS_LOG2 (1, max_log_level,
1068 "certificate was signed with an insecure algorithm:",
1069 c_hostname);
1070
1071 if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
1072 GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
1073 c_hostname);
1074
1075 if (peer_verification & GNUTLS_CERT_EXPIRED)
1076 GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
1077 c_hostname);
1078
1079 if (peer_verification != 0)
1080 {
1081 if (verify_error_all
1082 || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
1083 {
1084 emacs_gnutls_deinit (proc);
1085 error ("Certificate validation failed %s, verification code %d",
1086 c_hostname, peer_verification);
1087 }
1088 else
1089 {
1090 GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1091 c_hostname);
1092 }
1093 }
1094
1095 /* Up to here the process is the same for X.509 certificates and
1096 OpenPGP keys. From now on X.509 certificates are assumed. This
1097 can be easily extended to work with openpgp keys as well. */
1098 if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1099 {
1100 gnutls_x509_crt_t gnutls_verify_cert;
1101 const gnutls_datum_t *gnutls_verify_cert_list;
1102 unsigned int gnutls_verify_cert_list_size;
1103
1104 ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
1105 if (ret < GNUTLS_E_SUCCESS)
1106 return gnutls_make_error (ret);
1107
1108 gnutls_verify_cert_list =
1109 fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1110
1111 if (gnutls_verify_cert_list == NULL)
1112 {
1113 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1114 emacs_gnutls_deinit (proc);
1115 error ("No x509 certificate was found\n");
1116 }
1117
1118 /* We only check the first certificate in the given chain. */
1119 ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1120 &gnutls_verify_cert_list[0],
1121 GNUTLS_X509_FMT_DER);
1122
1123 if (ret < GNUTLS_E_SUCCESS)
1124 {
1125 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1126 return gnutls_make_error (ret);
1127 }
1128
1129 if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1130 {
1131 if (verify_error_all
1132 || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
1133 {
1134 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1135 emacs_gnutls_deinit (proc);
1136 error ("The x509 certificate does not match \"%s\"", c_hostname);
1137 }
1138 else
1139 {
1140 GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1141 c_hostname);
1142 }
1143 }
1144 fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1145 }
1146
1147 /* Set this flag only if the whole initialization succeeded. */
1148 XPROCESS (proc)->gnutls_p = 1;
1149
1150 return gnutls_make_error (ret);
1151 }
1152
1153 DEFUN ("gnutls-bye", Fgnutls_bye,
1154 Sgnutls_bye, 2, 2, 0,
1155 doc: /* Terminate current GnuTLS connection for process PROC.
1156 The connection should have been initiated using `gnutls-handshake'.
1157
1158 If CONT is not nil the TLS connection gets terminated and further
1159 receives and sends will be disallowed. If the return value is zero you
1160 may continue using the connection. If CONT is nil, GnuTLS actually
1161 sends an alert containing a close request and waits for the peer to
1162 reply with the same message. In order to reuse the connection you
1163 should wait for an EOF from the peer.
1164
1165 This function may also return `gnutls-e-again', or
1166 `gnutls-e-interrupted'. */)
1167 (Lisp_Object proc, Lisp_Object cont)
1168 {
1169 gnutls_session_t state;
1170 int ret;
1171
1172 CHECK_PROCESS (proc);
1173
1174 state = XPROCESS (proc)->gnutls_state;
1175
1176 ret = fn_gnutls_bye (state,
1177 NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1178
1179 return gnutls_make_error (ret);
1180 }
1181
1182 void
1183 syms_of_gnutls (void)
1184 {
1185 gnutls_global_initialized = 0;
1186
1187 DEFSYM (Qgnutls_dll, "gnutls");
1188 DEFSYM (Qgnutls_code, "gnutls-code");
1189 DEFSYM (Qgnutls_anon, "gnutls-anon");
1190 DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1191 DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1192 DEFSYM (QCgnutls_bootprop_priority, ":priority");
1193 DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1194 DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1195 DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1196 DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1197 DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1198 DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1199 DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1200 DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1201 DEFSYM (QCgnutls_bootprop_verify_error, ":verify-error");
1202
1203 DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1204 Fput (Qgnutls_e_interrupted, Qgnutls_code,
1205 make_number (GNUTLS_E_INTERRUPTED));
1206
1207 DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1208 Fput (Qgnutls_e_again, Qgnutls_code,
1209 make_number (GNUTLS_E_AGAIN));
1210
1211 DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1212 Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1213 make_number (GNUTLS_E_INVALID_SESSION));
1214
1215 DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1216 Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1217 make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1218
1219 defsubr (&Sgnutls_get_initstage);
1220 defsubr (&Sgnutls_errorp);
1221 defsubr (&Sgnutls_error_fatalp);
1222 defsubr (&Sgnutls_error_string);
1223 defsubr (&Sgnutls_boot);
1224 defsubr (&Sgnutls_deinit);
1225 defsubr (&Sgnutls_bye);
1226 defsubr (&Sgnutls_available_p);
1227
1228 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1229 doc: /* Logging level used by the GnuTLS functions.
1230 Set this larger than 0 to get debug output in the *Messages* buffer.
1231 1 is for important messages, 2 is for debug data, and higher numbers
1232 are as per the GnuTLS logging conventions. */);
1233 global_gnutls_log_level = 0;
1234 }
1235
1236 #endif /* HAVE_GNUTLS */