Commit | Line | Data |
---|---|---|
8af55556 | 1 | /* GnuTLS glue for GNU Emacs. |
73b0cd50 | 2 | Copyright (C) 2010-2011 Free Software Foundation, Inc. |
8af55556 TZ |
3 | |
4 | This file is part of GNU Emacs. | |
5 | ||
6 | GNU Emacs is free software: you can redistribute it and/or modify | |
7 | it under the terms of the GNU General Public License as published by | |
8 | the Free Software Foundation, either version 3 of the License, or | |
9 | (at your option) any later version. | |
10 | ||
11 | GNU Emacs is distributed in the hope that it will be useful, | |
12 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | GNU General Public License for more details. | |
15 | ||
16 | You should have received a copy of the GNU General Public License | |
17 | along 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 | ||
34 | static int | |
35 | emacs_gnutls_handle_error (gnutls_session_t, int err); | |
36 | ||
bafcf6a5 JB |
37 | static Lisp_Object Qgnutls_log_level; |
38 | static Lisp_Object Qgnutls_code; | |
39 | static Lisp_Object Qgnutls_anon, Qgnutls_x509pki; | |
40 | static Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again, | |
8af55556 | 41 | Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake; |
bafcf6a5 | 42 | static int gnutls_global_initialized; |
8af55556 | 43 | |
c1ae068b | 44 | /* The following are for the property list of `gnutls-boot'. */ |
bafcf6a5 JB |
45 | static Lisp_Object Qgnutls_bootprop_priority; |
46 | static Lisp_Object Qgnutls_bootprop_trustfiles; | |
47 | static Lisp_Object Qgnutls_bootprop_keyfiles; | |
48 | static Lisp_Object Qgnutls_bootprop_callbacks; | |
49 | static Lisp_Object Qgnutls_bootprop_loglevel; | |
50 | static Lisp_Object Qgnutls_bootprop_hostname; | |
51 | static Lisp_Object Qgnutls_bootprop_verify_flags; | |
52 | static Lisp_Object Qgnutls_bootprop_verify_error; | |
53 | static Lisp_Object Qgnutls_bootprop_verify_hostname_error; | |
e061a11b TZ |
54 | |
55 | /* Callback keys for `gnutls-boot'. Unused currently. */ | |
bafcf6a5 | 56 | static Lisp_Object Qgnutls_bootprop_callbacks_verify; |
c1ae068b | 57 | |
74f1829d | 58 | static void |
e061a11b TZ |
59 | gnutls_log_function (int level, const char* string) |
60 | { | |
61 | message ("gnutls.c: [%d] %s", level, string); | |
62 | } | |
63 | ||
64 | static void | |
65 | gnutls_log_function2 (int level, const char* string, const char* extra) | |
66 | { | |
67 | message ("gnutls.c: [%d] %s %s", level, string, extra); | |
68 | } | |
69 | ||
70 | static int | |
bac5cef8 LMI |
71 | emacs_gnutls_handshake (struct Lisp_Process *proc) |
72 | { | |
73 | gnutls_session_t state = proc->gnutls_state; | |
74 | int ret; | |
75 | ||
76 | if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO) | |
6a7a1b0b | 77 | return -1; |
bac5cef8 LMI |
78 | |
79 | if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET) | |
e6059fa2 | 80 | { |
e061a11b TZ |
81 | #ifdef WINDOWSNT |
82 | /* On W32 we cannot transfer socket handles between different runtime | |
83 | libraries, so we tell GnuTLS to use our special push/pull | |
84 | functions. */ | |
85 | gnutls_transport_set_ptr2 (state, | |
86 | (gnutls_transport_ptr_t) proc, | |
87 | (gnutls_transport_ptr_t) proc); | |
88 | gnutls_transport_set_push_function (state, &emacs_gnutls_push); | |
89 | gnutls_transport_set_pull_function (state, &emacs_gnutls_pull); | |
90 | ||
91 | /* For non blocking sockets or other custom made pull/push | |
92 | functions the gnutls_transport_set_lowat must be called, with | |
93 | a zero low water mark value. (GnuTLS 2.10.4 documentation) | |
94 | ||
95 | (Note: this is probably not strictly necessary as the lowat | |
96 | value is only used when no custom pull/push functions are | |
97 | set.) */ | |
98 | gnutls_transport_set_lowat (state, 0); | |
99 | #else | |
c1ae068b LMI |
100 | /* This is how GnuTLS takes sockets: as file descriptors passed |
101 | in. For an Emacs process socket, infd and outfd are the | |
102 | same but we use this two-argument version for clarity. */ | |
e6059fa2 | 103 | gnutls_transport_set_ptr2 (state, |
fb11d64d EZ |
104 | (gnutls_transport_ptr_t) (long) proc->infd, |
105 | (gnutls_transport_ptr_t) (long) proc->outfd); | |
e061a11b | 106 | #endif |
bac5cef8 | 107 | |
e6059fa2 LMI |
108 | proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET; |
109 | } | |
bac5cef8 | 110 | |
e061a11b TZ |
111 | do |
112 | { | |
113 | ret = gnutls_handshake (state); | |
114 | emacs_gnutls_handle_error (state, ret); | |
115 | } | |
116 | while (ret < 0 && gnutls_error_is_fatal (ret) == 0); | |
117 | ||
bac5cef8 LMI |
118 | proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED; |
119 | ||
120 | if (ret == GNUTLS_E_SUCCESS) | |
e6059fa2 | 121 | { |
e061a11b | 122 | /* Here we're finally done. */ |
e6059fa2 LMI |
123 | proc->gnutls_initstage = GNUTLS_STAGE_READY; |
124 | } | |
e061a11b TZ |
125 | else |
126 | { | |
127 | gnutls_alert_send_appropriate (state, ret); | |
128 | } | |
129 | return ret; | |
bac5cef8 LMI |
130 | } |
131 | ||
9587a89d | 132 | EMACS_INT |
368f4090 | 133 | emacs_gnutls_write (int fildes, struct Lisp_Process *proc, const char *buf, |
9587a89d | 134 | EMACS_INT nbyte) |
8af55556 | 135 | { |
c8926152 | 136 | ssize_t rtnval = 0; |
9587a89d | 137 | EMACS_INT bytes_written; |
df7fcaff LMI |
138 | gnutls_session_t state = proc->gnutls_state; |
139 | ||
355cdaf3 LMI |
140 | if (proc->gnutls_initstage != GNUTLS_STAGE_READY) { |
141 | #ifdef EWOULDBLOCK | |
142 | errno = EWOULDBLOCK; | |
143 | #endif | |
144 | #ifdef EAGAIN | |
145 | errno = EAGAIN; | |
146 | #endif | |
273a5f82 | 147 | return 0; |
355cdaf3 | 148 | } |
8af55556 TZ |
149 | |
150 | bytes_written = 0; | |
151 | ||
152 | while (nbyte > 0) | |
153 | { | |
154 | rtnval = gnutls_write (state, buf, nbyte); | |
155 | ||
2e6c74c5 | 156 | if (rtnval < 0) |
8af55556 | 157 | { |
2e6c74c5 | 158 | if (rtnval == GNUTLS_E_AGAIN || rtnval == GNUTLS_E_INTERRUPTED) |
8af55556 TZ |
159 | continue; |
160 | else | |
273a5f82 | 161 | break; |
8af55556 TZ |
162 | } |
163 | ||
164 | buf += rtnval; | |
165 | nbyte -= rtnval; | |
166 | bytes_written += rtnval; | |
167 | } | |
8af55556 | 168 | |
e061a11b | 169 | emacs_gnutls_handle_error (state, rtnval); |
8af55556 TZ |
170 | return (bytes_written); |
171 | } | |
172 | ||
9587a89d | 173 | EMACS_INT |
df7fcaff | 174 | emacs_gnutls_read (int fildes, struct Lisp_Process *proc, char *buf, |
9587a89d | 175 | EMACS_INT nbyte) |
8af55556 | 176 | { |
368f4090 | 177 | ssize_t rtnval; |
df7fcaff LMI |
178 | gnutls_session_t state = proc->gnutls_state; |
179 | ||
e6059fa2 LMI |
180 | if (proc->gnutls_initstage != GNUTLS_STAGE_READY) |
181 | { | |
182 | emacs_gnutls_handshake (proc); | |
183 | return -1; | |
184 | } | |
ec9f09be LMI |
185 | rtnval = gnutls_read (state, buf, nbyte); |
186 | if (rtnval >= 0) | |
187 | return rtnval; | |
e061a11b TZ |
188 | else if (emacs_gnutls_handle_error (state, rtnval) == 0) |
189 | /* non-fatal error */ | |
190 | return -1; | |
4b2d9ec2 | 191 | else { |
e061a11b TZ |
192 | /* a fatal error occured */ |
193 | return 0; | |
4b2d9ec2 | 194 | } |
8af55556 TZ |
195 | } |
196 | ||
e061a11b TZ |
197 | /* report a GnuTLS error to the user. |
198 | Returns zero if the error code was successfully handled. */ | |
199 | static int | |
200 | emacs_gnutls_handle_error (gnutls_session_t session, int err) | |
201 | { | |
202 | Lisp_Object gnutls_log_level = Fsymbol_value (Qgnutls_log_level); | |
203 | int max_log_level = 0; | |
204 | ||
0c8c7e5c | 205 | int ret; |
e061a11b TZ |
206 | const char *str; |
207 | ||
208 | /* TODO: use a Lisp_Object generated by gnutls_make_error? */ | |
209 | if (err >= 0) | |
210 | return 0; | |
211 | ||
212 | if (NUMBERP (gnutls_log_level)) | |
213 | max_log_level = XINT (gnutls_log_level); | |
214 | ||
215 | /* TODO: use gnutls-error-fatalp and gnutls-error-string. */ | |
216 | ||
217 | str = gnutls_strerror (err); | |
218 | if (!str) | |
219 | str = "unknown"; | |
220 | ||
221 | if (gnutls_error_is_fatal (err)) | |
222 | { | |
223 | ret = err; | |
224 | GNUTLS_LOG2 (0, max_log_level, "fatal error:", str); | |
225 | } | |
226 | else | |
227 | { | |
228 | ret = 0; | |
229 | GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str); | |
230 | /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2. */ | |
231 | } | |
232 | ||
233 | if (err == GNUTLS_E_WARNING_ALERT_RECEIVED | |
234 | || err == GNUTLS_E_FATAL_ALERT_RECEIVED) | |
235 | { | |
236 | int alert = gnutls_alert_get (session); | |
237 | int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1; | |
238 | str = gnutls_alert_get_name (alert); | |
239 | if (!str) | |
240 | str = "unknown"; | |
241 | ||
242 | GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str); | |
243 | } | |
244 | return ret; | |
245 | } | |
246 | ||
8af55556 TZ |
247 | /* convert an integer error to a Lisp_Object; it will be either a |
248 | known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or | |
249 | simply the integer value of the error. GNUTLS_E_SUCCESS is mapped | |
250 | to Qt. */ | |
74f1829d | 251 | static Lisp_Object |
ec8df744 | 252 | gnutls_make_error (int err) |
8af55556 | 253 | { |
ec8df744 | 254 | switch (err) |
e6059fa2 LMI |
255 | { |
256 | case GNUTLS_E_SUCCESS: | |
257 | return Qt; | |
258 | case GNUTLS_E_AGAIN: | |
259 | return Qgnutls_e_again; | |
260 | case GNUTLS_E_INTERRUPTED: | |
261 | return Qgnutls_e_interrupted; | |
262 | case GNUTLS_E_INVALID_SESSION: | |
263 | return Qgnutls_e_invalid_session; | |
264 | } | |
8af55556 | 265 | |
ec8df744 | 266 | return make_number (err); |
8af55556 TZ |
267 | } |
268 | ||
269 | DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0, | |
74f1829d | 270 | doc: /* Return the GnuTLS init stage of process PROC. |
8af55556 | 271 | See also `gnutls-boot'. */) |
74f1829d | 272 | (Lisp_Object proc) |
8af55556 TZ |
273 | { |
274 | CHECK_PROCESS (proc); | |
275 | ||
276 | return make_number (GNUTLS_INITSTAGE (proc)); | |
277 | } | |
278 | ||
279 | DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0, | |
74f1829d JB |
280 | doc: /* Return t if ERROR indicates a GnuTLS problem. |
281 | ERROR is an integer or a symbol with an integer `gnutls-code' property. | |
282 | usage: (gnutls-errorp ERROR) */) | |
283 | (Lisp_Object err) | |
8af55556 | 284 | { |
74f1829d | 285 | if (EQ (err, Qt)) return Qnil; |
8af55556 TZ |
286 | |
287 | return Qt; | |
288 | } | |
289 | ||
290 | DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0, | |
74f1829d JB |
291 | doc: /* Check if ERROR is fatal. |
292 | ERROR is an integer or a symbol with an integer `gnutls-code' property. | |
293 | usage: (gnutls-error-fatalp ERROR) */) | |
294 | (Lisp_Object err) | |
8af55556 TZ |
295 | { |
296 | Lisp_Object code; | |
297 | ||
298 | if (EQ (err, Qt)) return Qnil; | |
299 | ||
300 | if (SYMBOLP (err)) | |
8af55556 | 301 | { |
e6059fa2 LMI |
302 | code = Fget (err, Qgnutls_code); |
303 | if (NUMBERP (code)) | |
304 | { | |
305 | err = code; | |
306 | } | |
307 | else | |
308 | { | |
309 | error ("Symbol has no numeric gnutls-code property"); | |
310 | } | |
8af55556 | 311 | } |
8af55556 TZ |
312 | |
313 | if (!NUMBERP (err)) | |
314 | error ("Not an error symbol or code"); | |
315 | ||
316 | if (0 == gnutls_error_is_fatal (XINT (err))) | |
317 | return Qnil; | |
318 | ||
319 | return Qt; | |
320 | } | |
321 | ||
322 | DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0, | |
74f1829d JB |
323 | doc: /* Return a description of ERROR. |
324 | ERROR is an integer or a symbol with an integer `gnutls-code' property. | |
325 | usage: (gnutls-error-string ERROR) */) | |
326 | (Lisp_Object err) | |
8af55556 TZ |
327 | { |
328 | Lisp_Object code; | |
329 | ||
330 | if (EQ (err, Qt)) return build_string ("Not an error"); | |
331 | ||
332 | if (SYMBOLP (err)) | |
8af55556 | 333 | { |
e6059fa2 LMI |
334 | code = Fget (err, Qgnutls_code); |
335 | if (NUMBERP (code)) | |
336 | { | |
337 | err = code; | |
338 | } | |
339 | else | |
340 | { | |
341 | return build_string ("Symbol has no numeric gnutls-code property"); | |
342 | } | |
8af55556 | 343 | } |
8af55556 TZ |
344 | |
345 | if (!NUMBERP (err)) | |
346 | return build_string ("Not an error symbol or code"); | |
347 | ||
348 | return build_string (gnutls_strerror (XINT (err))); | |
349 | } | |
350 | ||
351 | DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0, | |
e1b69165 | 352 | doc: /* Deallocate GnuTLS resources associated with process PROC. |
8af55556 | 353 | See also `gnutls-init'. */) |
74f1829d | 354 | (Lisp_Object proc) |
8af55556 TZ |
355 | { |
356 | gnutls_session_t state; | |
357 | ||
358 | CHECK_PROCESS (proc); | |
359 | state = XPROCESS (proc)->gnutls_state; | |
360 | ||
361 | if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT) | |
e6059fa2 | 362 | { |
8af55556 TZ |
363 | gnutls_deinit (state); |
364 | GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1; | |
e6059fa2 | 365 | } |
8af55556 TZ |
366 | |
367 | return Qt; | |
368 | } | |
369 | ||
e1b69165 JB |
370 | /* Initializes global GnuTLS state to defaults. |
371 | Call `gnutls-global-deinit' when GnuTLS usage is no longer needed. | |
8af55556 | 372 | Returns zero on success. */ |
74f1829d | 373 | static Lisp_Object |
e061a11b | 374 | emacs_gnutls_global_init (void) |
8af55556 TZ |
375 | { |
376 | int ret = GNUTLS_E_SUCCESS; | |
377 | ||
e061a11b | 378 | if (!gnutls_global_initialized) |
8af55556 TZ |
379 | ret = gnutls_global_init (); |
380 | ||
e061a11b | 381 | gnutls_global_initialized = 1; |
8af55556 TZ |
382 | |
383 | return gnutls_make_error (ret); | |
384 | } | |
385 | ||
ec8df744 | 386 | #if 0 |
e1b69165 | 387 | /* Deinitializes global GnuTLS state. |
8af55556 | 388 | See also `gnutls-global-init'. */ |
74f1829d | 389 | static Lisp_Object |
e061a11b | 390 | emacs_gnutls_global_deinit (void) |
8af55556 | 391 | { |
e061a11b | 392 | if (gnutls_global_initialized) |
8af55556 TZ |
393 | gnutls_global_deinit (); |
394 | ||
e061a11b | 395 | gnutls_global_initialized = 0; |
8af55556 TZ |
396 | |
397 | return gnutls_make_error (GNUTLS_E_SUCCESS); | |
398 | } | |
ec8df744 | 399 | #endif |
8af55556 | 400 | |
c1ae068b LMI |
401 | DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0, |
402 | doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST. | |
8af55556 TZ |
403 | Currently only client mode is supported. Returns a success/failure |
404 | value you can check with `gnutls-errorp'. | |
405 | ||
c1ae068b LMI |
406 | TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'. |
407 | PROPLIST is a property list with the following keys: | |
408 | ||
e061a11b TZ |
409 | :hostname is a string naming the remote host. |
410 | ||
c1ae068b | 411 | :priority is a GnuTLS priority string, defaults to "NORMAL". |
e061a11b | 412 | |
c1ae068b | 413 | :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'. |
e061a11b | 414 | |
c1ae068b | 415 | :keyfiles is a list of PEM-encoded key files for `gnutls-x509pki'. |
e061a11b TZ |
416 | |
417 | :callbacks is an alist of callback functions, see below. | |
418 | ||
c1ae068b | 419 | :loglevel is the debug level requested from GnuTLS, try 4. |
8ed70bf3 | 420 | |
e061a11b TZ |
421 | :verify-flags is a bitset as per GnuTLS' |
422 | gnutls_certificate_set_verify_flags. | |
423 | ||
424 | :verify-error, if non-nil, makes failure of the certificate validation | |
425 | an error. Otherwise it will be just a series of warnings. | |
426 | ||
427 | :verify-hostname-error, if non-nil, makes a hostname mismatch an | |
428 | error. Otherwise it will be just a warning. | |
429 | ||
c1ae068b LMI |
430 | The debug level will be set for this process AND globally for GnuTLS. |
431 | So if you set it higher or lower at any point, it affects global | |
432 | debugging. | |
8af55556 TZ |
433 | |
434 | Note that the priority is set on the client. The server does not use | |
435 | the protocols's priority except for disabling protocols that were not | |
436 | specified. | |
437 | ||
74f1829d | 438 | Processes must be initialized with this function before other GnuTLS |
8af55556 TZ |
439 | functions are used. This function allocates resources which can only |
440 | be deallocated by calling `gnutls-deinit' or by calling it again. | |
441 | ||
e061a11b TZ |
442 | The callbacks alist can have a `verify' key, associated with a |
443 | verification function (UNUSED). | |
444 | ||
8af55556 | 445 | Each authentication type may need additional information in order to |
c1ae068b LMI |
446 | work. For X.509 PKI (`gnutls-x509pki'), you probably need at least |
447 | one trustfile (usually a CA bundle). */) | |
448 | (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist) | |
8af55556 TZ |
449 | { |
450 | int ret = GNUTLS_E_SUCCESS; | |
451 | ||
8ed70bf3 LMI |
452 | int max_log_level = 0; |
453 | ||
8af55556 TZ |
454 | /* TODO: GNUTLS_X509_FMT_DER is also an option. */ |
455 | int file_format = GNUTLS_X509_FMT_PEM; | |
456 | ||
e061a11b TZ |
457 | unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT; |
458 | gnutls_x509_crt_t gnutls_verify_cert; | |
459 | unsigned int gnutls_verify_cert_list_size; | |
460 | const gnutls_datum_t *gnutls_verify_cert_list; | |
461 | ||
8af55556 TZ |
462 | gnutls_session_t state; |
463 | gnutls_certificate_credentials_t x509_cred; | |
464 | gnutls_anon_client_credentials_t anon_cred; | |
8af55556 | 465 | Lisp_Object global_init; |
ec8df744 | 466 | char const *priority_string_ptr = "NORMAL"; /* default priority string. */ |
c1ae068b | 467 | Lisp_Object tail; |
7754e151 | 468 | unsigned int peer_verification; |
e061a11b | 469 | char* c_hostname; |
c1ae068b LMI |
470 | |
471 | /* Placeholders for the property list elements. */ | |
472 | Lisp_Object priority_string; | |
473 | Lisp_Object trustfiles; | |
474 | Lisp_Object keyfiles; | |
ec8df744 | 475 | /* Lisp_Object callbacks; */ |
c1ae068b | 476 | Lisp_Object loglevel; |
e061a11b TZ |
477 | Lisp_Object hostname; |
478 | Lisp_Object verify_flags; | |
8d4c3955 | 479 | /* Lisp_Object verify_error; */ |
e061a11b | 480 | Lisp_Object verify_hostname_error; |
8af55556 TZ |
481 | |
482 | CHECK_PROCESS (proc); | |
483 | CHECK_SYMBOL (type); | |
c1ae068b LMI |
484 | CHECK_LIST (proplist); |
485 | ||
e061a11b TZ |
486 | hostname = Fplist_get (proplist, Qgnutls_bootprop_hostname); |
487 | priority_string = Fplist_get (proplist, Qgnutls_bootprop_priority); | |
488 | trustfiles = Fplist_get (proplist, Qgnutls_bootprop_trustfiles); | |
489 | keyfiles = Fplist_get (proplist, Qgnutls_bootprop_keyfiles); | |
671875da | 490 | /* callbacks = Fplist_get (proplist, Qgnutls_bootprop_callbacks); */ |
e061a11b TZ |
491 | loglevel = Fplist_get (proplist, Qgnutls_bootprop_loglevel); |
492 | verify_flags = Fplist_get (proplist, Qgnutls_bootprop_verify_flags); | |
bafcf6a5 | 493 | /* verify_error = Fplist_get (proplist, Qgnutls_bootprop_verify_error); */ |
e061a11b TZ |
494 | verify_hostname_error = Fplist_get (proplist, Qgnutls_bootprop_verify_hostname_error); |
495 | ||
496 | if (!STRINGP (hostname)) | |
497 | error ("gnutls-boot: invalid :hostname parameter"); | |
498 | ||
499 | c_hostname = SSDATA (hostname); | |
8af55556 TZ |
500 | |
501 | state = XPROCESS (proc)->gnutls_state; | |
df7fcaff | 502 | XPROCESS (proc)->gnutls_p = 1; |
8af55556 | 503 | |
8ed70bf3 LMI |
504 | if (NUMBERP (loglevel)) |
505 | { | |
8ed70bf3 LMI |
506 | gnutls_global_set_log_function (gnutls_log_function); |
507 | gnutls_global_set_log_level (XINT (loglevel)); | |
508 | max_log_level = XINT (loglevel); | |
509 | XPROCESS (proc)->gnutls_log_level = max_log_level; | |
510 | } | |
df7fcaff | 511 | |
8af55556 | 512 | /* always initialize globals. */ |
e061a11b | 513 | global_init = emacs_gnutls_global_init (); |
8af55556 TZ |
514 | if (! NILP (Fgnutls_errorp (global_init))) |
515 | return global_init; | |
516 | ||
517 | /* deinit and free resources. */ | |
518 | if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_CRED_ALLOC) | |
e6059fa2 | 519 | { |
8ed70bf3 LMI |
520 | GNUTLS_LOG (1, max_log_level, "deallocating credentials"); |
521 | ||
8af55556 | 522 | if (EQ (type, Qgnutls_x509pki)) |
e6059fa2 | 523 | { |
8ed70bf3 LMI |
524 | GNUTLS_LOG (2, max_log_level, "deallocating x509 credentials"); |
525 | x509_cred = XPROCESS (proc)->gnutls_x509_cred; | |
8af55556 | 526 | gnutls_certificate_free_credentials (x509_cred); |
e6059fa2 | 527 | } |
8af55556 | 528 | else if (EQ (type, Qgnutls_anon)) |
e6059fa2 | 529 | { |
8ed70bf3 LMI |
530 | GNUTLS_LOG (2, max_log_level, "deallocating anon credentials"); |
531 | anon_cred = XPROCESS (proc)->gnutls_anon_cred; | |
8af55556 | 532 | gnutls_anon_free_client_credentials (anon_cred); |
e6059fa2 | 533 | } |
8af55556 | 534 | else |
e6059fa2 | 535 | { |
8af55556 TZ |
536 | error ("unknown credential type"); |
537 | ret = GNUTLS_EMACS_ERROR_INVALID_TYPE; | |
e6059fa2 | 538 | } |
8af55556 TZ |
539 | |
540 | if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT) | |
e6059fa2 | 541 | { |
8ed70bf3 | 542 | GNUTLS_LOG (1, max_log_level, "deallocating x509 credentials"); |
8af55556 | 543 | Fgnutls_deinit (proc); |
e6059fa2 LMI |
544 | } |
545 | } | |
8af55556 TZ |
546 | |
547 | GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY; | |
548 | ||
8ed70bf3 LMI |
549 | GNUTLS_LOG (1, max_log_level, "allocating credentials"); |
550 | ||
8af55556 | 551 | if (EQ (type, Qgnutls_x509pki)) |
e6059fa2 | 552 | { |
8ed70bf3 LMI |
553 | GNUTLS_LOG (2, max_log_level, "allocating x509 credentials"); |
554 | x509_cred = XPROCESS (proc)->gnutls_x509_cred; | |
8af55556 TZ |
555 | if (gnutls_certificate_allocate_credentials (&x509_cred) < 0) |
556 | memory_full (); | |
e061a11b TZ |
557 | |
558 | if (NUMBERP (verify_flags)) | |
559 | { | |
560 | gnutls_verify_flags = XINT (verify_flags); | |
561 | GNUTLS_LOG (2, max_log_level, "setting verification flags"); | |
562 | } | |
563 | else if (NILP (verify_flags)) | |
564 | { | |
565 | /* The default is already GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT. */ | |
566 | GNUTLS_LOG (2, max_log_level, "using default verification flags"); | |
567 | } | |
568 | else | |
569 | { | |
570 | /* The default is already GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT. */ | |
571 | GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags"); | |
572 | } | |
573 | gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags); | |
e6059fa2 | 574 | } |
8af55556 | 575 | else if (EQ (type, Qgnutls_anon)) |
e6059fa2 | 576 | { |
8ed70bf3 LMI |
577 | GNUTLS_LOG (2, max_log_level, "allocating anon credentials"); |
578 | anon_cred = XPROCESS (proc)->gnutls_anon_cred; | |
8af55556 TZ |
579 | if (gnutls_anon_allocate_client_credentials (&anon_cred) < 0) |
580 | memory_full (); | |
e6059fa2 | 581 | } |
8af55556 | 582 | else |
e6059fa2 | 583 | { |
8af55556 TZ |
584 | error ("unknown credential type"); |
585 | ret = GNUTLS_EMACS_ERROR_INVALID_TYPE; | |
e6059fa2 | 586 | } |
8af55556 TZ |
587 | |
588 | if (ret < GNUTLS_E_SUCCESS) | |
e6059fa2 | 589 | return gnutls_make_error (ret); |
8af55556 TZ |
590 | |
591 | GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC; | |
592 | ||
8af55556 | 593 | if (EQ (type, Qgnutls_x509pki)) |
e6059fa2 | 594 | { |
c1ae068b | 595 | for (tail = trustfiles; !NILP (tail); tail = Fcdr (tail)) |
e6059fa2 | 596 | { |
c1ae068b LMI |
597 | Lisp_Object trustfile = Fcar (tail); |
598 | if (STRINGP (trustfile)) | |
599 | { | |
600 | GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ", | |
ec8df744 | 601 | SSDATA (trustfile)); |
c1ae068b LMI |
602 | ret = gnutls_certificate_set_x509_trust_file |
603 | (x509_cred, | |
ec8df744 | 604 | SSDATA (trustfile), |
c1ae068b | 605 | file_format); |
51b59d79 | 606 | |
c1ae068b LMI |
607 | if (ret < GNUTLS_E_SUCCESS) |
608 | return gnutls_make_error (ret); | |
609 | } | |
610 | else | |
611 | { | |
612 | error ("Sorry, GnuTLS can't use non-string trustfile %s", | |
c4354cb4 | 613 | SDATA (trustfile)); |
c1ae068b LMI |
614 | } |
615 | } | |
8af55556 | 616 | |
c1ae068b | 617 | for (tail = keyfiles; !NILP (tail); tail = Fcdr (tail)) |
e6059fa2 | 618 | { |
c1ae068b LMI |
619 | Lisp_Object keyfile = Fcar (tail); |
620 | if (STRINGP (keyfile)) | |
621 | { | |
622 | GNUTLS_LOG2 (1, max_log_level, "setting the keyfile: ", | |
ec8df744 | 623 | SSDATA (keyfile)); |
c1ae068b LMI |
624 | ret = gnutls_certificate_set_x509_crl_file |
625 | (x509_cred, | |
ec8df744 | 626 | SSDATA (keyfile), |
c1ae068b | 627 | file_format); |
51b59d79 | 628 | |
c1ae068b LMI |
629 | if (ret < GNUTLS_E_SUCCESS) |
630 | return gnutls_make_error (ret); | |
631 | } | |
632 | else | |
633 | { | |
634 | error ("Sorry, GnuTLS can't use non-string keyfile %s", | |
c4354cb4 | 635 | SDATA (keyfile)); |
c1ae068b LMI |
636 | } |
637 | } | |
e6059fa2 | 638 | } |
8af55556 TZ |
639 | |
640 | GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES; | |
641 | ||
e061a11b TZ |
642 | GNUTLS_LOG (1, max_log_level, "gnutls callbacks"); |
643 | ||
644 | GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS; | |
645 | ||
646 | #ifdef HAVE_GNUTLS_CALLBACK_CERTIFICATE_VERIFY | |
647 | #else | |
648 | #endif | |
649 | ||
8ed70bf3 LMI |
650 | GNUTLS_LOG (1, max_log_level, "gnutls_init"); |
651 | ||
8af55556 TZ |
652 | ret = gnutls_init (&state, GNUTLS_CLIENT); |
653 | ||
654 | if (ret < GNUTLS_E_SUCCESS) | |
e6059fa2 | 655 | return gnutls_make_error (ret); |
8af55556 TZ |
656 | |
657 | XPROCESS (proc)->gnutls_state = state; | |
658 | ||
659 | GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT; | |
660 | ||
c1ae068b LMI |
661 | if (STRINGP (priority_string)) |
662 | { | |
51b59d79 | 663 | priority_string_ptr = SSDATA (priority_string); |
c1ae068b LMI |
664 | GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:", |
665 | priority_string_ptr); | |
666 | } | |
667 | else | |
668 | { | |
669 | GNUTLS_LOG2 (1, max_log_level, "using default priority string:", | |
670 | priority_string_ptr); | |
671 | } | |
51b59d79 | 672 | |
8ed70bf3 LMI |
673 | GNUTLS_LOG (1, max_log_level, "setting the priority string"); |
674 | ||
74f1829d | 675 | ret = gnutls_priority_set_direct (state, |
c1ae068b | 676 | priority_string_ptr, |
74f1829d | 677 | NULL); |
8af55556 TZ |
678 | |
679 | if (ret < GNUTLS_E_SUCCESS) | |
e6059fa2 | 680 | return gnutls_make_error (ret); |
8af55556 TZ |
681 | |
682 | GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY; | |
683 | ||
8af55556 | 684 | if (EQ (type, Qgnutls_x509pki)) |
e6059fa2 | 685 | { |
8af55556 | 686 | ret = gnutls_cred_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred); |
e6059fa2 | 687 | } |
8af55556 | 688 | else if (EQ (type, Qgnutls_anon)) |
e6059fa2 | 689 | { |
8af55556 | 690 | ret = gnutls_cred_set (state, GNUTLS_CRD_ANON, anon_cred); |
e6059fa2 | 691 | } |
8af55556 | 692 | else |
e6059fa2 | 693 | { |
8af55556 TZ |
694 | error ("unknown credential type"); |
695 | ret = GNUTLS_EMACS_ERROR_INVALID_TYPE; | |
e6059fa2 | 696 | } |
8af55556 TZ |
697 | |
698 | if (ret < GNUTLS_E_SUCCESS) | |
e6059fa2 | 699 | return gnutls_make_error (ret); |
8af55556 | 700 | |
8ed70bf3 LMI |
701 | XPROCESS (proc)->gnutls_anon_cred = anon_cred; |
702 | XPROCESS (proc)->gnutls_x509_cred = x509_cred; | |
8af55556 TZ |
703 | XPROCESS (proc)->gnutls_cred_type = type; |
704 | ||
705 | GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET; | |
706 | ||
e061a11b | 707 | ret = emacs_gnutls_handshake (XPROCESS (proc)); |
bac5cef8 | 708 | |
e061a11b TZ |
709 | if (ret < GNUTLS_E_SUCCESS) |
710 | return gnutls_make_error (ret); | |
711 | ||
712 | /* Now verify the peer, following | |
713 | http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html. | |
714 | The peer should present at least one certificate in the chain; do a | |
715 | check of the certificate's hostname with | |
716 | gnutls_x509_crt_check_hostname() against :hostname. */ | |
717 | ||
718 | ret = gnutls_certificate_verify_peers2 (state, &peer_verification); | |
719 | ||
720 | if (ret < GNUTLS_E_SUCCESS) | |
721 | return gnutls_make_error (ret); | |
671875da | 722 | |
e061a11b | 723 | if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID) |
671875da | 724 | message ("%s certificate could not be verified.", |
e061a11b | 725 | c_hostname); |
671875da | 726 | |
e061a11b TZ |
727 | if (peer_verification & GNUTLS_CERT_REVOKED) |
728 | GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):", | |
729 | c_hostname); | |
671875da | 730 | |
e061a11b TZ |
731 | if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND) |
732 | GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:", | |
733 | c_hostname); | |
671875da | 734 | |
e061a11b TZ |
735 | if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA) |
736 | GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:", | |
737 | c_hostname); | |
738 | ||
739 | if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM) | |
740 | GNUTLS_LOG2 (1, max_log_level, | |
741 | "certificate was signed with an insecure algorithm:", | |
742 | c_hostname); | |
743 | ||
744 | if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED) | |
745 | GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:", | |
746 | c_hostname); | |
747 | ||
748 | if (peer_verification & GNUTLS_CERT_EXPIRED) | |
749 | GNUTLS_LOG2 (1, max_log_level, "certificate has expired:", | |
750 | c_hostname); | |
751 | ||
752 | if (peer_verification != 0) | |
753 | { | |
754 | if (NILP (verify_hostname_error)) | |
755 | { | |
756 | GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:", | |
757 | c_hostname); | |
758 | } | |
759 | else | |
760 | { | |
761 | error ("Certificate validation failed %s, verification code %d", | |
762 | c_hostname, peer_verification); | |
763 | } | |
764 | } | |
765 | ||
766 | /* Up to here the process is the same for X.509 certificates and | |
767 | OpenPGP keys. From now on X.509 certificates are assumed. This | |
768 | can be easily extended to work with openpgp keys as well. */ | |
769 | if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509) | |
770 | { | |
771 | ret = gnutls_x509_crt_init (&gnutls_verify_cert); | |
772 | ||
773 | if (ret < GNUTLS_E_SUCCESS) | |
774 | return gnutls_make_error (ret); | |
775 | ||
671875da | 776 | gnutls_verify_cert_list = |
e061a11b TZ |
777 | gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size); |
778 | ||
779 | if (NULL == gnutls_verify_cert_list) | |
780 | { | |
781 | error ("No x509 certificate was found!\n"); | |
782 | } | |
783 | ||
784 | /* We only check the first certificate in the given chain. */ | |
785 | ret = gnutls_x509_crt_import (gnutls_verify_cert, | |
786 | &gnutls_verify_cert_list[0], | |
787 | GNUTLS_X509_FMT_DER); | |
788 | ||
789 | if (ret < GNUTLS_E_SUCCESS) | |
790 | { | |
791 | gnutls_x509_crt_deinit (gnutls_verify_cert); | |
792 | return gnutls_make_error (ret); | |
793 | } | |
794 | ||
795 | if (!gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname)) | |
796 | { | |
797 | if (NILP (verify_hostname_error)) | |
798 | { | |
799 | GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:", | |
800 | c_hostname); | |
801 | } | |
802 | else | |
803 | { | |
804 | gnutls_x509_crt_deinit (gnutls_verify_cert); | |
805 | error ("The x509 certificate does not match \"%s\"", | |
806 | c_hostname); | |
807 | } | |
808 | } | |
809 | ||
810 | gnutls_x509_crt_deinit (gnutls_verify_cert); | |
811 | } | |
812 | ||
813 | return gnutls_make_error (ret); | |
8af55556 TZ |
814 | } |
815 | ||
816 | DEFUN ("gnutls-bye", Fgnutls_bye, | |
817 | Sgnutls_bye, 2, 2, 0, | |
74f1829d | 818 | doc: /* Terminate current GnuTLS connection for process PROC. |
8af55556 TZ |
819 | The connection should have been initiated using `gnutls-handshake'. |
820 | ||
821 | If CONT is not nil the TLS connection gets terminated and further | |
74f1829d | 822 | receives and sends will be disallowed. If the return value is zero you |
8af55556 TZ |
823 | may continue using the connection. If CONT is nil, GnuTLS actually |
824 | sends an alert containing a close request and waits for the peer to | |
825 | reply with the same message. In order to reuse the connection you | |
826 | should wait for an EOF from the peer. | |
827 | ||
828 | This function may also return `gnutls-e-again', or | |
829 | `gnutls-e-interrupted'. */) | |
830 | (Lisp_Object proc, Lisp_Object cont) | |
831 | { | |
832 | gnutls_session_t state; | |
833 | int ret; | |
834 | ||
835 | CHECK_PROCESS (proc); | |
836 | ||
837 | state = XPROCESS (proc)->gnutls_state; | |
838 | ||
839 | ret = gnutls_bye (state, | |
840 | NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR); | |
841 | ||
842 | return gnutls_make_error (ret); | |
843 | } | |
844 | ||
8af55556 TZ |
845 | void |
846 | syms_of_gnutls (void) | |
847 | { | |
e061a11b TZ |
848 | gnutls_global_initialized = 0; |
849 | ||
850 | Qgnutls_log_level = intern_c_string ("gnutls-log-level"); | |
851 | staticpro (&Qgnutls_log_level); | |
8af55556 TZ |
852 | |
853 | Qgnutls_code = intern_c_string ("gnutls-code"); | |
854 | staticpro (&Qgnutls_code); | |
855 | ||
856 | Qgnutls_anon = intern_c_string ("gnutls-anon"); | |
857 | staticpro (&Qgnutls_anon); | |
858 | ||
859 | Qgnutls_x509pki = intern_c_string ("gnutls-x509pki"); | |
860 | staticpro (&Qgnutls_x509pki); | |
861 | ||
e061a11b TZ |
862 | Qgnutls_bootprop_hostname = intern_c_string (":hostname"); |
863 | staticpro (&Qgnutls_bootprop_hostname); | |
864 | ||
b845653d | 865 | Qgnutls_bootprop_priority = intern_c_string (":priority"); |
c1ae068b LMI |
866 | staticpro (&Qgnutls_bootprop_priority); |
867 | ||
b845653d | 868 | Qgnutls_bootprop_trustfiles = intern_c_string (":trustfiles"); |
c1ae068b LMI |
869 | staticpro (&Qgnutls_bootprop_trustfiles); |
870 | ||
b845653d | 871 | Qgnutls_bootprop_keyfiles = intern_c_string (":keyfiles"); |
c1ae068b LMI |
872 | staticpro (&Qgnutls_bootprop_keyfiles); |
873 | ||
b845653d | 874 | Qgnutls_bootprop_callbacks = intern_c_string (":callbacks"); |
c1ae068b LMI |
875 | staticpro (&Qgnutls_bootprop_callbacks); |
876 | ||
e061a11b TZ |
877 | Qgnutls_bootprop_callbacks_verify = intern_c_string ("verify"); |
878 | staticpro (&Qgnutls_bootprop_callbacks_verify); | |
879 | ||
b845653d | 880 | Qgnutls_bootprop_loglevel = intern_c_string (":loglevel"); |
c1ae068b LMI |
881 | staticpro (&Qgnutls_bootprop_loglevel); |
882 | ||
e061a11b TZ |
883 | Qgnutls_bootprop_verify_flags = intern_c_string (":verify-flags"); |
884 | staticpro (&Qgnutls_bootprop_verify_flags); | |
885 | ||
886 | Qgnutls_bootprop_verify_hostname_error = intern_c_string (":verify-error"); | |
887 | staticpro (&Qgnutls_bootprop_verify_error); | |
888 | ||
889 | Qgnutls_bootprop_verify_hostname_error = intern_c_string (":verify-hostname-error"); | |
890 | staticpro (&Qgnutls_bootprop_verify_hostname_error); | |
891 | ||
8af55556 TZ |
892 | Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted"); |
893 | staticpro (&Qgnutls_e_interrupted); | |
894 | Fput (Qgnutls_e_interrupted, Qgnutls_code, | |
895 | make_number (GNUTLS_E_INTERRUPTED)); | |
896 | ||
897 | Qgnutls_e_again = intern_c_string ("gnutls-e-again"); | |
898 | staticpro (&Qgnutls_e_again); | |
899 | Fput (Qgnutls_e_again, Qgnutls_code, | |
900 | make_number (GNUTLS_E_AGAIN)); | |
901 | ||
902 | Qgnutls_e_invalid_session = intern_c_string ("gnutls-e-invalid-session"); | |
903 | staticpro (&Qgnutls_e_invalid_session); | |
904 | Fput (Qgnutls_e_invalid_session, Qgnutls_code, | |
905 | make_number (GNUTLS_E_INVALID_SESSION)); | |
906 | ||
907 | Qgnutls_e_not_ready_for_handshake = | |
908 | intern_c_string ("gnutls-e-not-ready-for-handshake"); | |
909 | staticpro (&Qgnutls_e_not_ready_for_handshake); | |
910 | Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code, | |
911 | make_number (GNUTLS_E_APPLICATION_ERROR_MIN)); | |
912 | ||
913 | defsubr (&Sgnutls_get_initstage); | |
914 | defsubr (&Sgnutls_errorp); | |
915 | defsubr (&Sgnutls_error_fatalp); | |
916 | defsubr (&Sgnutls_error_string); | |
917 | defsubr (&Sgnutls_boot); | |
918 | defsubr (&Sgnutls_deinit); | |
8af55556 TZ |
919 | defsubr (&Sgnutls_bye); |
920 | } | |
bafcf6a5 JB |
921 | |
922 | #endif /* HAVE_GNUTLS */ |