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