1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2015 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/>. */
29 #include <gnutls/gnutls.h>
36 static bool emacs_gnutls_handle_error (gnutls_session_t
, int);
38 static bool gnutls_global_initialized
;
40 static void gnutls_log_function (int, const char *);
41 static void gnutls_log_function2 (int, const char *, const char *);
43 static void gnutls_audit_log_function (gnutls_session_t
, const char *);
46 enum extra_peer_verification
48 CERTIFICATE_NOT_MATCHING
= 2
54 DEF_DLL_FN (gnutls_alert_description_t
, gnutls_alert_get
,
56 DEF_DLL_FN (const char *, gnutls_alert_get_name
,
57 (gnutls_alert_description_t
));
58 DEF_DLL_FN (int, gnutls_alert_send_appropriate
, (gnutls_session_t
, int));
59 DEF_DLL_FN (int, gnutls_anon_allocate_client_credentials
,
60 (gnutls_anon_client_credentials_t
*));
61 DEF_DLL_FN (void, gnutls_anon_free_client_credentials
,
62 (gnutls_anon_client_credentials_t
));
63 DEF_DLL_FN (int, gnutls_bye
, (gnutls_session_t
, gnutls_close_request_t
));
64 DEF_DLL_FN (int, gnutls_certificate_allocate_credentials
,
65 (gnutls_certificate_credentials_t
*));
66 DEF_DLL_FN (void, gnutls_certificate_free_credentials
,
67 (gnutls_certificate_credentials_t
));
68 DEF_DLL_FN (const gnutls_datum_t
*, gnutls_certificate_get_peers
,
69 (gnutls_session_t
, unsigned int *));
70 DEF_DLL_FN (void, gnutls_certificate_set_verify_flags
,
71 (gnutls_certificate_credentials_t
, unsigned int));
72 DEF_DLL_FN (int, gnutls_certificate_set_x509_crl_file
,
73 (gnutls_certificate_credentials_t
, const char *,
74 gnutls_x509_crt_fmt_t
));
75 DEF_DLL_FN (int, gnutls_certificate_set_x509_key_file
,
76 (gnutls_certificate_credentials_t
, const char *, const char *,
77 gnutls_x509_crt_fmt_t
));
78 # if ((GNUTLS_VERSION_MAJOR \
79 + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20)) \
81 DEF_DLL_FN (int, gnutls_certificate_set_x509_system_trust
,
82 (gnutls_certificate_credentials_t
));
84 DEF_DLL_FN (int, gnutls_certificate_set_x509_trust_file
,
85 (gnutls_certificate_credentials_t
, const char *,
86 gnutls_x509_crt_fmt_t
));
87 DEF_DLL_FN (gnutls_certificate_type_t
, gnutls_certificate_type_get
,
89 DEF_DLL_FN (int, gnutls_certificate_verify_peers2
,
90 (gnutls_session_t
, unsigned int *));
91 DEF_DLL_FN (int, gnutls_credentials_set
,
92 (gnutls_session_t
, gnutls_credentials_type_t
, void *));
93 DEF_DLL_FN (void, gnutls_deinit
, (gnutls_session_t
));
94 DEF_DLL_FN (void, gnutls_dh_set_prime_bits
,
95 (gnutls_session_t
, unsigned int));
96 DEF_DLL_FN (int, gnutls_dh_get_prime_bits
, (gnutls_session_t
));
97 DEF_DLL_FN (int, gnutls_error_is_fatal
, (int));
98 DEF_DLL_FN (int, gnutls_global_init
, (void));
99 DEF_DLL_FN (void, gnutls_global_set_log_function
, (gnutls_log_func
));
101 DEF_DLL_FN (void, gnutls_global_set_audit_log_function
, (gnutls_audit_log_func
));
103 DEF_DLL_FN (void, gnutls_global_set_log_level
, (int));
104 DEF_DLL_FN (int, gnutls_handshake
, (gnutls_session_t
));
105 DEF_DLL_FN (int, gnutls_init
, (gnutls_session_t
*, unsigned int));
106 DEF_DLL_FN (int, gnutls_priority_set_direct
,
107 (gnutls_session_t
, const char *, const char **));
108 DEF_DLL_FN (size_t, gnutls_record_check_pending
, (gnutls_session_t
));
109 DEF_DLL_FN (ssize_t
, gnutls_record_recv
, (gnutls_session_t
, void *, size_t));
110 DEF_DLL_FN (ssize_t
, gnutls_record_send
,
111 (gnutls_session_t
, const void *, size_t));
112 DEF_DLL_FN (const char *, gnutls_strerror
, (int));
113 DEF_DLL_FN (void, gnutls_transport_set_errno
, (gnutls_session_t
, int));
114 DEF_DLL_FN (const char *, gnutls_check_version
, (const char *));
115 DEF_DLL_FN (void, gnutls_transport_set_lowat
, (gnutls_session_t
, int));
116 DEF_DLL_FN (void, gnutls_transport_set_ptr2
,
117 (gnutls_session_t
, gnutls_transport_ptr_t
,
118 gnutls_transport_ptr_t
));
119 DEF_DLL_FN (void, gnutls_transport_set_pull_function
,
120 (gnutls_session_t
, gnutls_pull_func
));
121 DEF_DLL_FN (void, gnutls_transport_set_push_function
,
122 (gnutls_session_t
, gnutls_push_func
));
123 DEF_DLL_FN (int, gnutls_x509_crt_check_hostname
,
124 (gnutls_x509_crt_t
, const char *));
125 DEF_DLL_FN (void, gnutls_x509_crt_deinit
, (gnutls_x509_crt_t
));
126 DEF_DLL_FN (int, gnutls_x509_crt_import
,
127 (gnutls_x509_crt_t
, const gnutls_datum_t
*,
128 gnutls_x509_crt_fmt_t
));
129 DEF_DLL_FN (int, gnutls_x509_crt_init
, (gnutls_x509_crt_t
*));
130 DEF_DLL_FN (int, gnutls_x509_crt_get_fingerprint
,
132 gnutls_digest_algorithm_t
, void *, size_t *));
133 DEF_DLL_FN (int, gnutls_x509_crt_get_version
,
134 (gnutls_x509_crt_t
));
135 DEF_DLL_FN (int, gnutls_x509_crt_get_serial
,
136 (gnutls_x509_crt_t
, void *, size_t *));
137 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_dn
,
138 (gnutls_x509_crt_t
, char *, size_t *));
139 DEF_DLL_FN (time_t, gnutls_x509_crt_get_activation_time
,
140 (gnutls_x509_crt_t
));
141 DEF_DLL_FN (time_t, gnutls_x509_crt_get_expiration_time
,
142 (gnutls_x509_crt_t
));
143 DEF_DLL_FN (int, gnutls_x509_crt_get_dn
,
144 (gnutls_x509_crt_t
, char *, size_t *));
145 DEF_DLL_FN (int, gnutls_x509_crt_get_pk_algorithm
,
146 (gnutls_x509_crt_t
, unsigned int *));
147 DEF_DLL_FN (const char*, gnutls_pk_algorithm_get_name
,
148 (gnutls_pk_algorithm_t
));
149 DEF_DLL_FN (int, gnutls_pk_bits_to_sec_param
,
150 (gnutls_pk_algorithm_t
, unsigned int));
151 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_unique_id
,
152 (gnutls_x509_crt_t
, char *, size_t *));
153 DEF_DLL_FN (int, gnutls_x509_crt_get_subject_unique_id
,
154 (gnutls_x509_crt_t
, char *, size_t *));
155 DEF_DLL_FN (int, gnutls_x509_crt_get_signature_algorithm
,
156 (gnutls_x509_crt_t
));
157 DEF_DLL_FN (int, gnutls_x509_crt_get_signature
,
158 (gnutls_x509_crt_t
, char *, size_t *));
159 DEF_DLL_FN (int, gnutls_x509_crt_get_key_id
,
160 (gnutls_x509_crt_t
, unsigned int, unsigned char *, size_t *_size
));
161 DEF_DLL_FN (const char*, gnutls_sec_param_get_name
, (gnutls_sec_param_t
));
162 DEF_DLL_FN (const char*, gnutls_sign_get_name
, (gnutls_sign_algorithm_t
));
163 DEF_DLL_FN (int, gnutls_server_name_set
,
164 (gnutls_session_t
, gnutls_server_name_type_t
,
165 const void *, size_t));
166 DEF_DLL_FN (gnutls_kx_algorithm_t
, gnutls_kx_get
, (gnutls_session_t
));
167 DEF_DLL_FN (const char*, gnutls_kx_get_name
, (gnutls_kx_algorithm_t
));
168 DEF_DLL_FN (gnutls_protocol_t
, gnutls_protocol_get_version
,
170 DEF_DLL_FN (const char*, gnutls_protocol_get_name
, (gnutls_protocol_t
));
171 DEF_DLL_FN (gnutls_cipher_algorithm_t
, gnutls_cipher_get
,
173 DEF_DLL_FN (const char*, gnutls_cipher_get_name
,
174 (gnutls_cipher_algorithm_t
));
175 DEF_DLL_FN (gnutls_mac_algorithm_t
, gnutls_mac_get
, (gnutls_session_t
));
176 DEF_DLL_FN (const char*, gnutls_mac_get_name
, (gnutls_mac_algorithm_t
));
180 init_gnutls_functions (void)
183 int max_log_level
= 1;
185 if (!(library
= w32_delayed_load (Qgnutls_dll
)))
187 GNUTLS_LOG (1, max_log_level
, "GnuTLS library not found");
191 LOAD_DLL_FN (library
, gnutls_alert_get
);
192 LOAD_DLL_FN (library
, gnutls_alert_get_name
);
193 LOAD_DLL_FN (library
, gnutls_alert_send_appropriate
);
194 LOAD_DLL_FN (library
, gnutls_anon_allocate_client_credentials
);
195 LOAD_DLL_FN (library
, gnutls_anon_free_client_credentials
);
196 LOAD_DLL_FN (library
, gnutls_bye
);
197 LOAD_DLL_FN (library
, gnutls_certificate_allocate_credentials
);
198 LOAD_DLL_FN (library
, gnutls_certificate_free_credentials
);
199 LOAD_DLL_FN (library
, gnutls_certificate_get_peers
);
200 LOAD_DLL_FN (library
, gnutls_certificate_set_verify_flags
);
201 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_crl_file
);
202 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_key_file
);
203 # if ((GNUTLS_VERSION_MAJOR \
204 + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20)) \
206 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_system_trust
);
208 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_trust_file
);
209 LOAD_DLL_FN (library
, gnutls_certificate_type_get
);
210 LOAD_DLL_FN (library
, gnutls_certificate_verify_peers2
);
211 LOAD_DLL_FN (library
, gnutls_credentials_set
);
212 LOAD_DLL_FN (library
, gnutls_deinit
);
213 LOAD_DLL_FN (library
, gnutls_dh_set_prime_bits
);
214 LOAD_DLL_FN (library
, gnutls_dh_get_prime_bits
);
215 LOAD_DLL_FN (library
, gnutls_error_is_fatal
);
216 LOAD_DLL_FN (library
, gnutls_global_init
);
217 LOAD_DLL_FN (library
, gnutls_global_set_log_function
);
219 LOAD_DLL_FN (library
, gnutls_global_set_audit_log_function
);
221 LOAD_DLL_FN (library
, gnutls_global_set_log_level
);
222 LOAD_DLL_FN (library
, gnutls_handshake
);
223 LOAD_DLL_FN (library
, gnutls_init
);
224 LOAD_DLL_FN (library
, gnutls_priority_set_direct
);
225 LOAD_DLL_FN (library
, gnutls_record_check_pending
);
226 LOAD_DLL_FN (library
, gnutls_record_recv
);
227 LOAD_DLL_FN (library
, gnutls_record_send
);
228 LOAD_DLL_FN (library
, gnutls_strerror
);
229 LOAD_DLL_FN (library
, gnutls_transport_set_errno
);
230 LOAD_DLL_FN (library
, gnutls_check_version
);
231 /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
232 and later, and the function was removed entirely in 3.0.0. */
233 if (!fn_gnutls_check_version ("2.11.1"))
234 LOAD_DLL_FN (library
, gnutls_transport_set_lowat
);
235 LOAD_DLL_FN (library
, gnutls_transport_set_ptr2
);
236 LOAD_DLL_FN (library
, gnutls_transport_set_pull_function
);
237 LOAD_DLL_FN (library
, gnutls_transport_set_push_function
);
238 LOAD_DLL_FN (library
, gnutls_x509_crt_check_hostname
);
239 LOAD_DLL_FN (library
, gnutls_x509_crt_deinit
);
240 LOAD_DLL_FN (library
, gnutls_x509_crt_import
);
241 LOAD_DLL_FN (library
, gnutls_x509_crt_init
);
242 LOAD_DLL_FN (library
, gnutls_x509_crt_get_fingerprint
);
243 LOAD_DLL_FN (library
, gnutls_x509_crt_get_version
);
244 LOAD_DLL_FN (library
, gnutls_x509_crt_get_serial
);
245 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_dn
);
246 LOAD_DLL_FN (library
, gnutls_x509_crt_get_activation_time
);
247 LOAD_DLL_FN (library
, gnutls_x509_crt_get_expiration_time
);
248 LOAD_DLL_FN (library
, gnutls_x509_crt_get_dn
);
249 LOAD_DLL_FN (library
, gnutls_x509_crt_get_pk_algorithm
);
250 LOAD_DLL_FN (library
, gnutls_pk_algorithm_get_name
);
251 LOAD_DLL_FN (library
, gnutls_pk_bits_to_sec_param
);
252 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_unique_id
);
253 LOAD_DLL_FN (library
, gnutls_x509_crt_get_subject_unique_id
);
254 LOAD_DLL_FN (library
, gnutls_x509_crt_get_signature_algorithm
);
255 LOAD_DLL_FN (library
, gnutls_x509_crt_get_signature
);
256 LOAD_DLL_FN (library
, gnutls_x509_crt_get_key_id
);
257 LOAD_DLL_FN (library
, gnutls_sec_param_get_name
);
258 LOAD_DLL_FN (library
, gnutls_sign_get_name
);
259 LOAD_DLL_FN (library
, gnutls_server_name_set
);
260 LOAD_DLL_FN (library
, gnutls_kx_get
);
261 LOAD_DLL_FN (library
, gnutls_kx_get_name
);
262 LOAD_DLL_FN (library
, gnutls_protocol_get_version
);
263 LOAD_DLL_FN (library
, gnutls_protocol_get_name
);
264 LOAD_DLL_FN (library
, gnutls_cipher_get
);
265 LOAD_DLL_FN (library
, gnutls_cipher_get_name
);
266 LOAD_DLL_FN (library
, gnutls_mac_get
);
267 LOAD_DLL_FN (library
, gnutls_mac_get_name
);
269 max_log_level
= global_gnutls_log_level
;
272 Lisp_Object name
= CAR_SAFE (Fget (Qgnutls_dll
, QCloaded_from
));
273 GNUTLS_LOG2 (1, max_log_level
, "GnuTLS library loaded:",
274 STRINGP (name
) ? (const char *) SDATA (name
) : "unknown");
280 # define gnutls_alert_get fn_gnutls_alert_get
281 # define gnutls_alert_get_name fn_gnutls_alert_get_name
282 # define gnutls_alert_send_appropriate fn_gnutls_alert_send_appropriate
283 # define gnutls_anon_allocate_client_credentials fn_gnutls_anon_allocate_client_credentials
284 # define gnutls_anon_free_client_credentials fn_gnutls_anon_free_client_credentials
285 # define gnutls_bye fn_gnutls_bye
286 # define gnutls_certificate_allocate_credentials fn_gnutls_certificate_allocate_credentials
287 # define gnutls_certificate_free_credentials fn_gnutls_certificate_free_credentials
288 # define gnutls_certificate_get_peers fn_gnutls_certificate_get_peers
289 # define gnutls_certificate_set_verify_flags fn_gnutls_certificate_set_verify_flags
290 # define gnutls_certificate_set_x509_crl_file fn_gnutls_certificate_set_x509_crl_file
291 # define gnutls_certificate_set_x509_key_file fn_gnutls_certificate_set_x509_key_file
292 # define gnutls_certificate_set_x509_system_trust fn_gnutls_certificate_set_x509_system_trust
293 # define gnutls_certificate_set_x509_trust_file fn_gnutls_certificate_set_x509_trust_file
294 # define gnutls_certificate_type_get fn_gnutls_certificate_type_get
295 # define gnutls_certificate_verify_peers2 fn_gnutls_certificate_verify_peers2
296 # define gnutls_check_version fn_gnutls_check_version
297 # define gnutls_cipher_get fn_gnutls_cipher_get
298 # define gnutls_cipher_get_name fn_gnutls_cipher_get_name
299 # define gnutls_credentials_set fn_gnutls_credentials_set
300 # define gnutls_deinit fn_gnutls_deinit
301 # define gnutls_dh_get_prime_bits fn_gnutls_dh_get_prime_bits
302 # define gnutls_dh_set_prime_bits fn_gnutls_dh_set_prime_bits
303 # define gnutls_error_is_fatal fn_gnutls_error_is_fatal
304 # define gnutls_global_init fn_gnutls_global_init
305 # define gnutls_global_set_audit_log_function fn_gnutls_global_set_audit_log_function
306 # define gnutls_global_set_log_function fn_gnutls_global_set_log_function
307 # define gnutls_global_set_log_level fn_gnutls_global_set_log_level
308 # define gnutls_handshake fn_gnutls_handshake
309 # define gnutls_init fn_gnutls_init
310 # define gnutls_kx_get fn_gnutls_kx_get
311 # define gnutls_kx_get_name fn_gnutls_kx_get_name
312 # define gnutls_mac_get fn_gnutls_mac_get
313 # define gnutls_mac_get_name fn_gnutls_mac_get_name
314 # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name
315 # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param
316 # define gnutls_priority_set_direct fn_gnutls_priority_set_direct
317 # define gnutls_protocol_get_name fn_gnutls_protocol_get_name
318 # define gnutls_protocol_get_version fn_gnutls_protocol_get_version
319 # define gnutls_record_check_pending fn_gnutls_record_check_pending
320 # define gnutls_record_recv fn_gnutls_record_recv
321 # define gnutls_record_send fn_gnutls_record_send
322 # define gnutls_sec_param_get_name fn_gnutls_sec_param_get_name
323 # define gnutls_server_name_set fn_gnutls_server_name_set
324 # define gnutls_sign_get_name fn_gnutls_sign_get_name
325 # define gnutls_strerror fn_gnutls_strerror
326 # define gnutls_transport_set_errno fn_gnutls_transport_set_errno
327 # define gnutls_transport_set_lowat fn_gnutls_transport_set_lowat
328 # define gnutls_transport_set_ptr2 fn_gnutls_transport_set_ptr2
329 # define gnutls_transport_set_pull_function fn_gnutls_transport_set_pull_function
330 # define gnutls_transport_set_push_function fn_gnutls_transport_set_push_function
331 # define gnutls_x509_crt_check_hostname fn_gnutls_x509_crt_check_hostname
332 # define gnutls_x509_crt_deinit fn_gnutls_x509_crt_deinit
333 # define gnutls_x509_crt_get_activation_time fn_gnutls_x509_crt_get_activation_time
334 # define gnutls_x509_crt_get_dn fn_gnutls_x509_crt_get_dn
335 # define gnutls_x509_crt_get_expiration_time fn_gnutls_x509_crt_get_expiration_time
336 # define gnutls_x509_crt_get_fingerprint fn_gnutls_x509_crt_get_fingerprint
337 # define gnutls_x509_crt_get_issuer_dn fn_gnutls_x509_crt_get_issuer_dn
338 # define gnutls_x509_crt_get_issuer_unique_id fn_gnutls_x509_crt_get_issuer_unique_id
339 # define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id
340 # define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm
341 # define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial
342 # define gnutls_x509_crt_get_signature fn_gnutls_x509_crt_get_signature
343 # define gnutls_x509_crt_get_signature_algorithm fn_gnutls_x509_crt_get_signature_algorithm
344 # define gnutls_x509_crt_get_subject_unique_id fn_gnutls_x509_crt_get_subject_unique_id
345 # define gnutls_x509_crt_get_version fn_gnutls_x509_crt_get_version
346 # define gnutls_x509_crt_import fn_gnutls_x509_crt_import
347 # define gnutls_x509_crt_init fn_gnutls_x509_crt_init
352 /* Report memory exhaustion if ERR is an out-of-memory indication. */
354 check_memory_full (int err
)
356 /* When GnuTLS exhausts memory, it doesn't say how much memory it
357 asked for, so tell the Emacs allocator that GnuTLS asked for no
358 bytes. This isn't accurate, but it's good enough. */
359 if (err
== GNUTLS_E_MEMORY_ERROR
)
364 /* Log a simple audit message. */
366 gnutls_audit_log_function (gnutls_session_t session
, const char *string
)
368 if (global_gnutls_log_level
>= 1)
370 message ("gnutls.c: [audit] %s", string
);
375 /* Log a simple message. */
377 gnutls_log_function (int level
, const char *string
)
379 message ("gnutls.c: [%d] %s", level
, string
);
382 /* Log a message and a string. */
384 gnutls_log_function2 (int level
, const char *string
, const char *extra
)
386 message ("gnutls.c: [%d] %s %s", level
, string
, extra
);
389 /* Log a message and an integer. */
391 gnutls_log_function2i (int level
, const char *string
, int extra
)
393 message ("gnutls.c: [%d] %s %d", level
, string
, extra
);
397 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
399 gnutls_session_t state
= proc
->gnutls_state
;
402 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
405 if (proc
->gnutls_initstage
< GNUTLS_STAGE_TRANSPORT_POINTERS_SET
)
408 /* On W32 we cannot transfer socket handles between different runtime
409 libraries, so we tell GnuTLS to use our special push/pull
411 gnutls_transport_set_ptr2 (state
,
412 (gnutls_transport_ptr_t
) proc
,
413 (gnutls_transport_ptr_t
) proc
);
414 gnutls_transport_set_push_function (state
, &emacs_gnutls_push
);
415 gnutls_transport_set_pull_function (state
, &emacs_gnutls_pull
);
417 /* For non blocking sockets or other custom made pull/push
418 functions the gnutls_transport_set_lowat must be called, with
419 a zero low water mark value. (GnuTLS 2.10.4 documentation)
421 (Note: this is probably not strictly necessary as the lowat
422 value is only used when no custom pull/push functions are
424 /* According to GnuTLS NEWS file, lowat level has been set to
425 zero by default in version 2.11.1, and the function
426 gnutls_transport_set_lowat was removed from the library in
428 if (!gnutls_check_version ("2.11.1"))
429 gnutls_transport_set_lowat (state
, 0);
431 /* This is how GnuTLS takes sockets: as file descriptors passed
432 in. For an Emacs process socket, infd and outfd are the
433 same but we use this two-argument version for clarity. */
434 gnutls_transport_set_ptr2 (state
,
435 (void *) (intptr_t) proc
->infd
,
436 (void *) (intptr_t) proc
->outfd
);
439 proc
->gnutls_initstage
= GNUTLS_STAGE_TRANSPORT_POINTERS_SET
;
444 ret
= gnutls_handshake (state
);
445 emacs_gnutls_handle_error (state
, ret
);
448 while (ret
< 0 && gnutls_error_is_fatal (ret
) == 0);
450 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
452 if (ret
== GNUTLS_E_SUCCESS
)
454 /* Here we're finally done. */
455 proc
->gnutls_initstage
= GNUTLS_STAGE_READY
;
459 check_memory_full (gnutls_alert_send_appropriate (state
, ret
));
465 emacs_gnutls_record_check_pending (gnutls_session_t state
)
467 return gnutls_record_check_pending (state
);
472 emacs_gnutls_transport_set_errno (gnutls_session_t state
, int err
)
474 gnutls_transport_set_errno (state
, err
);
479 emacs_gnutls_write (struct Lisp_Process
*proc
, const char *buf
, ptrdiff_t nbyte
)
482 ptrdiff_t bytes_written
;
483 gnutls_session_t state
= proc
->gnutls_state
;
485 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
495 rtnval
= gnutls_record_send (state
, buf
, nbyte
);
499 if (rtnval
== GNUTLS_E_INTERRUPTED
)
503 /* If we get GNUTLS_E_AGAIN, then set errno
504 appropriately so that send_process retries the
505 correct way instead of erroring out. */
506 if (rtnval
== GNUTLS_E_AGAIN
)
514 bytes_written
+= rtnval
;
517 emacs_gnutls_handle_error (state
, rtnval
);
518 return (bytes_written
);
522 emacs_gnutls_read (struct Lisp_Process
*proc
, char *buf
, ptrdiff_t nbyte
)
525 gnutls_session_t state
= proc
->gnutls_state
;
527 int log_level
= proc
->gnutls_log_level
;
529 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
531 /* If the handshake count is under the limit, try the handshake
532 again and increment the handshake count. This count is kept
533 per process (connection), not globally. */
534 if (proc
->gnutls_handshakes_tried
< GNUTLS_EMACS_HANDSHAKES_LIMIT
)
536 proc
->gnutls_handshakes_tried
++;
537 emacs_gnutls_handshake (proc
);
538 GNUTLS_LOG2i (5, log_level
, "Retried handshake",
539 proc
->gnutls_handshakes_tried
);
543 GNUTLS_LOG (2, log_level
, "Giving up on handshake; resetting retries");
544 proc
->gnutls_handshakes_tried
= 0;
547 rtnval
= gnutls_record_recv (state
, buf
, nbyte
);
550 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
551 /* The peer closed the connection. */
553 else if (emacs_gnutls_handle_error (state
, rtnval
))
554 /* non-fatal error */
557 /* a fatal error occurred */
562 /* Report a GnuTLS error to the user.
563 Return true if the error code was successfully handled. */
565 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
567 int max_log_level
= 0;
572 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
576 check_memory_full (err
);
578 max_log_level
= global_gnutls_log_level
;
580 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
582 str
= gnutls_strerror (err
);
586 if (gnutls_error_is_fatal (err
))
589 GNUTLS_LOG2 (1, max_log_level
, "fatal error:", str
);
610 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
611 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
613 int alert
= gnutls_alert_get (session
);
614 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
615 str
= gnutls_alert_get_name (alert
);
619 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
624 /* convert an integer error to a Lisp_Object; it will be either a
625 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
626 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
629 gnutls_make_error (int err
)
633 case GNUTLS_E_SUCCESS
:
636 return Qgnutls_e_again
;
637 case GNUTLS_E_INTERRUPTED
:
638 return Qgnutls_e_interrupted
;
639 case GNUTLS_E_INVALID_SESSION
:
640 return Qgnutls_e_invalid_session
;
643 check_memory_full (err
);
644 return make_number (err
);
648 emacs_gnutls_deinit (Lisp_Object proc
)
652 CHECK_PROCESS (proc
);
654 if (XPROCESS (proc
)->gnutls_p
== 0)
657 log_level
= XPROCESS (proc
)->gnutls_log_level
;
659 if (XPROCESS (proc
)->gnutls_x509_cred
)
661 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
662 gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
663 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
666 if (XPROCESS (proc
)->gnutls_anon_cred
)
668 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
669 gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
670 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
673 if (XPROCESS (proc
)->gnutls_state
)
675 gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
676 XPROCESS (proc
)->gnutls_state
= NULL
;
677 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
678 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
681 XPROCESS (proc
)->gnutls_p
= 0;
685 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
686 doc
: /* Return the GnuTLS init stage of process PROC.
687 See also `gnutls-boot'. */)
690 CHECK_PROCESS (proc
);
692 return make_number (GNUTLS_INITSTAGE (proc
));
695 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
696 doc
: /* Return t if ERROR indicates a GnuTLS problem.
697 ERROR is an integer or a symbol with an integer `gnutls-code' property.
698 usage: (gnutls-errorp ERROR) */
702 if (EQ (err
, Qt
)) return Qnil
;
707 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
708 doc
: /* Return non-nil if ERROR is fatal.
709 ERROR is an integer or a symbol with an integer `gnutls-code' property.
710 Usage: (gnutls-error-fatalp ERROR) */)
715 if (EQ (err
, Qt
)) return Qnil
;
719 code
= Fget (err
, Qgnutls_code
);
726 error ("Symbol has no numeric gnutls-code property");
730 if (! TYPE_RANGED_INTEGERP (int, err
))
731 error ("Not an error symbol or code");
733 if (0 == gnutls_error_is_fatal (XINT (err
)))
739 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
740 doc
: /* Return a description of ERROR.
741 ERROR is an integer or a symbol with an integer `gnutls-code' property.
742 usage: (gnutls-error-string ERROR) */)
747 if (EQ (err
, Qt
)) return build_string ("Not an error");
751 code
= Fget (err
, Qgnutls_code
);
758 return build_string ("Symbol has no numeric gnutls-code property");
762 if (! TYPE_RANGED_INTEGERP (int, err
))
763 return build_string ("Not an error symbol or code");
765 return build_string (gnutls_strerror (XINT (err
)));
768 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
769 doc
: /* Deallocate GnuTLS resources associated with process PROC.
770 See also `gnutls-init'. */)
773 return emacs_gnutls_deinit (proc
);
777 gnutls_hex_string (unsigned char *buf
, ptrdiff_t buf_size
, const char *prefix
)
779 ptrdiff_t prefix_length
= strlen (prefix
);
780 if ((STRING_BYTES_BOUND
- prefix_length
) / 3 < buf_size
)
782 Lisp_Object ret
= make_uninit_string (prefix_length
+ 3 * buf_size
784 char *string
= SSDATA (ret
);
785 strcpy (string
, prefix
);
787 for (ptrdiff_t i
= 0; i
< buf_size
; i
++)
788 sprintf (string
+ i
* 3 + prefix_length
,
789 i
== buf_size
- 1 ? "%02x" : "%02x:",
796 gnutls_certificate_details (gnutls_x509_crt_t cert
)
798 Lisp_Object res
= Qnil
;
804 int version
= gnutls_x509_crt_get_version (cert
);
805 check_memory_full (version
);
806 if (version
>= GNUTLS_E_SUCCESS
)
807 res
= nconc2 (res
, list2 (intern (":version"),
808 make_number (version
)));
813 err
= gnutls_x509_crt_get_serial (cert
, NULL
, &buf_size
);
814 check_memory_full (err
);
815 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
817 void *serial
= xmalloc (buf_size
);
818 err
= gnutls_x509_crt_get_serial (cert
, serial
, &buf_size
);
819 check_memory_full (err
);
820 if (err
>= GNUTLS_E_SUCCESS
)
821 res
= nconc2 (res
, list2 (intern (":serial-number"),
822 gnutls_hex_string (serial
, buf_size
, "")));
828 err
= gnutls_x509_crt_get_issuer_dn (cert
, NULL
, &buf_size
);
829 check_memory_full (err
);
830 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
832 char *dn
= xmalloc (buf_size
);
833 err
= gnutls_x509_crt_get_issuer_dn (cert
, dn
, &buf_size
);
834 check_memory_full (err
);
835 if (err
>= GNUTLS_E_SUCCESS
)
836 res
= nconc2 (res
, list2 (intern (":issuer"),
837 make_string (dn
, buf_size
)));
843 /* Add 1 to the buffer size, since 1900 is added to tm_year and
844 that might add 1 to the year length. */
845 char buf
[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
847 time_t tim
= gnutls_x509_crt_get_activation_time (cert
);
849 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
850 res
= nconc2 (res
, list2 (intern (":valid-from"), build_string (buf
)));
852 tim
= gnutls_x509_crt_get_expiration_time (cert
);
853 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
854 res
= nconc2 (res
, list2 (intern (":valid-to"), build_string (buf
)));
859 err
= gnutls_x509_crt_get_dn (cert
, NULL
, &buf_size
);
860 check_memory_full (err
);
861 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
863 char *dn
= xmalloc (buf_size
);
864 err
= gnutls_x509_crt_get_dn (cert
, dn
, &buf_size
);
865 check_memory_full (err
);
866 if (err
>= GNUTLS_E_SUCCESS
)
867 res
= nconc2 (res
, list2 (intern (":subject"),
868 make_string (dn
, buf_size
)));
872 /* Versions older than 2.11 doesn't have these four functions. */
873 #if GNUTLS_VERSION_NUMBER >= 0x020b00
874 /* SubjectPublicKeyInfo. */
878 err
= gnutls_x509_crt_get_pk_algorithm (cert
, &bits
);
879 check_memory_full (err
);
880 if (err
>= GNUTLS_E_SUCCESS
)
882 const char *name
= gnutls_pk_algorithm_get_name (err
);
884 res
= nconc2 (res
, list2 (intern (":public-key-algorithm"),
885 build_string (name
)));
887 name
= gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
889 res
= nconc2 (res
, list2 (intern (":certificate-security-level"),
890 build_string (name
)));
896 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, NULL
, &buf_size
);
897 check_memory_full (err
);
898 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
900 char *buf
= xmalloc (buf_size
);
901 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, buf
, &buf_size
);
902 check_memory_full (err
);
903 if (err
>= GNUTLS_E_SUCCESS
)
904 res
= nconc2 (res
, list2 (intern (":issuer-unique-id"),
905 make_string (buf
, buf_size
)));
910 err
= gnutls_x509_crt_get_subject_unique_id (cert
, NULL
, &buf_size
);
911 check_memory_full (err
);
912 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
914 char *buf
= xmalloc (buf_size
);
915 err
= gnutls_x509_crt_get_subject_unique_id (cert
, buf
, &buf_size
);
916 check_memory_full (err
);
917 if (err
>= GNUTLS_E_SUCCESS
)
918 res
= nconc2 (res
, list2 (intern (":subject-unique-id"),
919 make_string (buf
, buf_size
)));
925 err
= gnutls_x509_crt_get_signature_algorithm (cert
);
926 check_memory_full (err
);
927 if (err
>= GNUTLS_E_SUCCESS
)
929 const char *name
= gnutls_sign_get_name (err
);
931 res
= nconc2 (res
, list2 (intern (":signature-algorithm"),
932 build_string (name
)));
937 err
= gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
938 check_memory_full (err
);
939 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
941 void *buf
= xmalloc (buf_size
);
942 err
= gnutls_x509_crt_get_key_id (cert
, 0, buf
, &buf_size
);
943 check_memory_full (err
);
944 if (err
>= GNUTLS_E_SUCCESS
)
945 res
= nconc2 (res
, list2 (intern (":public-key-id"),
946 gnutls_hex_string (buf
, buf_size
, "sha1:")));
950 /* Certificate fingerprint. */
952 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
954 check_memory_full (err
);
955 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
957 void *buf
= xmalloc (buf_size
);
958 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
960 check_memory_full (err
);
961 if (err
>= GNUTLS_E_SUCCESS
)
962 res
= nconc2 (res
, list2 (intern (":certificate-id"),
963 gnutls_hex_string (buf
, buf_size
, "sha1:")));
970 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
971 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
972 (Lisp_Object status_symbol
)
974 CHECK_SYMBOL (status_symbol
);
976 if (EQ (status_symbol
, intern (":invalid")))
977 return build_string ("certificate could not be verified");
979 if (EQ (status_symbol
, intern (":revoked")))
980 return build_string ("certificate was revoked (CRL)");
982 if (EQ (status_symbol
, intern (":self-signed")))
983 return build_string ("certificate signer was not found (self-signed)");
985 if (EQ (status_symbol
, intern (":not-ca")))
986 return build_string ("certificate signer is not a CA");
988 if (EQ (status_symbol
, intern (":insecure")))
989 return build_string ("certificate was signed with an insecure algorithm");
991 if (EQ (status_symbol
, intern (":not-activated")))
992 return build_string ("certificate is not yet activated");
994 if (EQ (status_symbol
, intern (":expired")))
995 return build_string ("certificate has expired");
997 if (EQ (status_symbol
, intern (":no-host-match")))
998 return build_string ("certificate host does not match hostname");
1003 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
1004 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1005 The return value is a property list with top-level keys :warnings and
1006 :certificate. The :warnings entry is a list of symbols you can describe with
1007 `gnutls-peer-status-warning-describe'. */)
1010 Lisp_Object warnings
= Qnil
, result
= Qnil
;
1011 unsigned int verification
;
1012 gnutls_session_t state
;
1014 CHECK_PROCESS (proc
);
1016 if (GNUTLS_INITSTAGE (proc
) < GNUTLS_STAGE_INIT
)
1019 /* Then collect any warnings already computed by the handshake. */
1020 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
1022 if (verification
& GNUTLS_CERT_INVALID
)
1023 warnings
= Fcons (intern (":invalid"), warnings
);
1025 if (verification
& GNUTLS_CERT_REVOKED
)
1026 warnings
= Fcons (intern (":revoked"), warnings
);
1028 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1029 warnings
= Fcons (intern (":self-signed"), warnings
);
1031 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1032 warnings
= Fcons (intern (":not-ca"), warnings
);
1034 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1035 warnings
= Fcons (intern (":insecure"), warnings
);
1037 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1038 warnings
= Fcons (intern (":not-activated"), warnings
);
1040 if (verification
& GNUTLS_CERT_EXPIRED
)
1041 warnings
= Fcons (intern (":expired"), warnings
);
1043 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1044 CERTIFICATE_NOT_MATCHING
)
1045 warnings
= Fcons (intern (":no-host-match"), warnings
);
1047 if (!NILP (warnings
))
1048 result
= list2 (intern (":warnings"), warnings
);
1050 /* This could get called in the INIT stage, when the certificate is
1052 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1053 result
= nconc2 (result
, list2
1054 (intern (":certificate"),
1055 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1057 state
= XPROCESS (proc
)->gnutls_state
;
1059 /* Diffie-Hellman prime bits. */
1061 int bits
= gnutls_dh_get_prime_bits (state
);
1062 check_memory_full (bits
);
1064 result
= nconc2 (result
, list2 (intern (":diffie-hellman-prime-bits"),
1065 make_number (bits
)));
1070 (result
, list2 (intern (":key-exchange"),
1071 build_string (gnutls_kx_get_name
1072 (gnutls_kx_get (state
)))));
1074 /* Protocol name. */
1076 (result
, list2 (intern (":protocol"),
1077 build_string (gnutls_protocol_get_name
1078 (gnutls_protocol_get_version (state
)))));
1082 (result
, list2 (intern (":cipher"),
1083 build_string (gnutls_cipher_get_name
1084 (gnutls_cipher_get (state
)))));
1088 (result
, list2 (intern (":mac"),
1089 build_string (gnutls_mac_get_name
1090 (gnutls_mac_get (state
)))));
1096 /* Initialize global GnuTLS state to defaults.
1097 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1098 Return zero on success. */
1100 emacs_gnutls_global_init (void)
1102 int ret
= GNUTLS_E_SUCCESS
;
1104 if (!gnutls_global_initialized
)
1105 ret
= gnutls_global_init ();
1107 gnutls_global_initialized
= 1;
1109 return gnutls_make_error (ret
);
1113 gnutls_ip_address_p (char *string
)
1117 while ((c
= *string
++) != 0)
1118 if (! ((c
== '.' || c
== ':' || (c
>= '0' && c
<= '9'))))
1125 /* Deinitialize global GnuTLS state.
1126 See also `gnutls-global-init'. */
1128 emacs_gnutls_global_deinit (void)
1130 if (gnutls_global_initialized
)
1131 gnutls_global_deinit ();
1133 gnutls_global_initialized
= 0;
1135 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1139 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
1140 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1141 Currently only client mode is supported. Return a success/failure
1142 value you can check with `gnutls-errorp'.
1144 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1145 PROPLIST is a property list with the following keys:
1147 :hostname is a string naming the remote host.
1149 :priority is a GnuTLS priority string, defaults to "NORMAL".
1151 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1153 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1155 :keylist is an alist of PEM-encoded key files and PEM-encoded
1156 certificates for `gnutls-x509pki'.
1158 :callbacks is an alist of callback functions, see below.
1160 :loglevel is the debug level requested from GnuTLS, try 4.
1162 :verify-flags is a bitset as per GnuTLS'
1163 gnutls_certificate_set_verify_flags.
1165 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1168 :verify-error is a list of symbols to express verification checks or
1169 `t' to do all checks. Currently it can contain `:trustfiles' and
1170 `:hostname' to verify the certificate or the hostname respectively.
1172 :min-prime-bits is the minimum accepted number of bits the client will
1173 accept in Diffie-Hellman key exchange.
1175 The debug level will be set for this process AND globally for GnuTLS.
1176 So if you set it higher or lower at any point, it affects global
1179 Note that the priority is set on the client. The server does not use
1180 the protocols's priority except for disabling protocols that were not
1183 Processes must be initialized with this function before other GnuTLS
1184 functions are used. This function allocates resources which can only
1185 be deallocated by calling `gnutls-deinit' or by calling it again.
1187 The callbacks alist can have a `verify' key, associated with a
1188 verification function (UNUSED).
1190 Each authentication type may need additional information in order to
1191 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1192 one trustfile (usually a CA bundle). */)
1193 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
1195 int ret
= GNUTLS_E_SUCCESS
;
1196 int max_log_level
= 0;
1197 bool verify_error_all
= 0;
1199 gnutls_session_t state
;
1200 gnutls_certificate_credentials_t x509_cred
= NULL
;
1201 gnutls_anon_client_credentials_t anon_cred
= NULL
;
1202 Lisp_Object global_init
;
1203 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
1204 unsigned int peer_verification
;
1207 /* Placeholders for the property list elements. */
1208 Lisp_Object priority_string
;
1209 Lisp_Object trustfiles
;
1210 Lisp_Object crlfiles
;
1211 Lisp_Object keylist
;
1212 /* Lisp_Object callbacks; */
1213 Lisp_Object loglevel
;
1214 Lisp_Object hostname
;
1215 Lisp_Object verify_error
;
1216 Lisp_Object prime_bits
;
1217 Lisp_Object warnings
;
1219 CHECK_PROCESS (proc
);
1220 CHECK_SYMBOL (type
);
1221 CHECK_LIST (proplist
);
1223 if (NILP (Fgnutls_available_p ()))
1224 error ("GnuTLS not available");
1226 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
1227 error ("Invalid GnuTLS credential type");
1229 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1230 priority_string
= Fplist_get (proplist
, QCgnutls_bootprop_priority
);
1231 trustfiles
= Fplist_get (proplist
, QCgnutls_bootprop_trustfiles
);
1232 keylist
= Fplist_get (proplist
, QCgnutls_bootprop_keylist
);
1233 crlfiles
= Fplist_get (proplist
, QCgnutls_bootprop_crlfiles
);
1234 loglevel
= Fplist_get (proplist
, QCgnutls_bootprop_loglevel
);
1235 verify_error
= Fplist_get (proplist
, QCgnutls_bootprop_verify_error
);
1236 prime_bits
= Fplist_get (proplist
, QCgnutls_bootprop_min_prime_bits
);
1238 if (EQ (verify_error
, Qt
))
1240 verify_error_all
= 1;
1242 else if (NILP (Flistp (verify_error
)))
1244 error ("gnutls-boot: invalid :verify_error parameter (not a list)");
1247 if (!STRINGP (hostname
))
1248 error ("gnutls-boot: invalid :hostname parameter (not a string)");
1249 c_hostname
= SSDATA (hostname
);
1251 state
= XPROCESS (proc
)->gnutls_state
;
1253 if (TYPE_RANGED_INTEGERP (int, loglevel
))
1255 gnutls_global_set_log_function (gnutls_log_function
);
1257 gnutls_global_set_audit_log_function (gnutls_audit_log_function
);
1259 gnutls_global_set_log_level (XINT (loglevel
));
1260 max_log_level
= XINT (loglevel
);
1261 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
1264 GNUTLS_LOG2 (1, max_log_level
, "connecting to host:", c_hostname
);
1266 /* Always initialize globals. */
1267 global_init
= emacs_gnutls_global_init ();
1268 if (! NILP (Fgnutls_errorp (global_init
)))
1271 /* Before allocating new credentials, deallocate any credentials
1272 that PROC might already have. */
1273 emacs_gnutls_deinit (proc
);
1275 /* Mark PROC as a GnuTLS process. */
1276 XPROCESS (proc
)->gnutls_state
= NULL
;
1277 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
1278 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
1279 pset_gnutls_cred_type (XPROCESS (proc
), type
);
1280 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
1282 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
1283 if (EQ (type
, Qgnutls_x509pki
))
1285 Lisp_Object verify_flags
;
1286 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
1288 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
1289 check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred
));
1290 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
1292 verify_flags
= Fplist_get (proplist
, QCgnutls_bootprop_verify_flags
);
1293 if (NUMBERP (verify_flags
))
1295 gnutls_verify_flags
= XINT (verify_flags
);
1296 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
1298 else if (NILP (verify_flags
))
1299 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
1301 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
1303 gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
1305 else /* Qgnutls_anon: */
1307 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
1308 check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred
));
1309 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
1312 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
1314 if (EQ (type
, Qgnutls_x509pki
))
1316 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1317 int file_format
= GNUTLS_X509_FMT_PEM
;
1320 #if GNUTLS_VERSION_MAJOR + \
1321 (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
1322 ret
= gnutls_certificate_set_x509_system_trust (x509_cred
);
1323 if (ret
< GNUTLS_E_SUCCESS
)
1325 check_memory_full (ret
);
1326 GNUTLS_LOG2i (4, max_log_level
,
1327 "setting system trust failed with code ", ret
);
1331 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
1333 Lisp_Object trustfile
= XCAR (tail
);
1334 if (STRINGP (trustfile
))
1336 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
1337 SSDATA (trustfile
));
1338 trustfile
= ENCODE_FILE (trustfile
);
1340 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1341 file names on Windows, we need to re-encode the file
1342 name using the current ANSI codepage. */
1343 trustfile
= ansi_encode_filename (trustfile
);
1345 ret
= gnutls_certificate_set_x509_trust_file
1350 if (ret
< GNUTLS_E_SUCCESS
)
1351 return gnutls_make_error (ret
);
1355 emacs_gnutls_deinit (proc
);
1356 error ("Invalid trustfile");
1360 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
1362 Lisp_Object crlfile
= XCAR (tail
);
1363 if (STRINGP (crlfile
))
1365 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
1367 crlfile
= ENCODE_FILE (crlfile
);
1369 crlfile
= ansi_encode_filename (crlfile
);
1371 ret
= gnutls_certificate_set_x509_crl_file
1372 (x509_cred
, SSDATA (crlfile
), file_format
);
1374 if (ret
< GNUTLS_E_SUCCESS
)
1375 return gnutls_make_error (ret
);
1379 emacs_gnutls_deinit (proc
);
1380 error ("Invalid CRL file");
1384 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
1386 Lisp_Object keyfile
= Fcar (XCAR (tail
));
1387 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
1388 if (STRINGP (keyfile
) && STRINGP (certfile
))
1390 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
1392 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
1394 keyfile
= ENCODE_FILE (keyfile
);
1395 certfile
= ENCODE_FILE (certfile
);
1397 keyfile
= ansi_encode_filename (keyfile
);
1398 certfile
= ansi_encode_filename (certfile
);
1400 ret
= gnutls_certificate_set_x509_key_file
1401 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
1403 if (ret
< GNUTLS_E_SUCCESS
)
1404 return gnutls_make_error (ret
);
1408 emacs_gnutls_deinit (proc
);
1409 error (STRINGP (keyfile
) ? "Invalid client cert file"
1410 : "Invalid client key file");
1415 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
1416 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
1417 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
1419 /* Call gnutls_init here: */
1421 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
1422 ret
= gnutls_init (&state
, GNUTLS_CLIENT
);
1423 XPROCESS (proc
)->gnutls_state
= state
;
1424 if (ret
< GNUTLS_E_SUCCESS
)
1425 return gnutls_make_error (ret
);
1426 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
1428 if (STRINGP (priority_string
))
1430 priority_string_ptr
= SSDATA (priority_string
);
1431 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
1432 priority_string_ptr
);
1436 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
1437 priority_string_ptr
);
1440 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
1441 ret
= gnutls_priority_set_direct (state
, priority_string_ptr
, NULL
);
1442 if (ret
< GNUTLS_E_SUCCESS
)
1443 return gnutls_make_error (ret
);
1445 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
1447 if (INTEGERP (prime_bits
))
1448 gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
1450 ret
= EQ (type
, Qgnutls_x509pki
)
1451 ? gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
1452 : gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
1453 if (ret
< GNUTLS_E_SUCCESS
)
1454 return gnutls_make_error (ret
);
1456 if (!gnutls_ip_address_p (c_hostname
))
1458 ret
= gnutls_server_name_set (state
, GNUTLS_NAME_DNS
, c_hostname
,
1459 strlen (c_hostname
));
1460 if (ret
< GNUTLS_E_SUCCESS
)
1461 return gnutls_make_error (ret
);
1464 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
1465 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
1466 if (ret
< GNUTLS_E_SUCCESS
)
1467 return gnutls_make_error (ret
);
1469 /* Now verify the peer, following
1470 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1471 The peer should present at least one certificate in the chain; do a
1472 check of the certificate's hostname with
1473 gnutls_x509_crt_check_hostname against :hostname. */
1475 ret
= gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1476 if (ret
< GNUTLS_E_SUCCESS
)
1477 return gnutls_make_error (ret
);
1479 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1481 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1482 if (!NILP (warnings
))
1485 for (tail
= warnings
; CONSP (tail
); tail
= XCDR (tail
))
1487 Lisp_Object warning
= XCAR (tail
);
1488 Lisp_Object message
= Fgnutls_peer_status_warning_describe (warning
);
1489 if (!NILP (message
))
1490 GNUTLS_LOG2 (1, max_log_level
, "verification:", SSDATA (message
));
1494 if (peer_verification
!= 0)
1496 if (verify_error_all
1497 || !NILP (Fmember (QCgnutls_bootprop_trustfiles
, verify_error
)))
1499 emacs_gnutls_deinit (proc
);
1500 error ("Certificate validation failed %s, verification code %d",
1501 c_hostname
, peer_verification
);
1505 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1510 /* Up to here the process is the same for X.509 certificates and
1511 OpenPGP keys. From now on X.509 certificates are assumed. This
1512 can be easily extended to work with openpgp keys as well. */
1513 if (gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1515 gnutls_x509_crt_t gnutls_verify_cert
;
1516 const gnutls_datum_t
*gnutls_verify_cert_list
;
1517 unsigned int gnutls_verify_cert_list_size
;
1519 ret
= gnutls_x509_crt_init (&gnutls_verify_cert
);
1520 if (ret
< GNUTLS_E_SUCCESS
)
1521 return gnutls_make_error (ret
);
1523 gnutls_verify_cert_list
=
1524 gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1526 if (gnutls_verify_cert_list
== NULL
)
1528 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1529 emacs_gnutls_deinit (proc
);
1530 error ("No x509 certificate was found\n");
1533 /* We only check the first certificate in the given chain. */
1534 ret
= gnutls_x509_crt_import (gnutls_verify_cert
,
1535 &gnutls_verify_cert_list
[0],
1536 GNUTLS_X509_FMT_DER
);
1538 if (ret
< GNUTLS_E_SUCCESS
)
1540 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1541 return gnutls_make_error (ret
);
1544 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1546 int err
= gnutls_x509_crt_check_hostname (gnutls_verify_cert
,
1548 check_memory_full (err
);
1551 XPROCESS (proc
)->gnutls_extra_peer_verification
|=
1552 CERTIFICATE_NOT_MATCHING
;
1553 if (verify_error_all
1554 || !NILP (Fmember (QCgnutls_bootprop_hostname
, verify_error
)))
1556 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1557 emacs_gnutls_deinit (proc
);
1558 error ("The x509 certificate does not match \"%s\"", c_hostname
);
1562 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1568 /* Set this flag only if the whole initialization succeeded. */
1569 XPROCESS (proc
)->gnutls_p
= 1;
1571 return gnutls_make_error (ret
);
1574 DEFUN ("gnutls-bye", Fgnutls_bye
,
1575 Sgnutls_bye
, 2, 2, 0,
1576 doc
: /* Terminate current GnuTLS connection for process PROC.
1577 The connection should have been initiated using `gnutls-handshake'.
1579 If CONT is not nil the TLS connection gets terminated and further
1580 receives and sends will be disallowed. If the return value is zero you
1581 may continue using the connection. If CONT is nil, GnuTLS actually
1582 sends an alert containing a close request and waits for the peer to
1583 reply with the same message. In order to reuse the connection you
1584 should wait for an EOF from the peer.
1586 This function may also return `gnutls-e-again', or
1587 `gnutls-e-interrupted'. */)
1588 (Lisp_Object proc
, Lisp_Object cont
)
1590 gnutls_session_t state
;
1593 CHECK_PROCESS (proc
);
1595 state
= XPROCESS (proc
)->gnutls_state
;
1597 gnutls_x509_crt_deinit (XPROCESS (proc
)->gnutls_certificate
);
1599 ret
= gnutls_bye (state
, NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1601 return gnutls_make_error (ret
);
1604 #endif /* HAVE_GNUTLS */
1606 DEFUN ("gnutls-available-p", Fgnutls_available_p
, Sgnutls_available_p
, 0, 0, 0,
1607 doc
: /* Return t if GnuTLS is available in this instance of Emacs. */
1613 Lisp_Object found
= Fassq (Qgnutls_dll
, Vlibrary_cache
);
1615 return XCDR (found
);
1619 status
= init_gnutls_functions () ? Qt
: Qnil
;
1620 Vlibrary_cache
= Fcons (Fcons (Qgnutls_dll
, status
), Vlibrary_cache
);
1623 # else /* !WINDOWSNT */
1625 # endif /* !WINDOWSNT */
1626 #else /* !HAVE_GNUTLS */
1628 #endif /* !HAVE_GNUTLS */
1632 syms_of_gnutls (void)
1635 gnutls_global_initialized
= 0;
1637 DEFSYM (Qgnutls_dll
, "gnutls");
1638 DEFSYM (Qgnutls_code
, "gnutls-code");
1639 DEFSYM (Qgnutls_anon
, "gnutls-anon");
1640 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
1642 /* The following are for the property list of 'gnutls-boot'. */
1643 DEFSYM (QCgnutls_bootprop_hostname
, ":hostname");
1644 DEFSYM (QCgnutls_bootprop_priority
, ":priority");
1645 DEFSYM (QCgnutls_bootprop_trustfiles
, ":trustfiles");
1646 DEFSYM (QCgnutls_bootprop_keylist
, ":keylist");
1647 DEFSYM (QCgnutls_bootprop_crlfiles
, ":crlfiles");
1648 DEFSYM (QCgnutls_bootprop_callbacks
, ":callbacks");
1649 DEFSYM (QCgnutls_bootprop_min_prime_bits
, ":min-prime-bits");
1650 DEFSYM (QCgnutls_bootprop_loglevel
, ":loglevel");
1651 DEFSYM (QCgnutls_bootprop_verify_flags
, ":verify-flags");
1652 DEFSYM (QCgnutls_bootprop_verify_error
, ":verify-error");
1654 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
1655 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
1656 make_number (GNUTLS_E_INTERRUPTED
));
1658 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
1659 Fput (Qgnutls_e_again
, Qgnutls_code
,
1660 make_number (GNUTLS_E_AGAIN
));
1662 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
1663 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
1664 make_number (GNUTLS_E_INVALID_SESSION
));
1666 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
1667 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
1668 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
1670 defsubr (&Sgnutls_get_initstage
);
1671 defsubr (&Sgnutls_errorp
);
1672 defsubr (&Sgnutls_error_fatalp
);
1673 defsubr (&Sgnutls_error_string
);
1674 defsubr (&Sgnutls_boot
);
1675 defsubr (&Sgnutls_deinit
);
1676 defsubr (&Sgnutls_bye
);
1677 defsubr (&Sgnutls_peer_status
);
1678 defsubr (&Sgnutls_peer_status_warning_describe
);
1680 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
1681 doc
: /* Logging level used by the GnuTLS functions.
1682 Set this larger than 0 to get debug output in the *Messages* buffer.
1683 1 is for important messages, 2 is for debug data, and higher numbers
1684 are as per the GnuTLS logging conventions. */);
1685 global_gnutls_log_level
= 0;
1687 #endif /* HAVE_GNUTLS */
1689 defsubr (&Sgnutls_available_p
);