1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2021 Free Software Foundation, Inc.
3
4 This file is part of GNU Emacs.
5
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 (at
9 your option) any later version.
10
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.
15
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
18
19 #include <config.h>
20 #include <errno.h>
21 #include <stdio.h>
22
23 #include "lisp.h"
24 #include "process.h"
25 #include "gnutls.h"
26 #include "coding.h"
27 #include "buffer.h"
28 #include "pdumper.h"
29
30 #ifdef HAVE_GNUTLS
31
32 # if GNUTLS_VERSION_NUMBER >= 0x030014
33 # define HAVE_GNUTLS_X509_SYSTEM_TRUST
34 # endif
35
36 # if GNUTLS_VERSION_NUMBER >= 0x030200
37 # define HAVE_GNUTLS_CIPHER_GET_IV_SIZE
38 # endif
39
40 # if GNUTLS_VERSION_NUMBER >= 0x030202
41 # define HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
42 # define HAVE_GNUTLS_DIGEST_LIST /* also gnutls_digest_get_name */
43 # endif
44
45 # if GNUTLS_VERSION_NUMBER >= 0x030205
46 # define HAVE_GNUTLS_EXT__DUMBFW
47 # endif
48
49 # if GNUTLS_VERSION_NUMBER >= 0x030400
50 # define HAVE_GNUTLS_ETM_STATUS
51 # endif
52
53 # if GNUTLS_VERSION_NUMBER < 0x030600
54 # define HAVE_GNUTLS_COMPRESSION_GET
55 # endif
56
57 /* gnutls_mac_get_nonce_size was added in GnuTLS 3.2.0, but was
58 exported only since 3.3.0. */
59 # if GNUTLS_VERSION_NUMBER >= 0x030300
60 # define HAVE_GNUTLS_MAC_GET_NONCE_SIZE
61 # endif
62
63 # if GNUTLS_VERSION_NUMBER >= 0x030501
64 # define HAVE_GNUTLS_EXT_GET_NAME
65 # endif
66
67 /* Although AEAD support started in GnuTLS 3.4.0 and works in 3.5.14,
68 it was broken through at least GnuTLS 3.4.10; see:
69 https://lists.gnu.org/r/emacs-devel/2017-07/msg00992.html
70 The relevant fix seems to have been made in GnuTLS 3.5.1; see:
71 https://gitlab.com/gnutls/gnutls/commit/568935848dd6b82b9315d8b6c529d00e2605e03d
72 So, require 3.5.1. */
73 # if GNUTLS_VERSION_NUMBER >= 0x030501
74 # define HAVE_GNUTLS_AEAD
75 # endif
76
77 # ifdef WINDOWSNT
78 # include <windows.h>
79 # include "w32common.h"
80 # include "w32.h"
81 # endif
82
83 static int emacs_gnutls_handle_error (gnutls_session_t, int);
84
85 static bool gnutls_global_initialized;
86
87 static void gnutls_log_function (int, const char *);
88 static void gnutls_log_function2 (int, const char *, const char *);
89 # ifdef HAVE_GNUTLS3
90 static void gnutls_audit_log_function (gnutls_session_t, const char *);
91 # endif
92
93 enum extra_peer_verification
94 {
95 CERTIFICATE_NOT_MATCHING = 2
96 };
97
98
99 # ifdef WINDOWSNT
100
101 DEF_DLL_FN (gnutls_alert_description_t, gnutls_alert_get,
102 (gnutls_session_t));
103 DEF_DLL_FN (const char *, gnutls_alert_get_name,
104 (gnutls_alert_description_t));
105 DEF_DLL_FN (int, gnutls_anon_allocate_client_credentials,
106 (gnutls_anon_client_credentials_t *));
107 DEF_DLL_FN (void, gnutls_anon_free_client_credentials,
108 (gnutls_anon_client_credentials_t));
109 DEF_DLL_FN (int, gnutls_bye, (gnutls_session_t, gnutls_close_request_t));
110 DEF_DLL_FN (int, gnutls_certificate_allocate_credentials,
111 (gnutls_certificate_credentials_t *));
112 DEF_DLL_FN (void, gnutls_certificate_free_credentials,
113 (gnutls_certificate_credentials_t));
114 DEF_DLL_FN (const gnutls_datum_t *, gnutls_certificate_get_peers,
115 (gnutls_session_t, unsigned int *));
116 DEF_DLL_FN (void, gnutls_certificate_set_verify_flags,
117 (gnutls_certificate_credentials_t, unsigned int));
118 DEF_DLL_FN (int, gnutls_certificate_set_x509_crl_file,
119 (gnutls_certificate_credentials_t, const char *,
120 gnutls_x509_crt_fmt_t));
121 DEF_DLL_FN (int, gnutls_certificate_set_x509_key_file,
122 (gnutls_certificate_credentials_t, const char *, const char *,
123 gnutls_x509_crt_fmt_t));
124 # ifdef HAVE_GNUTLS_X509_SYSTEM_TRUST
125 DEF_DLL_FN (int, gnutls_certificate_set_x509_system_trust,
126 (gnutls_certificate_credentials_t));
127 # endif
128 DEF_DLL_FN (int, gnutls_certificate_set_x509_trust_file,
129 (gnutls_certificate_credentials_t, const char *,
130 gnutls_x509_crt_fmt_t));
131 DEF_DLL_FN (gnutls_certificate_type_t, gnutls_certificate_type_get,
132 (gnutls_session_t));
133 DEF_DLL_FN (int, gnutls_certificate_verify_peers2,
134 (gnutls_session_t, unsigned int *));
135 DEF_DLL_FN (int, gnutls_credentials_set,
136 (gnutls_session_t, gnutls_credentials_type_t, void *));
137 DEF_DLL_FN (void, gnutls_deinit, (gnutls_session_t));
138 DEF_DLL_FN (void, gnutls_dh_set_prime_bits,
139 (gnutls_session_t, unsigned int));
140 DEF_DLL_FN (int, gnutls_dh_get_prime_bits, (gnutls_session_t));
141 DEF_DLL_FN (int, gnutls_error_is_fatal, (int));
142 DEF_DLL_FN (int, gnutls_global_init, (void));
143 DEF_DLL_FN (void, gnutls_global_set_log_function, (gnutls_log_func));
144 # ifdef HAVE_GNUTLS3
145 DEF_DLL_FN (void, gnutls_global_set_audit_log_function, (gnutls_audit_log_func));
146 # endif
147 DEF_DLL_FN (void, gnutls_global_set_log_level, (int));
148 DEF_DLL_FN (int, gnutls_handshake, (gnutls_session_t));
149 DEF_DLL_FN (int, gnutls_init, (gnutls_session_t *, unsigned int));
150 DEF_DLL_FN (int, gnutls_priority_set_direct,
151 (gnutls_session_t, const char *, const char **));
152 DEF_DLL_FN (size_t, gnutls_record_check_pending, (gnutls_session_t));
153 DEF_DLL_FN (ssize_t, gnutls_record_recv, (gnutls_session_t, void *, size_t));
154 DEF_DLL_FN (ssize_t, gnutls_record_send,
155 (gnutls_session_t, const void *, size_t));
156 DEF_DLL_FN (const char *, gnutls_strerror, (int));
157 DEF_DLL_FN (void, gnutls_transport_set_errno, (gnutls_session_t, int));
158 DEF_DLL_FN (void, gnutls_transport_set_ptr2,
159 (gnutls_session_t, gnutls_transport_ptr_t,
160 gnutls_transport_ptr_t));
161 DEF_DLL_FN (void, gnutls_transport_set_pull_function,
162 (gnutls_session_t, gnutls_pull_func));
163 DEF_DLL_FN (void, gnutls_transport_set_push_function,
164 (gnutls_session_t, gnutls_push_func));
165 DEF_DLL_FN (int, gnutls_x509_crt_check_hostname,
166 (gnutls_x509_crt_t, const char *));
167 DEF_DLL_FN (int, gnutls_x509_crt_check_issuer,
168 (gnutls_x509_crt_t, gnutls_x509_crt_t));
169 DEF_DLL_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t));
170 DEF_DLL_FN (int, gnutls_x509_crt_export,
171 (gnutls_x509_crt_t, gnutls_x509_crt_fmt_t, void *, size_t *));
172 DEF_DLL_FN (int, gnutls_x509_crt_import,
173 (gnutls_x509_crt_t, const gnutls_datum_t *,
174 gnutls_x509_crt_fmt_t));
175 DEF_DLL_FN (int, gnutls_x509_crt_init, (gnutls_x509_crt_t *));
176 DEF_DLL_FN (int, gnutls_x509_crt_get_fingerprint,
177 (gnutls_x509_crt_t,
178 gnutls_digest_algorithm_t, void *, size_t *));
179 DEF_DLL_FN (int, gnutls_x509_crt_get_version,
180 (gnutls_x509_crt_t));
181 DEF_DLL_FN (int, gnutls_x509_crt_get_serial,
182 (gnutls_x509_crt_t, void *, size_t *));
183 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_dn,
184 (gnutls_x509_crt_t, char *, size_t *));
185 DEF_DLL_FN (time_t, gnutls_x509_crt_get_activation_time,
186 (gnutls_x509_crt_t));
187 DEF_DLL_FN (time_t, gnutls_x509_crt_get_expiration_time,
188 (gnutls_x509_crt_t));
189 DEF_DLL_FN (int, gnutls_x509_crt_get_dn,
190 (gnutls_x509_crt_t, char *, size_t *));
191 DEF_DLL_FN (int, gnutls_x509_crt_get_pk_algorithm,
192 (gnutls_x509_crt_t, unsigned int *));
193 DEF_DLL_FN (int, gnutls_x509_crt_print,
194 (gnutls_x509_crt_t, gnutls_certificate_print_formats_t,
195 gnutls_datum_t *));
196 DEF_DLL_FN (const char *, gnutls_pk_algorithm_get_name,
197 (gnutls_pk_algorithm_t));
198 DEF_DLL_FN (int, gnutls_pk_bits_to_sec_param,
199 (gnutls_pk_algorithm_t, unsigned int));
200 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_unique_id,
201 (gnutls_x509_crt_t, char *, size_t *));
202 DEF_DLL_FN (int, gnutls_x509_crt_get_subject_unique_id,
203 (gnutls_x509_crt_t, char *, size_t *));
204 DEF_DLL_FN (int, gnutls_x509_crt_get_signature_algorithm,
205 (gnutls_x509_crt_t));
206 DEF_DLL_FN (int, gnutls_x509_crt_get_key_id,
207 (gnutls_x509_crt_t, unsigned int, unsigned char *, size_t *_size));
208 DEF_DLL_FN (const char *, gnutls_sec_param_get_name, (gnutls_sec_param_t));
209 DEF_DLL_FN (const char *, gnutls_sign_get_name, (gnutls_sign_algorithm_t));
210 DEF_DLL_FN (int, gnutls_server_name_set,
211 (gnutls_session_t, gnutls_server_name_type_t,
212 const void *, size_t));
213 DEF_DLL_FN (gnutls_kx_algorithm_t, gnutls_kx_get, (gnutls_session_t));
214 DEF_DLL_FN (const char *, gnutls_kx_get_name, (gnutls_kx_algorithm_t));
215 DEF_DLL_FN (gnutls_protocol_t, gnutls_protocol_get_version,
216 (gnutls_session_t));
217 DEF_DLL_FN (const char *, gnutls_protocol_get_name, (gnutls_protocol_t));
218 DEF_DLL_FN (gnutls_cipher_algorithm_t, gnutls_cipher_get,
219 (gnutls_session_t));
220 DEF_DLL_FN (const char *, gnutls_cipher_get_name,
221 (gnutls_cipher_algorithm_t));
222 DEF_DLL_FN (gnutls_mac_algorithm_t, gnutls_mac_get, (gnutls_session_t));
223 DEF_DLL_FN (const char *, gnutls_mac_get_name, (gnutls_mac_algorithm_t));
224 # ifdef HAVE_GNUTLS_COMPRESSION_GET
225 DEF_DLL_FN (gnutls_compression_method_t, gnutls_compression_get,
226 (gnutls_session_t));
227 DEF_DLL_FN (const char *, gnutls_compression_get_name,
228 (gnutls_compression_method_t));
229 # endif
230 DEF_DLL_FN (unsigned, gnutls_safe_renegotiation_status, (gnutls_session_t));
231
232 # ifdef HAVE_GNUTLS3
233 DEF_DLL_FN (int, gnutls_rnd, (gnutls_rnd_level_t, void *, size_t));
234 DEF_DLL_FN (const gnutls_mac_algorithm_t *, gnutls_mac_list, (void));
235 # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE
236 DEF_DLL_FN (size_t, gnutls_mac_get_nonce_size, (gnutls_mac_algorithm_t));
237 # endif
238 DEF_DLL_FN (size_t, gnutls_mac_get_key_size, (gnutls_mac_algorithm_t));
239 # ifdef HAVE_GNUTLS_DIGEST_LIST
240 DEF_DLL_FN (const gnutls_digest_algorithm_t *, gnutls_digest_list, (void));
241 DEF_DLL_FN (const char *, gnutls_digest_get_name, (gnutls_digest_algorithm_t));
242 # endif
243 DEF_DLL_FN (gnutls_cipher_algorithm_t *, gnutls_cipher_list, (void));
244 # ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE
245 DEF_DLL_FN (int, gnutls_cipher_get_iv_size, (gnutls_cipher_algorithm_t));
246 # endif
247 DEF_DLL_FN (size_t, gnutls_cipher_get_key_size, (gnutls_cipher_algorithm_t));
248 DEF_DLL_FN (int, gnutls_cipher_get_block_size, (gnutls_cipher_algorithm_t));
249 # ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
250 DEF_DLL_FN (int, gnutls_cipher_get_tag_size, (gnutls_cipher_algorithm_t));
251 # endif
252 DEF_DLL_FN (int, gnutls_cipher_init,
253 (gnutls_cipher_hd_t *, gnutls_cipher_algorithm_t,
254 const gnutls_datum_t *, const gnutls_datum_t *));
255 DEF_DLL_FN (void, gnutls_cipher_set_iv, (gnutls_cipher_hd_t, void *, size_t));
256 DEF_DLL_FN (int, gnutls_cipher_encrypt2,
257 (gnutls_cipher_hd_t, const void *, size_t, void *, size_t));
258 DEF_DLL_FN (void, gnutls_cipher_deinit, (gnutls_cipher_hd_t));
259 DEF_DLL_FN (int, gnutls_cipher_decrypt2,
260 (gnutls_cipher_hd_t, const void *, size_t, void *, size_t));
261 # ifdef HAVE_GNUTLS_AEAD
262 DEF_DLL_FN (int, gnutls_aead_cipher_init,
263 (gnutls_aead_cipher_hd_t *, gnutls_cipher_algorithm_t,
264 const gnutls_datum_t *));
265 DEF_DLL_FN (void, gnutls_aead_cipher_deinit, (gnutls_aead_cipher_hd_t));
266 DEF_DLL_FN (int, gnutls_aead_cipher_encrypt,
267 (gnutls_aead_cipher_hd_t, const void *, size_t, const void *,
268 size_t, size_t, const void *, size_t, void *, size_t *));
269 DEF_DLL_FN (int, gnutls_aead_cipher_decrypt,
270 (gnutls_aead_cipher_hd_t, const void *, size_t, const void *,
271 size_t, size_t, const void *, size_t, void *, size_t *));
272 # endif
273 # ifdef HAVE_GNUTLS_ETM_STATUS
274 DEF_DLL_FN (unsigned, gnutls_session_etm_status, (gnutls_session_t));
275 # endif
276 DEF_DLL_FN (int, gnutls_hmac_init,
277 (gnutls_hmac_hd_t *, gnutls_mac_algorithm_t, const void *, size_t));
278 DEF_DLL_FN (int, gnutls_hmac_get_len, (gnutls_mac_algorithm_t));
279 DEF_DLL_FN (int, gnutls_hmac, (gnutls_hmac_hd_t, const void *, size_t));
280 DEF_DLL_FN (void, gnutls_hmac_deinit, (gnutls_hmac_hd_t, void *));
281 DEF_DLL_FN (void, gnutls_hmac_output, (gnutls_hmac_hd_t, void *));
282 DEF_DLL_FN (int, gnutls_hash_init,
283 (gnutls_hash_hd_t *, gnutls_digest_algorithm_t));
284 DEF_DLL_FN (int, gnutls_hash_get_len, (gnutls_digest_algorithm_t));
285 DEF_DLL_FN (int, gnutls_hash, (gnutls_hash_hd_t, const void *, size_t));
286 DEF_DLL_FN (void, gnutls_hash_deinit, (gnutls_hash_hd_t, void *));
287 DEF_DLL_FN (void, gnutls_hash_output, (gnutls_hash_hd_t, void *));
288 # ifdef HAVE_GNUTLS_EXT_GET_NAME
289 DEF_DLL_FN (const char *, gnutls_ext_get_name, (unsigned int));
290 # endif
291 # endif /* HAVE_GNUTLS3 */
292
293 static gnutls_free_function *gnutls_free_func;
294
295 static bool
init_gnutls_functions(void)296 init_gnutls_functions (void)
297 {
298 HMODULE library;
299 int max_log_level = 1;
300
301 if (!(library = w32_delayed_load (Qgnutls)))
302 {
303 GNUTLS_LOG (1, max_log_level, "GnuTLS library not found");
304 return 0;
305 }
306
307 LOAD_DLL_FN (library, gnutls_alert_get);
308 LOAD_DLL_FN (library, gnutls_alert_get_name);
309 LOAD_DLL_FN (library, gnutls_anon_allocate_client_credentials);
310 LOAD_DLL_FN (library, gnutls_anon_free_client_credentials);
311 LOAD_DLL_FN (library, gnutls_bye);
312 LOAD_DLL_FN (library, gnutls_certificate_allocate_credentials);
313 LOAD_DLL_FN (library, gnutls_certificate_free_credentials);
314 LOAD_DLL_FN (library, gnutls_certificate_get_peers);
315 LOAD_DLL_FN (library, gnutls_certificate_set_verify_flags);
316 LOAD_DLL_FN (library, gnutls_certificate_set_x509_crl_file);
317 LOAD_DLL_FN (library, gnutls_certificate_set_x509_key_file);
318 # ifdef HAVE_GNUTLS_X509_SYSTEM_TRUST
319 LOAD_DLL_FN (library, gnutls_certificate_set_x509_system_trust);
320 # endif
321 LOAD_DLL_FN (library, gnutls_certificate_set_x509_trust_file);
322 LOAD_DLL_FN (library, gnutls_certificate_type_get);
323 LOAD_DLL_FN (library, gnutls_certificate_verify_peers2);
324 LOAD_DLL_FN (library, gnutls_credentials_set);
325 LOAD_DLL_FN (library, gnutls_deinit);
326 LOAD_DLL_FN (library, gnutls_dh_set_prime_bits);
327 LOAD_DLL_FN (library, gnutls_dh_get_prime_bits);
328 LOAD_DLL_FN (library, gnutls_error_is_fatal);
329 LOAD_DLL_FN (library, gnutls_global_init);
330 LOAD_DLL_FN (library, gnutls_global_set_log_function);
331 # ifdef HAVE_GNUTLS3
332 LOAD_DLL_FN (library, gnutls_global_set_audit_log_function);
333 # endif
334 LOAD_DLL_FN (library, gnutls_global_set_log_level);
335 LOAD_DLL_FN (library, gnutls_handshake);
336 LOAD_DLL_FN (library, gnutls_init);
337 LOAD_DLL_FN (library, gnutls_priority_set_direct);
338 LOAD_DLL_FN (library, gnutls_record_check_pending);
339 LOAD_DLL_FN (library, gnutls_record_recv);
340 LOAD_DLL_FN (library, gnutls_record_send);
341 LOAD_DLL_FN (library, gnutls_strerror);
342 LOAD_DLL_FN (library, gnutls_transport_set_errno);
343 LOAD_DLL_FN (library, gnutls_transport_set_ptr2);
344 LOAD_DLL_FN (library, gnutls_transport_set_pull_function);
345 LOAD_DLL_FN (library, gnutls_transport_set_push_function);
346 LOAD_DLL_FN (library, gnutls_x509_crt_check_hostname);
347 LOAD_DLL_FN (library, gnutls_x509_crt_check_issuer);
348 LOAD_DLL_FN (library, gnutls_x509_crt_deinit);
349 LOAD_DLL_FN (library, gnutls_x509_crt_export);
350 LOAD_DLL_FN (library, gnutls_x509_crt_import);
351 LOAD_DLL_FN (library, gnutls_x509_crt_init);
352 LOAD_DLL_FN (library, gnutls_x509_crt_get_fingerprint);
353 LOAD_DLL_FN (library, gnutls_x509_crt_get_version);
354 LOAD_DLL_FN (library, gnutls_x509_crt_get_serial);
355 LOAD_DLL_FN (library, gnutls_x509_crt_get_issuer_dn);
356 LOAD_DLL_FN (library, gnutls_x509_crt_get_activation_time);
357 LOAD_DLL_FN (library, gnutls_x509_crt_get_expiration_time);
358 LOAD_DLL_FN (library, gnutls_x509_crt_get_dn);
359 LOAD_DLL_FN (library, gnutls_x509_crt_get_pk_algorithm);
360 LOAD_DLL_FN (library, gnutls_x509_crt_print);
361 LOAD_DLL_FN (library, gnutls_pk_algorithm_get_name);
362 LOAD_DLL_FN (library, gnutls_pk_bits_to_sec_param);
363 LOAD_DLL_FN (library, gnutls_x509_crt_get_issuer_unique_id);
364 LOAD_DLL_FN (library, gnutls_x509_crt_get_subject_unique_id);
365 LOAD_DLL_FN (library, gnutls_x509_crt_get_signature_algorithm);
366 LOAD_DLL_FN (library, gnutls_x509_crt_get_key_id);
367 LOAD_DLL_FN (library, gnutls_sec_param_get_name);
368 LOAD_DLL_FN (library, gnutls_sign_get_name);
369 LOAD_DLL_FN (library, gnutls_server_name_set);
370 LOAD_DLL_FN (library, gnutls_kx_get);
371 LOAD_DLL_FN (library, gnutls_kx_get_name);
372 LOAD_DLL_FN (library, gnutls_protocol_get_version);
373 LOAD_DLL_FN (library, gnutls_protocol_get_name);
374 LOAD_DLL_FN (library, gnutls_cipher_get);
375 LOAD_DLL_FN (library, gnutls_cipher_get_name);
376 LOAD_DLL_FN (library, gnutls_mac_get);
377 LOAD_DLL_FN (library, gnutls_mac_get_name);
378 # ifdef HAVE_GNUTLS_COMPRESSION_GET
379 LOAD_DLL_FN (library, gnutls_compression_get);
380 LOAD_DLL_FN (library, gnutls_compression_get_name);
381 # endif
382 LOAD_DLL_FN (library, gnutls_safe_renegotiation_status);
383 # ifdef HAVE_GNUTLS3
384 LOAD_DLL_FN (library, gnutls_rnd);
385 LOAD_DLL_FN (library, gnutls_mac_list);
386 # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE
387 LOAD_DLL_FN (library, gnutls_mac_get_nonce_size);
388 # endif
389 LOAD_DLL_FN (library, gnutls_mac_get_key_size);
390 # ifdef HAVE_GNUTLS_DIGEST_LIST
391 LOAD_DLL_FN (library, gnutls_digest_list);
392 LOAD_DLL_FN (library, gnutls_digest_get_name);
393 # endif
394 LOAD_DLL_FN (library, gnutls_cipher_list);
395 # ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE
396 LOAD_DLL_FN (library, gnutls_cipher_get_iv_size);
397 # endif
398 LOAD_DLL_FN (library, gnutls_cipher_get_key_size);
399 LOAD_DLL_FN (library, gnutls_cipher_get_block_size);
400 # ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
401 LOAD_DLL_FN (library, gnutls_cipher_get_tag_size);
402 # endif
403 LOAD_DLL_FN (library, gnutls_cipher_init);
404 LOAD_DLL_FN (library, gnutls_cipher_set_iv);
405 LOAD_DLL_FN (library, gnutls_cipher_encrypt2);
406 LOAD_DLL_FN (library, gnutls_cipher_deinit);
407 LOAD_DLL_FN (library, gnutls_cipher_decrypt2);
408 # ifdef HAVE_GNUTLS_AEAD
409 LOAD_DLL_FN (library, gnutls_aead_cipher_init);
410 LOAD_DLL_FN (library, gnutls_aead_cipher_deinit);
411 LOAD_DLL_FN (library, gnutls_aead_cipher_encrypt);
412 LOAD_DLL_FN (library, gnutls_aead_cipher_decrypt);
413 # endif
414 # ifdef HAVE_GNUTLS_ETM_STATUS
415 LOAD_DLL_FN (library, gnutls_session_etm_status);
416 # endif
417 LOAD_DLL_FN (library, gnutls_hmac_init);
418 LOAD_DLL_FN (library, gnutls_hmac_get_len);
419 LOAD_DLL_FN (library, gnutls_hmac);
420 LOAD_DLL_FN (library, gnutls_hmac_deinit);
421 LOAD_DLL_FN (library, gnutls_hmac_output);
422 LOAD_DLL_FN (library, gnutls_hash_init);
423 LOAD_DLL_FN (library, gnutls_hash_get_len);
424 LOAD_DLL_FN (library, gnutls_hash);
425 LOAD_DLL_FN (library, gnutls_hash_deinit);
426 LOAD_DLL_FN (library, gnutls_hash_output);
427 # ifdef HAVE_GNUTLS_EXT_GET_NAME
428 LOAD_DLL_FN (library, gnutls_ext_get_name);
429 # endif
430 # endif /* HAVE_GNUTLS3 */
431
432 /* gnutls_free is a variable inside GnuTLS, whose value is the
433 "free" function. So it needs special handling. */
434 gnutls_free_func = (gnutls_free_function *) GetProcAddress (library,
435 "gnutls_free");
436 if (!gnutls_free_func)
437 return false;
438
439 max_log_level = clip_to_bounds (INT_MIN, global_gnutls_log_level, INT_MAX);
440 {
441 Lisp_Object name = CAR_SAFE (Fget (Qgnutls, QCloaded_from));
442 GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:",
443 STRINGP (name) ? (const char *) SDATA (name) : "unknown");
444 }
445
446 return 1;
447 }
448
449 # define gnutls_alert_get fn_gnutls_alert_get
450 # define gnutls_alert_get_name fn_gnutls_alert_get_name
451 # define gnutls_anon_allocate_client_credentials fn_gnutls_anon_allocate_client_credentials
452 # define gnutls_anon_free_client_credentials fn_gnutls_anon_free_client_credentials
453 # define gnutls_bye fn_gnutls_bye
454 # define gnutls_certificate_allocate_credentials fn_gnutls_certificate_allocate_credentials
455 # define gnutls_certificate_free_credentials fn_gnutls_certificate_free_credentials
456 # define gnutls_certificate_get_peers fn_gnutls_certificate_get_peers
457 # define gnutls_certificate_set_verify_flags fn_gnutls_certificate_set_verify_flags
458 # define gnutls_certificate_set_x509_crl_file fn_gnutls_certificate_set_x509_crl_file
459 # define gnutls_certificate_set_x509_key_file fn_gnutls_certificate_set_x509_key_file
460 # define gnutls_certificate_set_x509_system_trust fn_gnutls_certificate_set_x509_system_trust
461 # define gnutls_certificate_set_x509_trust_file fn_gnutls_certificate_set_x509_trust_file
462 # define gnutls_certificate_type_get fn_gnutls_certificate_type_get
463 # define gnutls_certificate_verify_peers2 fn_gnutls_certificate_verify_peers2
464 # define gnutls_cipher_get fn_gnutls_cipher_get
465 # define gnutls_cipher_get_name fn_gnutls_cipher_get_name
466 # define gnutls_credentials_set fn_gnutls_credentials_set
467 # define gnutls_deinit fn_gnutls_deinit
468 # define gnutls_dh_get_prime_bits fn_gnutls_dh_get_prime_bits
469 # define gnutls_dh_set_prime_bits fn_gnutls_dh_set_prime_bits
470 # define gnutls_error_is_fatal fn_gnutls_error_is_fatal
471 # define gnutls_global_init fn_gnutls_global_init
472 # define gnutls_global_set_audit_log_function fn_gnutls_global_set_audit_log_function
473 # define gnutls_global_set_log_function fn_gnutls_global_set_log_function
474 # define gnutls_global_set_log_level fn_gnutls_global_set_log_level
475 # define gnutls_handshake fn_gnutls_handshake
476 # define gnutls_init fn_gnutls_init
477 # define gnutls_kx_get fn_gnutls_kx_get
478 # define gnutls_kx_get_name fn_gnutls_kx_get_name
479 # define gnutls_mac_get fn_gnutls_mac_get
480 # define gnutls_mac_get_name fn_gnutls_mac_get_name
481 # ifdef HAVE_GNUTLS_COMPRESSION_GET
482 # define gnutls_compression_get fn_gnutls_compression_get
483 # define gnutls_compression_get_name fn_gnutls_compression_get_name
484 # endif
485 # define gnutls_safe_renegotiation_status fn_gnutls_safe_renegotiation_status
486 # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name
487 # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param
488 # define gnutls_priority_set_direct fn_gnutls_priority_set_direct
489 # define gnutls_protocol_get_name fn_gnutls_protocol_get_name
490 # define gnutls_protocol_get_version fn_gnutls_protocol_get_version
491 # define gnutls_record_check_pending fn_gnutls_record_check_pending
492 # define gnutls_record_recv fn_gnutls_record_recv
493 # define gnutls_record_send fn_gnutls_record_send
494 # define gnutls_sec_param_get_name fn_gnutls_sec_param_get_name
495 # define gnutls_server_name_set fn_gnutls_server_name_set
496 # define gnutls_sign_get_name fn_gnutls_sign_get_name
497 # define gnutls_strerror fn_gnutls_strerror
498 # define gnutls_transport_set_errno fn_gnutls_transport_set_errno
499 # define gnutls_transport_set_ptr2 fn_gnutls_transport_set_ptr2
500 # define gnutls_transport_set_pull_function fn_gnutls_transport_set_pull_function
501 # define gnutls_transport_set_push_function fn_gnutls_transport_set_push_function
502 # define gnutls_x509_crt_check_hostname fn_gnutls_x509_crt_check_hostname
503 # define gnutls_x509_crt_check_issuer fn_gnutls_x509_crt_check_issuer
504 # define gnutls_x509_crt_deinit fn_gnutls_x509_crt_deinit
505 # define gnutls_x509_crt_export fn_gnutls_x509_crt_export
506 # define gnutls_x509_crt_get_activation_time fn_gnutls_x509_crt_get_activation_time
507 # define gnutls_x509_crt_get_dn fn_gnutls_x509_crt_get_dn
508 # define gnutls_x509_crt_get_expiration_time fn_gnutls_x509_crt_get_expiration_time
509 # define gnutls_x509_crt_get_fingerprint fn_gnutls_x509_crt_get_fingerprint
510 # define gnutls_x509_crt_get_issuer_dn fn_gnutls_x509_crt_get_issuer_dn
511 # define gnutls_x509_crt_get_issuer_unique_id fn_gnutls_x509_crt_get_issuer_unique_id
512 # define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id
513 # define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm
514 # define gnutls_x509_crt_print fn_gnutls_x509_crt_print
515 # define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial
516 # define gnutls_x509_crt_get_signature_algorithm fn_gnutls_x509_crt_get_signature_algorithm
517 # define gnutls_x509_crt_get_subject_unique_id fn_gnutls_x509_crt_get_subject_unique_id
518 # define gnutls_x509_crt_get_version fn_gnutls_x509_crt_get_version
519 # define gnutls_x509_crt_import fn_gnutls_x509_crt_import
520 # define gnutls_x509_crt_init fn_gnutls_x509_crt_init
521 # ifdef HAVE_GNUTLS3
522 # define gnutls_rnd fn_gnutls_rnd
523 # define gnutls_mac_list fn_gnutls_mac_list
524 # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE
525 # define gnutls_mac_get_nonce_size fn_gnutls_mac_get_nonce_size
526 # endif
527 # define gnutls_mac_get_key_size fn_gnutls_mac_get_key_size
528 # ifdef HAVE_GNUTLS_DIGEST_LIST
529 # define gnutls_digest_list fn_gnutls_digest_list
530 # define gnutls_digest_get_name fn_gnutls_digest_get_name
531 # endif
532 # define gnutls_cipher_list fn_gnutls_cipher_list
533 # ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE
534 # define gnutls_cipher_get_iv_size fn_gnutls_cipher_get_iv_size
535 # endif
536 # define gnutls_cipher_get_key_size fn_gnutls_cipher_get_key_size
537 # define gnutls_cipher_get_block_size fn_gnutls_cipher_get_block_size
538 # ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
539 # define gnutls_cipher_get_tag_size fn_gnutls_cipher_get_tag_size
540 # endif
541 # define gnutls_cipher_init fn_gnutls_cipher_init
542 # define gnutls_cipher_set_iv fn_gnutls_cipher_set_iv
543 # define gnutls_cipher_encrypt2 fn_gnutls_cipher_encrypt2
544 # define gnutls_cipher_decrypt2 fn_gnutls_cipher_decrypt2
545 # define gnutls_cipher_deinit fn_gnutls_cipher_deinit
546 # ifdef HAVE_GNUTLS_AEAD
547 # define gnutls_aead_cipher_encrypt fn_gnutls_aead_cipher_encrypt
548 # define gnutls_aead_cipher_decrypt fn_gnutls_aead_cipher_decrypt
549 # define gnutls_aead_cipher_init fn_gnutls_aead_cipher_init
550 # define gnutls_aead_cipher_deinit fn_gnutls_aead_cipher_deinit
551 # endif
552 # ifdef HAVE_GNUTLS_ETM_STATUS
553 # define gnutls_session_etm_status fn_gnutls_session_etm_status
554 # endif
555 # define gnutls_hmac_init fn_gnutls_hmac_init
556 # define gnutls_hmac_get_len fn_gnutls_hmac_get_len
557 # define gnutls_hmac fn_gnutls_hmac
558 # define gnutls_hmac_deinit fn_gnutls_hmac_deinit
559 # define gnutls_hmac_output fn_gnutls_hmac_output
560 # define gnutls_hash_init fn_gnutls_hash_init
561 # define gnutls_hash_get_len fn_gnutls_hash_get_len
562 # define gnutls_hash fn_gnutls_hash
563 # define gnutls_hash_deinit fn_gnutls_hash_deinit
564 # define gnutls_hash_output fn_gnutls_hash_output
565 # ifdef HAVE_GNUTLS_EXT_GET_NAME
566 # define gnutls_ext_get_name fn_gnutls_ext_get_name
567 # endif
568 # endif /* HAVE_GNUTLS3 */
569
570 /* gnutls_free_func is a data pointer to a variable which holds an
571 address of a function. We use #undef because MinGW64 defines
572 gnutls_free as a macro as well in the GnuTLS headers. */
573 # undef gnutls_free
574 # define gnutls_free (*gnutls_free_func)
575
576 /* This wrapper is called from fns.c, which doesn't know about the
577 LOAD_DLL_FN stuff above. */
578 int
w32_gnutls_rnd(gnutls_rnd_level_t level,void * data,size_t len)579 w32_gnutls_rnd (gnutls_rnd_level_t level, void *data, size_t len)
580 {
581 return gnutls_rnd (level, data, len);
582 }
583
584 # endif /* WINDOWSNT */
585
586
587 /* Report memory exhaustion if ERR is an out-of-memory indication. */
588 static void
check_memory_full(int err)589 check_memory_full (int err)
590 {
591 /* When GnuTLS exhausts memory, it doesn't say how much memory it
592 asked for, so tell the Emacs allocator that GnuTLS asked for no
593 bytes. This isn't accurate, but it's good enough. */
594 if (err == GNUTLS_E_MEMORY_ERROR)
595 memory_full (0);
596 }
597
598 # ifdef HAVE_GNUTLS3
599 /* Log a simple audit message. */
600 static void
gnutls_audit_log_function(gnutls_session_t session,const char * string)601 gnutls_audit_log_function (gnutls_session_t session, const char *string)
602 {
603 if (global_gnutls_log_level >= 1)
604 {
605 message ("gnutls.c: [audit] %s", string);
606 }
607 }
608 # endif
609
610 /* Log a simple message. */
611 static void
gnutls_log_function(int level,const char * string)612 gnutls_log_function (int level, const char *string)
613 {
614 message ("gnutls.c: [%d] %s", level, string);
615 }
616
617 /* Log a message and a string. */
618 static void
gnutls_log_function2(int level,const char * string,const char * extra)619 gnutls_log_function2 (int level, const char *string, const char *extra)
620 {
621 message ("gnutls.c: [%d] %s %s", level, string, extra);
622 }
623
624 int
gnutls_try_handshake(struct Lisp_Process * proc)625 gnutls_try_handshake (struct Lisp_Process *proc)
626 {
627 gnutls_session_t state = proc->gnutls_state;
628 int ret;
629 bool non_blocking = proc->is_non_blocking_client;
630
631 if (proc->gnutls_complete_negotiation_p)
632 non_blocking = false;
633
634 if (non_blocking)
635 proc->gnutls_p = true;
636
637 while ((ret = gnutls_handshake (state)) < 0)
638 {
639 do
640 ret = gnutls_handshake (state);
641 while (ret == GNUTLS_E_INTERRUPTED);
642
643 if (0 <= ret || emacs_gnutls_handle_error (state, ret) == 0
644 || non_blocking)
645 break;
646 maybe_quit ();
647 }
648
649 proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
650
651 if (ret == GNUTLS_E_SUCCESS)
652 {
653 /* Here we're finally done. */
654 proc->gnutls_initstage = GNUTLS_STAGE_READY;
655 }
656 else
657 {
658 /* check_memory_full (gnutls_alert_send_appropriate (state, ret)); */
659 }
660 return ret;
661 }
662
663 # ifndef WINDOWSNT
664 static int
emacs_gnutls_nonblock_errno(gnutls_transport_ptr_t ptr)665 emacs_gnutls_nonblock_errno (gnutls_transport_ptr_t ptr)
666 {
667 int err = errno;
668
669 switch (err)
670 {
671 # ifdef _AIX
672 /* This is taken from the GnuTLS system_errno function circa 2016;
673 see <https://savannah.gnu.org/support/?107464>. */
674 case 0:
675 errno = EAGAIN;
676 /* Fall through. */
677 # endif
678 case EINPROGRESS:
679 case ENOTCONN:
680 return EAGAIN;
681
682 default:
683 return err;
684 }
685 }
686 # endif /* !WINDOWSNT */
687
688 static int
emacs_gnutls_handshake(struct Lisp_Process * proc)689 emacs_gnutls_handshake (struct Lisp_Process *proc)
690 {
691 gnutls_session_t state = proc->gnutls_state;
692
693 if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
694 return -1;
695
696 if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
697 {
698 # ifdef WINDOWSNT
699 /* On W32 we cannot transfer socket handles between different runtime
700 libraries, so we tell GnuTLS to use our special push/pull
701 functions. */
702 gnutls_transport_set_ptr2 (state,
703 (gnutls_transport_ptr_t) proc,
704 (gnutls_transport_ptr_t) proc);
705 gnutls_transport_set_push_function (state, &emacs_gnutls_push);
706 gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
707 # else
708 /* This is how GnuTLS takes sockets: as file descriptors passed
709 in. For an Emacs process socket, infd and outfd are the
710 same but we use this two-argument version for clarity. */
711 gnutls_transport_set_ptr2 (state,
712 (void *) (intptr_t) proc->infd,
713 (void *) (intptr_t) proc->outfd);
714 if (proc->is_non_blocking_client)
715 gnutls_transport_set_errno_function (state,
716 emacs_gnutls_nonblock_errno);
717 # endif
718
719 proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
720 }
721
722 return gnutls_try_handshake (proc);
723 }
724
725 ptrdiff_t
emacs_gnutls_record_check_pending(gnutls_session_t state)726 emacs_gnutls_record_check_pending (gnutls_session_t state)
727 {
728 return gnutls_record_check_pending (state);
729 }
730
731 # ifdef WINDOWSNT
732 void
emacs_gnutls_transport_set_errno(gnutls_session_t state,int err)733 emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
734 {
735 gnutls_transport_set_errno (state, err);
736 }
737 # endif
738
739 ptrdiff_t
emacs_gnutls_write(struct Lisp_Process * proc,const char * buf,ptrdiff_t nbyte)740 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
741 {
742 gnutls_session_t state = proc->gnutls_state;
743
744 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
745 {
746 errno = EAGAIN;
747 return 0;
748 }
749
750 ptrdiff_t bytes_written = 0;
751
752 while (nbyte > 0)
753 {
754 ssize_t rtnval;
755 do
756 rtnval = gnutls_record_send (state, buf, nbyte);
757 while (rtnval == GNUTLS_E_INTERRUPTED);
758
759 if (rtnval < 0)
760 {
761 emacs_gnutls_handle_error (state, rtnval);
762 break;
763 }
764
765 buf += rtnval;
766 nbyte -= rtnval;
767 bytes_written += rtnval;
768 }
769
770 return (bytes_written);
771 }
772
773 ptrdiff_t
emacs_gnutls_read(struct Lisp_Process * proc,char * buf,ptrdiff_t nbyte)774 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
775 {
776 gnutls_session_t state = proc->gnutls_state;
777
778 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
779 {
780 errno = EAGAIN;
781 return -1;
782 }
783
784 ssize_t rtnval;
785 do
786 rtnval = gnutls_record_recv (state, buf, nbyte);
787 while (rtnval == GNUTLS_E_INTERRUPTED);
788
789 if (rtnval >= 0)
790 return rtnval;
791 else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
792 /* The peer closed the connection. */
793 return 0;
794 else
795 return emacs_gnutls_handle_error (state, rtnval);
796 }
797
798 static char const *
emacs_gnutls_strerror(int err)799 emacs_gnutls_strerror (int err)
800 {
801 char const *str = gnutls_strerror (err);
802 return str ? str : "unknown";
803 }
804
805 /* Report a GnuTLS error to the user.
806 SESSION is the GnuTLS session, ERR is the (negative) GnuTLS error code.
807 Return 0 if the error was fatal, -1 (setting errno) otherwise so
808 that the caller can notice the error and attempt a repair. */
809 static int
emacs_gnutls_handle_error(gnutls_session_t session,int err)810 emacs_gnutls_handle_error (gnutls_session_t session, int err)
811 {
812 int ret;
813
814 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
815
816 check_memory_full (err);
817
818 int max_log_level
819 = clip_to_bounds (INT_MIN, global_gnutls_log_level, INT_MAX);
820
821 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
822
823 char const *str = emacs_gnutls_strerror (err);
824 int errnum = EINVAL;
825
826 if (gnutls_error_is_fatal (err))
827 {
828 int level = 1;
829 /* Mostly ignore "The TLS connection was non-properly
830 terminated" message which just means that the peer closed the
831 connection. */
832 # ifdef HAVE_GNUTLS3
833 if (err == GNUTLS_E_PREMATURE_TERMINATION)
834 level = 3;
835 # endif
836
837 GNUTLS_LOG2 (level, max_log_level, "fatal error:", str);
838 ret = 0;
839 }
840 else
841 {
842 ret = -1;
843
844 switch (err)
845 {
846 case GNUTLS_E_AGAIN:
847 GNUTLS_LOG2 (3,
848 max_log_level,
849 "retry:",
850 str);
851 FALLTHROUGH;
852 default:
853 GNUTLS_LOG2 (1,
854 max_log_level,
855 "non-fatal error:",
856 str);
857 }
858
859 switch (err)
860 {
861 case GNUTLS_E_AGAIN:
862 errnum = EAGAIN;
863 break;
864
865 # ifdef EMSGSIZE
866 case GNUTLS_E_LARGE_PACKET:
867 case GNUTLS_E_PUSH_ERROR:
868 errnum = EMSGSIZE;
869 break;
870 # endif
871
872 # if defined HAVE_GNUTLS3 && defined ECONNRESET
873 case GNUTLS_E_PREMATURE_TERMINATION:
874 errnum = ECONNRESET;
875 break;
876 # endif
877 }
878 }
879
880 if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
881 || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
882 {
883 int alert = gnutls_alert_get (session);
884 int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
885 str = gnutls_alert_get_name (alert);
886 if (!str)
887 str = "unknown";
888
889 GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
890 }
891
892 errno = errnum;
893 return ret;
894 }
895
896 /* convert an integer error to a Lisp_Object; it will be either a
897 known symbol like 'gnutls_e_interrupted' and 'gnutls_e_again' or
898 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
899 to Qt. */
900 static Lisp_Object
gnutls_make_error(int err)901 gnutls_make_error (int err)
902 {
903 switch (err)
904 {
905 case GNUTLS_E_SUCCESS:
906 return Qt;
907 case GNUTLS_E_AGAIN:
908 return Qgnutls_e_again;
909 case GNUTLS_E_INTERRUPTED:
910 return Qgnutls_e_interrupted;
911 case GNUTLS_E_INVALID_SESSION:
912 return Qgnutls_e_invalid_session;
913 }
914
915 check_memory_full (err);
916 return make_fixnum (err);
917 }
918
919 static void
gnutls_deinit_certificates(struct Lisp_Process * p)920 gnutls_deinit_certificates (struct Lisp_Process *p)
921 {
922 if (! p->gnutls_certificates)
923 return;
924
925 for (int i = 0; i < p->gnutls_certificates_length; i++)
926 gnutls_x509_crt_deinit (p->gnutls_certificates[i]);
927
928 xfree (p->gnutls_certificates);
929 p->gnutls_certificates = NULL;
930 }
931
932 Lisp_Object
emacs_gnutls_deinit(Lisp_Object proc)933 emacs_gnutls_deinit (Lisp_Object proc)
934 {
935 int log_level;
936
937 CHECK_PROCESS (proc);
938
939 if (! XPROCESS (proc)->gnutls_p)
940 return Qnil;
941
942 log_level = XPROCESS (proc)->gnutls_log_level;
943
944 if (XPROCESS (proc)->gnutls_x509_cred)
945 {
946 GNUTLS_LOG (2, log_level, "Deallocating x509 credentials");
947 gnutls_certificate_free_credentials (XPROCESS (proc)->gnutls_x509_cred);
948 XPROCESS (proc)->gnutls_x509_cred = NULL;
949 }
950
951 if (XPROCESS (proc)->gnutls_anon_cred)
952 {
953 GNUTLS_LOG (2, log_level, "Deallocating anon credentials");
954 gnutls_anon_free_client_credentials (XPROCESS (proc)->gnutls_anon_cred);
955 XPROCESS (proc)->gnutls_anon_cred = NULL;
956 }
957
958 if (XPROCESS (proc)->gnutls_state)
959 {
960 gnutls_deinit (XPROCESS (proc)->gnutls_state);
961 XPROCESS (proc)->gnutls_state = NULL;
962 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
963 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
964 }
965
966 if (XPROCESS (proc)->gnutls_certificates)
967 gnutls_deinit_certificates (XPROCESS (proc));
968
969 XPROCESS (proc)->gnutls_p = false;
970 return Qt;
971 }
972
973 DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters,
974 Sgnutls_asynchronous_parameters, 2, 2, 0,
975 doc: /* Mark this process as being a pre-init GnuTLS process.
976 The second parameter is the list of parameters to feed to gnutls-boot
977 to finish setting up the connection. */)
978 (Lisp_Object proc, Lisp_Object params)
979 {
980 CHECK_PROCESS (proc);
981
982 XPROCESS (proc)->gnutls_boot_parameters = params;
983 return Qnil;
984 }
985
986 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
987 doc: /* Return the GnuTLS init stage of process PROC.
988 See also `gnutls-boot'. */)
989 (Lisp_Object proc)
990 {
991 CHECK_PROCESS (proc);
992
993 return make_fixnum (GNUTLS_INITSTAGE (proc));
994 }
995
996 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
997 doc: /* Return t if ERROR indicates a GnuTLS problem.
998 ERROR is an integer or a symbol with an integer `gnutls-code' property.
999 usage: (gnutls-errorp ERROR) */
1000 attributes: const)
1001 (Lisp_Object err)
1002 {
1003 if (EQ (err, Qt)
1004 || EQ (err, Qgnutls_e_again))
1005 return Qnil;
1006
1007 return Qt;
1008 }
1009
1010 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
1011 doc: /* Return non-nil if ERROR is fatal.
1012 ERROR is an integer or a symbol with an integer `gnutls-code' property.
1013 Usage: (gnutls-error-fatalp ERROR) */)
1014 (Lisp_Object err)
1015 {
1016 Lisp_Object code;
1017
1018 if (EQ (err, Qt)) return Qnil;
1019
1020 if (SYMBOLP (err))
1021 {
1022 code = Fget (err, Qgnutls_code);
1023 if (NUMBERP (code))
1024 {
1025 err = code;
1026 }
1027 else
1028 {
1029 error ("Symbol has no numeric gnutls-code property");
1030 }
1031 }
1032
1033 if (! TYPE_RANGED_FIXNUMP (int, err))
1034 error ("Not an error symbol or code");
1035
1036 if (0 == gnutls_error_is_fatal (XFIXNUM (err)))
1037 return Qnil;
1038
1039 return Qt;
1040 }
1041
1042 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
1043 doc: /* Return a description of ERROR.
1044 ERROR is an integer or a symbol with an integer `gnutls-code' property.
1045 usage: (gnutls-error-string ERROR) */)
1046 (Lisp_Object err)
1047 {
1048 Lisp_Object code;
1049
1050 if (EQ (err, Qt)) return build_string ("Not an error");
1051
1052 if (SYMBOLP (err))
1053 {
1054 code = Fget (err, Qgnutls_code);
1055 if (NUMBERP (code))
1056 {
1057 err = code;
1058 }
1059 else
1060 {
1061 return build_string ("Symbol has no numeric gnutls-code property");
1062 }
1063 }
1064
1065 if (! TYPE_RANGED_FIXNUMP (int, err))
1066 return build_string ("Not an error symbol or code");
1067
1068 return build_string (emacs_gnutls_strerror (XFIXNUM (err)));
1069 }
1070
1071 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
1072 doc: /* Deallocate GnuTLS resources associated with process PROC.
1073 See also `gnutls-init'. */)
1074 (Lisp_Object proc)
1075 {
1076 return emacs_gnutls_deinit (proc);
1077 }
1078
1079 static Lisp_Object
gnutls_hex_string(unsigned char * buf,ptrdiff_t buf_size,const char * prefix)1080 gnutls_hex_string (unsigned char *buf, ptrdiff_t buf_size, const char *prefix)
1081 {
1082 ptrdiff_t prefix_length = strlen (prefix);
1083 ptrdiff_t retlen;
1084 if (INT_MULTIPLY_WRAPV (buf_size, 3, &retlen)
1085 || INT_ADD_WRAPV (prefix_length - (buf_size != 0), retlen, &retlen))
1086 string_overflow ();
1087 Lisp_Object ret = make_uninit_string (retlen);
1088 char *string = SSDATA (ret);
1089 strcpy (string, prefix);
1090
1091 for (ptrdiff_t i = 0; i < buf_size; i++)
1092 sprintf (string + i * 3 + prefix_length,
1093 i == buf_size - 1 ? "%02x" : "%02x:",
1094 buf[i]);
1095
1096 return ret;
1097 }
1098
1099 static Lisp_Object
emacs_gnutls_certificate_export_pem(gnutls_x509_crt_t cert)1100 emacs_gnutls_certificate_export_pem (gnutls_x509_crt_t cert)
1101 {
1102 size_t size = 0;
1103 int err = gnutls_x509_crt_export (cert, GNUTLS_X509_FMT_PEM, NULL, &size);
1104 check_memory_full (err);
1105
1106 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
1107 {
1108 USE_SAFE_ALLOCA;
1109 char *buf = SAFE_ALLOCA (size);
1110 err = gnutls_x509_crt_export (cert, GNUTLS_X509_FMT_PEM, buf, &size);
1111 check_memory_full (err);
1112
1113 if (err < GNUTLS_E_SUCCESS)
1114 error ("GnuTLS certificate export error: %s",
1115 emacs_gnutls_strerror (err));
1116
1117 Lisp_Object result = build_string (buf);
1118 SAFE_FREE ();
1119 return result;
1120 }
1121 else if (err < GNUTLS_E_SUCCESS)
1122 error ("GnuTLS certificate export error: %s", emacs_gnutls_strerror (err));
1123
1124 return Qnil;
1125 }
1126
1127 static Lisp_Object
emacs_gnutls_certificate_details(gnutls_x509_crt_t cert)1128 emacs_gnutls_certificate_details (gnutls_x509_crt_t cert)
1129 {
1130 Lisp_Object res = Qnil;
1131 int err;
1132 size_t buf_size;
1133
1134 /* Version. */
1135 {
1136 int version = gnutls_x509_crt_get_version (cert);
1137 check_memory_full (version);
1138 if (version >= GNUTLS_E_SUCCESS)
1139 res = nconc2 (res, list2 (intern (":version"),
1140 make_fixnum (version)));
1141 }
1142
1143 /* Serial. */
1144 buf_size = 0;
1145 err = gnutls_x509_crt_get_serial (cert, NULL, &buf_size);
1146 check_memory_full (err);
1147 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
1148 {
1149 void *serial = xmalloc (buf_size);
1150 err = gnutls_x509_crt_get_serial (cert, serial, &buf_size);
1151 check_memory_full (err);
1152 if (err >= GNUTLS_E_SUCCESS)
1153 res = nconc2 (res, list2 (intern (":serial-number"),
1154 gnutls_hex_string (serial, buf_size, "")));
1155 xfree (serial);
1156 }
1157
1158 /* Issuer. */
1159 buf_size = 0;
1160 err = gnutls_x509_crt_get_issuer_dn (cert, NULL, &buf_size);
1161 check_memory_full (err);
1162 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
1163 {
1164 char *dn = xmalloc (buf_size);
1165 err = gnutls_x509_crt_get_issuer_dn (cert, dn, &buf_size);
1166 check_memory_full (err);
1167 if (err >= GNUTLS_E_SUCCESS)
1168 res = nconc2 (res, list2 (intern (":issuer"),
1169 make_string (dn, buf_size)));
1170 xfree (dn);
1171 }
1172
1173 /* Validity. */
1174 {
1175 /* Add 1 to the buffer size, since 1900 is added to tm_year and
1176 that might add 1 to the year length. */
1177 char buf[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
1178 struct tm t;
1179 time_t tim = gnutls_x509_crt_get_activation_time (cert);
1180
1181 if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t))
1182 res = nconc2 (res, list2 (intern (":valid-from"), build_string (buf)));
1183
1184 tim = gnutls_x509_crt_get_expiration_time (cert);
1185 if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t))
1186 res = nconc2 (res, list2 (intern (":valid-to"), build_string (buf)));
1187 }
1188
1189 /* Subject. */
1190 buf_size = 0;
1191 err = gnutls_x509_crt_get_dn (cert, NULL, &buf_size);
1192 check_memory_full (err);
1193 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
1194 {
1195 char *dn = xmalloc (buf_size);
1196 err = gnutls_x509_crt_get_dn (cert, dn, &buf_size);
1197 check_memory_full (err);
1198 if (err >= GNUTLS_E_SUCCESS)
1199 res = nconc2 (res, list2 (intern (":subject"),
1200 make_string (dn, buf_size)));
1201 xfree (dn);
1202 }
1203
1204 /* SubjectPublicKeyInfo. */
1205 {
1206 unsigned int bits;
1207
1208 err = gnutls_x509_crt_get_pk_algorithm (cert, &bits);
1209 check_memory_full (err);
1210 if (err >= GNUTLS_E_SUCCESS)
1211 {
1212 const char *name = gnutls_pk_algorithm_get_name (err);
1213 if (name)
1214 res = nconc2 (res, list2 (intern (":public-key-algorithm"),
1215 build_string (name)));
1216
1217 name = gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
1218 (err, bits));
1219 res = nconc2 (res, list2 (intern (":certificate-security-level"),
1220 build_string (name)));
1221 }
1222 }
1223
1224 /* Unique IDs. */
1225 buf_size = 0;
1226 err = gnutls_x509_crt_get_issuer_unique_id (cert, NULL, &buf_size);
1227 check_memory_full (err);
1228 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
1229 {
1230 char *buf = xmalloc (buf_size);
1231 err = gnutls_x509_crt_get_issuer_unique_id (cert, buf, &buf_size);
1232 check_memory_full (err);
1233 if (err >= GNUTLS_E_SUCCESS)
1234 res = nconc2 (res, list2 (intern (":issuer-unique-id"),
1235 make_string (buf, buf_size)));
1236 xfree (buf);
1237 }
1238
1239 buf_size = 0;
1240 err = gnutls_x509_crt_get_subject_unique_id (cert, NULL, &buf_size);
1241 check_memory_full (err);
1242 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
1243 {
1244 char *buf = xmalloc (buf_size);
1245 err = gnutls_x509_crt_get_subject_unique_id (cert, buf, &buf_size);
1246 check_memory_full (err);
1247 if (err >= GNUTLS_E_SUCCESS)
1248 res = nconc2 (res, list2 (intern (":subject-unique-id"),
1249 make_string (buf, buf_size)));
1250 xfree (buf);
1251 }
1252
1253 /* Signature. */
1254 err = gnutls_x509_crt_get_signature_algorithm (cert);
1255 check_memory_full (err);
1256 if (err >= GNUTLS_E_SUCCESS)
1257 {
1258 const char *name = gnutls_sign_get_name (err);
1259 if (name)
1260 res = nconc2 (res, list2 (intern (":signature-algorithm"),
1261 build_string (name)));
1262 }
1263
1264 /* Public key ID. */
1265 buf_size = 0;
1266 err = gnutls_x509_crt_get_key_id (cert, 0, NULL, &buf_size);
1267 check_memory_full (err);
1268 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
1269 {
1270 void *buf = xmalloc (buf_size);
1271 err = gnutls_x509_crt_get_key_id (cert, 0, buf, &buf_size);
1272 check_memory_full (err);
1273 if (err >= GNUTLS_E_SUCCESS)
1274 res = nconc2 (res, list2 (intern (":public-key-id"),
1275 gnutls_hex_string (buf, buf_size, "sha1:")));
1276 xfree (buf);
1277 }
1278
1279 /* Certificate fingerprint. */
1280 buf_size = 0;
1281 err = gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1,
1282 NULL, &buf_size);
1283 check_memory_full (err);
1284 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
1285 {
1286 void *buf = xmalloc (buf_size);
1287 err = gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1,
1288 buf, &buf_size);
1289 check_memory_full (err);
1290 if (err >= GNUTLS_E_SUCCESS)
1291 res = nconc2 (res, list2 (intern (":certificate-id"),
1292 gnutls_hex_string (buf, buf_size, "sha1:")));
1293 xfree (buf);
1294 }
1295
1296 /* PEM */
1297 res = nconc2 (res, list2 (intern (":pem"),
1298 emacs_gnutls_certificate_export_pem(cert)));
1299
1300 return res;
1301 }
1302
1303 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe, Sgnutls_peer_status_warning_describe, 1, 1, 0,
1304 doc: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
1305 (Lisp_Object status_symbol)
1306 {
1307 CHECK_SYMBOL (status_symbol);
1308
1309 if (EQ (status_symbol, intern (":invalid")))
1310 return build_string ("certificate could not be verified");
1311
1312 if (EQ (status_symbol, intern (":revoked")))
1313 return build_string ("certificate was revoked (CRL)");
1314
1315 if (EQ (status_symbol, intern (":self-signed")))
1316 return build_string ("certificate signer was not found (self-signed)");
1317
1318 if (EQ (status_symbol, intern (":unknown-ca")))
1319 return build_string ("the certificate was signed by an unknown "
1320 "and therefore untrusted authority");
1321
1322 if (EQ (status_symbol, intern (":not-ca")))
1323 return build_string ("certificate signer is not a CA");
1324
1325 if (EQ (status_symbol, intern (":insecure")))
1326 return build_string ("certificate was signed with an insecure algorithm");
1327
1328 if (EQ (status_symbol, intern (":not-activated")))
1329 return build_string ("certificate is not yet activated");
1330
1331 if (EQ (status_symbol, intern (":expired")))
1332 return build_string ("certificate has expired");
1333
1334 if (EQ (status_symbol, intern (":no-host-match")))
1335 return build_string ("certificate host does not match hostname");
1336
1337 if (EQ (status_symbol, intern (":signature-failure")))
1338 return build_string ("certificate signature could not be verified");
1339
1340 if (EQ (status_symbol, intern (":revocation-data-superseded")))
1341 return build_string ("certificate revocation data are old and have been "
1342 "superseded");
1343
1344 if (EQ (status_symbol, intern (":revocation-data-issued-in-future")))
1345 return build_string ("certificate revocation data have a future issue date");
1346
1347 if (EQ (status_symbol, intern (":signer-constraints-failure")))
1348 return build_string ("certificate signer constraints were violated");
1349
1350 if (EQ (status_symbol, intern (":purpose-mismatch")))
1351 return build_string ("certificate does not match the intended purpose");
1352
1353 if (EQ (status_symbol, intern (":missing-ocsp-status")))
1354 return build_string ("certificate requires the server to send a OCSP "
1355 "certificate status, but no status was received");
1356
1357 if (EQ (status_symbol, intern (":invalid-ocsp-status")))
1358 return build_string ("the received OCSP certificate status is invalid");
1359
1360 return Qnil;
1361 }
1362
1363 DEFUN ("gnutls-peer-status", Fgnutls_peer_status, Sgnutls_peer_status, 1, 1, 0,
1364 doc: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1365
1366 The return value is a property list with top-level keys :warnings and
1367 :certificates.
1368
1369 The :warnings entry is a list of symbols you can get a description of
1370 with `gnutls-peer-status-warning-describe', and :certificates is the
1371 certificate chain for the connection, with the host certificate
1372 first, and intermediary certificates (if any) following it.
1373
1374 In addition, for backwards compatibility, the host certificate is also
1375 returned as the :certificate entry. */)
1376 (Lisp_Object proc)
1377 {
1378 Lisp_Object warnings = Qnil, result = Qnil;
1379 unsigned int verification;
1380 gnutls_session_t state;
1381
1382 CHECK_PROCESS (proc);
1383
1384 if (GNUTLS_INITSTAGE (proc) != GNUTLS_STAGE_READY)
1385 return Qnil;
1386
1387 /* Then collect any warnings already computed by the handshake. */
1388 verification = XPROCESS (proc)->gnutls_peer_verification;
1389
1390 if (verification & GNUTLS_CERT_INVALID)
1391 warnings = Fcons (intern (":invalid"), warnings);
1392
1393 if (verification & GNUTLS_CERT_REVOKED)
1394 warnings = Fcons (intern (":revoked"), warnings);
1395
1396 if (verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
1397 warnings = Fcons (intern (":unknown-ca"), warnings);
1398
1399 if (verification & GNUTLS_CERT_SIGNER_NOT_CA)
1400 warnings = Fcons (intern (":not-ca"), warnings);
1401
1402 if (verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1403 warnings = Fcons (intern (":insecure"), warnings);
1404
1405 if (verification & GNUTLS_CERT_NOT_ACTIVATED)
1406 warnings = Fcons (intern (":not-activated"), warnings);
1407
1408 if (verification & GNUTLS_CERT_EXPIRED)
1409 warnings = Fcons (intern (":expired"), warnings);
1410
1411 # if GNUTLS_VERSION_NUMBER >= 0x030100
1412 if (verification & GNUTLS_CERT_SIGNATURE_FAILURE)
1413 warnings = Fcons (intern (":signature-failure"), warnings);
1414
1415 # if GNUTLS_VERSION_NUMBER >= 0x030114
1416 if (verification & GNUTLS_CERT_REVOCATION_DATA_SUPERSEDED)
1417 warnings = Fcons (intern (":revocation-data-superseded"), warnings);
1418
1419 if (verification & GNUTLS_CERT_REVOCATION_DATA_ISSUED_IN_FUTURE)
1420 warnings = Fcons (intern (":revocation-data-issued-in-future"), warnings);
1421
1422 if (verification & GNUTLS_CERT_SIGNER_CONSTRAINTS_FAILURE)
1423 warnings = Fcons (intern (":signer-constraints-failure"), warnings);
1424
1425 # if GNUTLS_VERSION_NUMBER >= 0x030400
1426 if (verification & GNUTLS_CERT_PURPOSE_MISMATCH)
1427 warnings = Fcons (intern (":purpose-mismatch"), warnings);
1428
1429 # if GNUTLS_VERSION_NUMBER >= 0x030501
1430 if (verification & GNUTLS_CERT_MISSING_OCSP_STATUS)
1431 warnings = Fcons (intern (":missing-ocsp-status"), warnings);
1432
1433 if (verification & GNUTLS_CERT_INVALID_OCSP_STATUS)
1434 warnings = Fcons (intern (":invalid-ocsp-status"), warnings);
1435 # endif
1436 # endif
1437 # endif
1438 # endif
1439
1440 if (XPROCESS (proc)->gnutls_extra_peer_verification &
1441 CERTIFICATE_NOT_MATCHING)
1442 warnings = Fcons (intern (":no-host-match"), warnings);
1443
1444 /* This could get called in the INIT stage, when the certificate is
1445 not yet set. */
1446 if (XPROCESS (proc)->gnutls_certificates != NULL &&
1447 gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificates[0],
1448 XPROCESS (proc)->gnutls_certificates[0]))
1449 warnings = Fcons (intern (":self-signed"), warnings);
1450
1451 if (!NILP (warnings))
1452 result = list2 (intern (":warnings"), warnings);
1453
1454 /* This could get called in the INIT stage, when the certificate is
1455 not yet set. */
1456 if (XPROCESS (proc)->gnutls_certificates != NULL)
1457 {
1458 Lisp_Object certs = Qnil;
1459
1460 /* Return all the certificates in a list. */
1461 for (int i = 0; i < XPROCESS (proc)->gnutls_certificates_length; i++)
1462 certs = nconc2 (certs, list1 (emacs_gnutls_certificate_details
1463 (XPROCESS (proc)->gnutls_certificates[i])));
1464
1465 result = nconc2 (result, list2 (intern (":certificates"), certs));
1466
1467 /* Return the host certificate in its own element for
1468 compatibility reasons. */
1469 result = nconc2 (result, list2 (intern (":certificate"), Fcar (certs)));
1470 }
1471
1472 state = XPROCESS (proc)->gnutls_state;
1473
1474 /* Diffie-Hellman prime bits. */
1475 {
1476 int bits = gnutls_dh_get_prime_bits (state);
1477 check_memory_full (bits);
1478 if (bits > 0)
1479 result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"),
1480 make_fixnum (bits)));
1481 }
1482
1483 /* Key exchange. */
1484 result = nconc2
1485 (result, list2 (intern (":key-exchange"),
1486 build_string (gnutls_kx_get_name
1487 (gnutls_kx_get (state)))));
1488
1489 /* Protocol name. */
1490 gnutls_protocol_t proto = gnutls_protocol_get_version (state);
1491 result = nconc2
1492 (result, list2 (intern (":protocol"),
1493 build_string (gnutls_protocol_get_name (proto))));
1494
1495 /* Cipher name. */
1496 result = nconc2
1497 (result, list2 (intern (":cipher"),
1498 build_string (gnutls_cipher_get_name
1499 (gnutls_cipher_get (state)))));
1500
1501 /* MAC name. */
1502 result = nconc2
1503 (result, list2 (intern (":mac"),
1504 build_string (gnutls_mac_get_name
1505 (gnutls_mac_get (state)))));
1506
1507 /* Compression name. */
1508 # ifdef HAVE_GNUTLS_COMPRESSION_GET
1509 result = nconc2
1510 (result, list2 (intern (":compression"),
1511 build_string (gnutls_compression_get_name
1512 (gnutls_compression_get (state)))));
1513 # endif
1514
1515 /* Encrypt-then-MAC. */
1516 # ifdef HAVE_GNUTLS_ETM_STATUS
1517 result = nconc2
1518 (result, list2 (intern (":encrypt-then-mac"),
1519 gnutls_session_etm_status (state) ? Qt : Qnil));
1520 # endif
1521
1522 /* Renegotiation Indication */
1523 if (proto <= GNUTLS_TLS1_2)
1524 result = nconc2
1525 (result, list2 (intern (":safe-renegotiation"),
1526 gnutls_safe_renegotiation_status (state) ? Qt : Qnil));
1527
1528 return result;
1529 }
1530
1531 /* Initialize global GnuTLS state to defaults.
1532 Call 'gnutls-global-deinit' when GnuTLS usage is no longer needed.
1533 Return zero on success. */
1534 Lisp_Object
emacs_gnutls_global_init(void)1535 emacs_gnutls_global_init (void)
1536 {
1537 int ret = GNUTLS_E_SUCCESS;
1538
1539 if (!gnutls_global_initialized)
1540 {
1541 ret = gnutls_global_init ();
1542 if (ret == GNUTLS_E_SUCCESS)
1543 gnutls_global_initialized = 1;
1544 }
1545
1546 return gnutls_make_error (ret);
1547 }
1548
1549 static bool
gnutls_ip_address_p(char * string)1550 gnutls_ip_address_p (char *string)
1551 {
1552 char c;
1553
1554 while ((c = *string++) != 0)
1555 if (! ((c == '.' || c == ':' || (c >= '0' && c <= '9'))))
1556 return false;
1557
1558 return true;
1559 }
1560
1561 # if 0
1562 /* Deinitialize global GnuTLS state.
1563 See also 'gnutls-global-init'. */
1564 static Lisp_Object
1565 emacs_gnutls_global_deinit (void)
1566 {
1567 if (gnutls_global_initialized)
1568 gnutls_global_deinit ();
1569
1570 gnutls_global_initialized = 0;
1571
1572 return gnutls_make_error (GNUTLS_E_SUCCESS);
1573 }
1574 # endif
1575
1576 static void ATTRIBUTE_FORMAT_PRINTF (2, 3)
boot_error(struct Lisp_Process * p,const char * m,...)1577 boot_error (struct Lisp_Process *p, const char *m, ...)
1578 {
1579 va_list ap;
1580 va_start (ap, m);
1581 if (p->is_non_blocking_client)
1582 pset_status (p, list2 (Qfailed, vformat_string (m, ap)));
1583 else
1584 verror (m, ap);
1585 va_end (ap);
1586 }
1587
1588 DEFUN ("gnutls-format-certificate", Fgnutls_format_certificate,
1589 Sgnutls_format_certificate, 1, 1, 0,
1590 doc: /* Format a X.509 certificate to a string.
1591
1592 Given a PEM-encoded X.509 certificate CERT, returns a human-readable
1593 string representation. */)
1594 (Lisp_Object cert)
1595 {
1596 CHECK_STRING (cert);
1597
1598 int err;
1599 gnutls_x509_crt_t crt;
1600
1601 err = gnutls_x509_crt_init (&crt);
1602 check_memory_full (err);
1603 if (err < GNUTLS_E_SUCCESS)
1604 error ("gnutls-format-certificate error: %s", emacs_gnutls_strerror (err));
1605
1606 gnutls_datum_t crt_data = { SDATA (cert), strlen (SSDATA (cert)) };
1607 err = gnutls_x509_crt_import (crt, &crt_data, GNUTLS_X509_FMT_PEM);
1608 check_memory_full (err);
1609 if (err < GNUTLS_E_SUCCESS)
1610 {
1611 gnutls_x509_crt_deinit (crt);
1612 error ("gnutls-format-certificate error: %s",
1613 emacs_gnutls_strerror (err));
1614 }
1615
1616 gnutls_datum_t out;
1617 err = gnutls_x509_crt_print (crt, GNUTLS_CRT_PRINT_FULL, &out);
1618 check_memory_full (err);
1619 if (err < GNUTLS_E_SUCCESS)
1620 {
1621 gnutls_x509_crt_deinit (crt);
1622 error ("gnutls-format-certificate error: %s",
1623 emacs_gnutls_strerror (err));
1624 }
1625
1626 Lisp_Object result = make_string_from_bytes ((char *) out.data, out.size,
1627 out.size);
1628 gnutls_free (out.data);
1629 gnutls_x509_crt_deinit (crt);
1630
1631 return result;
1632 }
1633
1634 Lisp_Object
gnutls_verify_boot(Lisp_Object proc,Lisp_Object proplist)1635 gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
1636 {
1637 int ret;
1638 struct Lisp_Process *p = XPROCESS (proc);
1639 gnutls_session_t state = p->gnutls_state;
1640 unsigned int peer_verification;
1641 Lisp_Object warnings;
1642 int max_log_level = p->gnutls_log_level;
1643 Lisp_Object hostname, verify_error;
1644 bool verify_error_all = false;
1645 char *c_hostname;
1646
1647 if (NILP (proplist))
1648 proplist = Fcdr (Fplist_get (p->childp, QCtls_parameters));
1649
1650 verify_error = Fplist_get (proplist, QCverify_error);
1651 hostname = Fplist_get (proplist, QChostname);
1652
1653 if (EQ (verify_error, Qt))
1654 verify_error_all = true;
1655 else if (NILP (Flistp (verify_error)))
1656 {
1657 boot_error (p,
1658 "gnutls-boot: invalid :verify_error parameter (not a list)");
1659 return Qnil;
1660 }
1661
1662 if (!STRINGP (hostname))
1663 {
1664 boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)");
1665 return Qnil;
1666 }
1667 c_hostname = SSDATA (hostname);
1668
1669 /* Now verify the peer, following
1670 https://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1671 The peer should present at least one certificate in the chain; do a
1672 check of the certificate's hostname with
1673 gnutls_x509_crt_check_hostname against :hostname. */
1674
1675 ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
1676 if (ret < GNUTLS_E_SUCCESS)
1677 return gnutls_make_error (ret);
1678
1679 p->gnutls_peer_verification = peer_verification;
1680
1681 warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
1682 if (!NILP (warnings))
1683 {
1684 for (Lisp_Object tail = warnings; CONSP (tail); tail = XCDR (tail))
1685 {
1686 Lisp_Object warning = XCAR (tail);
1687 Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
1688 if (!NILP (message))
1689 GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
1690 }
1691 }
1692
1693 if (peer_verification != 0)
1694 {
1695 if (verify_error_all
1696 || !NILP (Fmember (QCtrustfiles, verify_error)))
1697 {
1698 emacs_gnutls_deinit (proc);
1699 boot_error (p,
1700 "Certificate validation failed %s, verification code %x",
1701 c_hostname, peer_verification);
1702 return Qnil;
1703 }
1704 else
1705 {
1706 GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1707 c_hostname);
1708 }
1709 }
1710
1711 /* Up to here the process is the same for X.509 certificates and
1712 OpenPGP keys. From now on X.509 certificates are assumed. This
1713 can be easily extended to work with openpgp keys as well. */
1714 if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1715 {
1716 const gnutls_datum_t *cert_list;
1717 unsigned int cert_list_length;
1718 int failed_import = 0;
1719
1720 cert_list = gnutls_certificate_get_peers (state, &cert_list_length);
1721
1722 if (cert_list == NULL)
1723 {
1724 emacs_gnutls_deinit (proc);
1725 boot_error (p, "No x509 certificate was found\n");
1726 return Qnil;
1727 }
1728
1729 /* Check only the first certificate in the given chain, but
1730 store them all. */
1731 p->gnutls_certificates =
1732 xmalloc (cert_list_length * sizeof (gnutls_x509_crt_t));
1733 p->gnutls_certificates_length = cert_list_length;
1734
1735 for (int i = cert_list_length - 1; i >= 0; i--)
1736 {
1737 gnutls_x509_crt_t cert;
1738
1739 gnutls_x509_crt_init (&cert);
1740
1741 if (ret < GNUTLS_E_SUCCESS)
1742 failed_import = ret;
1743 else
1744 {
1745 ret = gnutls_x509_crt_import (cert, &cert_list[i],
1746 GNUTLS_X509_FMT_DER);
1747
1748 if (ret < GNUTLS_E_SUCCESS)
1749 failed_import = ret;
1750 }
1751
1752 p->gnutls_certificates[i] = cert;
1753 }
1754
1755 if (failed_import != 0)
1756 {
1757 gnutls_deinit_certificates (p);
1758 return gnutls_make_error (failed_import);
1759 }
1760
1761 int err = gnutls_x509_crt_check_hostname (p->gnutls_certificates[0],
1762 c_hostname);
1763 check_memory_full (err);
1764 if (!err)
1765 {
1766 p->gnutls_extra_peer_verification |= CERTIFICATE_NOT_MATCHING;
1767 if (verify_error_all
1768 || !NILP (Fmember (QChostname, verify_error)))
1769 {
1770 emacs_gnutls_deinit (proc);
1771 boot_error (p, "The x509 certificate does not match \"%s\"",
1772 c_hostname);
1773 return Qnil;
1774 }
1775 else
1776 GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1777 c_hostname);
1778 }
1779 }
1780
1781 /* Set this flag only if the whole initialization succeeded. */
1782 p->gnutls_p = true;
1783
1784 return gnutls_make_error (ret);
1785 }
1786
1787 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
1788 doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1789 Currently only client mode is supported. Return a success/failure
1790 value you can check with `gnutls-errorp'.
1791
1792 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1793 PROPLIST is a property list with the following keys:
1794
1795 :hostname is a string naming the remote host.
1796
1797 :priority is a GnuTLS priority string, defaults to "NORMAL".
1798
1799 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1800
1801 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1802
1803 :keylist is an alist of PEM-encoded key files and PEM-encoded
1804 certificates for `gnutls-x509pki'.
1805
1806 :callbacks is an alist of callback functions, see below.
1807
1808 :loglevel is the debug level requested from GnuTLS, try 4.
1809
1810 :verify-flags is a bitset as per GnuTLS'
1811 gnutls_certificate_set_verify_flags.
1812
1813 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1814 instead.
1815
1816 :verify-error is a list of symbols to express verification checks or
1817 t to do all checks. Currently it can contain `:trustfiles' and
1818 `:hostname' to verify the certificate or the hostname respectively.
1819
1820 :min-prime-bits is the minimum accepted number of bits the client will
1821 accept in Diffie-Hellman key exchange.
1822
1823 :complete-negotiation, if non-nil, will make negotiation complete
1824 before returning even on non-blocking sockets.
1825
1826 The debug level will be set for this process AND globally for GnuTLS.
1827 So if you set it higher or lower at any point, it affects global
1828 debugging.
1829
1830 Note that the priority is set on the client. The server does not use
1831 the protocols's priority except for disabling protocols that were not
1832 specified.
1833
1834 Processes must be initialized with this function before other GnuTLS
1835 functions are used. This function allocates resources which can only
1836 be deallocated by calling `gnutls-deinit' or by calling it again.
1837
1838 The callbacks alist can have a `verify' key, associated with a
1839 verification function (UNUSED).
1840
1841 Each authentication type may need additional information in order to
1842 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1843 one trustfile (usually a CA bundle). */)
1844 (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
1845 {
1846 int ret = GNUTLS_E_SUCCESS;
1847 int max_log_level = 0;
1848
1849 gnutls_session_t state;
1850 gnutls_certificate_credentials_t x509_cred = NULL;
1851 gnutls_anon_client_credentials_t anon_cred = NULL;
1852 Lisp_Object global_init;
1853 char const *priority_string_ptr = "NORMAL"; /* default priority string. */
1854 char *c_hostname;
1855
1856 /* Placeholders for the property list elements. */
1857 Lisp_Object priority_string;
1858 Lisp_Object trustfiles;
1859 Lisp_Object crlfiles;
1860 Lisp_Object keylist;
1861 /* Lisp_Object callbacks; */
1862 Lisp_Object loglevel;
1863 Lisp_Object hostname;
1864 Lisp_Object prime_bits;
1865 struct Lisp_Process *p = XPROCESS (proc);
1866
1867 CHECK_PROCESS (proc);
1868 CHECK_SYMBOL (type);
1869 CHECK_LIST (proplist);
1870
1871 if (NILP (Fgnutls_available_p ()))
1872 {
1873 boot_error (p, "GnuTLS not available");
1874 return Qnil;
1875 }
1876
1877 if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
1878 {
1879 boot_error (p, "Invalid GnuTLS credential type");
1880 return Qnil;
1881 }
1882
1883 hostname = Fplist_get (proplist, QChostname);
1884 priority_string = Fplist_get (proplist, QCpriority);
1885 trustfiles = Fplist_get (proplist, QCtrustfiles);
1886 keylist = Fplist_get (proplist, QCkeylist);
1887 crlfiles = Fplist_get (proplist, QCcrlfiles);
1888 loglevel = Fplist_get (proplist, QCloglevel);
1889 prime_bits = Fplist_get (proplist, QCmin_prime_bits);
1890
1891 if (!STRINGP (hostname))
1892 {
1893 boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)");
1894 return Qnil;
1895 }
1896 c_hostname = SSDATA (hostname);
1897
1898 state = XPROCESS (proc)->gnutls_state;
1899
1900 if (INTEGERP (loglevel))
1901 {
1902 gnutls_global_set_log_function (gnutls_log_function);
1903 # ifdef HAVE_GNUTLS3
1904 gnutls_global_set_audit_log_function (gnutls_audit_log_function);
1905 # endif
1906 int level = (FIXNUMP (loglevel)
1907 ? clip_to_bounds (INT_MIN, XFIXNUM (loglevel), INT_MAX)
1908 : NILP (Fnatnump (loglevel)) ? INT_MIN : INT_MAX);
1909 gnutls_global_set_log_level (level);
1910 max_log_level = level;
1911 XPROCESS (proc)->gnutls_log_level = max_log_level;
1912 }
1913
1914 GNUTLS_LOG2 (1, max_log_level, "connecting to host:", c_hostname);
1915
1916 /* Always initialize globals. */
1917 global_init = emacs_gnutls_global_init ();
1918 if (! NILP (Fgnutls_errorp (global_init)))
1919 return global_init;
1920
1921 /* Before allocating new credentials, deallocate any credentials
1922 that PROC might already have. */
1923 emacs_gnutls_deinit (proc);
1924
1925 /* Mark PROC as a GnuTLS process. */
1926 XPROCESS (proc)->gnutls_state = NULL;
1927 XPROCESS (proc)->gnutls_x509_cred = NULL;
1928 XPROCESS (proc)->gnutls_anon_cred = NULL;
1929 pset_gnutls_cred_type (XPROCESS (proc), type);
1930 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
1931
1932 GNUTLS_LOG (1, max_log_level, "allocating credentials");
1933 if (EQ (type, Qgnutls_x509pki))
1934 {
1935 Lisp_Object verify_flags;
1936 unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
1937
1938 GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
1939 check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred));
1940 XPROCESS (proc)->gnutls_x509_cred = x509_cred;
1941
1942 verify_flags = Fplist_get (proplist, QCverify_flags);
1943 if (TYPE_RANGED_FIXNUMP (unsigned int, verify_flags))
1944 {
1945 gnutls_verify_flags = XFIXNAT (verify_flags);
1946 GNUTLS_LOG (2, max_log_level, "setting verification flags");
1947 }
1948 else if (NILP (verify_flags))
1949 GNUTLS_LOG (2, max_log_level, "using default verification flags");
1950 else
1951 GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
1952
1953 gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
1954 }
1955 else /* Qgnutls_anon: */
1956 {
1957 GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
1958 check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred));
1959 XPROCESS (proc)->gnutls_anon_cred = anon_cred;
1960 }
1961
1962 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
1963
1964 if (EQ (type, Qgnutls_x509pki))
1965 {
1966 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1967 int file_format = GNUTLS_X509_FMT_PEM;
1968 Lisp_Object tail;
1969
1970 # ifdef HAVE_GNUTLS_X509_SYSTEM_TRUST
1971 ret = gnutls_certificate_set_x509_system_trust (x509_cred);
1972 if (ret < GNUTLS_E_SUCCESS)
1973 {
1974 check_memory_full (ret);
1975 GNUTLS_LOG2i (4, max_log_level,
1976 "setting system trust failed with code ", ret);
1977 }
1978 # endif
1979
1980 for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
1981 {
1982 Lisp_Object trustfile = XCAR (tail);
1983 if (STRINGP (trustfile))
1984 {
1985 GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
1986 SSDATA (trustfile));
1987 trustfile = ENCODE_FILE (trustfile);
1988 # ifdef WINDOWSNT
1989 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1990 file names on Windows, we need to re-encode the file
1991 name using the current ANSI codepage. */
1992 trustfile = ansi_encode_filename (trustfile);
1993 # endif
1994 ret = gnutls_certificate_set_x509_trust_file
1995 (x509_cred,
1996 SSDATA (trustfile),
1997 file_format);
1998
1999 if (ret < GNUTLS_E_SUCCESS)
2000 return gnutls_make_error (ret);
2001 }
2002 else
2003 {
2004 emacs_gnutls_deinit (proc);
2005 boot_error (p, "Invalid trustfile");
2006 return Qnil;
2007 }
2008 }
2009
2010 for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
2011 {
2012 Lisp_Object crlfile = XCAR (tail);
2013 if (STRINGP (crlfile))
2014 {
2015 GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
2016 SSDATA (crlfile));
2017 crlfile = ENCODE_FILE (crlfile);
2018 # ifdef WINDOWSNT
2019 crlfile = ansi_encode_filename (crlfile);
2020 # endif
2021 ret = gnutls_certificate_set_x509_crl_file
2022 (x509_cred, SSDATA (crlfile), file_format);
2023
2024 if (ret < GNUTLS_E_SUCCESS)
2025 return gnutls_make_error (ret);
2026 }
2027 else
2028 {
2029 emacs_gnutls_deinit (proc);
2030 boot_error (p, "Invalid CRL file");
2031 return Qnil;
2032 }
2033 }
2034
2035 for (tail = keylist; CONSP (tail); tail = XCDR (tail))
2036 {
2037 Lisp_Object keyfile = Fcar (XCAR (tail));
2038 Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
2039 if (STRINGP (keyfile) && STRINGP (certfile))
2040 {
2041 GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
2042 SSDATA (keyfile));
2043 GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
2044 SSDATA (certfile));
2045 keyfile = ENCODE_FILE (keyfile);
2046 certfile = ENCODE_FILE (certfile);
2047 # ifdef WINDOWSNT
2048 keyfile = ansi_encode_filename (keyfile);
2049 certfile = ansi_encode_filename (certfile);
2050 # endif
2051 ret = gnutls_certificate_set_x509_key_file
2052 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
2053
2054 if (ret < GNUTLS_E_SUCCESS)
2055 return gnutls_make_error (ret);
2056 }
2057 else
2058 {
2059 emacs_gnutls_deinit (proc);
2060 boot_error (p, STRINGP (keyfile) ? "Invalid client cert file"
2061 : "Invalid client key file");
2062 return Qnil;
2063 }
2064 }
2065 }
2066
2067 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
2068 GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
2069 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
2070
2071 /* Call gnutls_init here: */
2072
2073 GNUTLS_LOG (1, max_log_level, "gnutls_init");
2074 int gnutls_flags = GNUTLS_CLIENT;
2075 # ifdef GNUTLS_NONBLOCK
2076 if (XPROCESS (proc)->is_non_blocking_client)
2077 gnutls_flags |= GNUTLS_NONBLOCK;
2078 # endif
2079 ret = gnutls_init (&state, gnutls_flags);
2080 XPROCESS (proc)->gnutls_state = state;
2081 if (ret < GNUTLS_E_SUCCESS)
2082 return gnutls_make_error (ret);
2083 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
2084
2085 if (STRINGP (priority_string))
2086 {
2087 priority_string_ptr = SSDATA (priority_string);
2088 GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
2089 priority_string_ptr);
2090 }
2091 else
2092 {
2093 GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
2094 priority_string_ptr);
2095 }
2096
2097 GNUTLS_LOG (1, max_log_level, "setting the priority string");
2098 ret = gnutls_priority_set_direct (state, priority_string_ptr, NULL);
2099 if (ret < GNUTLS_E_SUCCESS)
2100 return gnutls_make_error (ret);
2101
2102 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
2103
2104 if (FIXNUMP (prime_bits))
2105 gnutls_dh_set_prime_bits (state, XUFIXNUM (prime_bits));
2106
2107 ret = EQ (type, Qgnutls_x509pki)
2108 ? gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
2109 : gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
2110 if (ret < GNUTLS_E_SUCCESS)
2111 return gnutls_make_error (ret);
2112
2113 if (!gnutls_ip_address_p (c_hostname))
2114 {
2115 ret = gnutls_server_name_set (state, GNUTLS_NAME_DNS, c_hostname,
2116 strlen (c_hostname));
2117 if (ret < GNUTLS_E_SUCCESS)
2118 return gnutls_make_error (ret);
2119 }
2120
2121 XPROCESS (proc)->gnutls_complete_negotiation_p =
2122 !NILP (Fplist_get (proplist, QCcomplete_negotiation));
2123 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
2124 ret = emacs_gnutls_handshake (XPROCESS (proc));
2125 if (ret < GNUTLS_E_SUCCESS)
2126 return gnutls_make_error (ret);
2127
2128 return gnutls_verify_boot (proc, proplist);
2129 }
2130
2131 DEFUN ("gnutls-bye", Fgnutls_bye,
2132 Sgnutls_bye, 2, 2, 0,
2133 doc: /* Terminate current GnuTLS connection for process PROC.
2134 The connection should have been initiated using `gnutls-handshake'.
2135
2136 If CONT is not nil the TLS connection gets terminated and further
2137 receives and sends will be disallowed. If the return value is zero you
2138 may continue using the connection. If CONT is nil, GnuTLS actually
2139 sends an alert containing a close request and waits for the peer to
2140 reply with the same message. In order to reuse the connection you
2141 should wait for an EOF from the peer.
2142
2143 This function may also return `gnutls-e-again', or
2144 `gnutls-e-interrupted'. */)
2145 (Lisp_Object proc, Lisp_Object cont)
2146 {
2147 gnutls_session_t state;
2148 int ret;
2149
2150 CHECK_PROCESS (proc);
2151
2152 state = XPROCESS (proc)->gnutls_state;
2153
2154 if (XPROCESS (proc)->gnutls_certificates)
2155 gnutls_deinit_certificates (XPROCESS (proc));
2156
2157 ret = gnutls_bye (state, NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
2158
2159 return gnutls_make_error (ret);
2160 }
2161
2162 #endif /* HAVE_GNUTLS */
2163
2164 #ifdef HAVE_GNUTLS3
2165
2166 # ifndef HAVE_GNUTLS_CIPHER_GET_IV_SIZE
2167 /* Block size is equivalent. */
2168 # define gnutls_cipher_get_iv_size(cipher) gnutls_cipher_get_block_size (cipher)
2169 # endif
2170
2171 # ifndef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
2172 /* Tag size is irrelevant. */
2173 # define gnutls_cipher_get_tag_size(cipher) 0
2174 # endif
2175
2176 # ifndef HAVE_GNUTLS_DIGEST_LIST
2177 /* The mac algorithms are equivalent. */
2178 # define gnutls_digest_list() \
2179 ((gnutls_digest_algorithm_t const *) gnutls_mac_list ())
2180 # define gnutls_digest_get_name(id) \
2181 gnutls_mac_get_name ((gnutls_mac_algorithm_t) (id))
2182 # endif
2183
2184 DEFUN ("gnutls-ciphers", Fgnutls_ciphers, Sgnutls_ciphers, 0, 0, 0,
2185 doc: /* Return alist of GnuTLS symmetric cipher descriptions as plists.
2186 The alist key is the cipher name. */)
2187 (void)
2188 {
2189 Lisp_Object ciphers = Qnil;
2190
2191 const gnutls_cipher_algorithm_t *gciphers = gnutls_cipher_list ();
2192 for (ptrdiff_t pos = 0; gciphers[pos] != 0; pos++)
2193 {
2194 gnutls_cipher_algorithm_t gca = gciphers[pos];
2195 if (gca == GNUTLS_CIPHER_NULL)
2196 continue;
2197 char const *cipher_name = gnutls_cipher_get_name (gca);
2198 if (!cipher_name)
2199 continue;
2200
2201 /* A symbol representing the GnuTLS cipher. */
2202 Lisp_Object cipher_symbol = intern (cipher_name);
2203
2204 ptrdiff_t cipher_tag_size = gnutls_cipher_get_tag_size (gca);
2205
2206 Lisp_Object cp
2207 = list (cipher_symbol,
2208 QCcipher_id, make_fixnum (gca),
2209 QCtype, Qgnutls_type_cipher,
2210 QCcipher_aead_capable, cipher_tag_size == 0 ? Qnil : Qt,
2211 QCcipher_tagsize, make_fixnum (cipher_tag_size),
2212
2213 QCcipher_blocksize,
2214 make_fixnum (gnutls_cipher_get_block_size (gca)),
2215
2216 QCcipher_keysize,
2217 make_fixnum (gnutls_cipher_get_key_size (gca)),
2218
2219 QCcipher_ivsize,
2220 make_fixnum (gnutls_cipher_get_iv_size (gca)));
2221
2222 ciphers = Fcons (cp, ciphers);
2223 }
2224
2225 return ciphers;
2226 }
2227
2228 static Lisp_Object
gnutls_symmetric_aead(bool encrypting,gnutls_cipher_algorithm_t gca,Lisp_Object cipher,const char * kdata,ptrdiff_t ksize,const char * vdata,ptrdiff_t vsize,const char * idata,ptrdiff_t isize,Lisp_Object aead_auth)2229 gnutls_symmetric_aead (bool encrypting, gnutls_cipher_algorithm_t gca,
2230 Lisp_Object cipher,
2231 const char *kdata, ptrdiff_t ksize,
2232 const char *vdata, ptrdiff_t vsize,
2233 const char *idata, ptrdiff_t isize,
2234 Lisp_Object aead_auth)
2235 {
2236 # ifdef HAVE_GNUTLS_AEAD
2237
2238 const char *desc = encrypting ? "encrypt" : "decrypt";
2239 Lisp_Object actual_iv = make_unibyte_string (vdata, vsize);
2240
2241 gnutls_aead_cipher_hd_t acipher;
2242 gnutls_datum_t key_datum = { (unsigned char *) kdata, ksize };
2243 int ret = gnutls_aead_cipher_init (&acipher, gca, &key_datum);
2244
2245 if (ret < GNUTLS_E_SUCCESS)
2246 error ("GnuTLS AEAD cipher %s/%s initialization failed: %s",
2247 gnutls_cipher_get_name (gca), desc, emacs_gnutls_strerror (ret));
2248
2249 ptrdiff_t cipher_tag_size = gnutls_cipher_get_tag_size (gca);
2250 ptrdiff_t tagged_size;
2251 if (INT_ADD_WRAPV (isize, cipher_tag_size, &tagged_size)
2252 || SIZE_MAX < tagged_size)
2253 memory_full (SIZE_MAX);
2254 size_t storage_length = tagged_size;
2255 USE_SAFE_ALLOCA;
2256 char *storage = SAFE_ALLOCA (storage_length);
2257
2258 const char *aead_auth_data = NULL;
2259 ptrdiff_t aead_auth_size = 0;
2260
2261 if (!NILP (aead_auth))
2262 {
2263 if (BUFFERP (aead_auth) || STRINGP (aead_auth))
2264 aead_auth = list1 (aead_auth);
2265
2266 CHECK_CONS (aead_auth);
2267
2268 ptrdiff_t astart_byte, aend_byte;
2269 const char *adata
2270 = extract_data_from_object (aead_auth, &astart_byte, &aend_byte);
2271 if (adata == NULL)
2272 error ("GnuTLS AEAD cipher auth extraction failed");
2273
2274 aead_auth_data = adata;
2275 aead_auth_size = aend_byte - astart_byte;
2276 }
2277
2278 ptrdiff_t expected_remainder = encrypting ? 0 : cipher_tag_size;
2279 ptrdiff_t cipher_block_size = gnutls_cipher_get_block_size (gca);
2280
2281 if (isize < expected_remainder
2282 || (isize - expected_remainder) % cipher_block_size != 0)
2283 error (("GnuTLS AEAD cipher %s/%s input block length %"pD"d "
2284 "is not %"pD"d greater than a multiple of the required %"pD"d"),
2285 gnutls_cipher_get_name (gca), desc,
2286 isize, expected_remainder, cipher_block_size);
2287
2288 ret = ((encrypting ? gnutls_aead_cipher_encrypt : gnutls_aead_cipher_decrypt)
2289 (acipher, vdata, vsize, aead_auth_data, aead_auth_size,
2290 cipher_tag_size, idata, isize, storage, &storage_length));
2291
2292 Lisp_Object output;
2293 if (GNUTLS_E_SUCCESS <= ret)
2294 output = make_unibyte_string (storage, storage_length);
2295 explicit_bzero (storage, storage_length);
2296 gnutls_aead_cipher_deinit (acipher);
2297
2298 if (ret < GNUTLS_E_SUCCESS)
2299 error ((encrypting
2300 ? "GnuTLS AEAD cipher %s encryption failed: %s"
2301 : "GnuTLS AEAD cipher %s decryption failed: %s"),
2302 gnutls_cipher_get_name (gca), emacs_gnutls_strerror (ret));
2303
2304 SAFE_FREE ();
2305 return list2 (output, actual_iv);
2306 # else
2307 intmax_t print_gca = gca;
2308 error ("GnuTLS AEAD cipher %"PRIdMAX" is invalid or not found", print_gca);
2309 # endif
2310 }
2311
2312 static Lisp_Object
gnutls_symmetric(bool encrypting,Lisp_Object cipher,Lisp_Object key,Lisp_Object iv,Lisp_Object input,Lisp_Object aead_auth)2313 gnutls_symmetric (bool encrypting, Lisp_Object cipher,
2314 Lisp_Object key, Lisp_Object iv,
2315 Lisp_Object input, Lisp_Object aead_auth)
2316 {
2317 if (BUFFERP (key) || STRINGP (key))
2318 key = list1 (key);
2319
2320 CHECK_CONS (key);
2321
2322 if (BUFFERP (input) || STRINGP (input))
2323 input = list1 (input);
2324
2325 CHECK_CONS (input);
2326
2327 if (BUFFERP (iv) || STRINGP (iv))
2328 iv = list1 (iv);
2329
2330 CHECK_CONS (iv);
2331
2332
2333 const char *desc = encrypting ? "encrypt" : "decrypt";
2334
2335 gnutls_cipher_algorithm_t gca = GNUTLS_CIPHER_UNKNOWN;
2336
2337 Lisp_Object info = Qnil;
2338 if (STRINGP (cipher))
2339 cipher = intern (SSDATA (cipher));
2340
2341 if (SYMBOLP (cipher))
2342 {
2343 info = Fassq (cipher, Fgnutls_ciphers ());
2344 if (!CONSP (info))
2345 xsignal2 (Qerror,
2346 build_string ("GnuTLS cipher is invalid or not found"),
2347 cipher);
2348 info = XCDR (info);
2349 }
2350 else if (TYPE_RANGED_FIXNUMP (gnutls_cipher_algorithm_t, cipher))
2351 gca = XFIXNUM (cipher);
2352 else
2353 info = cipher;
2354
2355 if (!NILP (info) && CONSP (info))
2356 {
2357 Lisp_Object v = Fplist_get (info, QCcipher_id);
2358 if (TYPE_RANGED_FIXNUMP (gnutls_cipher_algorithm_t, v))
2359 gca = XFIXNUM (v);
2360 }
2361
2362 ptrdiff_t key_size = gnutls_cipher_get_key_size (gca);
2363 if (key_size == 0)
2364 xsignal2 (Qerror,
2365 build_string ("GnuTLS cipher is invalid or not found"), cipher);
2366
2367 ptrdiff_t kstart_byte, kend_byte;
2368 const char *kdata = extract_data_from_object (key, &kstart_byte, &kend_byte);
2369
2370 if (kdata == NULL)
2371 error ("GnuTLS cipher key extraction failed");
2372
2373 if (kend_byte - kstart_byte != key_size)
2374 error (("GnuTLS cipher %s/%s key length %"pD"d is not equal to "
2375 "the required %"pD"d"),
2376 gnutls_cipher_get_name (gca), desc,
2377 kend_byte - kstart_byte, key_size);
2378
2379 ptrdiff_t vstart_byte, vend_byte;
2380 char *vdata = extract_data_from_object (iv, &vstart_byte, &vend_byte);
2381
2382 if (vdata == NULL)
2383 error ("GnuTLS cipher IV extraction failed");
2384
2385 ptrdiff_t iv_size = gnutls_cipher_get_iv_size (gca);
2386 if (vend_byte - vstart_byte != iv_size)
2387 error (("GnuTLS cipher %s/%s IV length %"pD"d is not equal to "
2388 "the required %"pD"d"),
2389 gnutls_cipher_get_name (gca), desc,
2390 vend_byte - vstart_byte, iv_size);
2391
2392 Lisp_Object actual_iv = make_unibyte_string (vdata, vend_byte - vstart_byte);
2393
2394 ptrdiff_t istart_byte, iend_byte;
2395 const char *idata
2396 = extract_data_from_object (input, &istart_byte, &iend_byte);
2397
2398 if (idata == NULL)
2399 error ("GnuTLS cipher input extraction failed");
2400
2401 /* Is this an AEAD cipher? */
2402 if (gnutls_cipher_get_tag_size (gca) > 0)
2403 {
2404 Lisp_Object aead_output =
2405 gnutls_symmetric_aead (encrypting, gca, cipher,
2406 kdata, kend_byte - kstart_byte,
2407 vdata, vend_byte - vstart_byte,
2408 idata, iend_byte - istart_byte,
2409 aead_auth);
2410 if (STRINGP (XCAR (key)))
2411 Fclear_string (XCAR (key));
2412 return aead_output;
2413 }
2414
2415 ptrdiff_t cipher_block_size = gnutls_cipher_get_block_size (gca);
2416 if ((iend_byte - istart_byte) % cipher_block_size != 0)
2417 error (("GnuTLS cipher %s/%s input block length %"pD"d is not a multiple "
2418 "of the required %"pD"d"),
2419 gnutls_cipher_get_name (gca), desc,
2420 iend_byte - istart_byte, cipher_block_size);
2421
2422 gnutls_cipher_hd_t hcipher;
2423 gnutls_datum_t key_datum
2424 = { (unsigned char *) kdata, kend_byte - kstart_byte };
2425
2426 int ret = gnutls_cipher_init (&hcipher, gca, &key_datum, NULL);
2427
2428 if (ret < GNUTLS_E_SUCCESS)
2429 error ("GnuTLS cipher %s/%s initialization failed: %s",
2430 gnutls_cipher_get_name (gca), desc, emacs_gnutls_strerror (ret));
2431
2432 /* Note that this will not support streaming block mode. */
2433 gnutls_cipher_set_iv (hcipher, vdata, vend_byte - vstart_byte);
2434
2435 /* GnuTLS docs: "For the supported ciphers the encrypted data length
2436 will equal the plaintext size." */
2437 ptrdiff_t storage_length = iend_byte - istart_byte;
2438 Lisp_Object storage = make_uninit_string (storage_length);
2439
2440 ret = ((encrypting ? gnutls_cipher_encrypt2 : gnutls_cipher_decrypt2)
2441 (hcipher, idata, iend_byte - istart_byte,
2442 SSDATA (storage), storage_length));
2443
2444 if (STRINGP (XCAR (key)))
2445 Fclear_string (XCAR (key));
2446
2447 if (ret < GNUTLS_E_SUCCESS)
2448 {
2449 gnutls_cipher_deinit (hcipher);
2450 if (encrypting)
2451 error ("GnuTLS cipher %s encryption failed: %s",
2452 gnutls_cipher_get_name (gca), emacs_gnutls_strerror (ret));
2453 else
2454 error ("GnuTLS cipher %s decryption failed: %s",
2455 gnutls_cipher_get_name (gca), emacs_gnutls_strerror (ret));
2456 }
2457
2458 gnutls_cipher_deinit (hcipher);
2459
2460 return list2 (storage, actual_iv);
2461 }
2462
2463 DEFUN ("gnutls-symmetric-encrypt", Fgnutls_symmetric_encrypt,
2464 Sgnutls_symmetric_encrypt, 4, 5, 0,
2465 doc: /* Encrypt INPUT with symmetric CIPHER, KEY+AEAD_AUTH, and IV to a unibyte string.
2466
2467 Return nil on error.
2468
2469 The KEY can be specified as a buffer or string or in other ways (see
2470 Info node `(elisp)Format of GnuTLS Cryptography Inputs'). The KEY
2471 will be wiped after use if it's a string.
2472
2473 The IV and INPUT and the optional AEAD_AUTH can also be specified as a
2474 buffer or string or in other ways.
2475
2476 The alist of symmetric ciphers can be obtained with `gnutls-ciphers'.
2477 The CIPHER may be a string or symbol matching a key in that alist, or
2478 a plist with the :cipher-id numeric property, or the number itself.
2479
2480 AEAD ciphers: these ciphers will have a `gnutls-ciphers' entry with
2481 :cipher-aead-capable set to t. AEAD_AUTH can be supplied for
2482 these AEAD ciphers, but it may still be omitted (nil) as well. */)
2483 (Lisp_Object cipher, Lisp_Object key, Lisp_Object iv,
2484 Lisp_Object input, Lisp_Object aead_auth)
2485 {
2486 return gnutls_symmetric (true, cipher, key, iv, input, aead_auth);
2487 }
2488
2489 DEFUN ("gnutls-symmetric-decrypt", Fgnutls_symmetric_decrypt,
2490 Sgnutls_symmetric_decrypt, 4, 5, 0,
2491 doc: /* Decrypt INPUT with symmetric CIPHER, KEY+AEAD_AUTH, and IV to a unibyte string.
2492
2493 Return nil on error.
2494
2495 The KEY can be specified as a buffer or string or in other ways (see
2496 Info node `(elisp)Format of GnuTLS Cryptography Inputs'). The KEY
2497 will be wiped after use if it's a string.
2498
2499 The IV and INPUT and the optional AEAD_AUTH can also be specified as a
2500 buffer or string or in other ways.
2501
2502 The alist of symmetric ciphers can be obtained with `gnutls-ciphers'.
2503 The CIPHER may be a string or symbol matching a key in that alist, or
2504 a plist with the `:cipher-id' numeric property, or the number itself.
2505
2506 AEAD ciphers: these ciphers will have a `gnutls-ciphers' entry with
2507 :cipher-aead-capable set to t. AEAD_AUTH can be supplied for
2508 these AEAD ciphers, but it may still be omitted (nil) as well. */)
2509 (Lisp_Object cipher, Lisp_Object key, Lisp_Object iv,
2510 Lisp_Object input, Lisp_Object aead_auth)
2511 {
2512 return gnutls_symmetric (false, cipher, key, iv, input, aead_auth);
2513 }
2514
2515 DEFUN ("gnutls-macs", Fgnutls_macs, Sgnutls_macs, 0, 0, 0,
2516 doc: /* Return alist of GnuTLS mac-algorithm method descriptions as plists.
2517
2518 Use the value of the alist (extract it with `alist-get' for instance)
2519 with `gnutls-hash-mac'. The alist key is the mac-algorithm method
2520 name. */)
2521 (void)
2522 {
2523 Lisp_Object mac_algorithms = Qnil;
2524 const gnutls_mac_algorithm_t *macs = gnutls_mac_list ();
2525 for (ptrdiff_t pos = 0; macs[pos] != 0; pos++)
2526 {
2527 const gnutls_mac_algorithm_t gma = macs[pos];
2528
2529 /* A symbol representing the GnuTLS MAC algorithm. */
2530 Lisp_Object gma_symbol = intern (gnutls_mac_get_name (gma));
2531
2532 size_t nonce_size = 0;
2533 # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE
2534 nonce_size = gnutls_mac_get_nonce_size (gma);
2535 # endif
2536 Lisp_Object mp = list (gma_symbol,
2537 QCmac_algorithm_id, make_fixnum (gma),
2538 QCtype, Qgnutls_type_mac_algorithm,
2539
2540 QCmac_algorithm_length,
2541 make_fixnum (gnutls_hmac_get_len (gma)),
2542
2543 QCmac_algorithm_keysize,
2544 make_fixnum (gnutls_mac_get_key_size (gma)),
2545
2546 QCmac_algorithm_noncesize,
2547 make_fixnum (nonce_size));
2548 mac_algorithms = Fcons (mp, mac_algorithms);
2549 }
2550
2551 return mac_algorithms;
2552 }
2553
2554 DEFUN ("gnutls-digests", Fgnutls_digests, Sgnutls_digests, 0, 0, 0,
2555 doc: /* Return alist of GnuTLS digest-algorithm method descriptions as plists.
2556
2557 Use the value of the alist (extract it with `alist-get' for instance)
2558 with `gnutls-hash-digest'. The alist key is the digest-algorithm
2559 method name. */)
2560 (void)
2561 {
2562 Lisp_Object digest_algorithms = Qnil;
2563 const gnutls_digest_algorithm_t *digests = gnutls_digest_list ();
2564 for (ptrdiff_t pos = 0; digests[pos] != 0; pos++)
2565 {
2566 const gnutls_digest_algorithm_t gda = digests[pos];
2567
2568 /* A symbol representing the GnuTLS digest algorithm. */
2569 Lisp_Object gda_symbol = intern (gnutls_digest_get_name (gda));
2570
2571 Lisp_Object mp = list (gda_symbol,
2572 QCdigest_algorithm_id, make_fixnum (gda),
2573 QCtype, Qgnutls_type_digest_algorithm,
2574
2575 QCdigest_algorithm_length,
2576 make_fixnum (gnutls_hash_get_len (gda)));
2577
2578 digest_algorithms = Fcons (mp, digest_algorithms);
2579 }
2580
2581 return digest_algorithms;
2582 }
2583
2584 DEFUN ("gnutls-hash-mac", Fgnutls_hash_mac, Sgnutls_hash_mac, 3, 3, 0,
2585 doc: /* Hash INPUT with HASH-METHOD and KEY into a unibyte string.
2586
2587 Return nil on error.
2588
2589 The KEY can be specified as a buffer or string or in other ways (see
2590 Info node `(elisp)Format of GnuTLS Cryptography Inputs'). The KEY
2591 will be wiped after use if it's a string.
2592
2593 The INPUT can also be specified as a buffer or string or in other
2594 ways.
2595
2596 The alist of MAC algorithms can be obtained with `gnutls-macs'. The
2597 HASH-METHOD may be a string or symbol matching a key in that alist, or
2598 a plist with the `:mac-algorithm-id' numeric property, or the number
2599 itself. */)
2600 (Lisp_Object hash_method, Lisp_Object key, Lisp_Object input)
2601 {
2602 if (BUFFERP (input) || STRINGP (input))
2603 input = list1 (input);
2604
2605 CHECK_CONS (input);
2606
2607 if (BUFFERP (key) || STRINGP (key))
2608 key = list1 (key);
2609
2610 CHECK_CONS (key);
2611
2612 gnutls_mac_algorithm_t gma = GNUTLS_MAC_UNKNOWN;
2613
2614 Lisp_Object info = Qnil;
2615 if (STRINGP (hash_method))
2616 hash_method = intern (SSDATA (hash_method));
2617
2618 if (SYMBOLP (hash_method))
2619 {
2620 info = Fassq (hash_method, Fgnutls_macs ());
2621 if (!CONSP (info))
2622 xsignal2 (Qerror,
2623 build_string ("GnuTLS MAC-method is invalid or not found"),
2624 hash_method);
2625 info = XCDR (info);
2626 }
2627 else if (TYPE_RANGED_FIXNUMP (gnutls_mac_algorithm_t, hash_method))
2628 gma = XFIXNUM (hash_method);
2629 else
2630 info = hash_method;
2631
2632 if (!NILP (info) && CONSP (info))
2633 {
2634 Lisp_Object v = Fplist_get (info, QCmac_algorithm_id);
2635 if (TYPE_RANGED_FIXNUMP (gnutls_mac_algorithm_t, v))
2636 gma = XFIXNUM (v);
2637 }
2638
2639 ptrdiff_t digest_length = gnutls_hmac_get_len (gma);
2640 if (digest_length == 0)
2641 xsignal2 (Qerror,
2642 build_string ("GnuTLS MAC-method is invalid or not found"),
2643 hash_method);
2644
2645 ptrdiff_t kstart_byte, kend_byte;
2646 const char *kdata = extract_data_from_object (key, &kstart_byte, &kend_byte);
2647 if (kdata == NULL)
2648 error ("GnuTLS MAC key extraction failed");
2649
2650 gnutls_hmac_hd_t hmac;
2651 int ret = gnutls_hmac_init (&hmac, gma,
2652 kdata + kstart_byte, kend_byte - kstart_byte);
2653 if (ret < GNUTLS_E_SUCCESS)
2654 error ("GnuTLS MAC %s initialization failed: %s",
2655 gnutls_mac_get_name (gma), emacs_gnutls_strerror (ret));
2656
2657 ptrdiff_t istart_byte, iend_byte;
2658 const char *idata
2659 = extract_data_from_object (input, &istart_byte, &iend_byte);
2660 if (idata == NULL)
2661 error ("GnuTLS MAC input extraction failed");
2662
2663 Lisp_Object digest = make_uninit_string (digest_length);
2664
2665 ret = gnutls_hmac (hmac, idata + istart_byte, iend_byte - istart_byte);
2666
2667 if (STRINGP (XCAR (key)))
2668 Fclear_string (XCAR (key));
2669
2670 if (ret < GNUTLS_E_SUCCESS)
2671 {
2672 gnutls_hmac_deinit (hmac, NULL);
2673 error ("GnuTLS MAC %s application failed: %s",
2674 gnutls_mac_get_name (gma), emacs_gnutls_strerror (ret));
2675 }
2676
2677 gnutls_hmac_output (hmac, SSDATA (digest));
2678 gnutls_hmac_deinit (hmac, NULL);
2679
2680 return digest;
2681 }
2682
2683 DEFUN ("gnutls-hash-digest", Fgnutls_hash_digest, Sgnutls_hash_digest, 2, 2, 0,
2684 doc: /* Digest INPUT with DIGEST-METHOD into a unibyte string.
2685
2686 Return nil on error.
2687
2688 The INPUT can be specified as a buffer or string or in other
2689 ways (see Info node `(elisp)Format of GnuTLS Cryptography Inputs').
2690
2691 The alist of digest algorithms can be obtained with `gnutls-digests'.
2692 The DIGEST-METHOD may be a string or symbol matching a key in that
2693 alist, or a plist with the `:digest-algorithm-id' numeric property, or
2694 the number itself. */)
2695 (Lisp_Object digest_method, Lisp_Object input)
2696 {
2697 if (BUFFERP (input) || STRINGP (input))
2698 input = list1 (input);
2699
2700 CHECK_CONS (input);
2701
2702 gnutls_digest_algorithm_t gda = GNUTLS_DIG_UNKNOWN;
2703
2704 Lisp_Object info = Qnil;
2705 if (STRINGP (digest_method))
2706 digest_method = intern (SSDATA (digest_method));
2707
2708 if (SYMBOLP (digest_method))
2709 {
2710 info = Fassq (digest_method, Fgnutls_digests ());
2711 if (!CONSP (info))
2712 xsignal2 (Qerror,
2713 build_string ("GnuTLS digest-method is invalid or not found"),
2714 digest_method);
2715 info = XCDR (info);
2716 }
2717 else if (TYPE_RANGED_FIXNUMP (gnutls_digest_algorithm_t, digest_method))
2718 gda = XFIXNUM (digest_method);
2719 else
2720 info = digest_method;
2721
2722 if (!NILP (info) && CONSP (info))
2723 {
2724 Lisp_Object v = Fplist_get (info, QCdigest_algorithm_id);
2725 if (TYPE_RANGED_FIXNUMP (gnutls_digest_algorithm_t, v))
2726 gda = XFIXNUM (v);
2727 }
2728
2729 ptrdiff_t digest_length = gnutls_hash_get_len (gda);
2730 if (digest_length == 0)
2731 xsignal2 (Qerror,
2732 build_string ("GnuTLS digest-method is invalid or not found"),
2733 digest_method);
2734
2735 gnutls_hash_hd_t hash;
2736 int ret = gnutls_hash_init (&hash, gda);
2737
2738 if (ret < GNUTLS_E_SUCCESS)
2739 error ("GnuTLS digest initialization failed: %s",
2740 emacs_gnutls_strerror (ret));
2741
2742 Lisp_Object digest = make_uninit_string (digest_length);
2743
2744 ptrdiff_t istart_byte, iend_byte;
2745 const char *idata
2746 = extract_data_from_object (input, &istart_byte, &iend_byte);
2747 if (idata == NULL)
2748 error ("GnuTLS digest input extraction failed");
2749
2750 ret = gnutls_hash (hash, idata + istart_byte, iend_byte - istart_byte);
2751
2752 if (ret < GNUTLS_E_SUCCESS)
2753 {
2754 gnutls_hash_deinit (hash, NULL);
2755 error ("GnuTLS digest application failed: %s",
2756 emacs_gnutls_strerror (ret));
2757 }
2758
2759 gnutls_hash_output (hash, SSDATA (digest));
2760 gnutls_hash_deinit (hash, NULL);
2761
2762 return digest;
2763 }
2764
2765 #endif /* HAVE_GNUTLS3 */
2766
2767 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
2768 doc: /* Return list of capabilities if GnuTLS is available in this instance of Emacs.
2769
2770 ...if supported : then...
2771 GnuTLS 3 or higher : the list will contain `gnutls3'.
2772 GnuTLS MACs : the list will contain `macs'.
2773 GnuTLS digests : the list will contain `digests'.
2774 GnuTLS symmetric ciphers: the list will contain `ciphers'.
2775 GnuTLS AEAD ciphers : the list will contain `AEAD-ciphers'.
2776 %DUMBFW : the list will contain `ClientHello\ Padding'.
2777 Any GnuTLS extension with ID up to 100
2778 : the list will contain its name. */)
2779 (void)
2780 {
2781 Lisp_Object capabilities = Qnil;
2782
2783 #ifdef HAVE_GNUTLS
2784
2785 # ifdef WINDOWSNT
2786 Lisp_Object found = Fassq (Qgnutls, Vlibrary_cache);
2787 if (CONSP (found))
2788 return XCDR (found);
2789
2790 /* Load the GnuTLS DLL and find exported functions. The external
2791 library cache is updated after the capabilities have been
2792 determined. */
2793 if (!init_gnutls_functions ())
2794 return Qnil;
2795 # endif /* WINDOWSNT */
2796
2797 capabilities = Fcons (intern("gnutls"), capabilities);
2798
2799 # ifdef HAVE_GNUTLS3
2800 capabilities = Fcons (intern("gnutls3"), capabilities);
2801 capabilities = Fcons (intern("digests"), capabilities);
2802 capabilities = Fcons (intern("ciphers"), capabilities);
2803
2804 # ifdef HAVE_GNUTLS_AEAD
2805 capabilities = Fcons (intern("AEAD-ciphers"), capabilities);
2806 # endif
2807
2808 capabilities = Fcons (intern("macs"), capabilities);
2809
2810 # ifdef HAVE_GNUTLS_EXT_GET_NAME
2811 for (unsigned int ext=0; ext < 100; ext++)
2812 {
2813 const char* name = gnutls_ext_get_name(ext);
2814 if (name != NULL)
2815 {
2816 capabilities = Fcons (intern(name), capabilities);
2817 }
2818 }
2819 # endif
2820 # endif /* HAVE_GNUTLS3 */
2821
2822 # ifdef HAVE_GNUTLS_EXT__DUMBFW
2823 capabilities = Fcons (intern("ClientHello Padding"), capabilities);
2824 # endif
2825
2826 # ifdef WINDOWSNT
2827 Vlibrary_cache = Fcons (Fcons (Qgnutls, capabilities), Vlibrary_cache);
2828 # endif /* WINDOWSNT */
2829 #endif /* HAVE_GNUTLS */
2830
2831 return capabilities;
2832 }
2833
2834 void
syms_of_gnutls(void)2835 syms_of_gnutls (void)
2836 {
2837 DEFVAR_LISP ("libgnutls-version", Vlibgnutls_version,
2838 doc: /* The version of libgnutls that Emacs was compiled with.
2839 The version number is encoded as an integer with the major version in
2840 the ten thousands place, minor version in the hundreds, and patch
2841 level in the ones. For builds without libgnutls, the value is -1. */);
2842 Vlibgnutls_version = make_fixnum
2843 #ifdef HAVE_GNUTLS
2844 (GNUTLS_VERSION_MAJOR * 10000
2845 + GNUTLS_VERSION_MINOR * 100
2846 + GNUTLS_VERSION_PATCH)
2847 #else
2848 (-1)
2849 #endif
2850 ;
2851
2852 #ifdef HAVE_GNUTLS
2853 gnutls_global_initialized = 0;
2854 PDUMPER_IGNORE (gnutls_global_initialized);
2855
2856 DEFSYM (Qgnutls_code, "gnutls-code");
2857 DEFSYM (Qgnutls_anon, "gnutls-anon");
2858 DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
2859
2860 /* The following are for the property list of 'gnutls-boot'. */
2861 DEFSYM (QChostname, ":hostname");
2862 DEFSYM (QCpriority, ":priority");
2863 DEFSYM (QCtrustfiles, ":trustfiles");
2864 DEFSYM (QCkeylist, ":keylist");
2865 DEFSYM (QCcrlfiles, ":crlfiles");
2866 DEFSYM (QCmin_prime_bits, ":min-prime-bits");
2867 DEFSYM (QCloglevel, ":loglevel");
2868 DEFSYM (QCcomplete_negotiation, ":complete-negotiation");
2869 DEFSYM (QCverify_flags, ":verify-flags");
2870 DEFSYM (QCverify_error, ":verify-error");
2871
2872 DEFSYM (QCcipher_id, ":cipher-id");
2873 DEFSYM (QCcipher_aead_capable, ":cipher-aead-capable");
2874 DEFSYM (QCcipher_blocksize, ":cipher-blocksize");
2875 DEFSYM (QCcipher_keysize, ":cipher-keysize");
2876 DEFSYM (QCcipher_tagsize, ":cipher-tagsize");
2877 DEFSYM (QCcipher_ivsize, ":cipher-ivsize");
2878
2879 DEFSYM (QCmac_algorithm_id, ":mac-algorithm-id");
2880 DEFSYM (QCmac_algorithm_noncesize, ":mac-algorithm-noncesize");
2881 DEFSYM (QCmac_algorithm_keysize, ":mac-algorithm-keysize");
2882 DEFSYM (QCmac_algorithm_length, ":mac-algorithm-length");
2883
2884 DEFSYM (QCdigest_algorithm_id, ":digest-algorithm-id");
2885 DEFSYM (QCdigest_algorithm_length, ":digest-algorithm-length");
2886
2887 DEFSYM (QCtype, ":type");
2888 DEFSYM (Qgnutls_type_cipher, "gnutls-symmetric-cipher");
2889 DEFSYM (Qgnutls_type_mac_algorithm, "gnutls-mac-algorithm");
2890 DEFSYM (Qgnutls_type_digest_algorithm, "gnutls-digest-algorithm");
2891
2892 DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
2893 Fput (Qgnutls_e_interrupted, Qgnutls_code,
2894 make_fixnum (GNUTLS_E_INTERRUPTED));
2895
2896 DEFSYM (Qgnutls_e_again, "gnutls-e-again");
2897 Fput (Qgnutls_e_again, Qgnutls_code,
2898 make_fixnum (GNUTLS_E_AGAIN));
2899
2900 DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
2901 Fput (Qgnutls_e_invalid_session, Qgnutls_code,
2902 make_fixnum (GNUTLS_E_INVALID_SESSION));
2903
2904 DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
2905 Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
2906 make_fixnum (GNUTLS_E_APPLICATION_ERROR_MIN));
2907
2908 defsubr (&Sgnutls_get_initstage);
2909 defsubr (&Sgnutls_asynchronous_parameters);
2910 defsubr (&Sgnutls_errorp);
2911 defsubr (&Sgnutls_error_fatalp);
2912 defsubr (&Sgnutls_error_string);
2913 defsubr (&Sgnutls_boot);
2914 defsubr (&Sgnutls_deinit);
2915 defsubr (&Sgnutls_bye);
2916 defsubr (&Sgnutls_peer_status);
2917 defsubr (&Sgnutls_peer_status_warning_describe);
2918 defsubr (&Sgnutls_format_certificate);
2919
2920 #ifdef HAVE_GNUTLS3
2921 defsubr (&Sgnutls_ciphers);
2922 defsubr (&Sgnutls_macs);
2923 defsubr (&Sgnutls_digests);
2924 defsubr (&Sgnutls_hash_mac);
2925 defsubr (&Sgnutls_hash_digest);
2926 defsubr (&Sgnutls_symmetric_encrypt);
2927 defsubr (&Sgnutls_symmetric_decrypt);
2928 #endif
2929
2930 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
2931 doc: /* Logging level used by the GnuTLS functions.
2932 Set this larger than 0 to get debug output in the *Messages* buffer.
2933 1 is for important messages, 2 is for debug data, and higher numbers
2934 are as per the GnuTLS logging conventions. */);
2935 global_gnutls_log_level = 0;
2936
2937 #endif /* HAVE_GNUTLS */
2938
2939 defsubr (&Sgnutls_available_p);
2940 }
2941