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
;
408 ret
= gnutls_handshake (state
);
409 emacs_gnutls_handle_error (state
, ret
);
412 while (ret
< 0 && gnutls_error_is_fatal (ret
) == 0 &&
413 ! proc
->is_non_blocking_client
);
415 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
417 if (proc
->is_non_blocking_client
)
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
)
546 rtnval
= gnutls_record_recv (state
, buf
, nbyte
);
549 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
550 /* The peer closed the connection. */
552 else if (emacs_gnutls_handle_error (state
, rtnval
))
553 /* non-fatal error */
556 /* a fatal error occurred */
561 /* Report a GnuTLS error to the user.
562 Return true if the error code was successfully handled. */
564 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
566 int max_log_level
= 0;
571 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
575 check_memory_full (err
);
577 max_log_level
= global_gnutls_log_level
;
579 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
581 str
= gnutls_strerror (err
);
585 if (gnutls_error_is_fatal (err
))
588 GNUTLS_LOG2 (1, max_log_level
, "fatal error:", str
);
609 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
610 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
612 int alert
= gnutls_alert_get (session
);
613 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
614 str
= gnutls_alert_get_name (alert
);
618 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
623 /* convert an integer error to a Lisp_Object; it will be either a
624 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
625 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
628 gnutls_make_error (int err
)
632 case GNUTLS_E_SUCCESS
:
635 return Qgnutls_e_again
;
636 case GNUTLS_E_INTERRUPTED
:
637 return Qgnutls_e_interrupted
;
638 case GNUTLS_E_INVALID_SESSION
:
639 return Qgnutls_e_invalid_session
;
642 check_memory_full (err
);
643 return make_number (err
);
647 emacs_gnutls_deinit (Lisp_Object proc
)
651 CHECK_PROCESS (proc
);
653 if (XPROCESS (proc
)->gnutls_p
== 0)
656 log_level
= XPROCESS (proc
)->gnutls_log_level
;
658 if (XPROCESS (proc
)->gnutls_x509_cred
)
660 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
661 gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
662 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
665 if (XPROCESS (proc
)->gnutls_anon_cred
)
667 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
668 gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
669 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
672 if (XPROCESS (proc
)->gnutls_state
)
674 gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
675 XPROCESS (proc
)->gnutls_state
= NULL
;
676 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
677 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
680 XPROCESS (proc
)->gnutls_p
= 0;
684 DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters
,
685 Sgnutls_asynchronous_parameters
, 2, 2, 0,
686 doc
: /* Mark this process as being a pre-init GnuTLS process.
687 The second parameter is the list of parameters to feed to gnutls-boot
688 to finish setting up the connection. */)
689 (Lisp_Object proc
, Lisp_Object params
)
691 CHECK_PROCESS (proc
);
693 XPROCESS (proc
)->gnutls_boot_parameters
= params
;
697 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
698 doc
: /* Return the GnuTLS init stage of process PROC.
699 See also `gnutls-boot'. */)
702 CHECK_PROCESS (proc
);
704 return make_number (GNUTLS_INITSTAGE (proc
));
707 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
708 doc
: /* Return t if ERROR indicates a GnuTLS problem.
709 ERROR is an integer or a symbol with an integer `gnutls-code' property.
710 usage: (gnutls-errorp ERROR) */
714 if (EQ (err
, Qt
)) return Qnil
;
719 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
720 doc
: /* Return non-nil if ERROR is fatal.
721 ERROR is an integer or a symbol with an integer `gnutls-code' property.
722 Usage: (gnutls-error-fatalp ERROR) */)
727 if (EQ (err
, Qt
)) return Qnil
;
731 code
= Fget (err
, Qgnutls_code
);
738 error ("Symbol has no numeric gnutls-code property");
742 if (! TYPE_RANGED_INTEGERP (int, err
))
743 error ("Not an error symbol or code");
745 if (0 == gnutls_error_is_fatal (XINT (err
)))
751 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
752 doc
: /* Return a description of ERROR.
753 ERROR is an integer or a symbol with an integer `gnutls-code' property.
754 usage: (gnutls-error-string ERROR) */)
759 if (EQ (err
, Qt
)) return build_string ("Not an error");
763 code
= Fget (err
, Qgnutls_code
);
770 return build_string ("Symbol has no numeric gnutls-code property");
774 if (! TYPE_RANGED_INTEGERP (int, err
))
775 return build_string ("Not an error symbol or code");
777 return build_string (gnutls_strerror (XINT (err
)));
780 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
781 doc
: /* Deallocate GnuTLS resources associated with process PROC.
782 See also `gnutls-init'. */)
785 return emacs_gnutls_deinit (proc
);
789 gnutls_hex_string (unsigned char *buf
, ptrdiff_t buf_size
, const char *prefix
)
791 ptrdiff_t prefix_length
= strlen (prefix
);
793 if (INT_MULTIPLY_WRAPV (buf_size
, 3, &retlen
)
794 || INT_ADD_WRAPV (prefix_length
- (buf_size
!= 0), retlen
, &retlen
))
796 Lisp_Object ret
= make_uninit_string (retlen
);
797 char *string
= SSDATA (ret
);
798 strcpy (string
, prefix
);
800 for (ptrdiff_t i
= 0; i
< buf_size
; i
++)
801 sprintf (string
+ i
* 3 + prefix_length
,
802 i
== buf_size
- 1 ? "%02x" : "%02x:",
809 gnutls_certificate_details (gnutls_x509_crt_t cert
)
811 Lisp_Object res
= Qnil
;
817 int version
= gnutls_x509_crt_get_version (cert
);
818 check_memory_full (version
);
819 if (version
>= GNUTLS_E_SUCCESS
)
820 res
= nconc2 (res
, list2 (intern (":version"),
821 make_number (version
)));
826 err
= gnutls_x509_crt_get_serial (cert
, NULL
, &buf_size
);
827 check_memory_full (err
);
828 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
830 void *serial
= xmalloc (buf_size
);
831 err
= gnutls_x509_crt_get_serial (cert
, serial
, &buf_size
);
832 check_memory_full (err
);
833 if (err
>= GNUTLS_E_SUCCESS
)
834 res
= nconc2 (res
, list2 (intern (":serial-number"),
835 gnutls_hex_string (serial
, buf_size
, "")));
841 err
= gnutls_x509_crt_get_issuer_dn (cert
, NULL
, &buf_size
);
842 check_memory_full (err
);
843 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
845 char *dn
= xmalloc (buf_size
);
846 err
= gnutls_x509_crt_get_issuer_dn (cert
, dn
, &buf_size
);
847 check_memory_full (err
);
848 if (err
>= GNUTLS_E_SUCCESS
)
849 res
= nconc2 (res
, list2 (intern (":issuer"),
850 make_string (dn
, buf_size
)));
856 /* Add 1 to the buffer size, since 1900 is added to tm_year and
857 that might add 1 to the year length. */
858 char buf
[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
860 time_t tim
= gnutls_x509_crt_get_activation_time (cert
);
862 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
863 res
= nconc2 (res
, list2 (intern (":valid-from"), build_string (buf
)));
865 tim
= gnutls_x509_crt_get_expiration_time (cert
);
866 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
867 res
= nconc2 (res
, list2 (intern (":valid-to"), build_string (buf
)));
872 err
= gnutls_x509_crt_get_dn (cert
, NULL
, &buf_size
);
873 check_memory_full (err
);
874 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
876 char *dn
= xmalloc (buf_size
);
877 err
= gnutls_x509_crt_get_dn (cert
, dn
, &buf_size
);
878 check_memory_full (err
);
879 if (err
>= GNUTLS_E_SUCCESS
)
880 res
= nconc2 (res
, list2 (intern (":subject"),
881 make_string (dn
, buf_size
)));
885 /* Versions older than 2.11 doesn't have these four functions. */
886 #if GNUTLS_VERSION_NUMBER >= 0x020b00
887 /* SubjectPublicKeyInfo. */
891 err
= gnutls_x509_crt_get_pk_algorithm (cert
, &bits
);
892 check_memory_full (err
);
893 if (err
>= GNUTLS_E_SUCCESS
)
895 const char *name
= gnutls_pk_algorithm_get_name (err
);
897 res
= nconc2 (res
, list2 (intern (":public-key-algorithm"),
898 build_string (name
)));
900 name
= gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
902 res
= nconc2 (res
, list2 (intern (":certificate-security-level"),
903 build_string (name
)));
909 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, NULL
, &buf_size
);
910 check_memory_full (err
);
911 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
913 char *buf
= xmalloc (buf_size
);
914 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, buf
, &buf_size
);
915 check_memory_full (err
);
916 if (err
>= GNUTLS_E_SUCCESS
)
917 res
= nconc2 (res
, list2 (intern (":issuer-unique-id"),
918 make_string (buf
, buf_size
)));
923 err
= gnutls_x509_crt_get_subject_unique_id (cert
, NULL
, &buf_size
);
924 check_memory_full (err
);
925 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
927 char *buf
= xmalloc (buf_size
);
928 err
= gnutls_x509_crt_get_subject_unique_id (cert
, buf
, &buf_size
);
929 check_memory_full (err
);
930 if (err
>= GNUTLS_E_SUCCESS
)
931 res
= nconc2 (res
, list2 (intern (":subject-unique-id"),
932 make_string (buf
, buf_size
)));
938 err
= gnutls_x509_crt_get_signature_algorithm (cert
);
939 check_memory_full (err
);
940 if (err
>= GNUTLS_E_SUCCESS
)
942 const char *name
= gnutls_sign_get_name (err
);
944 res
= nconc2 (res
, list2 (intern (":signature-algorithm"),
945 build_string (name
)));
950 err
= gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
951 check_memory_full (err
);
952 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
954 void *buf
= xmalloc (buf_size
);
955 err
= gnutls_x509_crt_get_key_id (cert
, 0, buf
, &buf_size
);
956 check_memory_full (err
);
957 if (err
>= GNUTLS_E_SUCCESS
)
958 res
= nconc2 (res
, list2 (intern (":public-key-id"),
959 gnutls_hex_string (buf
, buf_size
, "sha1:")));
963 /* Certificate fingerprint. */
965 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
967 check_memory_full (err
);
968 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
970 void *buf
= xmalloc (buf_size
);
971 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
973 check_memory_full (err
);
974 if (err
>= GNUTLS_E_SUCCESS
)
975 res
= nconc2 (res
, list2 (intern (":certificate-id"),
976 gnutls_hex_string (buf
, buf_size
, "sha1:")));
983 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
984 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
985 (Lisp_Object status_symbol
)
987 CHECK_SYMBOL (status_symbol
);
989 if (EQ (status_symbol
, intern (":invalid")))
990 return build_string ("certificate could not be verified");
992 if (EQ (status_symbol
, intern (":revoked")))
993 return build_string ("certificate was revoked (CRL)");
995 if (EQ (status_symbol
, intern (":self-signed")))
996 return build_string ("certificate signer was not found (self-signed)");
998 if (EQ (status_symbol
, intern (":unknown-ca")))
999 return build_string ("the certificate was signed by an unknown "
1000 "and therefore untrusted authority");
1002 if (EQ (status_symbol
, intern (":not-ca")))
1003 return build_string ("certificate signer is not a CA");
1005 if (EQ (status_symbol
, intern (":insecure")))
1006 return build_string ("certificate was signed with an insecure algorithm");
1008 if (EQ (status_symbol
, intern (":not-activated")))
1009 return build_string ("certificate is not yet activated");
1011 if (EQ (status_symbol
, intern (":expired")))
1012 return build_string ("certificate has expired");
1014 if (EQ (status_symbol
, intern (":no-host-match")))
1015 return build_string ("certificate host does not match hostname");
1020 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
1021 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1022 The return value is a property list with top-level keys :warnings and
1023 :certificate. The :warnings entry is a list of symbols you can describe with
1024 `gnutls-peer-status-warning-describe'. */)
1027 Lisp_Object warnings
= Qnil
, result
= Qnil
;
1028 unsigned int verification
;
1029 gnutls_session_t state
;
1031 CHECK_PROCESS (proc
);
1033 if (GNUTLS_INITSTAGE (proc
) != GNUTLS_STAGE_READY
)
1036 /* Then collect any warnings already computed by the handshake. */
1037 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
1039 if (verification
& GNUTLS_CERT_INVALID
)
1040 warnings
= Fcons (intern (":invalid"), warnings
);
1042 if (verification
& GNUTLS_CERT_REVOKED
)
1043 warnings
= Fcons (intern (":revoked"), warnings
);
1045 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1046 warnings
= Fcons (intern (":unknown-ca"), warnings
);
1048 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1049 warnings
= Fcons (intern (":not-ca"), warnings
);
1051 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1052 warnings
= Fcons (intern (":insecure"), warnings
);
1054 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1055 warnings
= Fcons (intern (":not-activated"), warnings
);
1057 if (verification
& GNUTLS_CERT_EXPIRED
)
1058 warnings
= Fcons (intern (":expired"), warnings
);
1060 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1061 CERTIFICATE_NOT_MATCHING
)
1062 warnings
= Fcons (intern (":no-host-match"), warnings
);
1064 /* This could get called in the INIT stage, when the certificate is
1066 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
&&
1067 gnutls_x509_crt_check_issuer(XPROCESS (proc
)->gnutls_certificate
,
1068 XPROCESS (proc
)->gnutls_certificate
))
1069 warnings
= Fcons (intern (":self-signed"), warnings
);
1071 if (!NILP (warnings
))
1072 result
= list2 (intern (":warnings"), warnings
);
1074 /* This could get called in the INIT stage, when the certificate is
1076 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1077 result
= nconc2 (result
, list2
1078 (intern (":certificate"),
1079 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1081 state
= XPROCESS (proc
)->gnutls_state
;
1083 /* Diffie-Hellman prime bits. */
1085 int bits
= gnutls_dh_get_prime_bits (state
);
1086 check_memory_full (bits
);
1088 result
= nconc2 (result
, list2 (intern (":diffie-hellman-prime-bits"),
1089 make_number (bits
)));
1094 (result
, list2 (intern (":key-exchange"),
1095 build_string (gnutls_kx_get_name
1096 (gnutls_kx_get (state
)))));
1098 /* Protocol name. */
1100 (result
, list2 (intern (":protocol"),
1101 build_string (gnutls_protocol_get_name
1102 (gnutls_protocol_get_version (state
)))));
1106 (result
, list2 (intern (":cipher"),
1107 build_string (gnutls_cipher_get_name
1108 (gnutls_cipher_get (state
)))));
1112 (result
, list2 (intern (":mac"),
1113 build_string (gnutls_mac_get_name
1114 (gnutls_mac_get (state
)))));
1120 /* Initialize global GnuTLS state to defaults.
1121 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1122 Return zero on success. */
1124 emacs_gnutls_global_init (void)
1126 int ret
= GNUTLS_E_SUCCESS
;
1128 if (!gnutls_global_initialized
)
1130 ret
= gnutls_global_init ();
1131 if (ret
== GNUTLS_E_SUCCESS
)
1132 gnutls_global_initialized
= 1;
1135 return gnutls_make_error (ret
);
1139 gnutls_ip_address_p (char *string
)
1143 while ((c
= *string
++) != 0)
1144 if (! ((c
== '.' || c
== ':' || (c
>= '0' && c
<= '9'))))
1151 /* Deinitialize global GnuTLS state.
1152 See also `gnutls-global-init'. */
1154 emacs_gnutls_global_deinit (void)
1156 if (gnutls_global_initialized
)
1157 gnutls_global_deinit ();
1159 gnutls_global_initialized
= 0;
1161 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1167 boot_error (struct Lisp_Process
*p
, const char *m
, ...)
1171 if (p
->is_non_blocking_client
)
1172 pset_status (p
, list2 (Qfailed
, vformat_string (m
, ap
)));
1178 gnutls_verify_boot (Lisp_Object proc
, Lisp_Object proplist
)
1181 struct Lisp_Process
*p
= XPROCESS (proc
);
1182 gnutls_session_t state
= p
->gnutls_state
;
1183 unsigned int peer_verification
;
1184 Lisp_Object warnings
;
1185 int max_log_level
= p
->gnutls_log_level
;
1186 Lisp_Object hostname
, verify_error
;
1187 bool verify_error_all
= 0;
1190 if (NILP (proplist
))
1191 proplist
= Fcdr (Fplist_get (p
->childp
, QCtls_parameters
));
1193 verify_error
= Fplist_get (proplist
, QCgnutls_bootprop_verify_error
);
1194 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1196 if (EQ (verify_error
, Qt
))
1198 verify_error_all
= 1;
1200 else if (NILP (Flistp (verify_error
)))
1202 boot_error (p
, "gnutls-boot: invalid :verify_error parameter (not a list)");
1206 if (!STRINGP (hostname
))
1208 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1211 c_hostname
= SSDATA (hostname
);
1213 /* Now verify the peer, following
1214 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1215 The peer should present at least one certificate in the chain; do a
1216 check of the certificate's hostname with
1217 gnutls_x509_crt_check_hostname against :hostname. */
1219 ret
= gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1220 if (ret
< GNUTLS_E_SUCCESS
)
1221 return gnutls_make_error (ret
);
1223 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1225 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1226 if (!NILP (warnings
))
1229 for (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
);
1244 boot_error (p
, "Certificate validation failed %s, verification code %x",
1245 c_hostname
, peer_verification
);
1250 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1255 /* Up to here the process is the same for X.509 certificates and
1256 OpenPGP keys. From now on X.509 certificates are assumed. This
1257 can be easily extended to work with openpgp keys as well. */
1258 if (gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1260 gnutls_x509_crt_t gnutls_verify_cert
;
1261 const gnutls_datum_t
*gnutls_verify_cert_list
;
1262 unsigned int gnutls_verify_cert_list_size
;
1264 ret
= gnutls_x509_crt_init (&gnutls_verify_cert
);
1265 if (ret
< GNUTLS_E_SUCCESS
)
1266 return gnutls_make_error (ret
);
1268 gnutls_verify_cert_list
=
1269 gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1271 if (gnutls_verify_cert_list
== NULL
)
1273 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1274 emacs_gnutls_deinit (proc
);
1275 boot_error (p
, "No x509 certificate was found\n");
1279 /* We only check the first certificate in the given chain. */
1280 ret
= gnutls_x509_crt_import (gnutls_verify_cert
,
1281 &gnutls_verify_cert_list
[0],
1282 GNUTLS_X509_FMT_DER
);
1284 if (ret
< GNUTLS_E_SUCCESS
)
1286 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1287 return gnutls_make_error (ret
);
1290 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1292 int err
= gnutls_x509_crt_check_hostname (gnutls_verify_cert
,
1294 check_memory_full (err
);
1297 XPROCESS (proc
)->gnutls_extra_peer_verification
|=
1298 CERTIFICATE_NOT_MATCHING
;
1299 if (verify_error_all
1300 || !NILP (Fmember (QCgnutls_bootprop_hostname
, verify_error
)))
1302 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1303 emacs_gnutls_deinit (proc
);
1304 boot_error (p
, "The x509 certificate does not match \"%s\"", c_hostname
);
1309 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
= 1;
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
);