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
;
406 if (proc
->is_non_blocking_client
)
407 proc
->gnutls_p
= true;
411 ret
= gnutls_handshake (state
);
412 emacs_gnutls_handle_error (state
, ret
);
415 while (ret
< 0 && gnutls_error_is_fatal (ret
) == 0
416 && ! proc
->is_non_blocking_client
);
418 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
420 if (ret
== GNUTLS_E_SUCCESS
)
422 /* Here we're finally done. */
423 proc
->gnutls_initstage
= GNUTLS_STAGE_READY
;
427 /* check_memory_full (gnutls_alert_send_appropriate (state, ret)); */
433 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
435 gnutls_session_t state
= proc
->gnutls_state
;
437 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
440 if (proc
->gnutls_initstage
< GNUTLS_STAGE_TRANSPORT_POINTERS_SET
)
443 /* On W32 we cannot transfer socket handles between different runtime
444 libraries, so we tell GnuTLS to use our special push/pull
446 gnutls_transport_set_ptr2 (state
,
447 (gnutls_transport_ptr_t
) proc
,
448 (gnutls_transport_ptr_t
) proc
);
449 gnutls_transport_set_push_function (state
, &emacs_gnutls_push
);
450 gnutls_transport_set_pull_function (state
, &emacs_gnutls_pull
);
452 /* For non blocking sockets or other custom made pull/push
453 functions the gnutls_transport_set_lowat must be called, with
454 a zero low water mark value. (GnuTLS 2.10.4 documentation)
456 (Note: this is probably not strictly necessary as the lowat
457 value is only used when no custom pull/push functions are
459 /* According to GnuTLS NEWS file, lowat level has been set to
460 zero by default in version 2.11.1, and the function
461 gnutls_transport_set_lowat was removed from the library in
463 if (!gnutls_check_version ("2.11.1"))
464 gnutls_transport_set_lowat (state
, 0);
466 /* This is how GnuTLS takes sockets: as file descriptors passed
467 in. For an Emacs process socket, infd and outfd are the
468 same but we use this two-argument version for clarity. */
469 gnutls_transport_set_ptr2 (state
,
470 (void *) (intptr_t) proc
->infd
,
471 (void *) (intptr_t) proc
->outfd
);
474 proc
->gnutls_initstage
= GNUTLS_STAGE_TRANSPORT_POINTERS_SET
;
477 return gnutls_try_handshake (proc
);
481 emacs_gnutls_record_check_pending (gnutls_session_t state
)
483 return gnutls_record_check_pending (state
);
488 emacs_gnutls_transport_set_errno (gnutls_session_t state
, int err
)
490 gnutls_transport_set_errno (state
, err
);
495 emacs_gnutls_write (struct Lisp_Process
*proc
, const char *buf
, ptrdiff_t nbyte
)
498 ptrdiff_t bytes_written
;
499 gnutls_session_t state
= proc
->gnutls_state
;
501 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
511 rtnval
= gnutls_record_send (state
, buf
, nbyte
);
515 if (rtnval
== GNUTLS_E_INTERRUPTED
)
519 /* If we get GNUTLS_E_AGAIN, then set errno
520 appropriately so that send_process retries the
521 correct way instead of erroring out. */
522 if (rtnval
== GNUTLS_E_AGAIN
)
530 bytes_written
+= rtnval
;
533 emacs_gnutls_handle_error (state
, rtnval
);
534 return (bytes_written
);
538 emacs_gnutls_read (struct Lisp_Process
*proc
, char *buf
, ptrdiff_t nbyte
)
541 gnutls_session_t state
= proc
->gnutls_state
;
543 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
549 rtnval
= gnutls_record_recv (state
, buf
, nbyte
);
552 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
553 /* The peer closed the connection. */
555 else if (emacs_gnutls_handle_error (state
, rtnval
))
556 /* non-fatal error */
559 /* a fatal error occurred */
564 /* Report a GnuTLS error to the user.
565 Return true if the error code was successfully handled. */
567 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
569 int max_log_level
= 0;
574 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
578 check_memory_full (err
);
580 max_log_level
= global_gnutls_log_level
;
582 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
584 str
= gnutls_strerror (err
);
588 if (gnutls_error_is_fatal (err
))
591 GNUTLS_LOG2 (1, max_log_level
, "fatal error:", str
);
612 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
613 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
615 int alert
= gnutls_alert_get (session
);
616 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
617 str
= gnutls_alert_get_name (alert
);
621 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
626 /* convert an integer error to a Lisp_Object; it will be either a
627 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
628 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
631 gnutls_make_error (int err
)
635 case GNUTLS_E_SUCCESS
:
638 return Qgnutls_e_again
;
639 case GNUTLS_E_INTERRUPTED
:
640 return Qgnutls_e_interrupted
;
641 case GNUTLS_E_INVALID_SESSION
:
642 return Qgnutls_e_invalid_session
;
645 check_memory_full (err
);
646 return make_number (err
);
650 emacs_gnutls_deinit (Lisp_Object proc
)
654 CHECK_PROCESS (proc
);
656 if (! XPROCESS (proc
)->gnutls_p
)
659 log_level
= XPROCESS (proc
)->gnutls_log_level
;
661 if (XPROCESS (proc
)->gnutls_x509_cred
)
663 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
664 gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
665 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
668 if (XPROCESS (proc
)->gnutls_anon_cred
)
670 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
671 gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
672 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
675 if (XPROCESS (proc
)->gnutls_state
)
677 gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
678 XPROCESS (proc
)->gnutls_state
= NULL
;
679 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
680 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
683 XPROCESS (proc
)->gnutls_p
= false;
687 DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters
,
688 Sgnutls_asynchronous_parameters
, 2, 2, 0,
689 doc
: /* Mark this process as being a pre-init GnuTLS process.
690 The second parameter is the list of parameters to feed to gnutls-boot
691 to finish setting up the connection. */)
692 (Lisp_Object proc
, Lisp_Object params
)
694 CHECK_PROCESS (proc
);
696 XPROCESS (proc
)->gnutls_boot_parameters
= params
;
700 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
701 doc
: /* Return the GnuTLS init stage of process PROC.
702 See also `gnutls-boot'. */)
705 CHECK_PROCESS (proc
);
707 return make_number (GNUTLS_INITSTAGE (proc
));
710 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
711 doc
: /* Return t if ERROR indicates a GnuTLS problem.
712 ERROR is an integer or a symbol with an integer `gnutls-code' property.
713 usage: (gnutls-errorp ERROR) */
717 if (EQ (err
, Qt
)) return Qnil
;
722 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
723 doc
: /* Return non-nil if ERROR is fatal.
724 ERROR is an integer or a symbol with an integer `gnutls-code' property.
725 Usage: (gnutls-error-fatalp ERROR) */)
730 if (EQ (err
, Qt
)) return Qnil
;
734 code
= Fget (err
, Qgnutls_code
);
741 error ("Symbol has no numeric gnutls-code property");
745 if (! TYPE_RANGED_INTEGERP (int, err
))
746 error ("Not an error symbol or code");
748 if (0 == gnutls_error_is_fatal (XINT (err
)))
754 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
755 doc
: /* Return a description of ERROR.
756 ERROR is an integer or a symbol with an integer `gnutls-code' property.
757 usage: (gnutls-error-string ERROR) */)
762 if (EQ (err
, Qt
)) return build_string ("Not an error");
766 code
= Fget (err
, Qgnutls_code
);
773 return build_string ("Symbol has no numeric gnutls-code property");
777 if (! TYPE_RANGED_INTEGERP (int, err
))
778 return build_string ("Not an error symbol or code");
780 return build_string (gnutls_strerror (XINT (err
)));
783 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
784 doc
: /* Deallocate GnuTLS resources associated with process PROC.
785 See also `gnutls-init'. */)
788 return emacs_gnutls_deinit (proc
);
792 gnutls_hex_string (unsigned char *buf
, ptrdiff_t buf_size
, const char *prefix
)
794 ptrdiff_t prefix_length
= strlen (prefix
);
796 if (INT_MULTIPLY_WRAPV (buf_size
, 3, &retlen
)
797 || INT_ADD_WRAPV (prefix_length
- (buf_size
!= 0), retlen
, &retlen
))
799 Lisp_Object ret
= make_uninit_string (retlen
);
800 char *string
= SSDATA (ret
);
801 strcpy (string
, prefix
);
803 for (ptrdiff_t i
= 0; i
< buf_size
; i
++)
804 sprintf (string
+ i
* 3 + prefix_length
,
805 i
== buf_size
- 1 ? "%02x" : "%02x:",
812 gnutls_certificate_details (gnutls_x509_crt_t cert
)
814 Lisp_Object res
= Qnil
;
820 int version
= gnutls_x509_crt_get_version (cert
);
821 check_memory_full (version
);
822 if (version
>= GNUTLS_E_SUCCESS
)
823 res
= nconc2 (res
, list2 (intern (":version"),
824 make_number (version
)));
829 err
= gnutls_x509_crt_get_serial (cert
, NULL
, &buf_size
);
830 check_memory_full (err
);
831 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
833 void *serial
= xmalloc (buf_size
);
834 err
= gnutls_x509_crt_get_serial (cert
, serial
, &buf_size
);
835 check_memory_full (err
);
836 if (err
>= GNUTLS_E_SUCCESS
)
837 res
= nconc2 (res
, list2 (intern (":serial-number"),
838 gnutls_hex_string (serial
, buf_size
, "")));
844 err
= gnutls_x509_crt_get_issuer_dn (cert
, NULL
, &buf_size
);
845 check_memory_full (err
);
846 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
848 char *dn
= xmalloc (buf_size
);
849 err
= gnutls_x509_crt_get_issuer_dn (cert
, dn
, &buf_size
);
850 check_memory_full (err
);
851 if (err
>= GNUTLS_E_SUCCESS
)
852 res
= nconc2 (res
, list2 (intern (":issuer"),
853 make_string (dn
, buf_size
)));
859 /* Add 1 to the buffer size, since 1900 is added to tm_year and
860 that might add 1 to the year length. */
861 char buf
[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
863 time_t tim
= gnutls_x509_crt_get_activation_time (cert
);
865 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
866 res
= nconc2 (res
, list2 (intern (":valid-from"), build_string (buf
)));
868 tim
= gnutls_x509_crt_get_expiration_time (cert
);
869 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
870 res
= nconc2 (res
, list2 (intern (":valid-to"), build_string (buf
)));
875 err
= gnutls_x509_crt_get_dn (cert
, NULL
, &buf_size
);
876 check_memory_full (err
);
877 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
879 char *dn
= xmalloc (buf_size
);
880 err
= gnutls_x509_crt_get_dn (cert
, dn
, &buf_size
);
881 check_memory_full (err
);
882 if (err
>= GNUTLS_E_SUCCESS
)
883 res
= nconc2 (res
, list2 (intern (":subject"),
884 make_string (dn
, buf_size
)));
888 /* Versions older than 2.11 doesn't have these four functions. */
889 #if GNUTLS_VERSION_NUMBER >= 0x020b00
890 /* SubjectPublicKeyInfo. */
894 err
= gnutls_x509_crt_get_pk_algorithm (cert
, &bits
);
895 check_memory_full (err
);
896 if (err
>= GNUTLS_E_SUCCESS
)
898 const char *name
= gnutls_pk_algorithm_get_name (err
);
900 res
= nconc2 (res
, list2 (intern (":public-key-algorithm"),
901 build_string (name
)));
903 name
= gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
905 res
= nconc2 (res
, list2 (intern (":certificate-security-level"),
906 build_string (name
)));
912 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, NULL
, &buf_size
);
913 check_memory_full (err
);
914 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
916 char *buf
= xmalloc (buf_size
);
917 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, buf
, &buf_size
);
918 check_memory_full (err
);
919 if (err
>= GNUTLS_E_SUCCESS
)
920 res
= nconc2 (res
, list2 (intern (":issuer-unique-id"),
921 make_string (buf
, buf_size
)));
926 err
= gnutls_x509_crt_get_subject_unique_id (cert
, NULL
, &buf_size
);
927 check_memory_full (err
);
928 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
930 char *buf
= xmalloc (buf_size
);
931 err
= gnutls_x509_crt_get_subject_unique_id (cert
, buf
, &buf_size
);
932 check_memory_full (err
);
933 if (err
>= GNUTLS_E_SUCCESS
)
934 res
= nconc2 (res
, list2 (intern (":subject-unique-id"),
935 make_string (buf
, buf_size
)));
941 err
= gnutls_x509_crt_get_signature_algorithm (cert
);
942 check_memory_full (err
);
943 if (err
>= GNUTLS_E_SUCCESS
)
945 const char *name
= gnutls_sign_get_name (err
);
947 res
= nconc2 (res
, list2 (intern (":signature-algorithm"),
948 build_string (name
)));
953 err
= gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
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_key_id (cert
, 0, buf
, &buf_size
);
959 check_memory_full (err
);
960 if (err
>= GNUTLS_E_SUCCESS
)
961 res
= nconc2 (res
, list2 (intern (":public-key-id"),
962 gnutls_hex_string (buf
, buf_size
, "sha1:")));
966 /* Certificate fingerprint. */
968 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
970 check_memory_full (err
);
971 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
973 void *buf
= xmalloc (buf_size
);
974 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
976 check_memory_full (err
);
977 if (err
>= GNUTLS_E_SUCCESS
)
978 res
= nconc2 (res
, list2 (intern (":certificate-id"),
979 gnutls_hex_string (buf
, buf_size
, "sha1:")));
986 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
987 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
988 (Lisp_Object status_symbol
)
990 CHECK_SYMBOL (status_symbol
);
992 if (EQ (status_symbol
, intern (":invalid")))
993 return build_string ("certificate could not be verified");
995 if (EQ (status_symbol
, intern (":revoked")))
996 return build_string ("certificate was revoked (CRL)");
998 if (EQ (status_symbol
, intern (":self-signed")))
999 return build_string ("certificate signer was not found (self-signed)");
1001 if (EQ (status_symbol
, intern (":unknown-ca")))
1002 return build_string ("the certificate was signed by an unknown "
1003 "and therefore untrusted authority");
1005 if (EQ (status_symbol
, intern (":not-ca")))
1006 return build_string ("certificate signer is not a CA");
1008 if (EQ (status_symbol
, intern (":insecure")))
1009 return build_string ("certificate was signed with an insecure algorithm");
1011 if (EQ (status_symbol
, intern (":not-activated")))
1012 return build_string ("certificate is not yet activated");
1014 if (EQ (status_symbol
, intern (":expired")))
1015 return build_string ("certificate has expired");
1017 if (EQ (status_symbol
, intern (":no-host-match")))
1018 return build_string ("certificate host does not match hostname");
1023 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
1024 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1025 The return value is a property list with top-level keys :warnings and
1026 :certificate. The :warnings entry is a list of symbols you can describe with
1027 `gnutls-peer-status-warning-describe'. */)
1030 Lisp_Object warnings
= Qnil
, result
= Qnil
;
1031 unsigned int verification
;
1032 gnutls_session_t state
;
1034 CHECK_PROCESS (proc
);
1036 if (GNUTLS_INITSTAGE (proc
) != GNUTLS_STAGE_READY
)
1039 /* Then collect any warnings already computed by the handshake. */
1040 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
1042 if (verification
& GNUTLS_CERT_INVALID
)
1043 warnings
= Fcons (intern (":invalid"), warnings
);
1045 if (verification
& GNUTLS_CERT_REVOKED
)
1046 warnings
= Fcons (intern (":revoked"), warnings
);
1048 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1049 warnings
= Fcons (intern (":unknown-ca"), warnings
);
1051 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1052 warnings
= Fcons (intern (":not-ca"), warnings
);
1054 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1055 warnings
= Fcons (intern (":insecure"), warnings
);
1057 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1058 warnings
= Fcons (intern (":not-activated"), warnings
);
1060 if (verification
& GNUTLS_CERT_EXPIRED
)
1061 warnings
= Fcons (intern (":expired"), warnings
);
1063 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1064 CERTIFICATE_NOT_MATCHING
)
1065 warnings
= Fcons (intern (":no-host-match"), warnings
);
1067 /* This could get called in the INIT stage, when the certificate is
1069 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
&&
1070 gnutls_x509_crt_check_issuer(XPROCESS (proc
)->gnutls_certificate
,
1071 XPROCESS (proc
)->gnutls_certificate
))
1072 warnings
= Fcons (intern (":self-signed"), warnings
);
1074 if (!NILP (warnings
))
1075 result
= list2 (intern (":warnings"), warnings
);
1077 /* This could get called in the INIT stage, when the certificate is
1079 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1080 result
= nconc2 (result
, list2
1081 (intern (":certificate"),
1082 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1084 state
= XPROCESS (proc
)->gnutls_state
;
1086 /* Diffie-Hellman prime bits. */
1088 int bits
= gnutls_dh_get_prime_bits (state
);
1089 check_memory_full (bits
);
1091 result
= nconc2 (result
, list2 (intern (":diffie-hellman-prime-bits"),
1092 make_number (bits
)));
1097 (result
, list2 (intern (":key-exchange"),
1098 build_string (gnutls_kx_get_name
1099 (gnutls_kx_get (state
)))));
1101 /* Protocol name. */
1103 (result
, list2 (intern (":protocol"),
1104 build_string (gnutls_protocol_get_name
1105 (gnutls_protocol_get_version (state
)))));
1109 (result
, list2 (intern (":cipher"),
1110 build_string (gnutls_cipher_get_name
1111 (gnutls_cipher_get (state
)))));
1115 (result
, list2 (intern (":mac"),
1116 build_string (gnutls_mac_get_name
1117 (gnutls_mac_get (state
)))));
1123 /* Initialize global GnuTLS state to defaults.
1124 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1125 Return zero on success. */
1127 emacs_gnutls_global_init (void)
1129 int ret
= GNUTLS_E_SUCCESS
;
1131 if (!gnutls_global_initialized
)
1133 ret
= gnutls_global_init ();
1134 if (ret
== GNUTLS_E_SUCCESS
)
1135 gnutls_global_initialized
= 1;
1138 return gnutls_make_error (ret
);
1142 gnutls_ip_address_p (char *string
)
1146 while ((c
= *string
++) != 0)
1147 if (! ((c
== '.' || c
== ':' || (c
>= '0' && c
<= '9'))))
1154 /* Deinitialize global GnuTLS state.
1155 See also `gnutls-global-init'. */
1157 emacs_gnutls_global_deinit (void)
1159 if (gnutls_global_initialized
)
1160 gnutls_global_deinit ();
1162 gnutls_global_initialized
= 0;
1164 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1168 static void ATTRIBUTE_FORMAT_PRINTF (2, 3)
1169 boot_error (struct Lisp_Process
*p
, const char *m
, ...)
1173 if (p
->is_non_blocking_client
)
1174 pset_status (p
, list2 (Qfailed
, vformat_string (m
, ap
)));
1180 gnutls_verify_boot (Lisp_Object proc
, Lisp_Object proplist
)
1183 struct Lisp_Process
*p
= XPROCESS (proc
);
1184 gnutls_session_t state
= p
->gnutls_state
;
1185 unsigned int peer_verification
;
1186 Lisp_Object warnings
;
1187 int max_log_level
= p
->gnutls_log_level
;
1188 Lisp_Object hostname
, verify_error
;
1189 bool verify_error_all
= false;
1192 if (NILP (proplist
))
1193 proplist
= Fcdr (Fplist_get (p
->childp
, QCtls_parameters
));
1195 verify_error
= Fplist_get (proplist
, QCgnutls_bootprop_verify_error
);
1196 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1198 if (EQ (verify_error
, Qt
))
1199 verify_error_all
= true;
1200 else if (NILP (Flistp (verify_error
)))
1203 "gnutls-boot: invalid :verify_error parameter (not a list)");
1207 if (!STRINGP (hostname
))
1209 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1212 c_hostname
= SSDATA (hostname
);
1214 /* Now verify the peer, following
1215 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1216 The peer should present at least one certificate in the chain; do a
1217 check of the certificate's hostname with
1218 gnutls_x509_crt_check_hostname against :hostname. */
1220 ret
= gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1221 if (ret
< GNUTLS_E_SUCCESS
)
1222 return gnutls_make_error (ret
);
1224 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1226 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1227 if (!NILP (warnings
))
1229 for (Lisp_Object tail
= warnings
; CONSP (tail
); tail
= XCDR (tail
))
1231 Lisp_Object warning
= XCAR (tail
);
1232 Lisp_Object message
= Fgnutls_peer_status_warning_describe (warning
);
1233 if (!NILP (message
))
1234 GNUTLS_LOG2 (1, max_log_level
, "verification:", SSDATA (message
));
1238 if (peer_verification
!= 0)
1240 if (verify_error_all
1241 || !NILP (Fmember (QCgnutls_bootprop_trustfiles
, verify_error
)))
1243 emacs_gnutls_deinit (proc
);
1245 "Certificate validation failed %s, verification code %x",
1246 c_hostname
, peer_verification
);
1251 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1256 /* Up to here the process is the same for X.509 certificates and
1257 OpenPGP keys. From now on X.509 certificates are assumed. This
1258 can be easily extended to work with openpgp keys as well. */
1259 if (gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1261 gnutls_x509_crt_t gnutls_verify_cert
;
1262 const gnutls_datum_t
*gnutls_verify_cert_list
;
1263 unsigned int gnutls_verify_cert_list_size
;
1265 ret
= gnutls_x509_crt_init (&gnutls_verify_cert
);
1266 if (ret
< GNUTLS_E_SUCCESS
)
1267 return gnutls_make_error (ret
);
1269 gnutls_verify_cert_list
1270 = gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1272 if (gnutls_verify_cert_list
== NULL
)
1274 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1275 emacs_gnutls_deinit (proc
);
1276 boot_error (p
, "No x509 certificate was found\n");
1280 /* Check only the first certificate in the given chain. */
1281 ret
= gnutls_x509_crt_import (gnutls_verify_cert
,
1282 &gnutls_verify_cert_list
[0],
1283 GNUTLS_X509_FMT_DER
);
1285 if (ret
< GNUTLS_E_SUCCESS
)
1287 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1288 return gnutls_make_error (ret
);
1291 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1293 int err
= gnutls_x509_crt_check_hostname (gnutls_verify_cert
,
1295 check_memory_full (err
);
1298 XPROCESS (proc
)->gnutls_extra_peer_verification
1299 |= CERTIFICATE_NOT_MATCHING
;
1300 if (verify_error_all
1301 || !NILP (Fmember (QCgnutls_bootprop_hostname
, verify_error
)))
1303 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1304 emacs_gnutls_deinit (proc
);
1305 boot_error (p
, "The x509 certificate does not match \"%s\"",
1310 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1315 /* Set this flag only if the whole initialization succeeded. */
1316 XPROCESS (proc
)->gnutls_p
= true;
1318 return gnutls_make_error (ret
);
1321 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
1322 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1323 Currently only client mode is supported. Return a success/failure
1324 value you can check with `gnutls-errorp'.
1326 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1327 PROPLIST is a property list with the following keys:
1329 :hostname is a string naming the remote host.
1331 :priority is a GnuTLS priority string, defaults to "NORMAL".
1333 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1335 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1337 :keylist is an alist of PEM-encoded key files and PEM-encoded
1338 certificates for `gnutls-x509pki'.
1340 :callbacks is an alist of callback functions, see below.
1342 :loglevel is the debug level requested from GnuTLS, try 4.
1344 :verify-flags is a bitset as per GnuTLS'
1345 gnutls_certificate_set_verify_flags.
1347 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1350 :verify-error is a list of symbols to express verification checks or
1351 t to do all checks. Currently it can contain `:trustfiles' and
1352 `:hostname' to verify the certificate or the hostname respectively.
1354 :min-prime-bits is the minimum accepted number of bits the client will
1355 accept in Diffie-Hellman key exchange.
1357 The debug level will be set for this process AND globally for GnuTLS.
1358 So if you set it higher or lower at any point, it affects global
1361 Note that the priority is set on the client. The server does not use
1362 the protocols's priority except for disabling protocols that were not
1365 Processes must be initialized with this function before other GnuTLS
1366 functions are used. This function allocates resources which can only
1367 be deallocated by calling `gnutls-deinit' or by calling it again.
1369 The callbacks alist can have a `verify' key, associated with a
1370 verification function (UNUSED).
1372 Each authentication type may need additional information in order to
1373 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1374 one trustfile (usually a CA bundle). */)
1375 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
1377 int ret
= GNUTLS_E_SUCCESS
;
1378 int max_log_level
= 0;
1380 gnutls_session_t state
;
1381 gnutls_certificate_credentials_t x509_cred
= NULL
;
1382 gnutls_anon_client_credentials_t anon_cred
= NULL
;
1383 Lisp_Object global_init
;
1384 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
1387 /* Placeholders for the property list elements. */
1388 Lisp_Object priority_string
;
1389 Lisp_Object trustfiles
;
1390 Lisp_Object crlfiles
;
1391 Lisp_Object keylist
;
1392 /* Lisp_Object callbacks; */
1393 Lisp_Object loglevel
;
1394 Lisp_Object hostname
;
1395 Lisp_Object prime_bits
;
1396 struct Lisp_Process
*p
= XPROCESS (proc
);
1398 CHECK_PROCESS (proc
);
1399 CHECK_SYMBOL (type
);
1400 CHECK_LIST (proplist
);
1402 if (NILP (Fgnutls_available_p ()))
1404 boot_error (p
, "GnuTLS not available");
1408 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
1410 boot_error (p
, "Invalid GnuTLS credential type");
1414 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1415 priority_string
= Fplist_get (proplist
, QCgnutls_bootprop_priority
);
1416 trustfiles
= Fplist_get (proplist
, QCgnutls_bootprop_trustfiles
);
1417 keylist
= Fplist_get (proplist
, QCgnutls_bootprop_keylist
);
1418 crlfiles
= Fplist_get (proplist
, QCgnutls_bootprop_crlfiles
);
1419 loglevel
= Fplist_get (proplist
, QCgnutls_bootprop_loglevel
);
1420 prime_bits
= Fplist_get (proplist
, QCgnutls_bootprop_min_prime_bits
);
1422 if (!STRINGP (hostname
))
1424 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1427 c_hostname
= SSDATA (hostname
);
1429 state
= XPROCESS (proc
)->gnutls_state
;
1431 if (TYPE_RANGED_INTEGERP (int, loglevel
))
1433 gnutls_global_set_log_function (gnutls_log_function
);
1435 gnutls_global_set_audit_log_function (gnutls_audit_log_function
);
1437 gnutls_global_set_log_level (XINT (loglevel
));
1438 max_log_level
= XINT (loglevel
);
1439 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
1442 GNUTLS_LOG2 (1, max_log_level
, "connecting to host:", c_hostname
);
1444 /* Always initialize globals. */
1445 global_init
= emacs_gnutls_global_init ();
1446 if (! NILP (Fgnutls_errorp (global_init
)))
1449 /* Before allocating new credentials, deallocate any credentials
1450 that PROC might already have. */
1451 emacs_gnutls_deinit (proc
);
1453 /* Mark PROC as a GnuTLS process. */
1454 XPROCESS (proc
)->gnutls_state
= NULL
;
1455 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
1456 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
1457 pset_gnutls_cred_type (XPROCESS (proc
), type
);
1458 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
1460 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
1461 if (EQ (type
, Qgnutls_x509pki
))
1463 Lisp_Object verify_flags
;
1464 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
1466 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
1467 check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred
));
1468 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
1470 verify_flags
= Fplist_get (proplist
, QCgnutls_bootprop_verify_flags
);
1471 if (NUMBERP (verify_flags
))
1473 gnutls_verify_flags
= XINT (verify_flags
);
1474 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
1476 else if (NILP (verify_flags
))
1477 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
1479 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
1481 gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
1483 else /* Qgnutls_anon: */
1485 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
1486 check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred
));
1487 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
1490 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
1492 if (EQ (type
, Qgnutls_x509pki
))
1494 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1495 int file_format
= GNUTLS_X509_FMT_PEM
;
1498 #if GNUTLS_VERSION_MAJOR + \
1499 (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
1500 ret
= gnutls_certificate_set_x509_system_trust (x509_cred
);
1501 if (ret
< GNUTLS_E_SUCCESS
)
1503 check_memory_full (ret
);
1504 GNUTLS_LOG2i (4, max_log_level
,
1505 "setting system trust failed with code ", ret
);
1509 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
1511 Lisp_Object trustfile
= XCAR (tail
);
1512 if (STRINGP (trustfile
))
1514 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
1515 SSDATA (trustfile
));
1516 trustfile
= ENCODE_FILE (trustfile
);
1518 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1519 file names on Windows, we need to re-encode the file
1520 name using the current ANSI codepage. */
1521 trustfile
= ansi_encode_filename (trustfile
);
1523 ret
= gnutls_certificate_set_x509_trust_file
1528 if (ret
< GNUTLS_E_SUCCESS
)
1529 return gnutls_make_error (ret
);
1533 emacs_gnutls_deinit (proc
);
1534 boot_error (p
, "Invalid trustfile");
1539 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
1541 Lisp_Object crlfile
= XCAR (tail
);
1542 if (STRINGP (crlfile
))
1544 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
1546 crlfile
= ENCODE_FILE (crlfile
);
1548 crlfile
= ansi_encode_filename (crlfile
);
1550 ret
= gnutls_certificate_set_x509_crl_file
1551 (x509_cred
, SSDATA (crlfile
), file_format
);
1553 if (ret
< GNUTLS_E_SUCCESS
)
1554 return gnutls_make_error (ret
);
1558 emacs_gnutls_deinit (proc
);
1559 boot_error (p
, "Invalid CRL file");
1564 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
1566 Lisp_Object keyfile
= Fcar (XCAR (tail
));
1567 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
1568 if (STRINGP (keyfile
) && STRINGP (certfile
))
1570 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
1572 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
1574 keyfile
= ENCODE_FILE (keyfile
);
1575 certfile
= ENCODE_FILE (certfile
);
1577 keyfile
= ansi_encode_filename (keyfile
);
1578 certfile
= ansi_encode_filename (certfile
);
1580 ret
= gnutls_certificate_set_x509_key_file
1581 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
1583 if (ret
< GNUTLS_E_SUCCESS
)
1584 return gnutls_make_error (ret
);
1588 emacs_gnutls_deinit (proc
);
1589 boot_error (p
, STRINGP (keyfile
) ? "Invalid client cert file"
1590 : "Invalid client key file");
1596 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
1597 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
1598 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
1600 /* Call gnutls_init here: */
1602 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
1603 ret
= gnutls_init (&state
, GNUTLS_CLIENT
);
1604 XPROCESS (proc
)->gnutls_state
= state
;
1605 if (ret
< GNUTLS_E_SUCCESS
)
1606 return gnutls_make_error (ret
);
1607 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
1609 if (STRINGP (priority_string
))
1611 priority_string_ptr
= SSDATA (priority_string
);
1612 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
1613 priority_string_ptr
);
1617 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
1618 priority_string_ptr
);
1621 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
1622 ret
= gnutls_priority_set_direct (state
, priority_string_ptr
, NULL
);
1623 if (ret
< GNUTLS_E_SUCCESS
)
1624 return gnutls_make_error (ret
);
1626 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
1628 if (INTEGERP (prime_bits
))
1629 gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
1631 ret
= EQ (type
, Qgnutls_x509pki
)
1632 ? gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
1633 : gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
1634 if (ret
< GNUTLS_E_SUCCESS
)
1635 return gnutls_make_error (ret
);
1637 if (!gnutls_ip_address_p (c_hostname
))
1639 ret
= gnutls_server_name_set (state
, GNUTLS_NAME_DNS
, c_hostname
,
1640 strlen (c_hostname
));
1641 if (ret
< GNUTLS_E_SUCCESS
)
1642 return gnutls_make_error (ret
);
1645 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
1646 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
1647 if (ret
< GNUTLS_E_SUCCESS
)
1648 return gnutls_make_error (ret
);
1650 return gnutls_verify_boot (proc
, proplist
);
1653 DEFUN ("gnutls-bye", Fgnutls_bye
,
1654 Sgnutls_bye
, 2, 2, 0,
1655 doc
: /* Terminate current GnuTLS connection for process PROC.
1656 The connection should have been initiated using `gnutls-handshake'.
1658 If CONT is not nil the TLS connection gets terminated and further
1659 receives and sends will be disallowed. If the return value is zero you
1660 may continue using the connection. If CONT is nil, GnuTLS actually
1661 sends an alert containing a close request and waits for the peer to
1662 reply with the same message. In order to reuse the connection you
1663 should wait for an EOF from the peer.
1665 This function may also return `gnutls-e-again', or
1666 `gnutls-e-interrupted'. */)
1667 (Lisp_Object proc
, Lisp_Object cont
)
1669 gnutls_session_t state
;
1672 CHECK_PROCESS (proc
);
1674 state
= XPROCESS (proc
)->gnutls_state
;
1676 gnutls_x509_crt_deinit (XPROCESS (proc
)->gnutls_certificate
);
1678 ret
= gnutls_bye (state
, NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1680 return gnutls_make_error (ret
);
1683 #endif /* HAVE_GNUTLS */
1685 DEFUN ("gnutls-available-p", Fgnutls_available_p
, Sgnutls_available_p
, 0, 0, 0,
1686 doc
: /* Return t if GnuTLS is available in this instance of Emacs. */)
1691 Lisp_Object found
= Fassq (Qgnutls_dll
, Vlibrary_cache
);
1693 return XCDR (found
);
1697 status
= init_gnutls_functions () ? Qt
: Qnil
;
1698 Vlibrary_cache
= Fcons (Fcons (Qgnutls_dll
, status
), Vlibrary_cache
);
1701 # else /* !WINDOWSNT */
1703 # endif /* !WINDOWSNT */
1704 #else /* !HAVE_GNUTLS */
1706 #endif /* !HAVE_GNUTLS */
1710 syms_of_gnutls (void)
1712 DEFSYM (Qlibgnutls_version
, "libgnutls-version");
1713 Fset (Qlibgnutls_version
,
1715 make_number (GNUTLS_VERSION_MAJOR
* 10000
1716 + GNUTLS_VERSION_MINOR
* 100
1717 + GNUTLS_VERSION_PATCH
)
1723 gnutls_global_initialized
= 0;
1725 DEFSYM (Qgnutls_code
, "gnutls-code");
1726 DEFSYM (Qgnutls_anon
, "gnutls-anon");
1727 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
1729 /* The following are for the property list of 'gnutls-boot'. */
1730 DEFSYM (QCgnutls_bootprop_hostname
, ":hostname");
1731 DEFSYM (QCgnutls_bootprop_priority
, ":priority");
1732 DEFSYM (QCgnutls_bootprop_trustfiles
, ":trustfiles");
1733 DEFSYM (QCgnutls_bootprop_keylist
, ":keylist");
1734 DEFSYM (QCgnutls_bootprop_crlfiles
, ":crlfiles");
1735 DEFSYM (QCgnutls_bootprop_min_prime_bits
, ":min-prime-bits");
1736 DEFSYM (QCgnutls_bootprop_loglevel
, ":loglevel");
1737 DEFSYM (QCgnutls_bootprop_verify_flags
, ":verify-flags");
1738 DEFSYM (QCgnutls_bootprop_verify_error
, ":verify-error");
1740 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
1741 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
1742 make_number (GNUTLS_E_INTERRUPTED
));
1744 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
1745 Fput (Qgnutls_e_again
, Qgnutls_code
,
1746 make_number (GNUTLS_E_AGAIN
));
1748 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
1749 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
1750 make_number (GNUTLS_E_INVALID_SESSION
));
1752 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
1753 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
1754 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
1756 defsubr (&Sgnutls_get_initstage
);
1757 defsubr (&Sgnutls_asynchronous_parameters
);
1758 defsubr (&Sgnutls_errorp
);
1759 defsubr (&Sgnutls_error_fatalp
);
1760 defsubr (&Sgnutls_error_string
);
1761 defsubr (&Sgnutls_boot
);
1762 defsubr (&Sgnutls_deinit
);
1763 defsubr (&Sgnutls_bye
);
1764 defsubr (&Sgnutls_peer_status
);
1765 defsubr (&Sgnutls_peer_status_warning_describe
);
1767 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
1768 doc
: /* Logging level used by the GnuTLS functions.
1769 Set this larger than 0 to get debug output in the *Messages* buffer.
1770 1 is for important messages, 2 is for debug data, and higher numbers
1771 are as per the GnuTLS logging conventions. */);
1772 global_gnutls_log_level
= 0;
1774 #endif /* HAVE_GNUTLS */
1776 defsubr (&Sgnutls_available_p
);