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