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