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