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