1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2016 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 (int, gnutls_x509_crt_check_issuer
,
126 (gnutls_x509_crt_t
, gnutls_x509_crt_t
));
127 DEF_DLL_FN (void, gnutls_x509_crt_deinit
, (gnutls_x509_crt_t
));
128 DEF_DLL_FN (int, gnutls_x509_crt_import
,
129 (gnutls_x509_crt_t
, const gnutls_datum_t
*,
130 gnutls_x509_crt_fmt_t
));
131 DEF_DLL_FN (int, gnutls_x509_crt_init
, (gnutls_x509_crt_t
*));
132 DEF_DLL_FN (int, gnutls_x509_crt_get_fingerprint
,
134 gnutls_digest_algorithm_t
, void *, size_t *));
135 DEF_DLL_FN (int, gnutls_x509_crt_get_version
,
136 (gnutls_x509_crt_t
));
137 DEF_DLL_FN (int, gnutls_x509_crt_get_serial
,
138 (gnutls_x509_crt_t
, void *, size_t *));
139 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_dn
,
140 (gnutls_x509_crt_t
, char *, size_t *));
141 DEF_DLL_FN (time_t, gnutls_x509_crt_get_activation_time
,
142 (gnutls_x509_crt_t
));
143 DEF_DLL_FN (time_t, gnutls_x509_crt_get_expiration_time
,
144 (gnutls_x509_crt_t
));
145 DEF_DLL_FN (int, gnutls_x509_crt_get_dn
,
146 (gnutls_x509_crt_t
, char *, size_t *));
147 DEF_DLL_FN (int, gnutls_x509_crt_get_pk_algorithm
,
148 (gnutls_x509_crt_t
, unsigned int *));
149 DEF_DLL_FN (const char*, gnutls_pk_algorithm_get_name
,
150 (gnutls_pk_algorithm_t
));
151 DEF_DLL_FN (int, gnutls_pk_bits_to_sec_param
,
152 (gnutls_pk_algorithm_t
, unsigned int));
153 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_unique_id
,
154 (gnutls_x509_crt_t
, char *, size_t *));
155 DEF_DLL_FN (int, gnutls_x509_crt_get_subject_unique_id
,
156 (gnutls_x509_crt_t
, char *, size_t *));
157 DEF_DLL_FN (int, gnutls_x509_crt_get_signature_algorithm
,
158 (gnutls_x509_crt_t
));
159 DEF_DLL_FN (int, gnutls_x509_crt_get_signature
,
160 (gnutls_x509_crt_t
, char *, size_t *));
161 DEF_DLL_FN (int, gnutls_x509_crt_get_key_id
,
162 (gnutls_x509_crt_t
, unsigned int, unsigned char *, size_t *_size
));
163 DEF_DLL_FN (const char*, gnutls_sec_param_get_name
, (gnutls_sec_param_t
));
164 DEF_DLL_FN (const char*, gnutls_sign_get_name
, (gnutls_sign_algorithm_t
));
165 DEF_DLL_FN (int, gnutls_server_name_set
,
166 (gnutls_session_t
, gnutls_server_name_type_t
,
167 const void *, size_t));
168 DEF_DLL_FN (gnutls_kx_algorithm_t
, gnutls_kx_get
, (gnutls_session_t
));
169 DEF_DLL_FN (const char*, gnutls_kx_get_name
, (gnutls_kx_algorithm_t
));
170 DEF_DLL_FN (gnutls_protocol_t
, gnutls_protocol_get_version
,
172 DEF_DLL_FN (const char*, gnutls_protocol_get_name
, (gnutls_protocol_t
));
173 DEF_DLL_FN (gnutls_cipher_algorithm_t
, gnutls_cipher_get
,
175 DEF_DLL_FN (const char*, gnutls_cipher_get_name
,
176 (gnutls_cipher_algorithm_t
));
177 DEF_DLL_FN (gnutls_mac_algorithm_t
, gnutls_mac_get
, (gnutls_session_t
));
178 DEF_DLL_FN (const char*, gnutls_mac_get_name
, (gnutls_mac_algorithm_t
));
182 init_gnutls_functions (void)
185 int max_log_level
= 1;
187 if (!(library
= w32_delayed_load (Qgnutls_dll
)))
189 GNUTLS_LOG (1, max_log_level
, "GnuTLS library not found");
193 LOAD_DLL_FN (library
, gnutls_alert_get
);
194 LOAD_DLL_FN (library
, gnutls_alert_get_name
);
195 LOAD_DLL_FN (library
, gnutls_alert_send_appropriate
);
196 LOAD_DLL_FN (library
, gnutls_anon_allocate_client_credentials
);
197 LOAD_DLL_FN (library
, gnutls_anon_free_client_credentials
);
198 LOAD_DLL_FN (library
, gnutls_bye
);
199 LOAD_DLL_FN (library
, gnutls_certificate_allocate_credentials
);
200 LOAD_DLL_FN (library
, gnutls_certificate_free_credentials
);
201 LOAD_DLL_FN (library
, gnutls_certificate_get_peers
);
202 LOAD_DLL_FN (library
, gnutls_certificate_set_verify_flags
);
203 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_crl_file
);
204 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_key_file
);
205 # if ((GNUTLS_VERSION_MAJOR \
206 + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20)) \
208 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_system_trust
);
210 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_trust_file
);
211 LOAD_DLL_FN (library
, gnutls_certificate_type_get
);
212 LOAD_DLL_FN (library
, gnutls_certificate_verify_peers2
);
213 LOAD_DLL_FN (library
, gnutls_credentials_set
);
214 LOAD_DLL_FN (library
, gnutls_deinit
);
215 LOAD_DLL_FN (library
, gnutls_dh_set_prime_bits
);
216 LOAD_DLL_FN (library
, gnutls_dh_get_prime_bits
);
217 LOAD_DLL_FN (library
, gnutls_error_is_fatal
);
218 LOAD_DLL_FN (library
, gnutls_global_init
);
219 LOAD_DLL_FN (library
, gnutls_global_set_log_function
);
221 LOAD_DLL_FN (library
, gnutls_global_set_audit_log_function
);
223 LOAD_DLL_FN (library
, gnutls_global_set_log_level
);
224 LOAD_DLL_FN (library
, gnutls_handshake
);
225 LOAD_DLL_FN (library
, gnutls_init
);
226 LOAD_DLL_FN (library
, gnutls_priority_set_direct
);
227 LOAD_DLL_FN (library
, gnutls_record_check_pending
);
228 LOAD_DLL_FN (library
, gnutls_record_recv
);
229 LOAD_DLL_FN (library
, gnutls_record_send
);
230 LOAD_DLL_FN (library
, gnutls_strerror
);
231 LOAD_DLL_FN (library
, gnutls_transport_set_errno
);
232 LOAD_DLL_FN (library
, gnutls_check_version
);
233 /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
234 and later, and the function was removed entirely in 3.0.0. */
235 if (!fn_gnutls_check_version ("2.11.1"))
236 LOAD_DLL_FN (library
, gnutls_transport_set_lowat
);
237 LOAD_DLL_FN (library
, gnutls_transport_set_ptr2
);
238 LOAD_DLL_FN (library
, gnutls_transport_set_pull_function
);
239 LOAD_DLL_FN (library
, gnutls_transport_set_push_function
);
240 LOAD_DLL_FN (library
, gnutls_x509_crt_check_hostname
);
241 LOAD_DLL_FN (library
, gnutls_x509_crt_check_issuer
);
242 LOAD_DLL_FN (library
, gnutls_x509_crt_deinit
);
243 LOAD_DLL_FN (library
, gnutls_x509_crt_import
);
244 LOAD_DLL_FN (library
, gnutls_x509_crt_init
);
245 LOAD_DLL_FN (library
, gnutls_x509_crt_get_fingerprint
);
246 LOAD_DLL_FN (library
, gnutls_x509_crt_get_version
);
247 LOAD_DLL_FN (library
, gnutls_x509_crt_get_serial
);
248 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_dn
);
249 LOAD_DLL_FN (library
, gnutls_x509_crt_get_activation_time
);
250 LOAD_DLL_FN (library
, gnutls_x509_crt_get_expiration_time
);
251 LOAD_DLL_FN (library
, gnutls_x509_crt_get_dn
);
252 LOAD_DLL_FN (library
, gnutls_x509_crt_get_pk_algorithm
);
253 LOAD_DLL_FN (library
, gnutls_pk_algorithm_get_name
);
254 LOAD_DLL_FN (library
, gnutls_pk_bits_to_sec_param
);
255 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_unique_id
);
256 LOAD_DLL_FN (library
, gnutls_x509_crt_get_subject_unique_id
);
257 LOAD_DLL_FN (library
, gnutls_x509_crt_get_signature_algorithm
);
258 LOAD_DLL_FN (library
, gnutls_x509_crt_get_signature
);
259 LOAD_DLL_FN (library
, gnutls_x509_crt_get_key_id
);
260 LOAD_DLL_FN (library
, gnutls_sec_param_get_name
);
261 LOAD_DLL_FN (library
, gnutls_sign_get_name
);
262 LOAD_DLL_FN (library
, gnutls_server_name_set
);
263 LOAD_DLL_FN (library
, gnutls_kx_get
);
264 LOAD_DLL_FN (library
, gnutls_kx_get_name
);
265 LOAD_DLL_FN (library
, gnutls_protocol_get_version
);
266 LOAD_DLL_FN (library
, gnutls_protocol_get_name
);
267 LOAD_DLL_FN (library
, gnutls_cipher_get
);
268 LOAD_DLL_FN (library
, gnutls_cipher_get_name
);
269 LOAD_DLL_FN (library
, gnutls_mac_get
);
270 LOAD_DLL_FN (library
, gnutls_mac_get_name
);
272 max_log_level
= global_gnutls_log_level
;
275 Lisp_Object name
= CAR_SAFE (Fget (Qgnutls_dll
, QCloaded_from
));
276 GNUTLS_LOG2 (1, max_log_level
, "GnuTLS library loaded:",
277 STRINGP (name
) ? (const char *) SDATA (name
) : "unknown");
283 # define gnutls_alert_get fn_gnutls_alert_get
284 # define gnutls_alert_get_name fn_gnutls_alert_get_name
285 # define gnutls_alert_send_appropriate fn_gnutls_alert_send_appropriate
286 # define gnutls_anon_allocate_client_credentials fn_gnutls_anon_allocate_client_credentials
287 # define gnutls_anon_free_client_credentials fn_gnutls_anon_free_client_credentials
288 # define gnutls_bye fn_gnutls_bye
289 # define gnutls_certificate_allocate_credentials fn_gnutls_certificate_allocate_credentials
290 # define gnutls_certificate_free_credentials fn_gnutls_certificate_free_credentials
291 # define gnutls_certificate_get_peers fn_gnutls_certificate_get_peers
292 # define gnutls_certificate_set_verify_flags fn_gnutls_certificate_set_verify_flags
293 # define gnutls_certificate_set_x509_crl_file fn_gnutls_certificate_set_x509_crl_file
294 # define gnutls_certificate_set_x509_key_file fn_gnutls_certificate_set_x509_key_file
295 # define gnutls_certificate_set_x509_system_trust fn_gnutls_certificate_set_x509_system_trust
296 # define gnutls_certificate_set_x509_trust_file fn_gnutls_certificate_set_x509_trust_file
297 # define gnutls_certificate_type_get fn_gnutls_certificate_type_get
298 # define gnutls_certificate_verify_peers2 fn_gnutls_certificate_verify_peers2
299 # define gnutls_check_version fn_gnutls_check_version
300 # define gnutls_cipher_get fn_gnutls_cipher_get
301 # define gnutls_cipher_get_name fn_gnutls_cipher_get_name
302 # define gnutls_credentials_set fn_gnutls_credentials_set
303 # define gnutls_deinit fn_gnutls_deinit
304 # define gnutls_dh_get_prime_bits fn_gnutls_dh_get_prime_bits
305 # define gnutls_dh_set_prime_bits fn_gnutls_dh_set_prime_bits
306 # define gnutls_error_is_fatal fn_gnutls_error_is_fatal
307 # define gnutls_global_init fn_gnutls_global_init
308 # define gnutls_global_set_audit_log_function fn_gnutls_global_set_audit_log_function
309 # define gnutls_global_set_log_function fn_gnutls_global_set_log_function
310 # define gnutls_global_set_log_level fn_gnutls_global_set_log_level
311 # define gnutls_handshake fn_gnutls_handshake
312 # define gnutls_init fn_gnutls_init
313 # define gnutls_kx_get fn_gnutls_kx_get
314 # define gnutls_kx_get_name fn_gnutls_kx_get_name
315 # define gnutls_mac_get fn_gnutls_mac_get
316 # define gnutls_mac_get_name fn_gnutls_mac_get_name
317 # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name
318 # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param
319 # define gnutls_priority_set_direct fn_gnutls_priority_set_direct
320 # define gnutls_protocol_get_name fn_gnutls_protocol_get_name
321 # define gnutls_protocol_get_version fn_gnutls_protocol_get_version
322 # define gnutls_record_check_pending fn_gnutls_record_check_pending
323 # define gnutls_record_recv fn_gnutls_record_recv
324 # define gnutls_record_send fn_gnutls_record_send
325 # define gnutls_sec_param_get_name fn_gnutls_sec_param_get_name
326 # define gnutls_server_name_set fn_gnutls_server_name_set
327 # define gnutls_sign_get_name fn_gnutls_sign_get_name
328 # define gnutls_strerror fn_gnutls_strerror
329 # define gnutls_transport_set_errno fn_gnutls_transport_set_errno
330 # define gnutls_transport_set_lowat fn_gnutls_transport_set_lowat
331 # define gnutls_transport_set_ptr2 fn_gnutls_transport_set_ptr2
332 # define gnutls_transport_set_pull_function fn_gnutls_transport_set_pull_function
333 # define gnutls_transport_set_push_function fn_gnutls_transport_set_push_function
334 # define gnutls_x509_crt_check_hostname fn_gnutls_x509_crt_check_hostname
335 # define gnutls_x509_crt_check_issuer fn_gnutls_x509_crt_check_issuer
336 # define gnutls_x509_crt_deinit fn_gnutls_x509_crt_deinit
337 # define gnutls_x509_crt_get_activation_time fn_gnutls_x509_crt_get_activation_time
338 # define gnutls_x509_crt_get_dn fn_gnutls_x509_crt_get_dn
339 # define gnutls_x509_crt_get_expiration_time fn_gnutls_x509_crt_get_expiration_time
340 # define gnutls_x509_crt_get_fingerprint fn_gnutls_x509_crt_get_fingerprint
341 # define gnutls_x509_crt_get_issuer_dn fn_gnutls_x509_crt_get_issuer_dn
342 # define gnutls_x509_crt_get_issuer_unique_id fn_gnutls_x509_crt_get_issuer_unique_id
343 # define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id
344 # define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm
345 # define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial
346 # define gnutls_x509_crt_get_signature fn_gnutls_x509_crt_get_signature
347 # define gnutls_x509_crt_get_signature_algorithm fn_gnutls_x509_crt_get_signature_algorithm
348 # define gnutls_x509_crt_get_subject_unique_id fn_gnutls_x509_crt_get_subject_unique_id
349 # define gnutls_x509_crt_get_version fn_gnutls_x509_crt_get_version
350 # define gnutls_x509_crt_import fn_gnutls_x509_crt_import
351 # define gnutls_x509_crt_init fn_gnutls_x509_crt_init
356 /* Report memory exhaustion if ERR is an out-of-memory indication. */
358 check_memory_full (int err
)
360 /* When GnuTLS exhausts memory, it doesn't say how much memory it
361 asked for, so tell the Emacs allocator that GnuTLS asked for no
362 bytes. This isn't accurate, but it's good enough. */
363 if (err
== GNUTLS_E_MEMORY_ERROR
)
368 /* Log a simple audit message. */
370 gnutls_audit_log_function (gnutls_session_t session
, const char *string
)
372 if (global_gnutls_log_level
>= 1)
374 message ("gnutls.c: [audit] %s", string
);
379 /* Log a simple message. */
381 gnutls_log_function (int level
, const char *string
)
383 message ("gnutls.c: [%d] %s", level
, string
);
386 /* Log a message and a string. */
388 gnutls_log_function2 (int level
, const char *string
, const char *extra
)
390 message ("gnutls.c: [%d] %s %s", level
, string
, extra
);
393 /* Log a message and an integer. */
395 gnutls_log_function2i (int level
, const char *string
, int extra
)
397 message ("gnutls.c: [%d] %s %d", level
, string
, extra
);
401 gnutls_try_handshake (struct Lisp_Process
*proc
)
403 gnutls_session_t state
= proc
->gnutls_state
;
405 bool non_blocking
= proc
->is_non_blocking_client
;
407 if (proc
->gnutls_complete_negotiation_p
)
408 non_blocking
= false;
411 proc
->gnutls_p
= true;
415 ret
= gnutls_handshake (state
);
416 emacs_gnutls_handle_error (state
, ret
);
420 && gnutls_error_is_fatal (ret
) == 0
423 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
425 if (ret
== GNUTLS_E_SUCCESS
)
427 /* Here we're finally done. */
428 proc
->gnutls_initstage
= GNUTLS_STAGE_READY
;
432 /* check_memory_full (gnutls_alert_send_appropriate (state, ret)); */
438 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
440 gnutls_session_t state
= proc
->gnutls_state
;
442 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
445 if (proc
->gnutls_initstage
< GNUTLS_STAGE_TRANSPORT_POINTERS_SET
)
448 /* On W32 we cannot transfer socket handles between different runtime
449 libraries, so we tell GnuTLS to use our special push/pull
451 gnutls_transport_set_ptr2 (state
,
452 (gnutls_transport_ptr_t
) proc
,
453 (gnutls_transport_ptr_t
) proc
);
454 gnutls_transport_set_push_function (state
, &emacs_gnutls_push
);
455 gnutls_transport_set_pull_function (state
, &emacs_gnutls_pull
);
457 /* For non blocking sockets or other custom made pull/push
458 functions the gnutls_transport_set_lowat must be called, with
459 a zero low water mark value. (GnuTLS 2.10.4 documentation)
461 (Note: this is probably not strictly necessary as the lowat
462 value is only used when no custom pull/push functions are
464 /* According to GnuTLS NEWS file, lowat level has been set to
465 zero by default in version 2.11.1, and the function
466 gnutls_transport_set_lowat was removed from the library in
468 if (!gnutls_check_version ("2.11.1"))
469 gnutls_transport_set_lowat (state
, 0);
471 /* This is how GnuTLS takes sockets: as file descriptors passed
472 in. For an Emacs process socket, infd and outfd are the
473 same but we use this two-argument version for clarity. */
474 gnutls_transport_set_ptr2 (state
,
475 (void *) (intptr_t) proc
->infd
,
476 (void *) (intptr_t) proc
->outfd
);
479 proc
->gnutls_initstage
= GNUTLS_STAGE_TRANSPORT_POINTERS_SET
;
482 return gnutls_try_handshake (proc
);
486 emacs_gnutls_record_check_pending (gnutls_session_t state
)
488 return gnutls_record_check_pending (state
);
493 emacs_gnutls_transport_set_errno (gnutls_session_t state
, int err
)
495 gnutls_transport_set_errno (state
, err
);
500 emacs_gnutls_write (struct Lisp_Process
*proc
, const char *buf
, ptrdiff_t nbyte
)
503 ptrdiff_t bytes_written
;
504 gnutls_session_t state
= proc
->gnutls_state
;
506 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
516 rtnval
= gnutls_record_send (state
, buf
, nbyte
);
520 if (rtnval
== GNUTLS_E_INTERRUPTED
)
524 /* If we get GNUTLS_E_AGAIN, then set errno
525 appropriately so that send_process retries the
526 correct way instead of erroring out. */
527 if (rtnval
== GNUTLS_E_AGAIN
)
535 bytes_written
+= rtnval
;
538 emacs_gnutls_handle_error (state
, rtnval
);
539 return (bytes_written
);
543 emacs_gnutls_read (struct Lisp_Process
*proc
, char *buf
, ptrdiff_t nbyte
)
546 gnutls_session_t state
= proc
->gnutls_state
;
548 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
554 rtnval
= gnutls_record_recv (state
, buf
, nbyte
);
557 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
558 /* The peer closed the connection. */
560 else if (emacs_gnutls_handle_error (state
, rtnval
))
561 /* non-fatal error */
564 /* a fatal error occurred */
569 /* Report a GnuTLS error to the user.
570 Return true if the error code was successfully handled. */
572 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
574 int max_log_level
= 0;
579 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
583 check_memory_full (err
);
585 max_log_level
= global_gnutls_log_level
;
587 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
589 str
= gnutls_strerror (err
);
593 if (gnutls_error_is_fatal (err
))
596 GNUTLS_LOG2 (1, max_log_level
, "fatal error:", str
);
617 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
618 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
620 int alert
= gnutls_alert_get (session
);
621 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
622 str
= gnutls_alert_get_name (alert
);
626 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
631 /* convert an integer error to a Lisp_Object; it will be either a
632 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
633 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
636 gnutls_make_error (int err
)
640 case GNUTLS_E_SUCCESS
:
643 return Qgnutls_e_again
;
644 case GNUTLS_E_INTERRUPTED
:
645 return Qgnutls_e_interrupted
;
646 case GNUTLS_E_INVALID_SESSION
:
647 return Qgnutls_e_invalid_session
;
650 check_memory_full (err
);
651 return make_number (err
);
655 emacs_gnutls_deinit (Lisp_Object proc
)
659 CHECK_PROCESS (proc
);
661 if (! XPROCESS (proc
)->gnutls_p
)
664 log_level
= XPROCESS (proc
)->gnutls_log_level
;
666 if (XPROCESS (proc
)->gnutls_x509_cred
)
668 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
669 gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
670 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
673 if (XPROCESS (proc
)->gnutls_anon_cred
)
675 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
676 gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
677 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
680 if (XPROCESS (proc
)->gnutls_state
)
682 gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
683 XPROCESS (proc
)->gnutls_state
= NULL
;
684 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
685 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
688 XPROCESS (proc
)->gnutls_p
= false;
692 DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters
,
693 Sgnutls_asynchronous_parameters
, 2, 2, 0,
694 doc
: /* Mark this process as being a pre-init GnuTLS process.
695 The second parameter is the list of parameters to feed to gnutls-boot
696 to finish setting up the connection. */)
697 (Lisp_Object proc
, Lisp_Object params
)
699 CHECK_PROCESS (proc
);
701 XPROCESS (proc
)->gnutls_boot_parameters
= params
;
705 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
706 doc
: /* Return the GnuTLS init stage of process PROC.
707 See also `gnutls-boot'. */)
710 CHECK_PROCESS (proc
);
712 return make_number (GNUTLS_INITSTAGE (proc
));
715 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
716 doc
: /* Return t if ERROR indicates a GnuTLS problem.
717 ERROR is an integer or a symbol with an integer `gnutls-code' property.
718 usage: (gnutls-errorp ERROR) */
722 if (EQ (err
, Qt
)) return Qnil
;
727 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
728 doc
: /* Return non-nil if ERROR is fatal.
729 ERROR is an integer or a symbol with an integer `gnutls-code' property.
730 Usage: (gnutls-error-fatalp ERROR) */)
735 if (EQ (err
, Qt
)) return Qnil
;
739 code
= Fget (err
, Qgnutls_code
);
746 error ("Symbol has no numeric gnutls-code property");
750 if (! TYPE_RANGED_INTEGERP (int, err
))
751 error ("Not an error symbol or code");
753 if (0 == gnutls_error_is_fatal (XINT (err
)))
759 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
760 doc
: /* Return a description of ERROR.
761 ERROR is an integer or a symbol with an integer `gnutls-code' property.
762 usage: (gnutls-error-string ERROR) */)
767 if (EQ (err
, Qt
)) return build_string ("Not an error");
771 code
= Fget (err
, Qgnutls_code
);
778 return build_string ("Symbol has no numeric gnutls-code property");
782 if (! TYPE_RANGED_INTEGERP (int, err
))
783 return build_string ("Not an error symbol or code");
785 return build_string (gnutls_strerror (XINT (err
)));
788 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
789 doc
: /* Deallocate GnuTLS resources associated with process PROC.
790 See also `gnutls-init'. */)
793 return emacs_gnutls_deinit (proc
);
797 gnutls_hex_string (unsigned char *buf
, ptrdiff_t buf_size
, const char *prefix
)
799 ptrdiff_t prefix_length
= strlen (prefix
);
801 if (INT_MULTIPLY_WRAPV (buf_size
, 3, &retlen
)
802 || INT_ADD_WRAPV (prefix_length
- (buf_size
!= 0), retlen
, &retlen
))
804 Lisp_Object ret
= make_uninit_string (retlen
);
805 char *string
= SSDATA (ret
);
806 strcpy (string
, prefix
);
808 for (ptrdiff_t i
= 0; i
< buf_size
; i
++)
809 sprintf (string
+ i
* 3 + prefix_length
,
810 i
== buf_size
- 1 ? "%02x" : "%02x:",
817 gnutls_certificate_details (gnutls_x509_crt_t cert
)
819 Lisp_Object res
= Qnil
;
825 int version
= gnutls_x509_crt_get_version (cert
);
826 check_memory_full (version
);
827 if (version
>= GNUTLS_E_SUCCESS
)
828 res
= nconc2 (res
, list2 (intern (":version"),
829 make_number (version
)));
834 err
= gnutls_x509_crt_get_serial (cert
, NULL
, &buf_size
);
835 check_memory_full (err
);
836 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
838 void *serial
= xmalloc (buf_size
);
839 err
= gnutls_x509_crt_get_serial (cert
, serial
, &buf_size
);
840 check_memory_full (err
);
841 if (err
>= GNUTLS_E_SUCCESS
)
842 res
= nconc2 (res
, list2 (intern (":serial-number"),
843 gnutls_hex_string (serial
, buf_size
, "")));
849 err
= gnutls_x509_crt_get_issuer_dn (cert
, NULL
, &buf_size
);
850 check_memory_full (err
);
851 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
853 char *dn
= xmalloc (buf_size
);
854 err
= gnutls_x509_crt_get_issuer_dn (cert
, dn
, &buf_size
);
855 check_memory_full (err
);
856 if (err
>= GNUTLS_E_SUCCESS
)
857 res
= nconc2 (res
, list2 (intern (":issuer"),
858 make_string (dn
, buf_size
)));
864 /* Add 1 to the buffer size, since 1900 is added to tm_year and
865 that might add 1 to the year length. */
866 char buf
[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
868 time_t tim
= gnutls_x509_crt_get_activation_time (cert
);
870 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
871 res
= nconc2 (res
, list2 (intern (":valid-from"), build_string (buf
)));
873 tim
= gnutls_x509_crt_get_expiration_time (cert
);
874 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
875 res
= nconc2 (res
, list2 (intern (":valid-to"), build_string (buf
)));
880 err
= gnutls_x509_crt_get_dn (cert
, NULL
, &buf_size
);
881 check_memory_full (err
);
882 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
884 char *dn
= xmalloc (buf_size
);
885 err
= gnutls_x509_crt_get_dn (cert
, dn
, &buf_size
);
886 check_memory_full (err
);
887 if (err
>= GNUTLS_E_SUCCESS
)
888 res
= nconc2 (res
, list2 (intern (":subject"),
889 make_string (dn
, buf_size
)));
893 /* Versions older than 2.11 doesn't have these four functions. */
894 #if GNUTLS_VERSION_NUMBER >= 0x020b00
895 /* SubjectPublicKeyInfo. */
899 err
= gnutls_x509_crt_get_pk_algorithm (cert
, &bits
);
900 check_memory_full (err
);
901 if (err
>= GNUTLS_E_SUCCESS
)
903 const char *name
= gnutls_pk_algorithm_get_name (err
);
905 res
= nconc2 (res
, list2 (intern (":public-key-algorithm"),
906 build_string (name
)));
908 name
= gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
910 res
= nconc2 (res
, list2 (intern (":certificate-security-level"),
911 build_string (name
)));
917 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, NULL
, &buf_size
);
918 check_memory_full (err
);
919 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
921 char *buf
= xmalloc (buf_size
);
922 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, buf
, &buf_size
);
923 check_memory_full (err
);
924 if (err
>= GNUTLS_E_SUCCESS
)
925 res
= nconc2 (res
, list2 (intern (":issuer-unique-id"),
926 make_string (buf
, buf_size
)));
931 err
= gnutls_x509_crt_get_subject_unique_id (cert
, NULL
, &buf_size
);
932 check_memory_full (err
);
933 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
935 char *buf
= xmalloc (buf_size
);
936 err
= gnutls_x509_crt_get_subject_unique_id (cert
, buf
, &buf_size
);
937 check_memory_full (err
);
938 if (err
>= GNUTLS_E_SUCCESS
)
939 res
= nconc2 (res
, list2 (intern (":subject-unique-id"),
940 make_string (buf
, buf_size
)));
946 err
= gnutls_x509_crt_get_signature_algorithm (cert
);
947 check_memory_full (err
);
948 if (err
>= GNUTLS_E_SUCCESS
)
950 const char *name
= gnutls_sign_get_name (err
);
952 res
= nconc2 (res
, list2 (intern (":signature-algorithm"),
953 build_string (name
)));
958 err
= gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
959 check_memory_full (err
);
960 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
962 void *buf
= xmalloc (buf_size
);
963 err
= gnutls_x509_crt_get_key_id (cert
, 0, buf
, &buf_size
);
964 check_memory_full (err
);
965 if (err
>= GNUTLS_E_SUCCESS
)
966 res
= nconc2 (res
, list2 (intern (":public-key-id"),
967 gnutls_hex_string (buf
, buf_size
, "sha1:")));
971 /* Certificate fingerprint. */
973 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
975 check_memory_full (err
);
976 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
978 void *buf
= xmalloc (buf_size
);
979 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
981 check_memory_full (err
);
982 if (err
>= GNUTLS_E_SUCCESS
)
983 res
= nconc2 (res
, list2 (intern (":certificate-id"),
984 gnutls_hex_string (buf
, buf_size
, "sha1:")));
991 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
992 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
993 (Lisp_Object status_symbol
)
995 CHECK_SYMBOL (status_symbol
);
997 if (EQ (status_symbol
, intern (":invalid")))
998 return build_string ("certificate could not be verified");
1000 if (EQ (status_symbol
, intern (":revoked")))
1001 return build_string ("certificate was revoked (CRL)");
1003 if (EQ (status_symbol
, intern (":self-signed")))
1004 return build_string ("certificate signer was not found (self-signed)");
1006 if (EQ (status_symbol
, intern (":unknown-ca")))
1007 return build_string ("the certificate was signed by an unknown "
1008 "and therefore untrusted authority");
1010 if (EQ (status_symbol
, intern (":not-ca")))
1011 return build_string ("certificate signer is not a CA");
1013 if (EQ (status_symbol
, intern (":insecure")))
1014 return build_string ("certificate was signed with an insecure algorithm");
1016 if (EQ (status_symbol
, intern (":not-activated")))
1017 return build_string ("certificate is not yet activated");
1019 if (EQ (status_symbol
, intern (":expired")))
1020 return build_string ("certificate has expired");
1022 if (EQ (status_symbol
, intern (":no-host-match")))
1023 return build_string ("certificate host does not match hostname");
1028 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
1029 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1030 The return value is a property list with top-level keys :warnings and
1031 :certificate. The :warnings entry is a list of symbols you can describe with
1032 `gnutls-peer-status-warning-describe'. */)
1035 Lisp_Object warnings
= Qnil
, result
= Qnil
;
1036 unsigned int verification
;
1037 gnutls_session_t state
;
1039 CHECK_PROCESS (proc
);
1041 if (GNUTLS_INITSTAGE (proc
) != GNUTLS_STAGE_READY
)
1044 /* Then collect any warnings already computed by the handshake. */
1045 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
1047 if (verification
& GNUTLS_CERT_INVALID
)
1048 warnings
= Fcons (intern (":invalid"), warnings
);
1050 if (verification
& GNUTLS_CERT_REVOKED
)
1051 warnings
= Fcons (intern (":revoked"), warnings
);
1053 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1054 warnings
= Fcons (intern (":unknown-ca"), warnings
);
1056 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1057 warnings
= Fcons (intern (":not-ca"), warnings
);
1059 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1060 warnings
= Fcons (intern (":insecure"), warnings
);
1062 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1063 warnings
= Fcons (intern (":not-activated"), warnings
);
1065 if (verification
& GNUTLS_CERT_EXPIRED
)
1066 warnings
= Fcons (intern (":expired"), warnings
);
1068 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1069 CERTIFICATE_NOT_MATCHING
)
1070 warnings
= Fcons (intern (":no-host-match"), warnings
);
1072 /* This could get called in the INIT stage, when the certificate is
1074 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
&&
1075 gnutls_x509_crt_check_issuer(XPROCESS (proc
)->gnutls_certificate
,
1076 XPROCESS (proc
)->gnutls_certificate
))
1077 warnings
= Fcons (intern (":self-signed"), warnings
);
1079 if (!NILP (warnings
))
1080 result
= list2 (intern (":warnings"), warnings
);
1082 /* This could get called in the INIT stage, when the certificate is
1084 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1085 result
= nconc2 (result
, list2
1086 (intern (":certificate"),
1087 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1089 state
= XPROCESS (proc
)->gnutls_state
;
1091 /* Diffie-Hellman prime bits. */
1093 int bits
= gnutls_dh_get_prime_bits (state
);
1094 check_memory_full (bits
);
1096 result
= nconc2 (result
, list2 (intern (":diffie-hellman-prime-bits"),
1097 make_number (bits
)));
1102 (result
, list2 (intern (":key-exchange"),
1103 build_string (gnutls_kx_get_name
1104 (gnutls_kx_get (state
)))));
1106 /* Protocol name. */
1108 (result
, list2 (intern (":protocol"),
1109 build_string (gnutls_protocol_get_name
1110 (gnutls_protocol_get_version (state
)))));
1114 (result
, list2 (intern (":cipher"),
1115 build_string (gnutls_cipher_get_name
1116 (gnutls_cipher_get (state
)))));
1120 (result
, list2 (intern (":mac"),
1121 build_string (gnutls_mac_get_name
1122 (gnutls_mac_get (state
)))));
1128 /* Initialize global GnuTLS state to defaults.
1129 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1130 Return zero on success. */
1132 emacs_gnutls_global_init (void)
1134 int ret
= GNUTLS_E_SUCCESS
;
1136 if (!gnutls_global_initialized
)
1138 ret
= gnutls_global_init ();
1139 if (ret
== GNUTLS_E_SUCCESS
)
1140 gnutls_global_initialized
= 1;
1143 return gnutls_make_error (ret
);
1147 gnutls_ip_address_p (char *string
)
1151 while ((c
= *string
++) != 0)
1152 if (! ((c
== '.' || c
== ':' || (c
>= '0' && c
<= '9'))))
1159 /* Deinitialize global GnuTLS state.
1160 See also `gnutls-global-init'. */
1162 emacs_gnutls_global_deinit (void)
1164 if (gnutls_global_initialized
)
1165 gnutls_global_deinit ();
1167 gnutls_global_initialized
= 0;
1169 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1173 static void ATTRIBUTE_FORMAT_PRINTF (2, 3)
1174 boot_error (struct Lisp_Process
*p
, const char *m
, ...)
1178 if (p
->is_non_blocking_client
)
1179 pset_status (p
, list2 (Qfailed
, vformat_string (m
, ap
)));
1185 gnutls_verify_boot (Lisp_Object proc
, Lisp_Object proplist
)
1188 struct Lisp_Process
*p
= XPROCESS (proc
);
1189 gnutls_session_t state
= p
->gnutls_state
;
1190 unsigned int peer_verification
;
1191 Lisp_Object warnings
;
1192 int max_log_level
= p
->gnutls_log_level
;
1193 Lisp_Object hostname
, verify_error
;
1194 bool verify_error_all
= false;
1197 if (NILP (proplist
))
1198 proplist
= Fcdr (Fplist_get (p
->childp
, QCtls_parameters
));
1200 verify_error
= Fplist_get (proplist
, QCgnutls_bootprop_verify_error
);
1201 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1203 if (EQ (verify_error
, Qt
))
1204 verify_error_all
= true;
1205 else if (NILP (Flistp (verify_error
)))
1208 "gnutls-boot: invalid :verify_error parameter (not a list)");
1212 if (!STRINGP (hostname
))
1214 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1217 c_hostname
= SSDATA (hostname
);
1219 /* Now verify the peer, following
1220 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1221 The peer should present at least one certificate in the chain; do a
1222 check of the certificate's hostname with
1223 gnutls_x509_crt_check_hostname against :hostname. */
1225 ret
= gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1226 if (ret
< GNUTLS_E_SUCCESS
)
1227 return gnutls_make_error (ret
);
1229 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1231 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1232 if (!NILP (warnings
))
1234 for (Lisp_Object tail
= warnings
; CONSP (tail
); tail
= XCDR (tail
))
1236 Lisp_Object warning
= XCAR (tail
);
1237 Lisp_Object message
= Fgnutls_peer_status_warning_describe (warning
);
1238 if (!NILP (message
))
1239 GNUTLS_LOG2 (1, max_log_level
, "verification:", SSDATA (message
));
1243 if (peer_verification
!= 0)
1245 if (verify_error_all
1246 || !NILP (Fmember (QCgnutls_bootprop_trustfiles
, verify_error
)))
1248 emacs_gnutls_deinit (proc
);
1250 "Certificate validation failed %s, verification code %x",
1251 c_hostname
, peer_verification
);
1256 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1261 /* Up to here the process is the same for X.509 certificates and
1262 OpenPGP keys. From now on X.509 certificates are assumed. This
1263 can be easily extended to work with openpgp keys as well. */
1264 if (gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1266 gnutls_x509_crt_t gnutls_verify_cert
;
1267 const gnutls_datum_t
*gnutls_verify_cert_list
;
1268 unsigned int gnutls_verify_cert_list_size
;
1270 ret
= gnutls_x509_crt_init (&gnutls_verify_cert
);
1271 if (ret
< GNUTLS_E_SUCCESS
)
1272 return gnutls_make_error (ret
);
1274 gnutls_verify_cert_list
1275 = gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1277 if (gnutls_verify_cert_list
== NULL
)
1279 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1280 emacs_gnutls_deinit (proc
);
1281 boot_error (p
, "No x509 certificate was found\n");
1285 /* Check only the first certificate in the given chain. */
1286 ret
= gnutls_x509_crt_import (gnutls_verify_cert
,
1287 &gnutls_verify_cert_list
[0],
1288 GNUTLS_X509_FMT_DER
);
1290 if (ret
< GNUTLS_E_SUCCESS
)
1292 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1293 return gnutls_make_error (ret
);
1296 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1298 int err
= gnutls_x509_crt_check_hostname (gnutls_verify_cert
,
1300 check_memory_full (err
);
1303 XPROCESS (proc
)->gnutls_extra_peer_verification
1304 |= CERTIFICATE_NOT_MATCHING
;
1305 if (verify_error_all
1306 || !NILP (Fmember (QCgnutls_bootprop_hostname
, verify_error
)))
1308 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1309 emacs_gnutls_deinit (proc
);
1310 boot_error (p
, "The x509 certificate does not match \"%s\"",
1315 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1320 /* Set this flag only if the whole initialization succeeded. */
1321 XPROCESS (proc
)->gnutls_p
= true;
1323 return gnutls_make_error (ret
);
1326 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
1327 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1328 Currently only client mode is supported. Return a success/failure
1329 value you can check with `gnutls-errorp'.
1331 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1332 PROPLIST is a property list with the following keys:
1334 :hostname is a string naming the remote host.
1336 :priority is a GnuTLS priority string, defaults to "NORMAL".
1338 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1340 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1342 :keylist is an alist of PEM-encoded key files and PEM-encoded
1343 certificates for `gnutls-x509pki'.
1345 :callbacks is an alist of callback functions, see below.
1347 :loglevel is the debug level requested from GnuTLS, try 4.
1349 :verify-flags is a bitset as per GnuTLS'
1350 gnutls_certificate_set_verify_flags.
1352 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1355 :verify-error is a list of symbols to express verification checks or
1356 t to do all checks. Currently it can contain `:trustfiles' and
1357 `:hostname' to verify the certificate or the hostname respectively.
1359 :min-prime-bits is the minimum accepted number of bits the client will
1360 accept in Diffie-Hellman key exchange.
1362 :complete-negotiation, if non-nil, will make negotiation complete
1363 before returning even on non-blocking sockets.
1365 The debug level will be set for this process AND globally for GnuTLS.
1366 So if you set it higher or lower at any point, it affects global
1369 Note that the priority is set on the client. The server does not use
1370 the protocols's priority except for disabling protocols that were not
1373 Processes must be initialized with this function before other GnuTLS
1374 functions are used. This function allocates resources which can only
1375 be deallocated by calling `gnutls-deinit' or by calling it again.
1377 The callbacks alist can have a `verify' key, associated with a
1378 verification function (UNUSED).
1380 Each authentication type may need additional information in order to
1381 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1382 one trustfile (usually a CA bundle). */)
1383 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
1385 int ret
= GNUTLS_E_SUCCESS
;
1386 int max_log_level
= 0;
1388 gnutls_session_t state
;
1389 gnutls_certificate_credentials_t x509_cred
= NULL
;
1390 gnutls_anon_client_credentials_t anon_cred
= NULL
;
1391 Lisp_Object global_init
;
1392 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
1395 /* Placeholders for the property list elements. */
1396 Lisp_Object priority_string
;
1397 Lisp_Object trustfiles
;
1398 Lisp_Object crlfiles
;
1399 Lisp_Object keylist
;
1400 /* Lisp_Object callbacks; */
1401 Lisp_Object loglevel
;
1402 Lisp_Object hostname
;
1403 Lisp_Object prime_bits
;
1404 struct Lisp_Process
*p
= XPROCESS (proc
);
1406 CHECK_PROCESS (proc
);
1407 CHECK_SYMBOL (type
);
1408 CHECK_LIST (proplist
);
1410 if (NILP (Fgnutls_available_p ()))
1412 boot_error (p
, "GnuTLS not available");
1416 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
1418 boot_error (p
, "Invalid GnuTLS credential type");
1422 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1423 priority_string
= Fplist_get (proplist
, QCgnutls_bootprop_priority
);
1424 trustfiles
= Fplist_get (proplist
, QCgnutls_bootprop_trustfiles
);
1425 keylist
= Fplist_get (proplist
, QCgnutls_bootprop_keylist
);
1426 crlfiles
= Fplist_get (proplist
, QCgnutls_bootprop_crlfiles
);
1427 loglevel
= Fplist_get (proplist
, QCgnutls_bootprop_loglevel
);
1428 prime_bits
= Fplist_get (proplist
, QCgnutls_bootprop_min_prime_bits
);
1430 if (!STRINGP (hostname
))
1432 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1435 c_hostname
= SSDATA (hostname
);
1437 state
= XPROCESS (proc
)->gnutls_state
;
1439 if (TYPE_RANGED_INTEGERP (int, loglevel
))
1441 gnutls_global_set_log_function (gnutls_log_function
);
1443 gnutls_global_set_audit_log_function (gnutls_audit_log_function
);
1445 gnutls_global_set_log_level (XINT (loglevel
));
1446 max_log_level
= XINT (loglevel
);
1447 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
1450 GNUTLS_LOG2 (1, max_log_level
, "connecting to host:", c_hostname
);
1452 /* Always initialize globals. */
1453 global_init
= emacs_gnutls_global_init ();
1454 if (! NILP (Fgnutls_errorp (global_init
)))
1457 /* Before allocating new credentials, deallocate any credentials
1458 that PROC might already have. */
1459 emacs_gnutls_deinit (proc
);
1461 /* Mark PROC as a GnuTLS process. */
1462 XPROCESS (proc
)->gnutls_state
= NULL
;
1463 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
1464 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
1465 pset_gnutls_cred_type (XPROCESS (proc
), type
);
1466 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
1468 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
1469 if (EQ (type
, Qgnutls_x509pki
))
1471 Lisp_Object verify_flags
;
1472 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
1474 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
1475 check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred
));
1476 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
1478 verify_flags
= Fplist_get (proplist
, QCgnutls_bootprop_verify_flags
);
1479 if (NUMBERP (verify_flags
))
1481 gnutls_verify_flags
= XINT (verify_flags
);
1482 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
1484 else if (NILP (verify_flags
))
1485 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
1487 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
1489 gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
1491 else /* Qgnutls_anon: */
1493 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
1494 check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred
));
1495 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
1498 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
1500 if (EQ (type
, Qgnutls_x509pki
))
1502 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1503 int file_format
= GNUTLS_X509_FMT_PEM
;
1506 #if GNUTLS_VERSION_MAJOR + \
1507 (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
1508 ret
= gnutls_certificate_set_x509_system_trust (x509_cred
);
1509 if (ret
< GNUTLS_E_SUCCESS
)
1511 check_memory_full (ret
);
1512 GNUTLS_LOG2i (4, max_log_level
,
1513 "setting system trust failed with code ", ret
);
1517 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
1519 Lisp_Object trustfile
= XCAR (tail
);
1520 if (STRINGP (trustfile
))
1522 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
1523 SSDATA (trustfile
));
1524 trustfile
= ENCODE_FILE (trustfile
);
1526 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1527 file names on Windows, we need to re-encode the file
1528 name using the current ANSI codepage. */
1529 trustfile
= ansi_encode_filename (trustfile
);
1531 ret
= gnutls_certificate_set_x509_trust_file
1536 if (ret
< GNUTLS_E_SUCCESS
)
1537 return gnutls_make_error (ret
);
1541 emacs_gnutls_deinit (proc
);
1542 boot_error (p
, "Invalid trustfile");
1547 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
1549 Lisp_Object crlfile
= XCAR (tail
);
1550 if (STRINGP (crlfile
))
1552 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
1554 crlfile
= ENCODE_FILE (crlfile
);
1556 crlfile
= ansi_encode_filename (crlfile
);
1558 ret
= gnutls_certificate_set_x509_crl_file
1559 (x509_cred
, SSDATA (crlfile
), file_format
);
1561 if (ret
< GNUTLS_E_SUCCESS
)
1562 return gnutls_make_error (ret
);
1566 emacs_gnutls_deinit (proc
);
1567 boot_error (p
, "Invalid CRL file");
1572 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
1574 Lisp_Object keyfile
= Fcar (XCAR (tail
));
1575 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
1576 if (STRINGP (keyfile
) && STRINGP (certfile
))
1578 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
1580 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
1582 keyfile
= ENCODE_FILE (keyfile
);
1583 certfile
= ENCODE_FILE (certfile
);
1585 keyfile
= ansi_encode_filename (keyfile
);
1586 certfile
= ansi_encode_filename (certfile
);
1588 ret
= gnutls_certificate_set_x509_key_file
1589 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
1591 if (ret
< GNUTLS_E_SUCCESS
)
1592 return gnutls_make_error (ret
);
1596 emacs_gnutls_deinit (proc
);
1597 boot_error (p
, STRINGP (keyfile
) ? "Invalid client cert file"
1598 : "Invalid client key file");
1604 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
1605 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
1606 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
1608 /* Call gnutls_init here: */
1610 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
1611 ret
= gnutls_init (&state
, GNUTLS_CLIENT
);
1612 XPROCESS (proc
)->gnutls_state
= state
;
1613 if (ret
< GNUTLS_E_SUCCESS
)
1614 return gnutls_make_error (ret
);
1615 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
1617 if (STRINGP (priority_string
))
1619 priority_string_ptr
= SSDATA (priority_string
);
1620 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
1621 priority_string_ptr
);
1625 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
1626 priority_string_ptr
);
1629 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
1630 ret
= gnutls_priority_set_direct (state
, priority_string_ptr
, NULL
);
1631 if (ret
< GNUTLS_E_SUCCESS
)
1632 return gnutls_make_error (ret
);
1634 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
1636 if (INTEGERP (prime_bits
))
1637 gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
1639 ret
= EQ (type
, Qgnutls_x509pki
)
1640 ? gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
1641 : gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
1642 if (ret
< GNUTLS_E_SUCCESS
)
1643 return gnutls_make_error (ret
);
1645 if (!gnutls_ip_address_p (c_hostname
))
1647 ret
= gnutls_server_name_set (state
, GNUTLS_NAME_DNS
, c_hostname
,
1648 strlen (c_hostname
));
1649 if (ret
< GNUTLS_E_SUCCESS
)
1650 return gnutls_make_error (ret
);
1653 XPROCESS (proc
)->gnutls_complete_negotiation_p
=
1654 !NILP (Fplist_get (proplist
, QCgnutls_complete_negotiation
));
1655 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
1656 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
1657 if (ret
< GNUTLS_E_SUCCESS
)
1658 return gnutls_make_error (ret
);
1660 return gnutls_verify_boot (proc
, proplist
);
1663 DEFUN ("gnutls-bye", Fgnutls_bye
,
1664 Sgnutls_bye
, 2, 2, 0,
1665 doc
: /* Terminate current GnuTLS connection for process PROC.
1666 The connection should have been initiated using `gnutls-handshake'.
1668 If CONT is not nil the TLS connection gets terminated and further
1669 receives and sends will be disallowed. If the return value is zero you
1670 may continue using the connection. If CONT is nil, GnuTLS actually
1671 sends an alert containing a close request and waits for the peer to
1672 reply with the same message. In order to reuse the connection you
1673 should wait for an EOF from the peer.
1675 This function may also return `gnutls-e-again', or
1676 `gnutls-e-interrupted'. */)
1677 (Lisp_Object proc
, Lisp_Object cont
)
1679 gnutls_session_t state
;
1682 CHECK_PROCESS (proc
);
1684 state
= XPROCESS (proc
)->gnutls_state
;
1686 gnutls_x509_crt_deinit (XPROCESS (proc
)->gnutls_certificate
);
1688 ret
= gnutls_bye (state
, NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1690 return gnutls_make_error (ret
);
1693 #endif /* HAVE_GNUTLS */
1695 DEFUN ("gnutls-available-p", Fgnutls_available_p
, Sgnutls_available_p
, 0, 0, 0,
1696 doc
: /* Return t if GnuTLS is available in this instance of Emacs. */)
1701 Lisp_Object found
= Fassq (Qgnutls_dll
, Vlibrary_cache
);
1703 return XCDR (found
);
1707 status
= init_gnutls_functions () ? Qt
: Qnil
;
1708 Vlibrary_cache
= Fcons (Fcons (Qgnutls_dll
, status
), Vlibrary_cache
);
1711 # else /* !WINDOWSNT */
1713 # endif /* !WINDOWSNT */
1714 #else /* !HAVE_GNUTLS */
1716 #endif /* !HAVE_GNUTLS */
1720 syms_of_gnutls (void)
1722 DEFSYM (Qlibgnutls_version
, "libgnutls-version");
1723 Fset (Qlibgnutls_version
,
1725 make_number (GNUTLS_VERSION_MAJOR
* 10000
1726 + GNUTLS_VERSION_MINOR
* 100
1727 + GNUTLS_VERSION_PATCH
)
1733 gnutls_global_initialized
= 0;
1735 DEFSYM (Qgnutls_code
, "gnutls-code");
1736 DEFSYM (Qgnutls_anon
, "gnutls-anon");
1737 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
1739 /* The following are for the property list of 'gnutls-boot'. */
1740 DEFSYM (QCgnutls_bootprop_hostname
, ":hostname");
1741 DEFSYM (QCgnutls_bootprop_priority
, ":priority");
1742 DEFSYM (QCgnutls_bootprop_trustfiles
, ":trustfiles");
1743 DEFSYM (QCgnutls_bootprop_keylist
, ":keylist");
1744 DEFSYM (QCgnutls_bootprop_crlfiles
, ":crlfiles");
1745 DEFSYM (QCgnutls_bootprop_min_prime_bits
, ":min-prime-bits");
1746 DEFSYM (QCgnutls_bootprop_loglevel
, ":loglevel");
1747 DEFSYM (QCgnutls_complete_negotiation
, ":complete-negotiation");
1748 DEFSYM (QCgnutls_bootprop_verify_flags
, ":verify-flags");
1749 DEFSYM (QCgnutls_bootprop_verify_error
, ":verify-error");
1751 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
1752 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
1753 make_number (GNUTLS_E_INTERRUPTED
));
1755 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
1756 Fput (Qgnutls_e_again
, Qgnutls_code
,
1757 make_number (GNUTLS_E_AGAIN
));
1759 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
1760 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
1761 make_number (GNUTLS_E_INVALID_SESSION
));
1763 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
1764 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
1765 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
1767 defsubr (&Sgnutls_get_initstage
);
1768 defsubr (&Sgnutls_asynchronous_parameters
);
1769 defsubr (&Sgnutls_errorp
);
1770 defsubr (&Sgnutls_error_fatalp
);
1771 defsubr (&Sgnutls_error_string
);
1772 defsubr (&Sgnutls_boot
);
1773 defsubr (&Sgnutls_deinit
);
1774 defsubr (&Sgnutls_bye
);
1775 defsubr (&Sgnutls_peer_status
);
1776 defsubr (&Sgnutls_peer_status_warning_describe
);
1778 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
1779 doc
: /* Logging level used by the GnuTLS functions.
1780 Set this larger than 0 to get debug output in the *Messages* buffer.
1781 1 is for important messages, 2 is for debug data, and higher numbers
1782 are as per the GnuTLS logging conventions. */);
1783 global_gnutls_log_level
= 0;
1785 #endif /* HAVE_GNUTLS */
1787 defsubr (&Sgnutls_available_p
);