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