1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2012 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
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.
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.
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/>. */
26 #include <gnutls/gnutls.h>
33 static bool emacs_gnutls_handle_error (gnutls_session_t
, int);
35 static Lisp_Object Qgnutls_dll
;
36 static Lisp_Object Qgnutls_code
;
37 static Lisp_Object Qgnutls_anon
, Qgnutls_x509pki
;
38 static Lisp_Object Qgnutls_e_interrupted
, Qgnutls_e_again
,
39 Qgnutls_e_invalid_session
, Qgnutls_e_not_ready_for_handshake
;
40 static bool gnutls_global_initialized
;
42 /* The following are for the property list of `gnutls-boot'. */
43 static Lisp_Object QCgnutls_bootprop_priority
;
44 static Lisp_Object QCgnutls_bootprop_trustfiles
;
45 static Lisp_Object QCgnutls_bootprop_keylist
;
46 static Lisp_Object QCgnutls_bootprop_crlfiles
;
47 static Lisp_Object QCgnutls_bootprop_callbacks
;
48 static Lisp_Object QCgnutls_bootprop_loglevel
;
49 static Lisp_Object QCgnutls_bootprop_hostname
;
50 static Lisp_Object QCgnutls_bootprop_min_prime_bits
;
51 static Lisp_Object QCgnutls_bootprop_verify_flags
;
52 static Lisp_Object QCgnutls_bootprop_verify_hostname_error
;
54 /* Callback keys for `gnutls-boot'. Unused currently. */
55 static Lisp_Object QCgnutls_bootprop_callbacks_verify
;
57 static void gnutls_log_function (int, const char *);
58 static void gnutls_log_function2 (int, const char*, const char*);
63 /* Macro for defining functions that will be loaded from the GnuTLS DLL. */
64 #define DEF_GNUTLS_FN(rettype,func,args) static rettype (FAR CDECL *fn_##func)args
66 /* Macro for loading GnuTLS functions from the library. */
67 #define LOAD_GNUTLS_FN(lib,func) { \
68 fn_##func = (void *) GetProcAddress (lib, #func); \
69 if (!fn_##func) return 0; \
72 DEF_GNUTLS_FN (gnutls_alert_description_t
, gnutls_alert_get
,
74 DEF_GNUTLS_FN (const char *, gnutls_alert_get_name
,
75 (gnutls_alert_description_t
));
76 DEF_GNUTLS_FN (int, gnutls_alert_send_appropriate
, (gnutls_session_t
, int));
77 DEF_GNUTLS_FN (int, gnutls_anon_allocate_client_credentials
,
78 (gnutls_anon_client_credentials_t
*));
79 DEF_GNUTLS_FN (void, gnutls_anon_free_client_credentials
,
80 (gnutls_anon_client_credentials_t
));
81 DEF_GNUTLS_FN (int, gnutls_bye
, (gnutls_session_t
, gnutls_close_request_t
));
82 DEF_GNUTLS_FN (int, gnutls_certificate_allocate_credentials
,
83 (gnutls_certificate_credentials_t
*));
84 DEF_GNUTLS_FN (void, gnutls_certificate_free_credentials
,
85 (gnutls_certificate_credentials_t
));
86 DEF_GNUTLS_FN (const gnutls_datum_t
*, gnutls_certificate_get_peers
,
87 (gnutls_session_t
, unsigned int *));
88 DEF_GNUTLS_FN (void, gnutls_certificate_set_verify_flags
,
89 (gnutls_certificate_credentials_t
, unsigned int));
90 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_crl_file
,
91 (gnutls_certificate_credentials_t
, const char *,
92 gnutls_x509_crt_fmt_t
));
93 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_key_file
,
94 (gnutls_certificate_credentials_t
, const char *, const char *,
95 gnutls_x509_crt_fmt_t
));
96 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_trust_file
,
97 (gnutls_certificate_credentials_t
, const char *,
98 gnutls_x509_crt_fmt_t
));
99 DEF_GNUTLS_FN (gnutls_certificate_type_t
, gnutls_certificate_type_get
,
101 DEF_GNUTLS_FN (int, gnutls_certificate_verify_peers2
,
102 (gnutls_session_t
, unsigned int *));
103 DEF_GNUTLS_FN (int, gnutls_credentials_set
,
104 (gnutls_session_t
, gnutls_credentials_type_t
, void *));
105 DEF_GNUTLS_FN (void, gnutls_deinit
, (gnutls_session_t
));
106 DEF_GNUTLS_FN (void, gnutls_dh_set_prime_bits
,
107 (gnutls_session_t
, unsigned int));
108 DEF_GNUTLS_FN (int, gnutls_error_is_fatal
, (int));
109 DEF_GNUTLS_FN (int, gnutls_global_init
, (void));
110 DEF_GNUTLS_FN (void, gnutls_global_set_log_function
, (gnutls_log_func
));
111 DEF_GNUTLS_FN (void, gnutls_global_set_log_level
, (int));
112 DEF_GNUTLS_FN (void, gnutls_global_set_mem_functions
,
113 (gnutls_alloc_function
, gnutls_alloc_function
,
114 gnutls_is_secure_function
, gnutls_realloc_function
,
115 gnutls_free_function
));
116 DEF_GNUTLS_FN (int, gnutls_handshake
, (gnutls_session_t
));
117 DEF_GNUTLS_FN (int, gnutls_init
, (gnutls_session_t
*, gnutls_connection_end_t
));
118 DEF_GNUTLS_FN (int, gnutls_priority_set_direct
,
119 (gnutls_session_t
, const char *, const char **));
120 DEF_GNUTLS_FN (size_t, gnutls_record_check_pending
, (gnutls_session_t
));
121 DEF_GNUTLS_FN (ssize_t
, gnutls_record_recv
, (gnutls_session_t
, void *, size_t));
122 DEF_GNUTLS_FN (ssize_t
, gnutls_record_send
,
123 (gnutls_session_t
, const void *, size_t));
124 DEF_GNUTLS_FN (const char *, gnutls_strerror
, (int));
125 DEF_GNUTLS_FN (void, gnutls_transport_set_errno
, (gnutls_session_t
, int));
126 DEF_GNUTLS_FN (const char *, gnutls_check_version
, (const char *));
127 DEF_GNUTLS_FN (void, gnutls_transport_set_lowat
, (gnutls_session_t
, int));
128 DEF_GNUTLS_FN (void, gnutls_transport_set_ptr2
,
129 (gnutls_session_t
, gnutls_transport_ptr_t
,
130 gnutls_transport_ptr_t
));
131 DEF_GNUTLS_FN (void, gnutls_transport_set_pull_function
,
132 (gnutls_session_t
, gnutls_pull_func
));
133 DEF_GNUTLS_FN (void, gnutls_transport_set_push_function
,
134 (gnutls_session_t
, gnutls_push_func
));
135 DEF_GNUTLS_FN (int, gnutls_x509_crt_check_hostname
,
136 (gnutls_x509_crt_t
, const char *));
137 DEF_GNUTLS_FN (void, gnutls_x509_crt_deinit
, (gnutls_x509_crt_t
));
138 DEF_GNUTLS_FN (int, gnutls_x509_crt_import
,
139 (gnutls_x509_crt_t
, const gnutls_datum_t
*,
140 gnutls_x509_crt_fmt_t
));
141 DEF_GNUTLS_FN (int, gnutls_x509_crt_init
, (gnutls_x509_crt_t
*));
144 init_gnutls_functions (void)
147 int max_log_level
= 1;
149 if (!(library
= w32_delayed_load (Qgnutls_dll
)))
151 GNUTLS_LOG (1, max_log_level
, "GnuTLS library not found");
155 LOAD_GNUTLS_FN (library
, gnutls_alert_get
);
156 LOAD_GNUTLS_FN (library
, gnutls_alert_get_name
);
157 LOAD_GNUTLS_FN (library
, gnutls_alert_send_appropriate
);
158 LOAD_GNUTLS_FN (library
, gnutls_anon_allocate_client_credentials
);
159 LOAD_GNUTLS_FN (library
, gnutls_anon_free_client_credentials
);
160 LOAD_GNUTLS_FN (library
, gnutls_bye
);
161 LOAD_GNUTLS_FN (library
, gnutls_certificate_allocate_credentials
);
162 LOAD_GNUTLS_FN (library
, gnutls_certificate_free_credentials
);
163 LOAD_GNUTLS_FN (library
, gnutls_certificate_get_peers
);
164 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_verify_flags
);
165 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_x509_crl_file
);
166 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_x509_key_file
);
167 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_x509_trust_file
);
168 LOAD_GNUTLS_FN (library
, gnutls_certificate_type_get
);
169 LOAD_GNUTLS_FN (library
, gnutls_certificate_verify_peers2
);
170 LOAD_GNUTLS_FN (library
, gnutls_credentials_set
);
171 LOAD_GNUTLS_FN (library
, gnutls_deinit
);
172 LOAD_GNUTLS_FN (library
, gnutls_dh_set_prime_bits
);
173 LOAD_GNUTLS_FN (library
, gnutls_error_is_fatal
);
174 LOAD_GNUTLS_FN (library
, gnutls_global_init
);
175 LOAD_GNUTLS_FN (library
, gnutls_global_set_log_function
);
176 LOAD_GNUTLS_FN (library
, gnutls_global_set_log_level
);
177 LOAD_GNUTLS_FN (library
, gnutls_global_set_mem_functions
);
178 LOAD_GNUTLS_FN (library
, gnutls_handshake
);
179 LOAD_GNUTLS_FN (library
, gnutls_init
);
180 LOAD_GNUTLS_FN (library
, gnutls_priority_set_direct
);
181 LOAD_GNUTLS_FN (library
, gnutls_record_check_pending
);
182 LOAD_GNUTLS_FN (library
, gnutls_record_recv
);
183 LOAD_GNUTLS_FN (library
, gnutls_record_send
);
184 LOAD_GNUTLS_FN (library
, gnutls_strerror
);
185 LOAD_GNUTLS_FN (library
, gnutls_transport_set_errno
);
186 LOAD_GNUTLS_FN (library
, gnutls_check_version
);
187 /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
188 and later, and the function was removed entirely in 3.0.0. */
189 if (!fn_gnutls_check_version ("2.11.1"))
190 LOAD_GNUTLS_FN (library
, gnutls_transport_set_lowat
);
191 LOAD_GNUTLS_FN (library
, gnutls_transport_set_ptr2
);
192 LOAD_GNUTLS_FN (library
, gnutls_transport_set_pull_function
);
193 LOAD_GNUTLS_FN (library
, gnutls_transport_set_push_function
);
194 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_check_hostname
);
195 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_deinit
);
196 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_import
);
197 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_init
);
199 max_log_level
= global_gnutls_log_level
;
202 Lisp_Object name
= CAR_SAFE (Fget (Qgnutls_dll
, QCloaded_from
));
203 GNUTLS_LOG2 (1, max_log_level
, "GnuTLS library loaded:",
204 STRINGP (name
) ? (const char *) SDATA (name
) : "unknown");
210 #else /* !WINDOWSNT */
212 #define fn_gnutls_alert_get gnutls_alert_get
213 #define fn_gnutls_alert_get_name gnutls_alert_get_name
214 #define fn_gnutls_alert_send_appropriate gnutls_alert_send_appropriate
215 #define fn_gnutls_anon_allocate_client_credentials gnutls_anon_allocate_client_credentials
216 #define fn_gnutls_anon_free_client_credentials gnutls_anon_free_client_credentials
217 #define fn_gnutls_bye gnutls_bye
218 #define fn_gnutls_certificate_allocate_credentials gnutls_certificate_allocate_credentials
219 #define fn_gnutls_certificate_free_credentials gnutls_certificate_free_credentials
220 #define fn_gnutls_certificate_get_peers gnutls_certificate_get_peers
221 #define fn_gnutls_certificate_set_verify_flags gnutls_certificate_set_verify_flags
222 #define fn_gnutls_certificate_set_x509_crl_file gnutls_certificate_set_x509_crl_file
223 #define fn_gnutls_certificate_set_x509_key_file gnutls_certificate_set_x509_key_file
224 #define fn_gnutls_certificate_set_x509_trust_file gnutls_certificate_set_x509_trust_file
225 #define fn_gnutls_certificate_type_get gnutls_certificate_type_get
226 #define fn_gnutls_certificate_verify_peers2 gnutls_certificate_verify_peers2
227 #define fn_gnutls_credentials_set gnutls_credentials_set
228 #define fn_gnutls_deinit gnutls_deinit
229 #define fn_gnutls_dh_set_prime_bits gnutls_dh_set_prime_bits
230 #define fn_gnutls_error_is_fatal gnutls_error_is_fatal
231 #define fn_gnutls_global_init gnutls_global_init
232 #define fn_gnutls_global_set_log_function gnutls_global_set_log_function
233 #define fn_gnutls_global_set_log_level gnutls_global_set_log_level
234 #define fn_gnutls_global_set_mem_functions gnutls_global_set_mem_functions
235 #define fn_gnutls_handshake gnutls_handshake
236 #define fn_gnutls_init gnutls_init
237 #define fn_gnutls_priority_set_direct gnutls_priority_set_direct
238 #define fn_gnutls_record_check_pending gnutls_record_check_pending
239 #define fn_gnutls_record_recv gnutls_record_recv
240 #define fn_gnutls_record_send gnutls_record_send
241 #define fn_gnutls_strerror gnutls_strerror
242 #define fn_gnutls_transport_set_errno gnutls_transport_set_errno
243 #define fn_gnutls_transport_set_ptr2 gnutls_transport_set_ptr2
244 #define fn_gnutls_x509_crt_check_hostname gnutls_x509_crt_check_hostname
245 #define fn_gnutls_x509_crt_deinit gnutls_x509_crt_deinit
246 #define fn_gnutls_x509_crt_import gnutls_x509_crt_import
247 #define fn_gnutls_x509_crt_init gnutls_x509_crt_init
249 #endif /* !WINDOWSNT */
252 /* Function to log a simple message. */
254 gnutls_log_function (int level
, const char* string
)
256 message ("gnutls.c: [%d] %s", level
, string
);
259 /* Function to log a message and a string. */
261 gnutls_log_function2 (int level
, const char* string
, const char* extra
)
263 message ("gnutls.c: [%d] %s %s", level
, string
, extra
);
266 /* Function to log a message and an integer. */
268 gnutls_log_function2i (int level
, const char* string
, int extra
)
270 message ("gnutls.c: [%d] %s %d", level
, string
, extra
);
274 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
276 gnutls_session_t state
= proc
->gnutls_state
;
279 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
282 if (proc
->gnutls_initstage
< GNUTLS_STAGE_TRANSPORT_POINTERS_SET
)
285 /* On W32 we cannot transfer socket handles between different runtime
286 libraries, so we tell GnuTLS to use our special push/pull
288 fn_gnutls_transport_set_ptr2 (state
,
289 (gnutls_transport_ptr_t
) proc
,
290 (gnutls_transport_ptr_t
) proc
);
291 fn_gnutls_transport_set_push_function (state
, &emacs_gnutls_push
);
292 fn_gnutls_transport_set_pull_function (state
, &emacs_gnutls_pull
);
294 /* For non blocking sockets or other custom made pull/push
295 functions the gnutls_transport_set_lowat must be called, with
296 a zero low water mark value. (GnuTLS 2.10.4 documentation)
298 (Note: this is probably not strictly necessary as the lowat
299 value is only used when no custom pull/push functions are
301 /* According to GnuTLS NEWS file, lowat level has been set to
302 zero by default in version 2.11.1, and the function
303 gnutls_transport_set_lowat was removed from the library in
305 if (!fn_gnutls_check_version ("2.11.1"))
306 fn_gnutls_transport_set_lowat (state
, 0);
308 /* This is how GnuTLS takes sockets: as file descriptors passed
309 in. For an Emacs process socket, infd and outfd are the
310 same but we use this two-argument version for clarity. */
311 fn_gnutls_transport_set_ptr2 (state
,
312 (gnutls_transport_ptr_t
) (long) proc
->infd
,
313 (gnutls_transport_ptr_t
) (long) proc
->outfd
);
316 proc
->gnutls_initstage
= GNUTLS_STAGE_TRANSPORT_POINTERS_SET
;
321 ret
= fn_gnutls_handshake (state
);
322 emacs_gnutls_handle_error (state
, ret
);
325 while (ret
< 0 && fn_gnutls_error_is_fatal (ret
) == 0);
327 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
329 if (ret
== GNUTLS_E_SUCCESS
)
331 /* Here we're finally done. */
332 proc
->gnutls_initstage
= GNUTLS_STAGE_READY
;
336 fn_gnutls_alert_send_appropriate (state
, ret
);
342 emacs_gnutls_record_check_pending (gnutls_session_t state
)
344 return fn_gnutls_record_check_pending (state
);
348 emacs_gnutls_transport_set_errno (gnutls_session_t state
, int err
)
350 fn_gnutls_transport_set_errno (state
, err
);
354 emacs_gnutls_write (struct Lisp_Process
*proc
, const char *buf
, ptrdiff_t nbyte
)
357 ptrdiff_t bytes_written
;
358 gnutls_session_t state
= proc
->gnutls_state
;
360 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
370 rtnval
= fn_gnutls_record_send (state
, buf
, nbyte
);
374 if (rtnval
== GNUTLS_E_INTERRUPTED
)
378 /* If we get GNUTLS_E_AGAIN, then set errno
379 appropriately so that send_process retries the
380 correct way instead of erroring out. */
381 if (rtnval
== GNUTLS_E_AGAIN
)
389 bytes_written
+= rtnval
;
392 emacs_gnutls_handle_error (state
, rtnval
);
393 return (bytes_written
);
397 emacs_gnutls_read (struct Lisp_Process
*proc
, char *buf
, ptrdiff_t nbyte
)
400 gnutls_session_t state
= proc
->gnutls_state
;
402 int log_level
= proc
->gnutls_log_level
;
404 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
406 /* If the handshake count is under the limit, try the handshake
407 again and increment the handshake count. This count is kept
408 per process (connection), not globally. */
409 if (proc
->gnutls_handshakes_tried
< GNUTLS_EMACS_HANDSHAKES_LIMIT
)
411 proc
->gnutls_handshakes_tried
++;
412 emacs_gnutls_handshake (proc
);
413 GNUTLS_LOG2i (5, log_level
, "Retried handshake",
414 proc
->gnutls_handshakes_tried
);
418 GNUTLS_LOG (2, log_level
, "Giving up on handshake; resetting retries");
419 proc
->gnutls_handshakes_tried
= 0;
422 rtnval
= fn_gnutls_record_recv (state
, buf
, nbyte
);
425 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
426 /* The peer closed the connection. */
428 else if (emacs_gnutls_handle_error (state
, rtnval
))
429 /* non-fatal error */
432 /* a fatal error occurred */
437 /* Report a GnuTLS error to the user.
438 Return true if the error code was successfully handled. */
440 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
442 int max_log_level
= 0;
447 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
451 max_log_level
= global_gnutls_log_level
;
453 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
455 str
= fn_gnutls_strerror (err
);
459 if (fn_gnutls_error_is_fatal (err
))
462 GNUTLS_LOG2 (0, max_log_level
, "fatal error:", str
);
467 GNUTLS_LOG2 (1, max_log_level
, "non-fatal error:", str
);
468 /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2. */
471 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
472 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
474 int alert
= fn_gnutls_alert_get (session
);
475 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
476 str
= fn_gnutls_alert_get_name (alert
);
480 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
485 /* convert an integer error to a Lisp_Object; it will be either a
486 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
487 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
490 gnutls_make_error (int err
)
494 case GNUTLS_E_SUCCESS
:
497 return Qgnutls_e_again
;
498 case GNUTLS_E_INTERRUPTED
:
499 return Qgnutls_e_interrupted
;
500 case GNUTLS_E_INVALID_SESSION
:
501 return Qgnutls_e_invalid_session
;
504 return make_number (err
);
508 emacs_gnutls_deinit (Lisp_Object proc
)
512 CHECK_PROCESS (proc
);
514 if (XPROCESS (proc
)->gnutls_p
== 0)
517 log_level
= XPROCESS (proc
)->gnutls_log_level
;
519 if (XPROCESS (proc
)->gnutls_x509_cred
)
521 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
522 fn_gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
523 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
526 if (XPROCESS (proc
)->gnutls_anon_cred
)
528 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
529 fn_gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
530 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
533 if (XPROCESS (proc
)->gnutls_state
)
535 fn_gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
536 XPROCESS (proc
)->gnutls_state
= NULL
;
537 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
538 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
541 XPROCESS (proc
)->gnutls_p
= 0;
545 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
546 doc
: /* Return the GnuTLS init stage of process PROC.
547 See also `gnutls-boot'. */)
550 CHECK_PROCESS (proc
);
552 return make_number (GNUTLS_INITSTAGE (proc
));
555 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
556 doc
: /* Return t if ERROR indicates a GnuTLS problem.
557 ERROR is an integer or a symbol with an integer `gnutls-code' property.
558 usage: (gnutls-errorp ERROR) */)
561 if (EQ (err
, Qt
)) return Qnil
;
566 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
567 doc
: /* Check if ERROR is fatal.
568 ERROR is an integer or a symbol with an integer `gnutls-code' property.
569 usage: (gnutls-error-fatalp ERROR) */)
574 if (EQ (err
, Qt
)) return Qnil
;
578 code
= Fget (err
, Qgnutls_code
);
585 error ("Symbol has no numeric gnutls-code property");
589 if (! TYPE_RANGED_INTEGERP (int, err
))
590 error ("Not an error symbol or code");
592 if (0 == fn_gnutls_error_is_fatal (XINT (err
)))
598 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
599 doc
: /* Return a description of ERROR.
600 ERROR is an integer or a symbol with an integer `gnutls-code' property.
601 usage: (gnutls-error-string ERROR) */)
606 if (EQ (err
, Qt
)) return build_string ("Not an error");
610 code
= Fget (err
, Qgnutls_code
);
617 return build_string ("Symbol has no numeric gnutls-code property");
621 if (! TYPE_RANGED_INTEGERP (int, err
))
622 return build_string ("Not an error symbol or code");
624 return build_string (fn_gnutls_strerror (XINT (err
)));
627 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
628 doc
: /* Deallocate GnuTLS resources associated with process PROC.
629 See also `gnutls-init'. */)
632 return emacs_gnutls_deinit (proc
);
635 DEFUN ("gnutls-available-p", Fgnutls_available_p
, Sgnutls_available_p
, 0, 0, 0,
636 doc
: /* Return t if GnuTLS is available in this instance of Emacs. */)
640 Lisp_Object found
= Fassq (Qgnutls_dll
, Vlibrary_cache
);
646 status
= init_gnutls_functions () ? Qt
: Qnil
;
647 Vlibrary_cache
= Fcons (Fcons (Qgnutls_dll
, status
), Vlibrary_cache
);
656 /* Initializes global GnuTLS state to defaults.
657 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
658 Returns zero on success. */
660 emacs_gnutls_global_init (void)
662 int ret
= GNUTLS_E_SUCCESS
;
664 if (!gnutls_global_initialized
)
666 fn_gnutls_global_set_mem_functions (xmalloc
, xmalloc
, NULL
,
668 ret
= fn_gnutls_global_init ();
670 gnutls_global_initialized
= 1;
672 return gnutls_make_error (ret
);
676 /* Deinitializes global GnuTLS state.
677 See also `gnutls-global-init'. */
679 emacs_gnutls_global_deinit (void)
681 if (gnutls_global_initialized
)
682 gnutls_global_deinit ();
684 gnutls_global_initialized
= 0;
686 return gnutls_make_error (GNUTLS_E_SUCCESS
);
690 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
691 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
692 Currently only client mode is supported. Return a success/failure
693 value you can check with `gnutls-errorp'.
695 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
696 PROPLIST is a property list with the following keys:
698 :hostname is a string naming the remote host.
700 :priority is a GnuTLS priority string, defaults to "NORMAL".
702 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
704 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
706 :keylist is an alist of PEM-encoded key files and PEM-encoded
707 certificates for `gnutls-x509pki'.
709 :callbacks is an alist of callback functions, see below.
711 :loglevel is the debug level requested from GnuTLS, try 4.
713 :verify-flags is a bitset as per GnuTLS'
714 gnutls_certificate_set_verify_flags.
716 :verify-hostname-error, if non-nil, makes a hostname mismatch an
717 error. Otherwise it will be just a warning.
719 :min-prime-bits is the minimum accepted number of bits the client will
720 accept in Diffie-Hellman key exchange.
722 The debug level will be set for this process AND globally for GnuTLS.
723 So if you set it higher or lower at any point, it affects global
726 Note that the priority is set on the client. The server does not use
727 the protocols's priority except for disabling protocols that were not
730 Processes must be initialized with this function before other GnuTLS
731 functions are used. This function allocates resources which can only
732 be deallocated by calling `gnutls-deinit' or by calling it again.
734 The callbacks alist can have a `verify' key, associated with a
735 verification function (UNUSED).
737 Each authentication type may need additional information in order to
738 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
739 one trustfile (usually a CA bundle). */)
740 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
742 int ret
= GNUTLS_E_SUCCESS
;
743 int max_log_level
= 0;
745 gnutls_session_t state
;
746 gnutls_certificate_credentials_t x509_cred
= NULL
;
747 gnutls_anon_client_credentials_t anon_cred
= NULL
;
748 Lisp_Object global_init
;
749 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
750 unsigned int peer_verification
;
753 /* Placeholders for the property list elements. */
754 Lisp_Object priority_string
;
755 Lisp_Object trustfiles
;
756 Lisp_Object crlfiles
;
758 /* Lisp_Object callbacks; */
759 Lisp_Object loglevel
;
760 Lisp_Object hostname
;
761 /* Lisp_Object verify_error; */
762 Lisp_Object verify_hostname_error
;
763 Lisp_Object prime_bits
;
765 CHECK_PROCESS (proc
);
767 CHECK_LIST (proplist
);
769 if (NILP (Fgnutls_available_p ()))
771 error ("GnuTLS not available");
772 return gnutls_make_error (GNUTLS_EMACS_ERROR_NOT_LOADED
);
775 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
777 error ("Invalid GnuTLS credential type");
778 return gnutls_make_error (GNUTLS_EMACS_ERROR_INVALID_TYPE
);
781 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
782 priority_string
= Fplist_get (proplist
, QCgnutls_bootprop_priority
);
783 trustfiles
= Fplist_get (proplist
, QCgnutls_bootprop_trustfiles
);
784 keylist
= Fplist_get (proplist
, QCgnutls_bootprop_keylist
);
785 crlfiles
= Fplist_get (proplist
, QCgnutls_bootprop_crlfiles
);
786 loglevel
= Fplist_get (proplist
, QCgnutls_bootprop_loglevel
);
787 verify_hostname_error
= Fplist_get (proplist
, QCgnutls_bootprop_verify_hostname_error
);
788 prime_bits
= Fplist_get (proplist
, QCgnutls_bootprop_min_prime_bits
);
790 if (!STRINGP (hostname
))
791 error ("gnutls-boot: invalid :hostname parameter");
792 c_hostname
= SSDATA (hostname
);
794 state
= XPROCESS (proc
)->gnutls_state
;
795 XPROCESS (proc
)->gnutls_p
= 1;
797 if (TYPE_RANGED_INTEGERP (int, loglevel
))
799 fn_gnutls_global_set_log_function (gnutls_log_function
);
800 fn_gnutls_global_set_log_level (XINT (loglevel
));
801 max_log_level
= XINT (loglevel
);
802 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
805 /* always initialize globals. */
806 global_init
= emacs_gnutls_global_init ();
807 if (! NILP (Fgnutls_errorp (global_init
)))
810 /* Before allocating new credentials, deallocate any credentials
811 that PROC might already have. */
812 emacs_gnutls_deinit (proc
);
814 /* Mark PROC as a GnuTLS process. */
815 XPROCESS (proc
)->gnutls_p
= 1;
816 XPROCESS (proc
)->gnutls_state
= NULL
;
817 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
818 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
819 pset_gnutls_cred_type (XPROCESS (proc
), type
);
820 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
822 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
823 if (EQ (type
, Qgnutls_x509pki
))
825 Lisp_Object verify_flags
;
826 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
828 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
829 fn_gnutls_certificate_allocate_credentials (&x509_cred
);
830 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
832 verify_flags
= Fplist_get (proplist
, QCgnutls_bootprop_verify_flags
);
833 if (NUMBERP (verify_flags
))
835 gnutls_verify_flags
= XINT (verify_flags
);
836 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
838 else if (NILP (verify_flags
))
839 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
841 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
843 fn_gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
845 else /* Qgnutls_anon: */
847 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
848 fn_gnutls_anon_allocate_client_credentials (&anon_cred
);
849 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
852 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
854 if (EQ (type
, Qgnutls_x509pki
))
856 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
857 int file_format
= GNUTLS_X509_FMT_PEM
;
860 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
862 Lisp_Object trustfile
= XCAR (tail
);
863 if (STRINGP (trustfile
))
865 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
867 ret
= fn_gnutls_certificate_set_x509_trust_file
872 if (ret
< GNUTLS_E_SUCCESS
)
873 return gnutls_make_error (ret
);
877 emacs_gnutls_deinit (proc
);
878 error ("Invalid trustfile");
882 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
884 Lisp_Object crlfile
= XCAR (tail
);
885 if (STRINGP (crlfile
))
887 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
889 ret
= fn_gnutls_certificate_set_x509_crl_file
890 (x509_cred
, SSDATA (crlfile
), file_format
);
892 if (ret
< GNUTLS_E_SUCCESS
)
893 return gnutls_make_error (ret
);
897 emacs_gnutls_deinit (proc
);
898 error ("Invalid CRL file");
902 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
904 Lisp_Object keyfile
= Fcar (XCAR (tail
));
905 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
906 if (STRINGP (keyfile
) && STRINGP (certfile
))
908 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
910 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
912 ret
= fn_gnutls_certificate_set_x509_key_file
913 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
915 if (ret
< GNUTLS_E_SUCCESS
)
916 return gnutls_make_error (ret
);
920 emacs_gnutls_deinit (proc
);
921 error (STRINGP (keyfile
) ? "Invalid client cert file"
922 : "Invalid client key file");
927 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
928 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
929 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
931 /* Call gnutls_init here: */
933 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
934 ret
= fn_gnutls_init (&state
, GNUTLS_CLIENT
);
935 XPROCESS (proc
)->gnutls_state
= state
;
936 if (ret
< GNUTLS_E_SUCCESS
)
937 return gnutls_make_error (ret
);
938 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
940 if (STRINGP (priority_string
))
942 priority_string_ptr
= SSDATA (priority_string
);
943 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
944 priority_string_ptr
);
948 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
949 priority_string_ptr
);
952 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
953 ret
= fn_gnutls_priority_set_direct (state
,
956 if (ret
< GNUTLS_E_SUCCESS
)
957 return gnutls_make_error (ret
);
959 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
961 if (INTEGERP (prime_bits
))
962 fn_gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
964 ret
= EQ (type
, Qgnutls_x509pki
)
965 ? fn_gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
966 : fn_gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
967 if (ret
< GNUTLS_E_SUCCESS
)
968 return gnutls_make_error (ret
);
970 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
971 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
972 if (ret
< GNUTLS_E_SUCCESS
)
973 return gnutls_make_error (ret
);
975 /* Now verify the peer, following
976 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
977 The peer should present at least one certificate in the chain; do a
978 check of the certificate's hostname with
979 gnutls_x509_crt_check_hostname() against :hostname. */
981 ret
= fn_gnutls_certificate_verify_peers2 (state
, &peer_verification
);
982 if (ret
< GNUTLS_E_SUCCESS
)
983 return gnutls_make_error (ret
);
985 if (XINT (loglevel
) > 0 && peer_verification
& GNUTLS_CERT_INVALID
)
986 message ("%s certificate could not be verified.", c_hostname
);
988 if (peer_verification
& GNUTLS_CERT_REVOKED
)
989 GNUTLS_LOG2 (1, max_log_level
, "certificate was revoked (CRL):",
992 if (peer_verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
993 GNUTLS_LOG2 (1, max_log_level
, "certificate signer was not found:",
996 if (peer_verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
997 GNUTLS_LOG2 (1, max_log_level
, "certificate signer is not a CA:",
1000 if (peer_verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1001 GNUTLS_LOG2 (1, max_log_level
,
1002 "certificate was signed with an insecure algorithm:",
1005 if (peer_verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1006 GNUTLS_LOG2 (1, max_log_level
, "certificate is not yet activated:",
1009 if (peer_verification
& GNUTLS_CERT_EXPIRED
)
1010 GNUTLS_LOG2 (1, max_log_level
, "certificate has expired:",
1013 if (peer_verification
!= 0)
1015 if (NILP (verify_hostname_error
))
1016 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1020 emacs_gnutls_deinit (proc
);
1021 error ("Certificate validation failed %s, verification code %d",
1022 c_hostname
, peer_verification
);
1026 /* Up to here the process is the same for X.509 certificates and
1027 OpenPGP keys. From now on X.509 certificates are assumed. This
1028 can be easily extended to work with openpgp keys as well. */
1029 if (fn_gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1031 gnutls_x509_crt_t gnutls_verify_cert
;
1032 const gnutls_datum_t
*gnutls_verify_cert_list
;
1033 unsigned int gnutls_verify_cert_list_size
;
1035 ret
= fn_gnutls_x509_crt_init (&gnutls_verify_cert
);
1036 if (ret
< GNUTLS_E_SUCCESS
)
1037 return gnutls_make_error (ret
);
1039 gnutls_verify_cert_list
=
1040 fn_gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1042 if (gnutls_verify_cert_list
== NULL
)
1044 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1045 emacs_gnutls_deinit (proc
);
1046 error ("No x509 certificate was found\n");
1049 /* We only check the first certificate in the given chain. */
1050 ret
= fn_gnutls_x509_crt_import (gnutls_verify_cert
,
1051 &gnutls_verify_cert_list
[0],
1052 GNUTLS_X509_FMT_DER
);
1054 if (ret
< GNUTLS_E_SUCCESS
)
1056 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1057 return gnutls_make_error (ret
);
1060 if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert
, c_hostname
))
1062 if (NILP (verify_hostname_error
))
1063 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1067 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1068 emacs_gnutls_deinit (proc
);
1069 error ("The x509 certificate does not match \"%s\"", c_hostname
);
1072 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1075 return gnutls_make_error (ret
);
1078 DEFUN ("gnutls-bye", Fgnutls_bye
,
1079 Sgnutls_bye
, 2, 2, 0,
1080 doc
: /* Terminate current GnuTLS connection for process PROC.
1081 The connection should have been initiated using `gnutls-handshake'.
1083 If CONT is not nil the TLS connection gets terminated and further
1084 receives and sends will be disallowed. If the return value is zero you
1085 may continue using the connection. If CONT is nil, GnuTLS actually
1086 sends an alert containing a close request and waits for the peer to
1087 reply with the same message. In order to reuse the connection you
1088 should wait for an EOF from the peer.
1090 This function may also return `gnutls-e-again', or
1091 `gnutls-e-interrupted'. */)
1092 (Lisp_Object proc
, Lisp_Object cont
)
1094 gnutls_session_t state
;
1097 CHECK_PROCESS (proc
);
1099 state
= XPROCESS (proc
)->gnutls_state
;
1101 ret
= fn_gnutls_bye (state
,
1102 NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1104 return gnutls_make_error (ret
);
1108 syms_of_gnutls (void)
1110 gnutls_global_initialized
= 0;
1112 DEFSYM (Qgnutls_dll
, "gnutls");
1113 DEFSYM (Qgnutls_code
, "gnutls-code");
1114 DEFSYM (Qgnutls_anon
, "gnutls-anon");
1115 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
1116 DEFSYM (QCgnutls_bootprop_hostname
, ":hostname");
1117 DEFSYM (QCgnutls_bootprop_priority
, ":priority");
1118 DEFSYM (QCgnutls_bootprop_trustfiles
, ":trustfiles");
1119 DEFSYM (QCgnutls_bootprop_keylist
, ":keylist");
1120 DEFSYM (QCgnutls_bootprop_crlfiles
, ":crlfiles");
1121 DEFSYM (QCgnutls_bootprop_callbacks
, ":callbacks");
1122 DEFSYM (QCgnutls_bootprop_callbacks_verify
, "verify");
1123 DEFSYM (QCgnutls_bootprop_min_prime_bits
, ":min-prime-bits");
1124 DEFSYM (QCgnutls_bootprop_loglevel
, ":loglevel");
1125 DEFSYM (QCgnutls_bootprop_verify_flags
, ":verify-flags");
1126 DEFSYM (QCgnutls_bootprop_verify_hostname_error
, ":verify-hostname-error");
1128 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
1129 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
1130 make_number (GNUTLS_E_INTERRUPTED
));
1132 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
1133 Fput (Qgnutls_e_again
, Qgnutls_code
,
1134 make_number (GNUTLS_E_AGAIN
));
1136 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
1137 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
1138 make_number (GNUTLS_E_INVALID_SESSION
));
1140 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
1141 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
1142 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
1144 defsubr (&Sgnutls_get_initstage
);
1145 defsubr (&Sgnutls_errorp
);
1146 defsubr (&Sgnutls_error_fatalp
);
1147 defsubr (&Sgnutls_error_string
);
1148 defsubr (&Sgnutls_boot
);
1149 defsubr (&Sgnutls_deinit
);
1150 defsubr (&Sgnutls_bye
);
1151 defsubr (&Sgnutls_available_p
);
1153 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
1154 doc
: /* Logging level used by the GnuTLS functions.
1155 Set this larger than 0 to get debug output in the *Messages* buffer.
1156 1 is for important messages, 2 is for debug data, and higher numbers
1157 are as per the GnuTLS logging conventions. */);
1158 global_gnutls_log_level
= 0;
1161 #endif /* HAVE_GNUTLS */