1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2017 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or (at
9 your option) any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
36 static bool emacs_gnutls_handle_error (gnutls_session_t
, int);
38 static bool gnutls_global_initialized
;
40 static void gnutls_log_function (int, const char *);
41 static void gnutls_log_function2 (int, const char *, const char *);
43 static void gnutls_audit_log_function (gnutls_session_t
, const char *);
46 enum extra_peer_verification
48 CERTIFICATE_NOT_MATCHING
= 2
54 DEF_DLL_FN (gnutls_alert_description_t
, gnutls_alert_get
,
56 DEF_DLL_FN (const char *, gnutls_alert_get_name
,
57 (gnutls_alert_description_t
));
58 DEF_DLL_FN (int, gnutls_anon_allocate_client_credentials
,
59 (gnutls_anon_client_credentials_t
*));
60 DEF_DLL_FN (void, gnutls_anon_free_client_credentials
,
61 (gnutls_anon_client_credentials_t
));
62 DEF_DLL_FN (int, gnutls_bye
, (gnutls_session_t
, gnutls_close_request_t
));
63 DEF_DLL_FN (int, gnutls_certificate_allocate_credentials
,
64 (gnutls_certificate_credentials_t
*));
65 DEF_DLL_FN (void, gnutls_certificate_free_credentials
,
66 (gnutls_certificate_credentials_t
));
67 DEF_DLL_FN (const gnutls_datum_t
*, gnutls_certificate_get_peers
,
68 (gnutls_session_t
, unsigned int *));
69 DEF_DLL_FN (void, gnutls_certificate_set_verify_flags
,
70 (gnutls_certificate_credentials_t
, unsigned int));
71 DEF_DLL_FN (int, gnutls_certificate_set_x509_crl_file
,
72 (gnutls_certificate_credentials_t
, const char *,
73 gnutls_x509_crt_fmt_t
));
74 DEF_DLL_FN (int, gnutls_certificate_set_x509_key_file
,
75 (gnutls_certificate_credentials_t
, const char *, const char *,
76 gnutls_x509_crt_fmt_t
));
77 # if ((GNUTLS_VERSION_MAJOR \
78 + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20)) \
80 DEF_DLL_FN (int, gnutls_certificate_set_x509_system_trust
,
81 (gnutls_certificate_credentials_t
));
83 DEF_DLL_FN (int, gnutls_certificate_set_x509_trust_file
,
84 (gnutls_certificate_credentials_t
, const char *,
85 gnutls_x509_crt_fmt_t
));
86 DEF_DLL_FN (gnutls_certificate_type_t
, gnutls_certificate_type_get
,
88 DEF_DLL_FN (int, gnutls_certificate_verify_peers2
,
89 (gnutls_session_t
, unsigned int *));
90 DEF_DLL_FN (int, gnutls_credentials_set
,
91 (gnutls_session_t
, gnutls_credentials_type_t
, void *));
92 DEF_DLL_FN (void, gnutls_deinit
, (gnutls_session_t
));
93 DEF_DLL_FN (void, gnutls_dh_set_prime_bits
,
94 (gnutls_session_t
, unsigned int));
95 DEF_DLL_FN (int, gnutls_dh_get_prime_bits
, (gnutls_session_t
));
96 DEF_DLL_FN (int, gnutls_error_is_fatal
, (int));
97 DEF_DLL_FN (int, gnutls_global_init
, (void));
98 DEF_DLL_FN (void, gnutls_global_set_log_function
, (gnutls_log_func
));
100 DEF_DLL_FN (void, gnutls_global_set_audit_log_function
, (gnutls_audit_log_func
));
102 DEF_DLL_FN (void, gnutls_global_set_log_level
, (int));
103 DEF_DLL_FN (int, gnutls_handshake
, (gnutls_session_t
));
104 DEF_DLL_FN (int, gnutls_init
, (gnutls_session_t
*, unsigned int));
105 DEF_DLL_FN (int, gnutls_priority_set_direct
,
106 (gnutls_session_t
, const char *, const char **));
107 DEF_DLL_FN (size_t, gnutls_record_check_pending
, (gnutls_session_t
));
108 DEF_DLL_FN (ssize_t
, gnutls_record_recv
, (gnutls_session_t
, void *, size_t));
109 DEF_DLL_FN (ssize_t
, gnutls_record_send
,
110 (gnutls_session_t
, const void *, size_t));
111 DEF_DLL_FN (const char *, gnutls_strerror
, (int));
112 DEF_DLL_FN (void, gnutls_transport_set_errno
, (gnutls_session_t
, int));
113 DEF_DLL_FN (void, gnutls_transport_set_ptr2
,
114 (gnutls_session_t
, gnutls_transport_ptr_t
,
115 gnutls_transport_ptr_t
));
116 DEF_DLL_FN (void, gnutls_transport_set_pull_function
,
117 (gnutls_session_t
, gnutls_pull_func
));
118 DEF_DLL_FN (void, gnutls_transport_set_push_function
,
119 (gnutls_session_t
, gnutls_push_func
));
120 DEF_DLL_FN (int, gnutls_x509_crt_check_hostname
,
121 (gnutls_x509_crt_t
, const char *));
122 DEF_DLL_FN (int, gnutls_x509_crt_check_issuer
,
123 (gnutls_x509_crt_t
, gnutls_x509_crt_t
));
124 DEF_DLL_FN (void, gnutls_x509_crt_deinit
, (gnutls_x509_crt_t
));
125 DEF_DLL_FN (int, gnutls_x509_crt_import
,
126 (gnutls_x509_crt_t
, const gnutls_datum_t
*,
127 gnutls_x509_crt_fmt_t
));
128 DEF_DLL_FN (int, gnutls_x509_crt_init
, (gnutls_x509_crt_t
*));
129 DEF_DLL_FN (int, gnutls_x509_crt_get_fingerprint
,
131 gnutls_digest_algorithm_t
, void *, size_t *));
132 DEF_DLL_FN (int, gnutls_x509_crt_get_version
,
133 (gnutls_x509_crt_t
));
134 DEF_DLL_FN (int, gnutls_x509_crt_get_serial
,
135 (gnutls_x509_crt_t
, void *, size_t *));
136 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_dn
,
137 (gnutls_x509_crt_t
, char *, size_t *));
138 DEF_DLL_FN (time_t, gnutls_x509_crt_get_activation_time
,
139 (gnutls_x509_crt_t
));
140 DEF_DLL_FN (time_t, gnutls_x509_crt_get_expiration_time
,
141 (gnutls_x509_crt_t
));
142 DEF_DLL_FN (int, gnutls_x509_crt_get_dn
,
143 (gnutls_x509_crt_t
, char *, size_t *));
144 DEF_DLL_FN (int, gnutls_x509_crt_get_pk_algorithm
,
145 (gnutls_x509_crt_t
, unsigned int *));
146 DEF_DLL_FN (const char *, gnutls_pk_algorithm_get_name
,
147 (gnutls_pk_algorithm_t
));
148 DEF_DLL_FN (int, gnutls_pk_bits_to_sec_param
,
149 (gnutls_pk_algorithm_t
, unsigned int));
150 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_unique_id
,
151 (gnutls_x509_crt_t
, char *, size_t *));
152 DEF_DLL_FN (int, gnutls_x509_crt_get_subject_unique_id
,
153 (gnutls_x509_crt_t
, char *, size_t *));
154 DEF_DLL_FN (int, gnutls_x509_crt_get_signature_algorithm
,
155 (gnutls_x509_crt_t
));
156 DEF_DLL_FN (int, gnutls_x509_crt_get_key_id
,
157 (gnutls_x509_crt_t
, unsigned int, unsigned char *, size_t *_size
));
158 DEF_DLL_FN (const char *, gnutls_sec_param_get_name
, (gnutls_sec_param_t
));
159 DEF_DLL_FN (const char *, gnutls_sign_get_name
, (gnutls_sign_algorithm_t
));
160 DEF_DLL_FN (int, gnutls_server_name_set
,
161 (gnutls_session_t
, gnutls_server_name_type_t
,
162 const void *, size_t));
163 DEF_DLL_FN (gnutls_kx_algorithm_t
, gnutls_kx_get
, (gnutls_session_t
));
164 DEF_DLL_FN (const char *, gnutls_kx_get_name
, (gnutls_kx_algorithm_t
));
165 DEF_DLL_FN (gnutls_protocol_t
, gnutls_protocol_get_version
,
167 DEF_DLL_FN (const char *, gnutls_protocol_get_name
, (gnutls_protocol_t
));
168 DEF_DLL_FN (gnutls_cipher_algorithm_t
, gnutls_cipher_get
,
170 DEF_DLL_FN (const char *, gnutls_cipher_get_name
,
171 (gnutls_cipher_algorithm_t
));
172 DEF_DLL_FN (gnutls_mac_algorithm_t
, gnutls_mac_get
, (gnutls_session_t
));
173 DEF_DLL_FN (const char *, gnutls_mac_get_name
, (gnutls_mac_algorithm_t
));
176 DEF_DLL_FN (int, gnutls_rnd
, (gnutls_rnd_level_t
, void *, size_t));
177 DEF_DLL_FN (const gnutls_mac_algorithm_t
*, gnutls_mac_list
, (void));
178 DEF_DLL_FN (size_t, gnutls_mac_get_nonce_size
, (gnutls_mac_algorithm_t
));
179 DEF_DLL_FN (size_t, gnutls_mac_get_key_size
, (gnutls_mac_algorithm_t
));
180 DEF_DLL_FN (const gnutls_digest_algorithm_t
*, gnutls_digest_list
, (void));
181 DEF_DLL_FN (const char *, gnutls_digest_get_name
, (gnutls_digest_algorithm_t
));
182 # ifdef HAVE_GNUTLS3_CIPHER
183 DEF_DLL_FN (gnutls_cipher_algorithm_t
*, gnutls_cipher_list
, (void));
184 DEF_DLL_FN (int, gnutls_cipher_get_iv_size
, (gnutls_cipher_algorithm_t
));
185 DEF_DLL_FN (size_t, gnutls_cipher_get_key_size
, (gnutls_cipher_algorithm_t
));
186 DEF_DLL_FN (int, gnutls_cipher_get_block_size
, (gnutls_cipher_algorithm_t
));
187 DEF_DLL_FN (int, gnutls_cipher_get_tag_size
, (gnutls_cipher_algorithm_t
));
188 DEF_DLL_FN (int, gnutls_cipher_init
,
189 (gnutls_cipher_hd_t
*, gnutls_cipher_algorithm_t
,
190 const gnutls_datum_t
*, const gnutls_datum_t
*));
191 DEF_DLL_FN (void, gnutls_cipher_set_iv
, (gnutls_cipher_hd_t
, void *, size_t));
192 DEF_DLL_FN (int, gnutls_cipher_encrypt2
,
193 (gnutls_cipher_hd_t
, const void *, size_t, void *, size_t));
194 DEF_DLL_FN (void, gnutls_cipher_deinit
, (gnutls_cipher_hd_t
));
195 DEF_DLL_FN (int, gnutls_cipher_decrypt2
,
196 (gnutls_cipher_hd_t
, const void *, size_t, void *, size_t));
197 # ifdef HAVE_GNUTLS3_AEAD
198 DEF_DLL_FN (int, gnutls_aead_cipher_init
,
199 (gnutls_aead_cipher_hd_t
*, gnutls_cipher_algorithm_t
,
200 const gnutls_datum_t
*));
201 DEF_DLL_FN (void, gnutls_aead_cipher_deinit
, (gnutls_aead_cipher_hd_t
));
202 DEF_DLL_FN (int, gnutls_aead_cipher_encrypt
,
203 (gnutls_aead_cipher_hd_t
, const void *, size_t, const void *,
204 size_t, size_t, const void *, size_t, void *, size_t *));
205 DEF_DLL_FN (int, gnutls_aead_cipher_decrypt
,
206 (gnutls_aead_cipher_hd_t
, const void *, size_t, const void *,
207 size_t, size_t, const void *, size_t, void *, size_t *));
208 # endif /* HAVE_GNUTLS3_AEAD */
209 # ifdef HAVE_GNUTLS3_HMAC
210 DEF_DLL_FN (int, gnutls_hmac_init
,
211 (gnutls_hmac_hd_t
*, gnutls_mac_algorithm_t
, const void *, size_t));
212 DEF_DLL_FN (int, gnutls_hmac_get_len
, (gnutls_mac_algorithm_t
));
213 DEF_DLL_FN (int, gnutls_hmac
, (gnutls_hmac_hd_t
, const void *, size_t));
214 DEF_DLL_FN (void, gnutls_hmac_deinit
, (gnutls_hmac_hd_t
, void *));
215 DEF_DLL_FN (void, gnutls_hmac_output
, (gnutls_hmac_hd_t
, void *));
216 # endif /* HAVE_GNUTLS3_HMAC */
217 # endif /* HAVE_GNUTLS3_CIPHER */
218 # ifdef HAVE_GNUTLS3_DIGEST
219 DEF_DLL_FN (int, gnutls_hash_init
,
220 (gnutls_hash_hd_t
*, gnutls_digest_algorithm_t
));
221 DEF_DLL_FN (int, gnutls_hash_get_len
, (gnutls_digest_algorithm_t
));
222 DEF_DLL_FN (int, gnutls_hash
, (gnutls_hash_hd_t
, const void *, size_t));
223 DEF_DLL_FN (void, gnutls_hash_deinit
, (gnutls_hash_hd_t
, void *));
224 DEF_DLL_FN (void, gnutls_hash_output
, (gnutls_hash_hd_t
, void *));
225 # endif /* HAVE_GNUTLS3_DIGEST */
226 # endif /* HAVE_GNUTLS3 */
230 init_gnutls_functions (void)
233 int max_log_level
= 1;
235 if (!(library
= w32_delayed_load (Qgnutls
)))
237 GNUTLS_LOG (1, max_log_level
, "GnuTLS library not found");
241 LOAD_DLL_FN (library
, gnutls_alert_get
);
242 LOAD_DLL_FN (library
, gnutls_alert_get_name
);
243 LOAD_DLL_FN (library
, gnutls_anon_allocate_client_credentials
);
244 LOAD_DLL_FN (library
, gnutls_anon_free_client_credentials
);
245 LOAD_DLL_FN (library
, gnutls_bye
);
246 LOAD_DLL_FN (library
, gnutls_certificate_allocate_credentials
);
247 LOAD_DLL_FN (library
, gnutls_certificate_free_credentials
);
248 LOAD_DLL_FN (library
, gnutls_certificate_get_peers
);
249 LOAD_DLL_FN (library
, gnutls_certificate_set_verify_flags
);
250 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_crl_file
);
251 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_key_file
);
252 # if ((GNUTLS_VERSION_MAJOR \
253 + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20)) \
255 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_system_trust
);
257 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_trust_file
);
258 LOAD_DLL_FN (library
, gnutls_certificate_type_get
);
259 LOAD_DLL_FN (library
, gnutls_certificate_verify_peers2
);
260 LOAD_DLL_FN (library
, gnutls_credentials_set
);
261 LOAD_DLL_FN (library
, gnutls_deinit
);
262 LOAD_DLL_FN (library
, gnutls_dh_set_prime_bits
);
263 LOAD_DLL_FN (library
, gnutls_dh_get_prime_bits
);
264 LOAD_DLL_FN (library
, gnutls_error_is_fatal
);
265 LOAD_DLL_FN (library
, gnutls_global_init
);
266 LOAD_DLL_FN (library
, gnutls_global_set_log_function
);
268 LOAD_DLL_FN (library
, gnutls_global_set_audit_log_function
);
270 LOAD_DLL_FN (library
, gnutls_global_set_log_level
);
271 LOAD_DLL_FN (library
, gnutls_handshake
);
272 LOAD_DLL_FN (library
, gnutls_init
);
273 LOAD_DLL_FN (library
, gnutls_priority_set_direct
);
274 LOAD_DLL_FN (library
, gnutls_record_check_pending
);
275 LOAD_DLL_FN (library
, gnutls_record_recv
);
276 LOAD_DLL_FN (library
, gnutls_record_send
);
277 LOAD_DLL_FN (library
, gnutls_strerror
);
278 LOAD_DLL_FN (library
, gnutls_transport_set_errno
);
279 LOAD_DLL_FN (library
, gnutls_transport_set_ptr2
);
280 LOAD_DLL_FN (library
, gnutls_transport_set_pull_function
);
281 LOAD_DLL_FN (library
, gnutls_transport_set_push_function
);
282 LOAD_DLL_FN (library
, gnutls_x509_crt_check_hostname
);
283 LOAD_DLL_FN (library
, gnutls_x509_crt_check_issuer
);
284 LOAD_DLL_FN (library
, gnutls_x509_crt_deinit
);
285 LOAD_DLL_FN (library
, gnutls_x509_crt_import
);
286 LOAD_DLL_FN (library
, gnutls_x509_crt_init
);
287 LOAD_DLL_FN (library
, gnutls_x509_crt_get_fingerprint
);
288 LOAD_DLL_FN (library
, gnutls_x509_crt_get_version
);
289 LOAD_DLL_FN (library
, gnutls_x509_crt_get_serial
);
290 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_dn
);
291 LOAD_DLL_FN (library
, gnutls_x509_crt_get_activation_time
);
292 LOAD_DLL_FN (library
, gnutls_x509_crt_get_expiration_time
);
293 LOAD_DLL_FN (library
, gnutls_x509_crt_get_dn
);
294 LOAD_DLL_FN (library
, gnutls_x509_crt_get_pk_algorithm
);
295 LOAD_DLL_FN (library
, gnutls_pk_algorithm_get_name
);
296 LOAD_DLL_FN (library
, gnutls_pk_bits_to_sec_param
);
297 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_unique_id
);
298 LOAD_DLL_FN (library
, gnutls_x509_crt_get_subject_unique_id
);
299 LOAD_DLL_FN (library
, gnutls_x509_crt_get_signature_algorithm
);
300 LOAD_DLL_FN (library
, gnutls_x509_crt_get_key_id
);
301 LOAD_DLL_FN (library
, gnutls_sec_param_get_name
);
302 LOAD_DLL_FN (library
, gnutls_sign_get_name
);
303 LOAD_DLL_FN (library
, gnutls_server_name_set
);
304 LOAD_DLL_FN (library
, gnutls_kx_get
);
305 LOAD_DLL_FN (library
, gnutls_kx_get_name
);
306 LOAD_DLL_FN (library
, gnutls_protocol_get_version
);
307 LOAD_DLL_FN (library
, gnutls_protocol_get_name
);
308 LOAD_DLL_FN (library
, gnutls_cipher_get
);
309 LOAD_DLL_FN (library
, gnutls_cipher_get_name
);
310 LOAD_DLL_FN (library
, gnutls_mac_get
);
311 LOAD_DLL_FN (library
, gnutls_mac_get_name
);
313 LOAD_DLL_FN (library
, gnutls_rnd
);
314 LOAD_DLL_FN (library
, gnutls_mac_list
);
315 LOAD_DLL_FN (library
, gnutls_mac_get_nonce_size
);
316 LOAD_DLL_FN (library
, gnutls_mac_get_key_size
);
317 LOAD_DLL_FN (library
, gnutls_digest_list
);
318 LOAD_DLL_FN (library
, gnutls_digest_get_name
);
319 # ifdef HAVE_GNUTLS3_CIPHER
320 LOAD_DLL_FN (library
, gnutls_cipher_list
);
321 LOAD_DLL_FN (library
, gnutls_cipher_get_iv_size
);
322 LOAD_DLL_FN (library
, gnutls_cipher_get_key_size
);
323 LOAD_DLL_FN (library
, gnutls_cipher_get_block_size
);
324 LOAD_DLL_FN (library
, gnutls_cipher_get_tag_size
);
325 LOAD_DLL_FN (library
, gnutls_cipher_init
);
326 LOAD_DLL_FN (library
, gnutls_cipher_set_iv
);
327 LOAD_DLL_FN (library
, gnutls_cipher_encrypt2
);
328 LOAD_DLL_FN (library
, gnutls_cipher_deinit
);
329 LOAD_DLL_FN (library
, gnutls_cipher_decrypt2
);
330 # ifdef HAVE_GNUTLS3_AEAD
331 LOAD_DLL_FN (library
, gnutls_aead_cipher_init
);
332 LOAD_DLL_FN (library
, gnutls_aead_cipher_deinit
);
333 LOAD_DLL_FN (library
, gnutls_aead_cipher_encrypt
);
334 LOAD_DLL_FN (library
, gnutls_aead_cipher_decrypt
);
336 # ifdef HAVE_GNUTLS3_HMAC
337 LOAD_DLL_FN (library
, gnutls_hmac_init
);
338 LOAD_DLL_FN (library
, gnutls_hmac_get_len
);
339 LOAD_DLL_FN (library
, gnutls_hmac
);
340 LOAD_DLL_FN (library
, gnutls_hmac_deinit
);
341 LOAD_DLL_FN (library
, gnutls_hmac_output
);
342 # endif /* HAVE_GNUTLS3_HMAC */
343 # endif /* HAVE_GNUTLS3_CIPHER */
344 # ifdef HAVE_GNUTLS3_DIGEST
345 LOAD_DLL_FN (library
, gnutls_hash_init
);
346 LOAD_DLL_FN (library
, gnutls_hash_get_len
);
347 LOAD_DLL_FN (library
, gnutls_hash
);
348 LOAD_DLL_FN (library
, gnutls_hash_deinit
);
349 LOAD_DLL_FN (library
, gnutls_hash_output
);
351 # endif /* HAVE_GNUTLS3 */
353 max_log_level
= global_gnutls_log_level
;
356 Lisp_Object name
= CAR_SAFE (Fget (Qgnutls
, QCloaded_from
));
357 GNUTLS_LOG2 (1, max_log_level
, "GnuTLS library loaded:",
358 STRINGP (name
) ? (const char *) SDATA (name
) : "unknown");
364 # define gnutls_alert_get fn_gnutls_alert_get
365 # define gnutls_alert_get_name fn_gnutls_alert_get_name
366 # define gnutls_anon_allocate_client_credentials fn_gnutls_anon_allocate_client_credentials
367 # define gnutls_anon_free_client_credentials fn_gnutls_anon_free_client_credentials
368 # define gnutls_bye fn_gnutls_bye
369 # define gnutls_certificate_allocate_credentials fn_gnutls_certificate_allocate_credentials
370 # define gnutls_certificate_free_credentials fn_gnutls_certificate_free_credentials
371 # define gnutls_certificate_get_peers fn_gnutls_certificate_get_peers
372 # define gnutls_certificate_set_verify_flags fn_gnutls_certificate_set_verify_flags
373 # define gnutls_certificate_set_x509_crl_file fn_gnutls_certificate_set_x509_crl_file
374 # define gnutls_certificate_set_x509_key_file fn_gnutls_certificate_set_x509_key_file
375 # define gnutls_certificate_set_x509_system_trust fn_gnutls_certificate_set_x509_system_trust
376 # define gnutls_certificate_set_x509_trust_file fn_gnutls_certificate_set_x509_trust_file
377 # define gnutls_certificate_type_get fn_gnutls_certificate_type_get
378 # define gnutls_certificate_verify_peers2 fn_gnutls_certificate_verify_peers2
379 # define gnutls_cipher_get fn_gnutls_cipher_get
380 # define gnutls_cipher_get_name fn_gnutls_cipher_get_name
381 # define gnutls_credentials_set fn_gnutls_credentials_set
382 # define gnutls_deinit fn_gnutls_deinit
383 # define gnutls_dh_get_prime_bits fn_gnutls_dh_get_prime_bits
384 # define gnutls_dh_set_prime_bits fn_gnutls_dh_set_prime_bits
385 # define gnutls_error_is_fatal fn_gnutls_error_is_fatal
386 # define gnutls_global_init fn_gnutls_global_init
387 # define gnutls_global_set_audit_log_function fn_gnutls_global_set_audit_log_function
388 # define gnutls_global_set_log_function fn_gnutls_global_set_log_function
389 # define gnutls_global_set_log_level fn_gnutls_global_set_log_level
390 # define gnutls_handshake fn_gnutls_handshake
391 # define gnutls_init fn_gnutls_init
392 # define gnutls_kx_get fn_gnutls_kx_get
393 # define gnutls_kx_get_name fn_gnutls_kx_get_name
394 # define gnutls_mac_get fn_gnutls_mac_get
395 # define gnutls_mac_get_name fn_gnutls_mac_get_name
396 # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name
397 # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param
398 # define gnutls_priority_set_direct fn_gnutls_priority_set_direct
399 # define gnutls_protocol_get_name fn_gnutls_protocol_get_name
400 # define gnutls_protocol_get_version fn_gnutls_protocol_get_version
401 # define gnutls_record_check_pending fn_gnutls_record_check_pending
402 # define gnutls_record_recv fn_gnutls_record_recv
403 # define gnutls_record_send fn_gnutls_record_send
404 # define gnutls_sec_param_get_name fn_gnutls_sec_param_get_name
405 # define gnutls_server_name_set fn_gnutls_server_name_set
406 # define gnutls_sign_get_name fn_gnutls_sign_get_name
407 # define gnutls_strerror fn_gnutls_strerror
408 # define gnutls_transport_set_errno fn_gnutls_transport_set_errno
409 # define gnutls_transport_set_ptr2 fn_gnutls_transport_set_ptr2
410 # define gnutls_transport_set_pull_function fn_gnutls_transport_set_pull_function
411 # define gnutls_transport_set_push_function fn_gnutls_transport_set_push_function
412 # define gnutls_x509_crt_check_hostname fn_gnutls_x509_crt_check_hostname
413 # define gnutls_x509_crt_check_issuer fn_gnutls_x509_crt_check_issuer
414 # define gnutls_x509_crt_deinit fn_gnutls_x509_crt_deinit
415 # define gnutls_x509_crt_get_activation_time fn_gnutls_x509_crt_get_activation_time
416 # define gnutls_x509_crt_get_dn fn_gnutls_x509_crt_get_dn
417 # define gnutls_x509_crt_get_expiration_time fn_gnutls_x509_crt_get_expiration_time
418 # define gnutls_x509_crt_get_fingerprint fn_gnutls_x509_crt_get_fingerprint
419 # define gnutls_x509_crt_get_issuer_dn fn_gnutls_x509_crt_get_issuer_dn
420 # define gnutls_x509_crt_get_issuer_unique_id fn_gnutls_x509_crt_get_issuer_unique_id
421 # define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id
422 # define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm
423 # define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial
424 # define gnutls_x509_crt_get_signature_algorithm fn_gnutls_x509_crt_get_signature_algorithm
425 # define gnutls_x509_crt_get_subject_unique_id fn_gnutls_x509_crt_get_subject_unique_id
426 # define gnutls_x509_crt_get_version fn_gnutls_x509_crt_get_version
427 # define gnutls_x509_crt_import fn_gnutls_x509_crt_import
428 # define gnutls_x509_crt_init fn_gnutls_x509_crt_init
430 # define gnutls_rnd fn_gnutls_rnd
431 # define gnutls_mac_list fn_gnutls_mac_list
432 # define gnutls_mac_get_nonce_size fn_gnutls_mac_get_nonce_size
433 # define gnutls_mac_get_key_size fn_gnutls_mac_get_key_size
434 # define gnutls_digest_list fn_gnutls_digest_list
435 # define gnutls_digest_get_name fn_gnutls_digest_get_name
436 # ifdef HAVE_GNUTLS3_CIPHER
437 # define gnutls_cipher_list fn_gnutls_cipher_list
438 # define gnutls_cipher_get_iv_size fn_gnutls_cipher_get_iv_size
439 # define gnutls_cipher_get_key_size fn_gnutls_cipher_get_key_size
440 # define gnutls_cipher_get_block_size fn_gnutls_cipher_get_block_size
441 # define gnutls_cipher_get_tag_size fn_gnutls_cipher_get_tag_size
442 # define gnutls_cipher_init fn_gnutls_cipher_init
443 # define gnutls_cipher_set_iv fn_gnutls_cipher_set_iv
444 # define gnutls_cipher_encrypt2 fn_gnutls_cipher_encrypt2
445 # define gnutls_cipher_decrypt2 fn_gnutls_cipher_decrypt2
446 # define gnutls_cipher_deinit fn_gnutls_cipher_deinit
447 # ifdef HAVE_GNUTLS3_AEAD
448 # define gnutls_aead_cipher_encrypt fn_gnutls_aead_cipher_encrypt
449 # define gnutls_aead_cipher_decrypt fn_gnutls_aead_cipher_decrypt
450 # define gnutls_aead_cipher_init fn_gnutls_aead_cipher_init
451 # define gnutls_aead_cipher_deinit fn_gnutls_aead_cipher_deinit
452 # endif /* HAVE_GNUTLS3_AEAD */
453 # ifdef HAVE_GNUTLS3_HMAC
454 # define gnutls_hmac_init fn_gnutls_hmac_init
455 # define gnutls_hmac_get_len fn_gnutls_hmac_get_len
456 # define gnutls_hmac fn_gnutls_hmac
457 # define gnutls_hmac_deinit fn_gnutls_hmac_deinit
458 # define gnutls_hmac_output fn_gnutls_hmac_output
459 # endif /* HAVE_GNUTLS3_HMAC */
460 # endif /* HAVE_GNUTLS3_CIPHER */
461 # ifdef HAVE_GNUTLS3_DIGEST
462 # define gnutls_hash_init fn_gnutls_hash_init
463 # define gnutls_hash_get_len fn_gnutls_hash_get_len
464 # define gnutls_hash fn_gnutls_hash
465 # define gnutls_hash_deinit fn_gnutls_hash_deinit
466 # define gnutls_hash_output fn_gnutls_hash_output
468 # endif /* HAVE_GNUTLS3 */
470 /* This wrapper is called from fns.c, which doesn't know about the
471 LOAD_DLL_FN stuff above. */
473 w32_gnutls_rnd (gnutls_rnd_level_t level
, void *data
, size_t len
)
475 return gnutls_rnd (level
, data
, len
);
478 #endif /* WINDOWSNT */
481 /* Report memory exhaustion if ERR is an out-of-memory indication. */
483 check_memory_full (int err
)
485 /* When GnuTLS exhausts memory, it doesn't say how much memory it
486 asked for, so tell the Emacs allocator that GnuTLS asked for no
487 bytes. This isn't accurate, but it's good enough. */
488 if (err
== GNUTLS_E_MEMORY_ERROR
)
493 /* Log a simple audit message. */
495 gnutls_audit_log_function (gnutls_session_t session
, const char *string
)
497 if (global_gnutls_log_level
>= 1)
499 message ("gnutls.c: [audit] %s", string
);
504 /* Log a simple message. */
506 gnutls_log_function (int level
, const char *string
)
508 message ("gnutls.c: [%d] %s", level
, string
);
511 /* Log a message and a string. */
513 gnutls_log_function2 (int level
, const char *string
, const char *extra
)
515 message ("gnutls.c: [%d] %s %s", level
, string
, extra
);
519 gnutls_try_handshake (struct Lisp_Process
*proc
)
521 gnutls_session_t state
= proc
->gnutls_state
;
523 bool non_blocking
= proc
->is_non_blocking_client
;
525 if (proc
->gnutls_complete_negotiation_p
)
526 non_blocking
= false;
529 proc
->gnutls_p
= true;
533 ret
= gnutls_handshake (state
);
534 emacs_gnutls_handle_error (state
, ret
);
538 && gnutls_error_is_fatal (ret
) == 0
541 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
543 if (ret
== GNUTLS_E_SUCCESS
)
545 /* Here we're finally done. */
546 proc
->gnutls_initstage
= GNUTLS_STAGE_READY
;
550 /* check_memory_full (gnutls_alert_send_appropriate (state, ret)); */
557 emacs_gnutls_nonblock_errno (gnutls_transport_ptr_t ptr
)
564 /* This is taken from the GnuTLS system_errno function circa 2016;
565 see <http://savannah.gnu.org/support/?107464>. */
578 #endif /* !WINDOWSNT */
581 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
583 gnutls_session_t state
= proc
->gnutls_state
;
585 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
588 if (proc
->gnutls_initstage
< GNUTLS_STAGE_TRANSPORT_POINTERS_SET
)
591 /* On W32 we cannot transfer socket handles between different runtime
592 libraries, so we tell GnuTLS to use our special push/pull
594 gnutls_transport_set_ptr2 (state
,
595 (gnutls_transport_ptr_t
) proc
,
596 (gnutls_transport_ptr_t
) proc
);
597 gnutls_transport_set_push_function (state
, &emacs_gnutls_push
);
598 gnutls_transport_set_pull_function (state
, &emacs_gnutls_pull
);
600 /* This is how GnuTLS takes sockets: as file descriptors passed
601 in. For an Emacs process socket, infd and outfd are the
602 same but we use this two-argument version for clarity. */
603 gnutls_transport_set_ptr2 (state
,
604 (void *) (intptr_t) proc
->infd
,
605 (void *) (intptr_t) proc
->outfd
);
606 if (proc
->is_non_blocking_client
)
607 gnutls_transport_set_errno_function (state
,
608 emacs_gnutls_nonblock_errno
);
611 proc
->gnutls_initstage
= GNUTLS_STAGE_TRANSPORT_POINTERS_SET
;
614 return gnutls_try_handshake (proc
);
618 emacs_gnutls_record_check_pending (gnutls_session_t state
)
620 return gnutls_record_check_pending (state
);
625 emacs_gnutls_transport_set_errno (gnutls_session_t state
, int err
)
627 gnutls_transport_set_errno (state
, err
);
632 emacs_gnutls_write (struct Lisp_Process
*proc
, const char *buf
, ptrdiff_t nbyte
)
635 ptrdiff_t bytes_written
;
636 gnutls_session_t state
= proc
->gnutls_state
;
638 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
648 rtnval
= gnutls_record_send (state
, buf
, nbyte
);
652 if (rtnval
== GNUTLS_E_INTERRUPTED
)
656 /* If we get GNUTLS_E_AGAIN, then set errno
657 appropriately so that send_process retries the
658 correct way instead of erroring out. */
659 if (rtnval
== GNUTLS_E_AGAIN
)
667 bytes_written
+= rtnval
;
670 emacs_gnutls_handle_error (state
, rtnval
);
671 return (bytes_written
);
675 emacs_gnutls_read (struct Lisp_Process
*proc
, char *buf
, ptrdiff_t nbyte
)
678 gnutls_session_t state
= proc
->gnutls_state
;
680 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
686 rtnval
= gnutls_record_recv (state
, buf
, nbyte
);
689 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
690 /* The peer closed the connection. */
692 else if (emacs_gnutls_handle_error (state
, rtnval
))
693 /* non-fatal error */
696 /* a fatal error occurred */
702 emacs_gnutls_strerror (int err
)
704 char const *str
= gnutls_strerror (err
);
705 return str
? str
: "unknown";
708 /* Report a GnuTLS error to the user.
709 Return true if the error code was successfully handled. */
711 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
713 int max_log_level
= 0;
717 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
721 check_memory_full (err
);
723 max_log_level
= global_gnutls_log_level
;
725 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
727 char const *str
= emacs_gnutls_strerror (err
);
729 if (gnutls_error_is_fatal (err
))
732 /* Mostly ignore "The TLS connection was non-properly
733 terminated" message which just means that the peer closed the
736 if (err
== GNUTLS_E_PREMATURE_TERMINATION
)
740 GNUTLS_LOG2 (level
, max_log_level
, "fatal error:", str
);
763 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
764 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
766 int alert
= gnutls_alert_get (session
);
767 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
768 str
= gnutls_alert_get_name (alert
);
772 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
777 /* convert an integer error to a Lisp_Object; it will be either a
778 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
779 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
782 gnutls_make_error (int err
)
786 case GNUTLS_E_SUCCESS
:
789 return Qgnutls_e_again
;
790 case GNUTLS_E_INTERRUPTED
:
791 return Qgnutls_e_interrupted
;
792 case GNUTLS_E_INVALID_SESSION
:
793 return Qgnutls_e_invalid_session
;
796 check_memory_full (err
);
797 return make_number (err
);
801 emacs_gnutls_deinit (Lisp_Object proc
)
805 CHECK_PROCESS (proc
);
807 if (! XPROCESS (proc
)->gnutls_p
)
810 log_level
= XPROCESS (proc
)->gnutls_log_level
;
812 if (XPROCESS (proc
)->gnutls_x509_cred
)
814 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
815 gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
816 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
819 if (XPROCESS (proc
)->gnutls_anon_cred
)
821 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
822 gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
823 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
826 if (XPROCESS (proc
)->gnutls_state
)
828 gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
829 XPROCESS (proc
)->gnutls_state
= NULL
;
830 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
831 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
834 XPROCESS (proc
)->gnutls_p
= false;
838 DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters
,
839 Sgnutls_asynchronous_parameters
, 2, 2, 0,
840 doc
: /* Mark this process as being a pre-init GnuTLS process.
841 The second parameter is the list of parameters to feed to gnutls-boot
842 to finish setting up the connection. */)
843 (Lisp_Object proc
, Lisp_Object params
)
845 CHECK_PROCESS (proc
);
847 XPROCESS (proc
)->gnutls_boot_parameters
= params
;
851 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
852 doc
: /* Return the GnuTLS init stage of process PROC.
853 See also `gnutls-boot'. */)
856 CHECK_PROCESS (proc
);
858 return make_number (GNUTLS_INITSTAGE (proc
));
861 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
862 doc
: /* Return t if ERROR indicates a GnuTLS problem.
863 ERROR is an integer or a symbol with an integer `gnutls-code' property.
864 usage: (gnutls-errorp ERROR) */
869 || EQ (err
, Qgnutls_e_again
))
875 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
876 doc
: /* Return non-nil if ERROR is fatal.
877 ERROR is an integer or a symbol with an integer `gnutls-code' property.
878 Usage: (gnutls-error-fatalp ERROR) */)
883 if (EQ (err
, Qt
)) return Qnil
;
887 code
= Fget (err
, Qgnutls_code
);
894 error ("Symbol has no numeric gnutls-code property");
898 if (! TYPE_RANGED_INTEGERP (int, err
))
899 error ("Not an error symbol or code");
901 if (0 == gnutls_error_is_fatal (XINT (err
)))
907 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
908 doc
: /* Return a description of ERROR.
909 ERROR is an integer or a symbol with an integer `gnutls-code' property.
910 usage: (gnutls-error-string ERROR) */)
915 if (EQ (err
, Qt
)) return build_string ("Not an error");
919 code
= Fget (err
, Qgnutls_code
);
926 return build_string ("Symbol has no numeric gnutls-code property");
930 if (! TYPE_RANGED_INTEGERP (int, err
))
931 return build_string ("Not an error symbol or code");
933 return build_string (emacs_gnutls_strerror (XINT (err
)));
936 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
937 doc
: /* Deallocate GnuTLS resources associated with process PROC.
938 See also `gnutls-init'. */)
941 return emacs_gnutls_deinit (proc
);
945 gnutls_hex_string (unsigned char *buf
, ptrdiff_t buf_size
, const char *prefix
)
947 ptrdiff_t prefix_length
= strlen (prefix
);
949 if (INT_MULTIPLY_WRAPV (buf_size
, 3, &retlen
)
950 || INT_ADD_WRAPV (prefix_length
- (buf_size
!= 0), retlen
, &retlen
))
952 Lisp_Object ret
= make_uninit_string (retlen
);
953 char *string
= SSDATA (ret
);
954 strcpy (string
, prefix
);
956 for (ptrdiff_t i
= 0; i
< buf_size
; i
++)
957 sprintf (string
+ i
* 3 + prefix_length
,
958 i
== buf_size
- 1 ? "%02x" : "%02x:",
965 gnutls_certificate_details (gnutls_x509_crt_t cert
)
967 Lisp_Object res
= Qnil
;
973 int version
= gnutls_x509_crt_get_version (cert
);
974 check_memory_full (version
);
975 if (version
>= GNUTLS_E_SUCCESS
)
976 res
= nconc2 (res
, list2 (intern (":version"),
977 make_number (version
)));
982 err
= gnutls_x509_crt_get_serial (cert
, NULL
, &buf_size
);
983 check_memory_full (err
);
984 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
986 void *serial
= xmalloc (buf_size
);
987 err
= gnutls_x509_crt_get_serial (cert
, serial
, &buf_size
);
988 check_memory_full (err
);
989 if (err
>= GNUTLS_E_SUCCESS
)
990 res
= nconc2 (res
, list2 (intern (":serial-number"),
991 gnutls_hex_string (serial
, buf_size
, "")));
997 err
= gnutls_x509_crt_get_issuer_dn (cert
, NULL
, &buf_size
);
998 check_memory_full (err
);
999 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
1001 char *dn
= xmalloc (buf_size
);
1002 err
= gnutls_x509_crt_get_issuer_dn (cert
, dn
, &buf_size
);
1003 check_memory_full (err
);
1004 if (err
>= GNUTLS_E_SUCCESS
)
1005 res
= nconc2 (res
, list2 (intern (":issuer"),
1006 make_string (dn
, buf_size
)));
1012 /* Add 1 to the buffer size, since 1900 is added to tm_year and
1013 that might add 1 to the year length. */
1014 char buf
[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
1016 time_t tim
= gnutls_x509_crt_get_activation_time (cert
);
1018 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
1019 res
= nconc2 (res
, list2 (intern (":valid-from"), build_string (buf
)));
1021 tim
= gnutls_x509_crt_get_expiration_time (cert
);
1022 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
1023 res
= nconc2 (res
, list2 (intern (":valid-to"), build_string (buf
)));
1028 err
= gnutls_x509_crt_get_dn (cert
, NULL
, &buf_size
);
1029 check_memory_full (err
);
1030 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
1032 char *dn
= xmalloc (buf_size
);
1033 err
= gnutls_x509_crt_get_dn (cert
, dn
, &buf_size
);
1034 check_memory_full (err
);
1035 if (err
>= GNUTLS_E_SUCCESS
)
1036 res
= nconc2 (res
, list2 (intern (":subject"),
1037 make_string (dn
, buf_size
)));
1041 /* SubjectPublicKeyInfo. */
1045 err
= gnutls_x509_crt_get_pk_algorithm (cert
, &bits
);
1046 check_memory_full (err
);
1047 if (err
>= GNUTLS_E_SUCCESS
)
1049 const char *name
= gnutls_pk_algorithm_get_name (err
);
1051 res
= nconc2 (res
, list2 (intern (":public-key-algorithm"),
1052 build_string (name
)));
1054 name
= gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
1056 res
= nconc2 (res
, list2 (intern (":certificate-security-level"),
1057 build_string (name
)));
1063 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, NULL
, &buf_size
);
1064 check_memory_full (err
);
1065 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
1067 char *buf
= xmalloc (buf_size
);
1068 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, buf
, &buf_size
);
1069 check_memory_full (err
);
1070 if (err
>= GNUTLS_E_SUCCESS
)
1071 res
= nconc2 (res
, list2 (intern (":issuer-unique-id"),
1072 make_string (buf
, buf_size
)));
1077 err
= gnutls_x509_crt_get_subject_unique_id (cert
, NULL
, &buf_size
);
1078 check_memory_full (err
);
1079 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
1081 char *buf
= xmalloc (buf_size
);
1082 err
= gnutls_x509_crt_get_subject_unique_id (cert
, buf
, &buf_size
);
1083 check_memory_full (err
);
1084 if (err
>= GNUTLS_E_SUCCESS
)
1085 res
= nconc2 (res
, list2 (intern (":subject-unique-id"),
1086 make_string (buf
, buf_size
)));
1091 err
= gnutls_x509_crt_get_signature_algorithm (cert
);
1092 check_memory_full (err
);
1093 if (err
>= GNUTLS_E_SUCCESS
)
1095 const char *name
= gnutls_sign_get_name (err
);
1097 res
= nconc2 (res
, list2 (intern (":signature-algorithm"),
1098 build_string (name
)));
1101 /* Public key ID. */
1103 err
= gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
1104 check_memory_full (err
);
1105 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
1107 void *buf
= xmalloc (buf_size
);
1108 err
= gnutls_x509_crt_get_key_id (cert
, 0, buf
, &buf_size
);
1109 check_memory_full (err
);
1110 if (err
>= GNUTLS_E_SUCCESS
)
1111 res
= nconc2 (res
, list2 (intern (":public-key-id"),
1112 gnutls_hex_string (buf
, buf_size
, "sha1:")));
1116 /* Certificate fingerprint. */
1118 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
1120 check_memory_full (err
);
1121 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
1123 void *buf
= xmalloc (buf_size
);
1124 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
1126 check_memory_full (err
);
1127 if (err
>= GNUTLS_E_SUCCESS
)
1128 res
= nconc2 (res
, list2 (intern (":certificate-id"),
1129 gnutls_hex_string (buf
, buf_size
, "sha1:")));
1136 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
1137 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
1138 (Lisp_Object status_symbol
)
1140 CHECK_SYMBOL (status_symbol
);
1142 if (EQ (status_symbol
, intern (":invalid")))
1143 return build_string ("certificate could not be verified");
1145 if (EQ (status_symbol
, intern (":revoked")))
1146 return build_string ("certificate was revoked (CRL)");
1148 if (EQ (status_symbol
, intern (":self-signed")))
1149 return build_string ("certificate signer was not found (self-signed)");
1151 if (EQ (status_symbol
, intern (":unknown-ca")))
1152 return build_string ("the certificate was signed by an unknown "
1153 "and therefore untrusted authority");
1155 if (EQ (status_symbol
, intern (":not-ca")))
1156 return build_string ("certificate signer is not a CA");
1158 if (EQ (status_symbol
, intern (":insecure")))
1159 return build_string ("certificate was signed with an insecure algorithm");
1161 if (EQ (status_symbol
, intern (":not-activated")))
1162 return build_string ("certificate is not yet activated");
1164 if (EQ (status_symbol
, intern (":expired")))
1165 return build_string ("certificate has expired");
1167 if (EQ (status_symbol
, intern (":no-host-match")))
1168 return build_string ("certificate host does not match hostname");
1173 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
1174 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1175 The return value is a property list with top-level keys :warnings and
1176 :certificate. The :warnings entry is a list of symbols you can describe with
1177 `gnutls-peer-status-warning-describe'. */)
1180 Lisp_Object warnings
= Qnil
, result
= Qnil
;
1181 unsigned int verification
;
1182 gnutls_session_t state
;
1184 CHECK_PROCESS (proc
);
1186 if (GNUTLS_INITSTAGE (proc
) != GNUTLS_STAGE_READY
)
1189 /* Then collect any warnings already computed by the handshake. */
1190 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
1192 if (verification
& GNUTLS_CERT_INVALID
)
1193 warnings
= Fcons (intern (":invalid"), warnings
);
1195 if (verification
& GNUTLS_CERT_REVOKED
)
1196 warnings
= Fcons (intern (":revoked"), warnings
);
1198 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1199 warnings
= Fcons (intern (":unknown-ca"), warnings
);
1201 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1202 warnings
= Fcons (intern (":not-ca"), warnings
);
1204 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1205 warnings
= Fcons (intern (":insecure"), warnings
);
1207 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1208 warnings
= Fcons (intern (":not-activated"), warnings
);
1210 if (verification
& GNUTLS_CERT_EXPIRED
)
1211 warnings
= Fcons (intern (":expired"), warnings
);
1213 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1214 CERTIFICATE_NOT_MATCHING
)
1215 warnings
= Fcons (intern (":no-host-match"), warnings
);
1217 /* This could get called in the INIT stage, when the certificate is
1219 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
&&
1220 gnutls_x509_crt_check_issuer(XPROCESS (proc
)->gnutls_certificate
,
1221 XPROCESS (proc
)->gnutls_certificate
))
1222 warnings
= Fcons (intern (":self-signed"), warnings
);
1224 if (!NILP (warnings
))
1225 result
= list2 (intern (":warnings"), warnings
);
1227 /* This could get called in the INIT stage, when the certificate is
1229 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1230 result
= nconc2 (result
, list2
1231 (intern (":certificate"),
1232 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1234 state
= XPROCESS (proc
)->gnutls_state
;
1236 /* Diffie-Hellman prime bits. */
1238 int bits
= gnutls_dh_get_prime_bits (state
);
1239 check_memory_full (bits
);
1241 result
= nconc2 (result
, list2 (intern (":diffie-hellman-prime-bits"),
1242 make_number (bits
)));
1247 (result
, list2 (intern (":key-exchange"),
1248 build_string (gnutls_kx_get_name
1249 (gnutls_kx_get (state
)))));
1251 /* Protocol name. */
1253 (result
, list2 (intern (":protocol"),
1254 build_string (gnutls_protocol_get_name
1255 (gnutls_protocol_get_version (state
)))));
1259 (result
, list2 (intern (":cipher"),
1260 build_string (gnutls_cipher_get_name
1261 (gnutls_cipher_get (state
)))));
1265 (result
, list2 (intern (":mac"),
1266 build_string (gnutls_mac_get_name
1267 (gnutls_mac_get (state
)))));
1273 /* Initialize global GnuTLS state to defaults.
1274 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1275 Return zero on success. */
1277 emacs_gnutls_global_init (void)
1279 int ret
= GNUTLS_E_SUCCESS
;
1281 if (!gnutls_global_initialized
)
1283 ret
= gnutls_global_init ();
1284 if (ret
== GNUTLS_E_SUCCESS
)
1285 gnutls_global_initialized
= 1;
1288 return gnutls_make_error (ret
);
1292 gnutls_ip_address_p (char *string
)
1296 while ((c
= *string
++) != 0)
1297 if (! ((c
== '.' || c
== ':' || (c
>= '0' && c
<= '9'))))
1304 /* Deinitialize global GnuTLS state.
1305 See also `gnutls-global-init'. */
1307 emacs_gnutls_global_deinit (void)
1309 if (gnutls_global_initialized
)
1310 gnutls_global_deinit ();
1312 gnutls_global_initialized
= 0;
1314 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1318 static void ATTRIBUTE_FORMAT_PRINTF (2, 3)
1319 boot_error (struct Lisp_Process
*p
, const char *m
, ...)
1323 if (p
->is_non_blocking_client
)
1324 pset_status (p
, list2 (Qfailed
, vformat_string (m
, ap
)));
1331 gnutls_verify_boot (Lisp_Object proc
, Lisp_Object proplist
)
1334 struct Lisp_Process
*p
= XPROCESS (proc
);
1335 gnutls_session_t state
= p
->gnutls_state
;
1336 unsigned int peer_verification
;
1337 Lisp_Object warnings
;
1338 int max_log_level
= p
->gnutls_log_level
;
1339 Lisp_Object hostname
, verify_error
;
1340 bool verify_error_all
= false;
1343 if (NILP (proplist
))
1344 proplist
= Fcdr (Fplist_get (p
->childp
, QCtls_parameters
));
1346 verify_error
= Fplist_get (proplist
, QCverify_error
);
1347 hostname
= Fplist_get (proplist
, QChostname
);
1349 if (EQ (verify_error
, Qt
))
1350 verify_error_all
= true;
1351 else if (NILP (Flistp (verify_error
)))
1354 "gnutls-boot: invalid :verify_error parameter (not a list)");
1358 if (!STRINGP (hostname
))
1360 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1363 c_hostname
= SSDATA (hostname
);
1365 /* Now verify the peer, following
1366 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1367 The peer should present at least one certificate in the chain; do a
1368 check of the certificate's hostname with
1369 gnutls_x509_crt_check_hostname against :hostname. */
1371 ret
= gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1372 if (ret
< GNUTLS_E_SUCCESS
)
1373 return gnutls_make_error (ret
);
1375 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1377 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1378 if (!NILP (warnings
))
1380 for (Lisp_Object tail
= warnings
; CONSP (tail
); tail
= XCDR (tail
))
1382 Lisp_Object warning
= XCAR (tail
);
1383 Lisp_Object message
= Fgnutls_peer_status_warning_describe (warning
);
1384 if (!NILP (message
))
1385 GNUTLS_LOG2 (1, max_log_level
, "verification:", SSDATA (message
));
1389 if (peer_verification
!= 0)
1391 if (verify_error_all
1392 || !NILP (Fmember (QCtrustfiles
, verify_error
)))
1394 emacs_gnutls_deinit (proc
);
1396 "Certificate validation failed %s, verification code %x",
1397 c_hostname
, peer_verification
);
1402 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1407 /* Up to here the process is the same for X.509 certificates and
1408 OpenPGP keys. From now on X.509 certificates are assumed. This
1409 can be easily extended to work with openpgp keys as well. */
1410 if (gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1412 gnutls_x509_crt_t gnutls_verify_cert
;
1413 const gnutls_datum_t
*gnutls_verify_cert_list
;
1414 unsigned int gnutls_verify_cert_list_size
;
1416 ret
= gnutls_x509_crt_init (&gnutls_verify_cert
);
1417 if (ret
< GNUTLS_E_SUCCESS
)
1418 return gnutls_make_error (ret
);
1420 gnutls_verify_cert_list
1421 = gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1423 if (gnutls_verify_cert_list
== NULL
)
1425 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1426 emacs_gnutls_deinit (proc
);
1427 boot_error (p
, "No x509 certificate was found\n");
1431 /* Check only the first certificate in the given chain. */
1432 ret
= gnutls_x509_crt_import (gnutls_verify_cert
,
1433 &gnutls_verify_cert_list
[0],
1434 GNUTLS_X509_FMT_DER
);
1436 if (ret
< GNUTLS_E_SUCCESS
)
1438 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1439 return gnutls_make_error (ret
);
1442 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1444 int err
= gnutls_x509_crt_check_hostname (gnutls_verify_cert
,
1446 check_memory_full (err
);
1449 XPROCESS (proc
)->gnutls_extra_peer_verification
1450 |= CERTIFICATE_NOT_MATCHING
;
1451 if (verify_error_all
1452 || !NILP (Fmember (QChostname
, verify_error
)))
1454 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1455 emacs_gnutls_deinit (proc
);
1456 boot_error (p
, "The x509 certificate does not match \"%s\"",
1461 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1466 /* Set this flag only if the whole initialization succeeded. */
1467 XPROCESS (proc
)->gnutls_p
= true;
1469 return gnutls_make_error (ret
);
1472 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
1473 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1474 Currently only client mode is supported. Return a success/failure
1475 value you can check with `gnutls-errorp'.
1477 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1478 PROPLIST is a property list with the following keys:
1480 :hostname is a string naming the remote host.
1482 :priority is a GnuTLS priority string, defaults to "NORMAL".
1484 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1486 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1488 :keylist is an alist of PEM-encoded key files and PEM-encoded
1489 certificates for `gnutls-x509pki'.
1491 :callbacks is an alist of callback functions, see below.
1493 :loglevel is the debug level requested from GnuTLS, try 4.
1495 :verify-flags is a bitset as per GnuTLS'
1496 gnutls_certificate_set_verify_flags.
1498 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1501 :verify-error is a list of symbols to express verification checks or
1502 t to do all checks. Currently it can contain `:trustfiles' and
1503 `:hostname' to verify the certificate or the hostname respectively.
1505 :min-prime-bits is the minimum accepted number of bits the client will
1506 accept in Diffie-Hellman key exchange.
1508 :complete-negotiation, if non-nil, will make negotiation complete
1509 before returning even on non-blocking sockets.
1511 The debug level will be set for this process AND globally for GnuTLS.
1512 So if you set it higher or lower at any point, it affects global
1515 Note that the priority is set on the client. The server does not use
1516 the protocols's priority except for disabling protocols that were not
1519 Processes must be initialized with this function before other GnuTLS
1520 functions are used. This function allocates resources which can only
1521 be deallocated by calling `gnutls-deinit' or by calling it again.
1523 The callbacks alist can have a `verify' key, associated with a
1524 verification function (UNUSED).
1526 Each authentication type may need additional information in order to
1527 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1528 one trustfile (usually a CA bundle). */)
1529 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
1531 int ret
= GNUTLS_E_SUCCESS
;
1532 int max_log_level
= 0;
1534 gnutls_session_t state
;
1535 gnutls_certificate_credentials_t x509_cred
= NULL
;
1536 gnutls_anon_client_credentials_t anon_cred
= NULL
;
1537 Lisp_Object global_init
;
1538 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
1541 /* Placeholders for the property list elements. */
1542 Lisp_Object priority_string
;
1543 Lisp_Object trustfiles
;
1544 Lisp_Object crlfiles
;
1545 Lisp_Object keylist
;
1546 /* Lisp_Object callbacks; */
1547 Lisp_Object loglevel
;
1548 Lisp_Object hostname
;
1549 Lisp_Object prime_bits
;
1550 struct Lisp_Process
*p
= XPROCESS (proc
);
1552 CHECK_PROCESS (proc
);
1553 CHECK_SYMBOL (type
);
1554 CHECK_LIST (proplist
);
1556 if (NILP (Fgnutls_available_p ()))
1558 boot_error (p
, "GnuTLS not available");
1562 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
1564 boot_error (p
, "Invalid GnuTLS credential type");
1568 hostname
= Fplist_get (proplist
, QChostname
);
1569 priority_string
= Fplist_get (proplist
, QCpriority
);
1570 trustfiles
= Fplist_get (proplist
, QCtrustfiles
);
1571 keylist
= Fplist_get (proplist
, QCkeylist
);
1572 crlfiles
= Fplist_get (proplist
, QCcrlfiles
);
1573 loglevel
= Fplist_get (proplist
, QCloglevel
);
1574 prime_bits
= Fplist_get (proplist
, QCmin_prime_bits
);
1576 if (!STRINGP (hostname
))
1578 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1581 c_hostname
= SSDATA (hostname
);
1583 state
= XPROCESS (proc
)->gnutls_state
;
1585 if (TYPE_RANGED_INTEGERP (int, loglevel
))
1587 gnutls_global_set_log_function (gnutls_log_function
);
1589 gnutls_global_set_audit_log_function (gnutls_audit_log_function
);
1591 gnutls_global_set_log_level (XINT (loglevel
));
1592 max_log_level
= XINT (loglevel
);
1593 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
1596 GNUTLS_LOG2 (1, max_log_level
, "connecting to host:", c_hostname
);
1598 /* Always initialize globals. */
1599 global_init
= emacs_gnutls_global_init ();
1600 if (! NILP (Fgnutls_errorp (global_init
)))
1603 /* Before allocating new credentials, deallocate any credentials
1604 that PROC might already have. */
1605 emacs_gnutls_deinit (proc
);
1607 /* Mark PROC as a GnuTLS process. */
1608 XPROCESS (proc
)->gnutls_state
= NULL
;
1609 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
1610 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
1611 pset_gnutls_cred_type (XPROCESS (proc
), type
);
1612 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
1614 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
1615 if (EQ (type
, Qgnutls_x509pki
))
1617 Lisp_Object verify_flags
;
1618 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
1620 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
1621 check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred
));
1622 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
1624 verify_flags
= Fplist_get (proplist
, QCverify_flags
);
1625 if (TYPE_RANGED_INTEGERP (unsigned int, verify_flags
))
1627 gnutls_verify_flags
= XFASTINT (verify_flags
);
1628 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
1630 else if (NILP (verify_flags
))
1631 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
1633 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
1635 gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
1637 else /* Qgnutls_anon: */
1639 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
1640 check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred
));
1641 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
1644 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
1646 if (EQ (type
, Qgnutls_x509pki
))
1648 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1649 int file_format
= GNUTLS_X509_FMT_PEM
;
1652 #if GNUTLS_VERSION_MAJOR + \
1653 (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
1654 ret
= gnutls_certificate_set_x509_system_trust (x509_cred
);
1655 if (ret
< GNUTLS_E_SUCCESS
)
1657 check_memory_full (ret
);
1658 GNUTLS_LOG2i (4, max_log_level
,
1659 "setting system trust failed with code ", ret
);
1663 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
1665 Lisp_Object trustfile
= XCAR (tail
);
1666 if (STRINGP (trustfile
))
1668 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
1669 SSDATA (trustfile
));
1670 trustfile
= ENCODE_FILE (trustfile
);
1672 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1673 file names on Windows, we need to re-encode the file
1674 name using the current ANSI codepage. */
1675 trustfile
= ansi_encode_filename (trustfile
);
1677 ret
= gnutls_certificate_set_x509_trust_file
1682 if (ret
< GNUTLS_E_SUCCESS
)
1683 return gnutls_make_error (ret
);
1687 emacs_gnutls_deinit (proc
);
1688 boot_error (p
, "Invalid trustfile");
1693 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
1695 Lisp_Object crlfile
= XCAR (tail
);
1696 if (STRINGP (crlfile
))
1698 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
1700 crlfile
= ENCODE_FILE (crlfile
);
1702 crlfile
= ansi_encode_filename (crlfile
);
1704 ret
= gnutls_certificate_set_x509_crl_file
1705 (x509_cred
, SSDATA (crlfile
), file_format
);
1707 if (ret
< GNUTLS_E_SUCCESS
)
1708 return gnutls_make_error (ret
);
1712 emacs_gnutls_deinit (proc
);
1713 boot_error (p
, "Invalid CRL file");
1718 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
1720 Lisp_Object keyfile
= Fcar (XCAR (tail
));
1721 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
1722 if (STRINGP (keyfile
) && STRINGP (certfile
))
1724 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
1726 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
1728 keyfile
= ENCODE_FILE (keyfile
);
1729 certfile
= ENCODE_FILE (certfile
);
1731 keyfile
= ansi_encode_filename (keyfile
);
1732 certfile
= ansi_encode_filename (certfile
);
1734 ret
= gnutls_certificate_set_x509_key_file
1735 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
1737 if (ret
< GNUTLS_E_SUCCESS
)
1738 return gnutls_make_error (ret
);
1742 emacs_gnutls_deinit (proc
);
1743 boot_error (p
, STRINGP (keyfile
) ? "Invalid client cert file"
1744 : "Invalid client key file");
1750 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
1751 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
1752 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
1754 /* Call gnutls_init here: */
1756 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
1757 int gnutls_flags
= GNUTLS_CLIENT
;
1758 #ifdef GNUTLS_NONBLOCK
1759 if (XPROCESS (proc
)->is_non_blocking_client
)
1760 gnutls_flags
|= GNUTLS_NONBLOCK
;
1762 ret
= gnutls_init (&state
, gnutls_flags
);
1763 XPROCESS (proc
)->gnutls_state
= state
;
1764 if (ret
< GNUTLS_E_SUCCESS
)
1765 return gnutls_make_error (ret
);
1766 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
1768 if (STRINGP (priority_string
))
1770 priority_string_ptr
= SSDATA (priority_string
);
1771 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
1772 priority_string_ptr
);
1776 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
1777 priority_string_ptr
);
1780 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
1781 ret
= gnutls_priority_set_direct (state
, priority_string_ptr
, NULL
);
1782 if (ret
< GNUTLS_E_SUCCESS
)
1783 return gnutls_make_error (ret
);
1785 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
1787 if (INTEGERP (prime_bits
))
1788 gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
1790 ret
= EQ (type
, Qgnutls_x509pki
)
1791 ? gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
1792 : gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
1793 if (ret
< GNUTLS_E_SUCCESS
)
1794 return gnutls_make_error (ret
);
1796 if (!gnutls_ip_address_p (c_hostname
))
1798 ret
= gnutls_server_name_set (state
, GNUTLS_NAME_DNS
, c_hostname
,
1799 strlen (c_hostname
));
1800 if (ret
< GNUTLS_E_SUCCESS
)
1801 return gnutls_make_error (ret
);
1804 XPROCESS (proc
)->gnutls_complete_negotiation_p
=
1805 !NILP (Fplist_get (proplist
, QCcomplete_negotiation
));
1806 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
1807 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
1808 if (ret
< GNUTLS_E_SUCCESS
)
1809 return gnutls_make_error (ret
);
1811 return gnutls_verify_boot (proc
, proplist
);
1814 DEFUN ("gnutls-bye", Fgnutls_bye
,
1815 Sgnutls_bye
, 2, 2, 0,
1816 doc
: /* Terminate current GnuTLS connection for process PROC.
1817 The connection should have been initiated using `gnutls-handshake'.
1819 If CONT is not nil the TLS connection gets terminated and further
1820 receives and sends will be disallowed. If the return value is zero you
1821 may continue using the connection. If CONT is nil, GnuTLS actually
1822 sends an alert containing a close request and waits for the peer to
1823 reply with the same message. In order to reuse the connection you
1824 should wait for an EOF from the peer.
1826 This function may also return `gnutls-e-again', or
1827 `gnutls-e-interrupted'. */)
1828 (Lisp_Object proc
, Lisp_Object cont
)
1830 gnutls_session_t state
;
1833 CHECK_PROCESS (proc
);
1835 state
= XPROCESS (proc
)->gnutls_state
;
1837 gnutls_x509_crt_deinit (XPROCESS (proc
)->gnutls_certificate
);
1839 ret
= gnutls_bye (state
, NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1841 return gnutls_make_error (ret
);
1844 #endif /* HAVE_GNUTLS */
1848 DEFUN ("gnutls-ciphers", Fgnutls_ciphers
, Sgnutls_ciphers
, 0, 0, 0,
1849 doc
: /* Return alist of GnuTLS symmetric cipher descriptions as plists.
1850 The alist key is the cipher name. */)
1853 Lisp_Object ciphers
= Qnil
;
1855 const gnutls_cipher_algorithm_t
*gciphers
= gnutls_cipher_list ();
1856 for (ptrdiff_t pos
= 0; gciphers
[pos
] != GNUTLS_CIPHER_NULL
; pos
++)
1858 gnutls_cipher_algorithm_t gca
= gciphers
[pos
];
1859 Lisp_Object cipher_symbol
= intern (gnutls_cipher_get_name (gca
));
1860 ptrdiff_t cipher_tag_size
= gnutls_cipher_get_tag_size (gca
);
1863 = listn (CONSTYPE_HEAP
, 15, cipher_symbol
,
1864 QCcipher_id
, make_number (gca
),
1865 QCtype
, Qgnutls_type_cipher
,
1866 QCcipher_aead_capable
, cipher_tag_size
== 0 ? Qnil
: Qt
,
1867 QCcipher_tagsize
, make_number (cipher_tag_size
),
1870 make_number (gnutls_cipher_get_block_size (gca
)),
1873 make_number (gnutls_cipher_get_key_size (gca
)),
1876 make_number (gnutls_cipher_get_iv_size (gca
)));
1878 ciphers
= Fcons (cp
, ciphers
);
1885 gnutls_symmetric_aead (bool encrypting
, gnutls_cipher_algorithm_t gca
,
1887 const char *kdata
, ptrdiff_t ksize
,
1888 const char *vdata
, ptrdiff_t vsize
,
1889 const char *idata
, ptrdiff_t isize
,
1890 Lisp_Object aead_auth
)
1892 #ifdef HAVE_GNUTLS3_AEAD
1894 const char *desc
= encrypting
? "encrypt" : "decrypt";
1895 Lisp_Object actual_iv
= make_unibyte_string (vdata
, vsize
);
1897 gnutls_aead_cipher_hd_t acipher
;
1898 gnutls_datum_t key_datum
= { (unsigned char *) kdata
, ksize
};
1899 int ret
= gnutls_aead_cipher_init (&acipher
, gca
, &key_datum
);
1901 if (ret
< GNUTLS_E_SUCCESS
)
1902 error ("GnuTLS AEAD cipher %s/%s initialization failed: %s",
1903 gnutls_cipher_get_name (gca
), desc
, emacs_gnutls_strerror (ret
));
1905 ptrdiff_t cipher_tag_size
= gnutls_cipher_get_tag_size (gca
);
1906 ptrdiff_t tagged_size
;
1907 if (INT_ADD_WRAPV (isize
, cipher_tag_size
, &tagged_size
)
1908 || SIZE_MAX
< tagged_size
)
1909 memory_full (SIZE_MAX
);
1910 size_t storage_length
= tagged_size
;
1912 char *storage
= SAFE_ALLOCA (storage_length
);
1914 const char *aead_auth_data
= NULL
;
1915 ptrdiff_t aead_auth_size
= 0;
1917 if (!NILP (aead_auth
))
1919 if (BUFFERP (aead_auth
) || STRINGP (aead_auth
))
1920 aead_auth
= list1 (aead_auth
);
1922 CHECK_CONS (aead_auth
);
1924 ptrdiff_t astart_byte
, aend_byte
;
1926 = extract_data_from_object (aead_auth
, &astart_byte
, &aend_byte
);
1928 error ("GnuTLS AEAD cipher auth extraction failed");
1930 aead_auth_data
= adata
;
1931 aead_auth_size
= aend_byte
- astart_byte
;
1934 ptrdiff_t expected_remainder
= encrypting
? 0 : cipher_tag_size
;
1935 ptrdiff_t cipher_block_size
= gnutls_cipher_get_block_size (gca
);
1937 if (isize
< expected_remainder
1938 || (isize
- expected_remainder
) % cipher_block_size
!= 0)
1939 error (("GnuTLS AEAD cipher %s/%s input block length %"pD
"d "
1940 "is not %"pD
"d greater than a multiple of the required %"pD
"d"),
1941 gnutls_cipher_get_name (gca
), desc
,
1942 isize
, expected_remainder
, cipher_block_size
);
1944 ret
= ((encrypting
? gnutls_aead_cipher_encrypt
: gnutls_aead_cipher_decrypt
)
1945 (acipher
, vdata
, vsize
, aead_auth_data
, aead_auth_size
,
1946 cipher_tag_size
, idata
, isize
, storage
, &storage_length
));
1948 if (ret
< GNUTLS_E_SUCCESS
)
1950 memset (storage
, 0, storage_length
);
1952 gnutls_aead_cipher_deinit (acipher
);
1953 error ("GnuTLS AEAD cipher %s %sion failed: %s",
1954 gnutls_cipher_get_name (gca
), desc
, emacs_gnutls_strerror (ret
));
1957 gnutls_aead_cipher_deinit (acipher
);
1959 Lisp_Object output
= make_unibyte_string (storage
, storage_length
);
1960 memset (storage
, 0, storage_length
);
1962 return list2 (output
, actual_iv
);
1964 printmax_t print_gca
= gca
;
1965 error ("GnuTLS AEAD cipher %"pMd
" is invalid or not found", print_gca
);
1970 gnutls_symmetric (bool encrypting
, Lisp_Object cipher
,
1971 Lisp_Object key
, Lisp_Object iv
,
1972 Lisp_Object input
, Lisp_Object aead_auth
)
1974 if (BUFFERP (key
) || STRINGP (key
))
1979 if (BUFFERP (input
) || STRINGP (input
))
1980 input
= list1 (input
);
1984 if (BUFFERP (iv
) || STRINGP (iv
))
1990 const char *desc
= encrypting
? "encrypt" : "decrypt";
1992 gnutls_cipher_algorithm_t gca
= GNUTLS_CIPHER_UNKNOWN
;
1994 Lisp_Object info
= Qnil
;
1995 if (STRINGP (cipher
))
1996 cipher
= intern (SSDATA (cipher
));
1998 if (SYMBOLP (cipher
))
1999 info
= XCDR (Fassq (cipher
, Fgnutls_ciphers ()));
2000 else if (TYPE_RANGED_INTEGERP (gnutls_cipher_algorithm_t
, cipher
))
2001 gca
= XINT (cipher
);
2005 if (!NILP (info
) && CONSP (info
))
2007 Lisp_Object v
= Fplist_get (info
, QCcipher_id
);
2008 if (TYPE_RANGED_INTEGERP (gnutls_cipher_algorithm_t
, v
))
2012 ptrdiff_t key_size
= gnutls_cipher_get_key_size (gca
);
2014 error ("GnuTLS cipher is invalid or not found");
2016 ptrdiff_t kstart_byte
, kend_byte
;
2017 const char *kdata
= extract_data_from_object (key
, &kstart_byte
, &kend_byte
);
2020 error ("GnuTLS cipher key extraction failed");
2022 if (kend_byte
- kstart_byte
!= key_size
)
2023 error (("GnuTLS cipher %s/%s key length %"pD
"d is not equal to "
2024 "the required %"pD
"d"),
2025 gnutls_cipher_get_name (gca
), desc
,
2026 kend_byte
- kstart_byte
, key_size
);
2028 ptrdiff_t vstart_byte
, vend_byte
;
2029 char *vdata
= extract_data_from_object (iv
, &vstart_byte
, &vend_byte
);
2032 error ("GnuTLS cipher IV extraction failed");
2034 ptrdiff_t iv_size
= gnutls_cipher_get_iv_size (gca
);
2035 if (vend_byte
- vstart_byte
!= iv_size
)
2036 error (("GnuTLS cipher %s/%s IV length %"pD
"d is not equal to "
2037 "the required %"pD
"d"),
2038 gnutls_cipher_get_name (gca
), desc
,
2039 vend_byte
- vstart_byte
, iv_size
);
2041 Lisp_Object actual_iv
= make_unibyte_string (vdata
, vend_byte
- vstart_byte
);
2043 ptrdiff_t istart_byte
, iend_byte
;
2045 = extract_data_from_object (input
, &istart_byte
, &iend_byte
);
2048 error ("GnuTLS cipher input extraction failed");
2050 /* Is this an AEAD cipher? */
2051 if (gnutls_cipher_get_tag_size (gca
) > 0)
2053 Lisp_Object aead_output
=
2054 gnutls_symmetric_aead (encrypting
, gca
, cipher
,
2055 kdata
, kend_byte
- kstart_byte
,
2056 vdata
, vend_byte
- vstart_byte
,
2057 idata
, iend_byte
- istart_byte
,
2059 if (STRINGP (XCAR (key
)))
2060 Fclear_string (XCAR (key
));
2064 ptrdiff_t cipher_block_size
= gnutls_cipher_get_block_size (gca
);
2065 if ((iend_byte
- istart_byte
) % cipher_block_size
!= 0)
2066 error (("GnuTLS cipher %s/%s input block length %"pD
"d is not a multiple "
2067 "of the required %"pD
"d"),
2068 gnutls_cipher_get_name (gca
), desc
,
2069 iend_byte
- istart_byte
, cipher_block_size
);
2071 gnutls_cipher_hd_t hcipher
;
2072 gnutls_datum_t key_datum
2073 = { (unsigned char *) kdata
, kend_byte
- kstart_byte
};
2075 int ret
= gnutls_cipher_init (&hcipher
, gca
, &key_datum
, NULL
);
2077 if (ret
< GNUTLS_E_SUCCESS
)
2078 error ("GnuTLS cipher %s/%s initialization failed: %s",
2079 gnutls_cipher_get_name (gca
), desc
, emacs_gnutls_strerror (ret
));
2081 /* Note that this will not support streaming block mode. */
2082 gnutls_cipher_set_iv (hcipher
, vdata
, vend_byte
- vstart_byte
);
2084 /* GnuTLS docs: "For the supported ciphers the encrypted data length
2085 will equal the plaintext size." */
2086 ptrdiff_t storage_length
= iend_byte
- istart_byte
;
2087 Lisp_Object storage
= make_uninit_string (storage_length
);
2089 ret
= ((encrypting
? gnutls_cipher_encrypt2
: gnutls_cipher_decrypt2
)
2090 (hcipher
, idata
, iend_byte
- istart_byte
,
2091 SSDATA (storage
), storage_length
));
2093 if (STRINGP (XCAR (key
)))
2094 Fclear_string (XCAR (key
));
2096 if (ret
< GNUTLS_E_SUCCESS
)
2098 gnutls_cipher_deinit (hcipher
);
2099 error ("GnuTLS cipher %s %sion failed: %s",
2100 gnutls_cipher_get_name (gca
), desc
, emacs_gnutls_strerror (ret
));
2103 gnutls_cipher_deinit (hcipher
);
2105 return list2 (storage
, actual_iv
);
2108 DEFUN ("gnutls-symmetric-encrypt", Fgnutls_symmetric_encrypt
,
2109 Sgnutls_symmetric_encrypt
, 4, 5, 0,
2110 doc
: /* Encrypt INPUT with symmetric CIPHER, KEY+AEAD_AUTH, and IV to a unibyte string.
2112 Return nil on error.
2114 The KEY can be specified as a buffer or string or in other ways (see
2115 Info node `(elisp)Format of GnuTLS Cryptography Inputs'). The KEY
2116 will be wiped after use if it's a string.
2118 The IV and INPUT and the optional AEAD_AUTH can be specified as a
2119 buffer or string or in other ways (see Info node `(elisp)Format of
2120 GnuTLS Cryptography Inputs').
2122 The alist of symmetric ciphers can be obtained with `gnutls-ciphers`.
2123 The CIPHER may be a string or symbol matching a key in that alist, or
2124 a plist with the :cipher-id numeric property, or the number itself.
2126 AEAD ciphers: these ciphers will have a `gnutls-ciphers' entry with
2127 :cipher-aead-capable set to t. AEAD_AUTH can be supplied for
2128 these AEAD ciphers, but it may still be omitted (nil) as well. */)
2129 (Lisp_Object cipher
, Lisp_Object key
, Lisp_Object iv
,
2130 Lisp_Object input
, Lisp_Object aead_auth
)
2132 return gnutls_symmetric (true, cipher
, key
, iv
, input
, aead_auth
);
2135 DEFUN ("gnutls-symmetric-decrypt", Fgnutls_symmetric_decrypt
,
2136 Sgnutls_symmetric_decrypt
, 4, 5, 0,
2137 doc
: /* Decrypt INPUT with symmetric CIPHER, KEY+AEAD_AUTH, and IV to a unibyte string.
2139 Return nil on error.
2141 The KEY can be specified as a buffer or string or in other ways (see
2142 Info node `(elisp)Format of GnuTLS Cryptography Inputs'). The KEY
2143 will be wiped after use if it's a string.
2145 The IV and INPUT and the optional AEAD_AUTH can be specified as a
2146 buffer or string or in other ways (see Info node `(elisp)Format of
2147 GnuTLS Cryptography Inputs').
2149 The alist of symmetric ciphers can be obtained with `gnutls-ciphers`.
2150 The CIPHER may be a string or symbol matching a key in that alist, or
2151 a plist with the `:cipher-id' numeric property, or the number itself.
2153 AEAD ciphers: these ciphers will have a `gnutls-ciphers' entry with
2154 :cipher-aead-capable set to t. AEAD_AUTH can be supplied for
2155 these AEAD ciphers, but it may still be omitted (nil) as well. */)
2156 (Lisp_Object cipher
, Lisp_Object key
, Lisp_Object iv
,
2157 Lisp_Object input
, Lisp_Object aead_auth
)
2159 return gnutls_symmetric (false, cipher
, key
, iv
, input
, aead_auth
);
2162 DEFUN ("gnutls-macs", Fgnutls_macs
, Sgnutls_macs
, 0, 0, 0,
2163 doc
: /* Return alist of GnuTLS mac-algorithm method descriptions as plists.
2165 Use the value of the alist (extract it with `alist-get' for instance)
2166 with `gnutls-hash-mac'. The alist key is the mac-algorithm method
2170 Lisp_Object mac_algorithms
= Qnil
;
2171 const gnutls_mac_algorithm_t
*macs
= gnutls_mac_list ();
2172 for (ptrdiff_t pos
= 0; macs
[pos
] != 0; pos
++)
2174 const gnutls_mac_algorithm_t gma
= macs
[pos
];
2176 const char *name
= gnutls_mac_get_name (gma
);
2178 Lisp_Object mp
= listn (CONSTYPE_HEAP
, 11, intern (name
),
2179 QCmac_algorithm_id
, make_number (gma
),
2180 QCtype
, Qgnutls_type_mac_algorithm
,
2182 QCmac_algorithm_length
,
2183 make_number (gnutls_hmac_get_len (gma
)),
2185 QCmac_algorithm_keysize
,
2186 make_number (gnutls_mac_get_key_size (gma
)),
2188 QCmac_algorithm_noncesize
,
2189 make_number (gnutls_mac_get_nonce_size (gma
)));
2190 mac_algorithms
= Fcons (mp
, mac_algorithms
);
2193 return mac_algorithms
;
2196 DEFUN ("gnutls-digests", Fgnutls_digests
, Sgnutls_digests
, 0, 0, 0,
2197 doc
: /* Return alist of GnuTLS digest-algorithm method descriptions as plists.
2199 Use the value of the alist (extract it with `alist-get' for instance)
2200 with `gnutls-hash-digest'. The alist key is the digest-algorithm
2204 Lisp_Object digest_algorithms
= Qnil
;
2205 const gnutls_digest_algorithm_t
*digests
= gnutls_digest_list ();
2206 for (ptrdiff_t pos
= 0; digests
[pos
] != 0; pos
++)
2208 const gnutls_digest_algorithm_t gda
= digests
[pos
];
2210 const char *name
= gnutls_digest_get_name (gda
);
2212 Lisp_Object mp
= listn (CONSTYPE_HEAP
, 7, intern (name
),
2213 QCdigest_algorithm_id
, make_number (gda
),
2214 QCtype
, Qgnutls_type_digest_algorithm
,
2216 QCdigest_algorithm_length
,
2217 make_number (gnutls_hash_get_len (gda
)));
2219 digest_algorithms
= Fcons (mp
, digest_algorithms
);
2222 return digest_algorithms
;
2225 DEFUN ("gnutls-hash-mac", Fgnutls_hash_mac
, Sgnutls_hash_mac
, 3, 3, 0,
2226 doc
: /* Hash INPUT with HASH-METHOD and KEY into a unibyte string.
2228 Return nil on error.
2230 The KEY can be specified as a buffer or string or in other ways (see
2231 Info node `(elisp)Format of GnuTLS Cryptography Inputs'). The KEY
2232 will be wiped after use if it's a string.
2234 The INPUT can be specified as a buffer or string or in other
2235 ways (see Info node `(elisp)Format of GnuTLS Cryptography Inputs').
2237 The alist of MAC algorithms can be obtained with `gnutls-macs`. The
2238 HASH-METHOD may be a string or symbol matching a key in that alist, or
2239 a plist with the `:mac-algorithm-id' numeric property, or the number
2241 (Lisp_Object hash_method
, Lisp_Object key
, Lisp_Object input
)
2243 if (BUFFERP (input
) || STRINGP (input
))
2244 input
= list1 (input
);
2248 if (BUFFERP (key
) || STRINGP (key
))
2253 gnutls_mac_algorithm_t gma
= GNUTLS_MAC_UNKNOWN
;
2255 Lisp_Object info
= Qnil
;
2256 if (STRINGP (hash_method
))
2257 hash_method
= intern (SSDATA (hash_method
));
2259 if (SYMBOLP (hash_method
))
2260 info
= XCDR (Fassq (hash_method
, Fgnutls_macs ()));
2261 else if (TYPE_RANGED_INTEGERP (gnutls_mac_algorithm_t
, hash_method
))
2262 gma
= XINT (hash_method
);
2266 if (!NILP (info
) && CONSP (info
))
2268 Lisp_Object v
= Fplist_get (info
, QCmac_algorithm_id
);
2269 if (TYPE_RANGED_INTEGERP (gnutls_mac_algorithm_t
, v
))
2273 ptrdiff_t digest_length
= gnutls_hmac_get_len (gma
);
2274 if (digest_length
== 0)
2275 error ("GnuTLS MAC-method is invalid or not found");
2277 ptrdiff_t kstart_byte
, kend_byte
;
2278 const char *kdata
= extract_data_from_object (key
, &kstart_byte
, &kend_byte
);
2280 error ("GnuTLS MAC key extraction failed");
2282 gnutls_hmac_hd_t hmac
;
2283 int ret
= gnutls_hmac_init (&hmac
, gma
,
2284 kdata
+ kstart_byte
, kend_byte
- kstart_byte
);
2285 if (ret
< GNUTLS_E_SUCCESS
)
2286 error ("GnuTLS MAC %s initialization failed: %s",
2287 gnutls_mac_get_name (gma
), emacs_gnutls_strerror (ret
));
2289 ptrdiff_t istart_byte
, iend_byte
;
2291 = extract_data_from_object (input
, &istart_byte
, &iend_byte
);
2293 error ("GnuTLS MAC input extraction failed");
2295 Lisp_Object digest
= make_uninit_string (digest_length
);
2297 ret
= gnutls_hmac (hmac
, idata
+ istart_byte
, iend_byte
- istart_byte
);
2299 if (STRINGP (XCAR (key
)))
2300 Fclear_string (XCAR (key
));
2302 if (ret
< GNUTLS_E_SUCCESS
)
2304 gnutls_hmac_deinit (hmac
, NULL
);
2305 error ("GnuTLS MAC %s application failed: %s",
2306 gnutls_mac_get_name (gma
), emacs_gnutls_strerror (ret
));
2309 gnutls_hmac_output (hmac
, SSDATA (digest
));
2310 gnutls_hmac_deinit (hmac
, NULL
);
2315 DEFUN ("gnutls-hash-digest", Fgnutls_hash_digest
, Sgnutls_hash_digest
, 2, 2, 0,
2316 doc
: /* Digest INPUT with DIGEST-METHOD into a unibyte string.
2318 Return nil on error.
2320 The INPUT can be specified as a buffer or string or in other
2321 ways (see Info node `(elisp)Format of GnuTLS Cryptography Inputs').
2323 The alist of digest algorithms can be obtained with `gnutls-digests`.
2324 The DIGEST-METHOD may be a string or symbol matching a key in that
2325 alist, or a plist with the `:digest-algorithm-id' numeric property, or
2326 the number itself. */)
2327 (Lisp_Object digest_method
, Lisp_Object input
)
2329 if (BUFFERP (input
) || STRINGP (input
))
2330 input
= list1 (input
);
2334 gnutls_digest_algorithm_t gda
= GNUTLS_DIG_UNKNOWN
;
2336 Lisp_Object info
= Qnil
;
2337 if (STRINGP (digest_method
))
2338 digest_method
= intern (SSDATA (digest_method
));
2340 if (SYMBOLP (digest_method
))
2341 info
= XCDR (Fassq (digest_method
, Fgnutls_digests ()));
2342 else if (TYPE_RANGED_INTEGERP (gnutls_digest_algorithm_t
, digest_method
))
2343 gda
= XINT (digest_method
);
2345 info
= digest_method
;
2347 if (!NILP (info
) && CONSP (info
))
2349 Lisp_Object v
= Fplist_get (info
, QCdigest_algorithm_id
);
2350 if (TYPE_RANGED_INTEGERP (gnutls_digest_algorithm_t
, v
))
2354 ptrdiff_t digest_length
= gnutls_hash_get_len (gda
);
2355 if (digest_length
== 0)
2356 error ("GnuTLS digest-method is invalid or not found");
2358 gnutls_hash_hd_t hash
;
2359 int ret
= gnutls_hash_init (&hash
, gda
);
2361 if (ret
< GNUTLS_E_SUCCESS
)
2362 error ("GnuTLS digest initialization failed: %s",
2363 emacs_gnutls_strerror (ret
));
2365 Lisp_Object digest
= make_uninit_string (digest_length
);
2367 ptrdiff_t istart_byte
, iend_byte
;
2369 = extract_data_from_object (input
, &istart_byte
, &iend_byte
);
2371 error ("GnuTLS digest input extraction failed");
2373 ret
= gnutls_hash (hash
, idata
+ istart_byte
, iend_byte
- istart_byte
);
2375 if (ret
< GNUTLS_E_SUCCESS
)
2377 gnutls_hash_deinit (hash
, NULL
);
2378 error ("GnuTLS digest application failed: %s",
2379 emacs_gnutls_strerror (ret
));
2382 gnutls_hash_output (hash
, SSDATA (digest
));
2383 gnutls_hash_deinit (hash
, NULL
);
2388 #endif /* HAVE_GNUTLS3 */
2390 DEFUN ("gnutls-available-p", Fgnutls_available_p
, Sgnutls_available_p
, 0, 0, 0,
2391 doc
: /* Return list of capabilities if GnuTLS is available in this instance of Emacs.
2393 ...if supported : then...
2394 GnuTLS 3 or higher : the list will contain `gnutls3'.
2395 GnuTLS MACs : the list will contain `macs'.
2396 GnuTLS digests : the list will contain `digests'.
2397 GnuTLS symmetric ciphers: the list will contain `ciphers'.
2398 GnuTLS AEAD ciphers : the list will contain `AEAD-ciphers'. */)
2401 Lisp_Object capabilities
= Qnil
;
2403 # ifdef HAVE_GNUTLS3
2404 capabilities
= Fcons (intern("gnutls3"), capabilities
);
2406 # ifdef HAVE_GNUTLS3_DIGEST
2407 capabilities
= Fcons (intern("digests"), capabilities
);
2410 # ifdef HAVE_GNUTLS3_CIPHER
2411 capabilities
= Fcons (intern("ciphers"), capabilities
);
2413 # ifdef HAVE_GNUTLS3_AEAD
2414 capabilities
= Fcons (intern("AEAD-ciphers"), capabilities
);
2417 # ifdef HAVE_GNUTLS3_HMAC
2418 capabilities
= Fcons (intern("macs"), capabilities
);
2420 # endif /* HAVE_GNUTLS3_CIPHER */
2421 # endif /* HAVE_GNUTLS3 */
2424 Lisp_Object found
= Fassq (Qgnutls
, Vlibrary_cache
);
2426 return XCDR (found
);
2430 status
= init_gnutls_functions () ? capabilities
: Qnil
;
2431 Vlibrary_cache
= Fcons (Fcons (Qgnutls
, status
), Vlibrary_cache
);
2434 #else /* !WINDOWSNT */
2436 return capabilities
;
2442 syms_of_gnutls (void)
2444 DEFSYM (Qlibgnutls_version
, "libgnutls-version");
2445 Fset (Qlibgnutls_version
,
2447 make_number (GNUTLS_VERSION_MAJOR
* 10000
2448 + GNUTLS_VERSION_MINOR
* 100
2449 + GNUTLS_VERSION_PATCH
)
2455 gnutls_global_initialized
= 0;
2457 DEFSYM (Qgnutls_code
, "gnutls-code");
2458 DEFSYM (Qgnutls_anon
, "gnutls-anon");
2459 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
2461 /* The following are for the property list of 'gnutls-boot'. */
2462 DEFSYM (QChostname
, ":hostname");
2463 DEFSYM (QCpriority
, ":priority");
2464 DEFSYM (QCtrustfiles
, ":trustfiles");
2465 DEFSYM (QCkeylist
, ":keylist");
2466 DEFSYM (QCcrlfiles
, ":crlfiles");
2467 DEFSYM (QCmin_prime_bits
, ":min-prime-bits");
2468 DEFSYM (QCloglevel
, ":loglevel");
2469 DEFSYM (QCcomplete_negotiation
, ":complete-negotiation");
2470 DEFSYM (QCverify_flags
, ":verify-flags");
2471 DEFSYM (QCverify_error
, ":verify-error");
2473 DEFSYM (QCcipher_id
, ":cipher-id");
2474 DEFSYM (QCcipher_aead_capable
, ":cipher-aead-capable");
2475 DEFSYM (QCcipher_blocksize
, ":cipher-blocksize");
2476 DEFSYM (QCcipher_keysize
, ":cipher-keysize");
2477 DEFSYM (QCcipher_tagsize
, ":cipher-tagsize");
2478 DEFSYM (QCcipher_keysize
, ":cipher-keysize");
2479 DEFSYM (QCcipher_ivsize
, ":cipher-ivsize");
2481 DEFSYM (QCmac_algorithm_id
, ":mac-algorithm-id");
2482 DEFSYM (QCmac_algorithm_noncesize
, ":mac-algorithm-noncesize");
2483 DEFSYM (QCmac_algorithm_keysize
, ":mac-algorithm-keysize");
2484 DEFSYM (QCmac_algorithm_length
, ":mac-algorithm-length");
2486 DEFSYM (QCdigest_algorithm_id
, ":digest-algorithm-id");
2487 DEFSYM (QCdigest_algorithm_length
, ":digest-algorithm-length");
2489 DEFSYM (QCtype
, ":type");
2490 DEFSYM (Qgnutls_type_cipher
, "gnutls-symmetric-cipher");
2491 DEFSYM (Qgnutls_type_mac_algorithm
, "gnutls-mac-algorithm");
2492 DEFSYM (Qgnutls_type_digest_algorithm
, "gnutls-digest-algorithm");
2494 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
2495 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
2496 make_number (GNUTLS_E_INTERRUPTED
));
2498 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
2499 Fput (Qgnutls_e_again
, Qgnutls_code
,
2500 make_number (GNUTLS_E_AGAIN
));
2502 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
2503 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
2504 make_number (GNUTLS_E_INVALID_SESSION
));
2506 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
2507 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
2508 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
2510 defsubr (&Sgnutls_get_initstage
);
2511 defsubr (&Sgnutls_asynchronous_parameters
);
2512 defsubr (&Sgnutls_errorp
);
2513 defsubr (&Sgnutls_error_fatalp
);
2514 defsubr (&Sgnutls_error_string
);
2515 defsubr (&Sgnutls_boot
);
2516 defsubr (&Sgnutls_deinit
);
2517 defsubr (&Sgnutls_bye
);
2518 defsubr (&Sgnutls_peer_status
);
2519 defsubr (&Sgnutls_peer_status_warning_describe
);
2521 defsubr (&Sgnutls_ciphers
);
2522 defsubr (&Sgnutls_macs
);
2523 defsubr (&Sgnutls_digests
);
2524 defsubr (&Sgnutls_hash_mac
);
2525 defsubr (&Sgnutls_hash_digest
);
2526 defsubr (&Sgnutls_symmetric_encrypt
);
2527 defsubr (&Sgnutls_symmetric_decrypt
);
2529 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
2530 doc
: /* Logging level used by the GnuTLS functions.
2531 Set this larger than 0 to get debug output in the *Messages* buffer.
2532 1 is for important messages, 2 is for debug data, and higher numbers
2533 are as per the GnuTLS logging conventions. */);
2534 global_gnutls_log_level
= 0;
2536 #endif /* HAVE_GNUTLS */
2538 defsubr (&Sgnutls_available_p
);