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