1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2016 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
29 #include <gnutls/gnutls.h>
36 static bool emacs_gnutls_handle_error (gnutls_session_t
, int);
38 static bool gnutls_global_initialized
;
40 static void gnutls_log_function (int, const char *);
41 static void gnutls_log_function2 (int, const char *, const char *);
43 static void gnutls_audit_log_function (gnutls_session_t
, const char *);
46 enum extra_peer_verification
48 CERTIFICATE_NOT_MATCHING
= 2
54 DEF_DLL_FN (gnutls_alert_description_t
, gnutls_alert_get
,
56 DEF_DLL_FN (const char *, gnutls_alert_get_name
,
57 (gnutls_alert_description_t
));
58 DEF_DLL_FN (int, gnutls_alert_send_appropriate
, (gnutls_session_t
, int));
59 DEF_DLL_FN (int, gnutls_anon_allocate_client_credentials
,
60 (gnutls_anon_client_credentials_t
*));
61 DEF_DLL_FN (void, gnutls_anon_free_client_credentials
,
62 (gnutls_anon_client_credentials_t
));
63 DEF_DLL_FN (int, gnutls_bye
, (gnutls_session_t
, gnutls_close_request_t
));
64 DEF_DLL_FN (int, gnutls_certificate_allocate_credentials
,
65 (gnutls_certificate_credentials_t
*));
66 DEF_DLL_FN (void, gnutls_certificate_free_credentials
,
67 (gnutls_certificate_credentials_t
));
68 DEF_DLL_FN (const gnutls_datum_t
*, gnutls_certificate_get_peers
,
69 (gnutls_session_t
, unsigned int *));
70 DEF_DLL_FN (void, gnutls_certificate_set_verify_flags
,
71 (gnutls_certificate_credentials_t
, unsigned int));
72 DEF_DLL_FN (int, gnutls_certificate_set_x509_crl_file
,
73 (gnutls_certificate_credentials_t
, const char *,
74 gnutls_x509_crt_fmt_t
));
75 DEF_DLL_FN (int, gnutls_certificate_set_x509_key_file
,
76 (gnutls_certificate_credentials_t
, const char *, const char *,
77 gnutls_x509_crt_fmt_t
));
78 # if ((GNUTLS_VERSION_MAJOR \
79 + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20)) \
81 DEF_DLL_FN (int, gnutls_certificate_set_x509_system_trust
,
82 (gnutls_certificate_credentials_t
));
84 DEF_DLL_FN (int, gnutls_certificate_set_x509_trust_file
,
85 (gnutls_certificate_credentials_t
, const char *,
86 gnutls_x509_crt_fmt_t
));
87 DEF_DLL_FN (gnutls_certificate_type_t
, gnutls_certificate_type_get
,
89 DEF_DLL_FN (int, gnutls_certificate_verify_peers2
,
90 (gnutls_session_t
, unsigned int *));
91 DEF_DLL_FN (int, gnutls_credentials_set
,
92 (gnutls_session_t
, gnutls_credentials_type_t
, void *));
93 DEF_DLL_FN (void, gnutls_deinit
, (gnutls_session_t
));
94 DEF_DLL_FN (void, gnutls_dh_set_prime_bits
,
95 (gnutls_session_t
, unsigned int));
96 DEF_DLL_FN (int, gnutls_dh_get_prime_bits
, (gnutls_session_t
));
97 DEF_DLL_FN (int, gnutls_error_is_fatal
, (int));
98 DEF_DLL_FN (int, gnutls_global_init
, (void));
99 DEF_DLL_FN (void, gnutls_global_set_log_function
, (gnutls_log_func
));
101 DEF_DLL_FN (void, gnutls_global_set_audit_log_function
, (gnutls_audit_log_func
));
103 DEF_DLL_FN (void, gnutls_global_set_log_level
, (int));
104 DEF_DLL_FN (int, gnutls_handshake
, (gnutls_session_t
));
105 DEF_DLL_FN (int, gnutls_init
, (gnutls_session_t
*, unsigned int));
106 DEF_DLL_FN (int, gnutls_priority_set_direct
,
107 (gnutls_session_t
, const char *, const char **));
108 DEF_DLL_FN (size_t, gnutls_record_check_pending
, (gnutls_session_t
));
109 DEF_DLL_FN (ssize_t
, gnutls_record_recv
, (gnutls_session_t
, void *, size_t));
110 DEF_DLL_FN (ssize_t
, gnutls_record_send
,
111 (gnutls_session_t
, const void *, size_t));
112 DEF_DLL_FN (const char *, gnutls_strerror
, (int));
113 DEF_DLL_FN (void, gnutls_transport_set_errno
, (gnutls_session_t
, int));
114 DEF_DLL_FN (const char *, gnutls_check_version
, (const char *));
115 DEF_DLL_FN (void, gnutls_transport_set_lowat
, (gnutls_session_t
, int));
116 DEF_DLL_FN (void, gnutls_transport_set_ptr2
,
117 (gnutls_session_t
, gnutls_transport_ptr_t
,
118 gnutls_transport_ptr_t
));
119 DEF_DLL_FN (void, gnutls_transport_set_pull_function
,
120 (gnutls_session_t
, gnutls_pull_func
));
121 DEF_DLL_FN (void, gnutls_transport_set_push_function
,
122 (gnutls_session_t
, gnutls_push_func
));
123 DEF_DLL_FN (int, gnutls_x509_crt_check_hostname
,
124 (gnutls_x509_crt_t
, const char *));
125 DEF_DLL_FN (int, gnutls_x509_crt_check_issuer
,
126 (gnutls_x509_crt_t
, gnutls_x509_crt_t
));
127 DEF_DLL_FN (void, gnutls_x509_crt_deinit
, (gnutls_x509_crt_t
));
128 DEF_DLL_FN (int, gnutls_x509_crt_import
,
129 (gnutls_x509_crt_t
, const gnutls_datum_t
*,
130 gnutls_x509_crt_fmt_t
));
131 DEF_DLL_FN (int, gnutls_x509_crt_init
, (gnutls_x509_crt_t
*));
132 DEF_DLL_FN (int, gnutls_x509_crt_get_fingerprint
,
134 gnutls_digest_algorithm_t
, void *, size_t *));
135 DEF_DLL_FN (int, gnutls_x509_crt_get_version
,
136 (gnutls_x509_crt_t
));
137 DEF_DLL_FN (int, gnutls_x509_crt_get_serial
,
138 (gnutls_x509_crt_t
, void *, size_t *));
139 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_dn
,
140 (gnutls_x509_crt_t
, char *, size_t *));
141 DEF_DLL_FN (time_t, gnutls_x509_crt_get_activation_time
,
142 (gnutls_x509_crt_t
));
143 DEF_DLL_FN (time_t, gnutls_x509_crt_get_expiration_time
,
144 (gnutls_x509_crt_t
));
145 DEF_DLL_FN (int, gnutls_x509_crt_get_dn
,
146 (gnutls_x509_crt_t
, char *, size_t *));
147 DEF_DLL_FN (int, gnutls_x509_crt_get_pk_algorithm
,
148 (gnutls_x509_crt_t
, unsigned int *));
149 DEF_DLL_FN (const char*, gnutls_pk_algorithm_get_name
,
150 (gnutls_pk_algorithm_t
));
151 DEF_DLL_FN (int, gnutls_pk_bits_to_sec_param
,
152 (gnutls_pk_algorithm_t
, unsigned int));
153 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_unique_id
,
154 (gnutls_x509_crt_t
, char *, size_t *));
155 DEF_DLL_FN (int, gnutls_x509_crt_get_subject_unique_id
,
156 (gnutls_x509_crt_t
, char *, size_t *));
157 DEF_DLL_FN (int, gnutls_x509_crt_get_signature_algorithm
,
158 (gnutls_x509_crt_t
));
159 DEF_DLL_FN (int, gnutls_x509_crt_get_signature
,
160 (gnutls_x509_crt_t
, char *, size_t *));
161 DEF_DLL_FN (int, gnutls_x509_crt_get_key_id
,
162 (gnutls_x509_crt_t
, unsigned int, unsigned char *, size_t *_size
));
163 DEF_DLL_FN (const char*, gnutls_sec_param_get_name
, (gnutls_sec_param_t
));
164 DEF_DLL_FN (const char*, gnutls_sign_get_name
, (gnutls_sign_algorithm_t
));
165 DEF_DLL_FN (int, gnutls_server_name_set
,
166 (gnutls_session_t
, gnutls_server_name_type_t
,
167 const void *, size_t));
168 DEF_DLL_FN (gnutls_kx_algorithm_t
, gnutls_kx_get
, (gnutls_session_t
));
169 DEF_DLL_FN (const char*, gnutls_kx_get_name
, (gnutls_kx_algorithm_t
));
170 DEF_DLL_FN (gnutls_protocol_t
, gnutls_protocol_get_version
,
172 DEF_DLL_FN (const char*, gnutls_protocol_get_name
, (gnutls_protocol_t
));
173 DEF_DLL_FN (gnutls_cipher_algorithm_t
, gnutls_cipher_get
,
175 DEF_DLL_FN (const char*, gnutls_cipher_get_name
,
176 (gnutls_cipher_algorithm_t
));
177 DEF_DLL_FN (gnutls_mac_algorithm_t
, gnutls_mac_get
, (gnutls_session_t
));
178 DEF_DLL_FN (const char*, gnutls_mac_get_name
, (gnutls_mac_algorithm_t
));
182 init_gnutls_functions (void)
185 int max_log_level
= 1;
187 if (!(library
= w32_delayed_load (Qgnutls_dll
)))
189 GNUTLS_LOG (1, max_log_level
, "GnuTLS library not found");
193 LOAD_DLL_FN (library
, gnutls_alert_get
);
194 LOAD_DLL_FN (library
, gnutls_alert_get_name
);
195 LOAD_DLL_FN (library
, gnutls_alert_send_appropriate
);
196 LOAD_DLL_FN (library
, gnutls_anon_allocate_client_credentials
);
197 LOAD_DLL_FN (library
, gnutls_anon_free_client_credentials
);
198 LOAD_DLL_FN (library
, gnutls_bye
);
199 LOAD_DLL_FN (library
, gnutls_certificate_allocate_credentials
);
200 LOAD_DLL_FN (library
, gnutls_certificate_free_credentials
);
201 LOAD_DLL_FN (library
, gnutls_certificate_get_peers
);
202 LOAD_DLL_FN (library
, gnutls_certificate_set_verify_flags
);
203 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_crl_file
);
204 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_key_file
);
205 # if ((GNUTLS_VERSION_MAJOR \
206 + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20)) \
208 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_system_trust
);
210 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_trust_file
);
211 LOAD_DLL_FN (library
, gnutls_certificate_type_get
);
212 LOAD_DLL_FN (library
, gnutls_certificate_verify_peers2
);
213 LOAD_DLL_FN (library
, gnutls_credentials_set
);
214 LOAD_DLL_FN (library
, gnutls_deinit
);
215 LOAD_DLL_FN (library
, gnutls_dh_set_prime_bits
);
216 LOAD_DLL_FN (library
, gnutls_dh_get_prime_bits
);
217 LOAD_DLL_FN (library
, gnutls_error_is_fatal
);
218 LOAD_DLL_FN (library
, gnutls_global_init
);
219 LOAD_DLL_FN (library
, gnutls_global_set_log_function
);
221 LOAD_DLL_FN (library
, gnutls_global_set_audit_log_function
);
223 LOAD_DLL_FN (library
, gnutls_global_set_log_level
);
224 LOAD_DLL_FN (library
, gnutls_handshake
);
225 LOAD_DLL_FN (library
, gnutls_init
);
226 LOAD_DLL_FN (library
, gnutls_priority_set_direct
);
227 LOAD_DLL_FN (library
, gnutls_record_check_pending
);
228 LOAD_DLL_FN (library
, gnutls_record_recv
);
229 LOAD_DLL_FN (library
, gnutls_record_send
);
230 LOAD_DLL_FN (library
, gnutls_strerror
);
231 LOAD_DLL_FN (library
, gnutls_transport_set_errno
);
232 LOAD_DLL_FN (library
, gnutls_check_version
);
233 /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
234 and later, and the function was removed entirely in 3.0.0. */
235 if (!fn_gnutls_check_version ("2.11.1"))
236 LOAD_DLL_FN (library
, gnutls_transport_set_lowat
);
237 LOAD_DLL_FN (library
, gnutls_transport_set_ptr2
);
238 LOAD_DLL_FN (library
, gnutls_transport_set_pull_function
);
239 LOAD_DLL_FN (library
, gnutls_transport_set_push_function
);
240 LOAD_DLL_FN (library
, gnutls_x509_crt_check_hostname
);
241 LOAD_DLL_FN (library
, gnutls_x509_crt_check_issuer
);
242 LOAD_DLL_FN (library
, gnutls_x509_crt_deinit
);
243 LOAD_DLL_FN (library
, gnutls_x509_crt_import
);
244 LOAD_DLL_FN (library
, gnutls_x509_crt_init
);
245 LOAD_DLL_FN (library
, gnutls_x509_crt_get_fingerprint
);
246 LOAD_DLL_FN (library
, gnutls_x509_crt_get_version
);
247 LOAD_DLL_FN (library
, gnutls_x509_crt_get_serial
);
248 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_dn
);
249 LOAD_DLL_FN (library
, gnutls_x509_crt_get_activation_time
);
250 LOAD_DLL_FN (library
, gnutls_x509_crt_get_expiration_time
);
251 LOAD_DLL_FN (library
, gnutls_x509_crt_get_dn
);
252 LOAD_DLL_FN (library
, gnutls_x509_crt_get_pk_algorithm
);
253 LOAD_DLL_FN (library
, gnutls_pk_algorithm_get_name
);
254 LOAD_DLL_FN (library
, gnutls_pk_bits_to_sec_param
);
255 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_unique_id
);
256 LOAD_DLL_FN (library
, gnutls_x509_crt_get_subject_unique_id
);
257 LOAD_DLL_FN (library
, gnutls_x509_crt_get_signature_algorithm
);
258 LOAD_DLL_FN (library
, gnutls_x509_crt_get_signature
);
259 LOAD_DLL_FN (library
, gnutls_x509_crt_get_key_id
);
260 LOAD_DLL_FN (library
, gnutls_sec_param_get_name
);
261 LOAD_DLL_FN (library
, gnutls_sign_get_name
);
262 LOAD_DLL_FN (library
, gnutls_server_name_set
);
263 LOAD_DLL_FN (library
, gnutls_kx_get
);
264 LOAD_DLL_FN (library
, gnutls_kx_get_name
);
265 LOAD_DLL_FN (library
, gnutls_protocol_get_version
);
266 LOAD_DLL_FN (library
, gnutls_protocol_get_name
);
267 LOAD_DLL_FN (library
, gnutls_cipher_get
);
268 LOAD_DLL_FN (library
, gnutls_cipher_get_name
);
269 LOAD_DLL_FN (library
, gnutls_mac_get
);
270 LOAD_DLL_FN (library
, gnutls_mac_get_name
);
272 max_log_level
= global_gnutls_log_level
;
275 Lisp_Object name
= CAR_SAFE (Fget (Qgnutls_dll
, QCloaded_from
));
276 GNUTLS_LOG2 (1, max_log_level
, "GnuTLS library loaded:",
277 STRINGP (name
) ? (const char *) SDATA (name
) : "unknown");
283 # define gnutls_alert_get fn_gnutls_alert_get
284 # define gnutls_alert_get_name fn_gnutls_alert_get_name
285 # define gnutls_alert_send_appropriate fn_gnutls_alert_send_appropriate
286 # define gnutls_anon_allocate_client_credentials fn_gnutls_anon_allocate_client_credentials
287 # define gnutls_anon_free_client_credentials fn_gnutls_anon_free_client_credentials
288 # define gnutls_bye fn_gnutls_bye
289 # define gnutls_certificate_allocate_credentials fn_gnutls_certificate_allocate_credentials
290 # define gnutls_certificate_free_credentials fn_gnutls_certificate_free_credentials
291 # define gnutls_certificate_get_peers fn_gnutls_certificate_get_peers
292 # define gnutls_certificate_set_verify_flags fn_gnutls_certificate_set_verify_flags
293 # define gnutls_certificate_set_x509_crl_file fn_gnutls_certificate_set_x509_crl_file
294 # define gnutls_certificate_set_x509_key_file fn_gnutls_certificate_set_x509_key_file
295 # define gnutls_certificate_set_x509_system_trust fn_gnutls_certificate_set_x509_system_trust
296 # define gnutls_certificate_set_x509_trust_file fn_gnutls_certificate_set_x509_trust_file
297 # define gnutls_certificate_type_get fn_gnutls_certificate_type_get
298 # define gnutls_certificate_verify_peers2 fn_gnutls_certificate_verify_peers2
299 # define gnutls_check_version fn_gnutls_check_version
300 # define gnutls_cipher_get fn_gnutls_cipher_get
301 # define gnutls_cipher_get_name fn_gnutls_cipher_get_name
302 # define gnutls_credentials_set fn_gnutls_credentials_set
303 # define gnutls_deinit fn_gnutls_deinit
304 # define gnutls_dh_get_prime_bits fn_gnutls_dh_get_prime_bits
305 # define gnutls_dh_set_prime_bits fn_gnutls_dh_set_prime_bits
306 # define gnutls_error_is_fatal fn_gnutls_error_is_fatal
307 # define gnutls_global_init fn_gnutls_global_init
308 # define gnutls_global_set_audit_log_function fn_gnutls_global_set_audit_log_function
309 # define gnutls_global_set_log_function fn_gnutls_global_set_log_function
310 # define gnutls_global_set_log_level fn_gnutls_global_set_log_level
311 # define gnutls_handshake fn_gnutls_handshake
312 # define gnutls_init fn_gnutls_init
313 # define gnutls_kx_get fn_gnutls_kx_get
314 # define gnutls_kx_get_name fn_gnutls_kx_get_name
315 # define gnutls_mac_get fn_gnutls_mac_get
316 # define gnutls_mac_get_name fn_gnutls_mac_get_name
317 # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name
318 # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param
319 # define gnutls_priority_set_direct fn_gnutls_priority_set_direct
320 # define gnutls_protocol_get_name fn_gnutls_protocol_get_name
321 # define gnutls_protocol_get_version fn_gnutls_protocol_get_version
322 # define gnutls_record_check_pending fn_gnutls_record_check_pending
323 # define gnutls_record_recv fn_gnutls_record_recv
324 # define gnutls_record_send fn_gnutls_record_send
325 # define gnutls_sec_param_get_name fn_gnutls_sec_param_get_name
326 # define gnutls_server_name_set fn_gnutls_server_name_set
327 # define gnutls_sign_get_name fn_gnutls_sign_get_name
328 # define gnutls_strerror fn_gnutls_strerror
329 # define gnutls_transport_set_errno fn_gnutls_transport_set_errno
330 # define gnutls_transport_set_lowat fn_gnutls_transport_set_lowat
331 # define gnutls_transport_set_ptr2 fn_gnutls_transport_set_ptr2
332 # define gnutls_transport_set_pull_function fn_gnutls_transport_set_pull_function
333 # define gnutls_transport_set_push_function fn_gnutls_transport_set_push_function
334 # define gnutls_x509_crt_check_hostname fn_gnutls_x509_crt_check_hostname
335 # define gnutls_x509_crt_check_issuer fn_gnutls_x509_crt_check_issuer
336 # define gnutls_x509_crt_deinit fn_gnutls_x509_crt_deinit
337 # define gnutls_x509_crt_get_activation_time fn_gnutls_x509_crt_get_activation_time
338 # define gnutls_x509_crt_get_dn fn_gnutls_x509_crt_get_dn
339 # define gnutls_x509_crt_get_expiration_time fn_gnutls_x509_crt_get_expiration_time
340 # define gnutls_x509_crt_get_fingerprint fn_gnutls_x509_crt_get_fingerprint
341 # define gnutls_x509_crt_get_issuer_dn fn_gnutls_x509_crt_get_issuer_dn
342 # define gnutls_x509_crt_get_issuer_unique_id fn_gnutls_x509_crt_get_issuer_unique_id
343 # define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id
344 # define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm
345 # define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial
346 # define gnutls_x509_crt_get_signature fn_gnutls_x509_crt_get_signature
347 # define gnutls_x509_crt_get_signature_algorithm fn_gnutls_x509_crt_get_signature_algorithm
348 # define gnutls_x509_crt_get_subject_unique_id fn_gnutls_x509_crt_get_subject_unique_id
349 # define gnutls_x509_crt_get_version fn_gnutls_x509_crt_get_version
350 # define gnutls_x509_crt_import fn_gnutls_x509_crt_import
351 # define gnutls_x509_crt_init fn_gnutls_x509_crt_init
356 /* Report memory exhaustion if ERR is an out-of-memory indication. */
358 check_memory_full (int err
)
360 /* When GnuTLS exhausts memory, it doesn't say how much memory it
361 asked for, so tell the Emacs allocator that GnuTLS asked for no
362 bytes. This isn't accurate, but it's good enough. */
363 if (err
== GNUTLS_E_MEMORY_ERROR
)
368 /* Log a simple audit message. */
370 gnutls_audit_log_function (gnutls_session_t session
, const char *string
)
372 if (global_gnutls_log_level
>= 1)
374 message ("gnutls.c: [audit] %s", string
);
379 /* Log a simple message. */
381 gnutls_log_function (int level
, const char *string
)
383 message ("gnutls.c: [%d] %s", level
, string
);
386 /* Log a message and a string. */
388 gnutls_log_function2 (int level
, const char *string
, const char *extra
)
390 message ("gnutls.c: [%d] %s %s", level
, string
, extra
);
393 /* Log a message and an integer. */
395 gnutls_log_function2i (int level
, const char *string
, int extra
)
397 message ("gnutls.c: [%d] %s %d", level
, string
, extra
);
401 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
403 gnutls_session_t state
= proc
->gnutls_state
;
406 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
409 if (proc
->gnutls_initstage
< GNUTLS_STAGE_TRANSPORT_POINTERS_SET
)
412 /* On W32 we cannot transfer socket handles between different runtime
413 libraries, so we tell GnuTLS to use our special push/pull
415 gnutls_transport_set_ptr2 (state
,
416 (gnutls_transport_ptr_t
) proc
,
417 (gnutls_transport_ptr_t
) proc
);
418 gnutls_transport_set_push_function (state
, &emacs_gnutls_push
);
419 gnutls_transport_set_pull_function (state
, &emacs_gnutls_pull
);
421 /* For non blocking sockets or other custom made pull/push
422 functions the gnutls_transport_set_lowat must be called, with
423 a zero low water mark value. (GnuTLS 2.10.4 documentation)
425 (Note: this is probably not strictly necessary as the lowat
426 value is only used when no custom pull/push functions are
428 /* According to GnuTLS NEWS file, lowat level has been set to
429 zero by default in version 2.11.1, and the function
430 gnutls_transport_set_lowat was removed from the library in
432 if (!gnutls_check_version ("2.11.1"))
433 gnutls_transport_set_lowat (state
, 0);
435 /* This is how GnuTLS takes sockets: as file descriptors passed
436 in. For an Emacs process socket, infd and outfd are the
437 same but we use this two-argument version for clarity. */
438 gnutls_transport_set_ptr2 (state
,
439 (void *) (intptr_t) proc
->infd
,
440 (void *) (intptr_t) proc
->outfd
);
443 proc
->gnutls_initstage
= GNUTLS_STAGE_TRANSPORT_POINTERS_SET
;
448 ret
= gnutls_handshake (state
);
449 emacs_gnutls_handle_error (state
, ret
);
452 while (ret
< 0 && gnutls_error_is_fatal (ret
) == 0);
454 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
456 if (ret
== GNUTLS_E_SUCCESS
)
458 /* Here we're finally done. */
459 proc
->gnutls_initstage
= GNUTLS_STAGE_READY
;
463 check_memory_full (gnutls_alert_send_appropriate (state
, ret
));
469 emacs_gnutls_record_check_pending (gnutls_session_t state
)
471 return gnutls_record_check_pending (state
);
476 emacs_gnutls_transport_set_errno (gnutls_session_t state
, int err
)
478 gnutls_transport_set_errno (state
, err
);
483 emacs_gnutls_write (struct Lisp_Process
*proc
, const char *buf
, ptrdiff_t nbyte
)
486 ptrdiff_t bytes_written
;
487 gnutls_session_t state
= proc
->gnutls_state
;
489 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
499 rtnval
= gnutls_record_send (state
, buf
, nbyte
);
503 if (rtnval
== GNUTLS_E_INTERRUPTED
)
507 /* If we get GNUTLS_E_AGAIN, then set errno
508 appropriately so that send_process retries the
509 correct way instead of erroring out. */
510 if (rtnval
== GNUTLS_E_AGAIN
)
518 bytes_written
+= rtnval
;
521 emacs_gnutls_handle_error (state
, rtnval
);
522 return (bytes_written
);
526 emacs_gnutls_read (struct Lisp_Process
*proc
, char *buf
, ptrdiff_t nbyte
)
529 gnutls_session_t state
= proc
->gnutls_state
;
531 int log_level
= proc
->gnutls_log_level
;
533 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
535 /* If the handshake count is under the limit, try the handshake
536 again and increment the handshake count. This count is kept
537 per process (connection), not globally. */
538 if (proc
->gnutls_handshakes_tried
< GNUTLS_EMACS_HANDSHAKES_LIMIT
)
540 proc
->gnutls_handshakes_tried
++;
541 emacs_gnutls_handshake (proc
);
542 GNUTLS_LOG2i (5, log_level
, "Retried handshake",
543 proc
->gnutls_handshakes_tried
);
547 GNUTLS_LOG (2, log_level
, "Giving up on handshake; resetting retries");
548 proc
->gnutls_handshakes_tried
= 0;
551 rtnval
= gnutls_record_recv (state
, buf
, nbyte
);
554 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
555 /* The peer closed the connection. */
557 else if (emacs_gnutls_handle_error (state
, rtnval
))
558 /* non-fatal error */
561 /* a fatal error occurred */
566 /* Report a GnuTLS error to the user.
567 Return true if the error code was successfully handled. */
569 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
571 int max_log_level
= 0;
576 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
580 check_memory_full (err
);
582 max_log_level
= global_gnutls_log_level
;
584 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
586 str
= gnutls_strerror (err
);
590 if (gnutls_error_is_fatal (err
))
593 GNUTLS_LOG2 (1, max_log_level
, "fatal error:", str
);
614 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
615 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
617 int alert
= gnutls_alert_get (session
);
618 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
619 str
= gnutls_alert_get_name (alert
);
623 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
628 /* convert an integer error to a Lisp_Object; it will be either a
629 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
630 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
633 gnutls_make_error (int err
)
637 case GNUTLS_E_SUCCESS
:
640 return Qgnutls_e_again
;
641 case GNUTLS_E_INTERRUPTED
:
642 return Qgnutls_e_interrupted
;
643 case GNUTLS_E_INVALID_SESSION
:
644 return Qgnutls_e_invalid_session
;
647 check_memory_full (err
);
648 return make_number (err
);
652 emacs_gnutls_deinit (Lisp_Object proc
)
656 CHECK_PROCESS (proc
);
658 if (XPROCESS (proc
)->gnutls_p
== 0)
661 log_level
= XPROCESS (proc
)->gnutls_log_level
;
663 if (XPROCESS (proc
)->gnutls_x509_cred
)
665 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
666 gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
667 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
670 if (XPROCESS (proc
)->gnutls_anon_cred
)
672 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
673 gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
674 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
677 if (XPROCESS (proc
)->gnutls_state
)
679 gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
680 XPROCESS (proc
)->gnutls_state
= NULL
;
681 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
682 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
685 XPROCESS (proc
)->gnutls_p
= 0;
689 DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters
,
690 Sgnutls_asynchronous_parameters
, 2, 2, 0,
691 doc
: /* Mark this process as being a pre-init GnuTLS process.
692 The second parameter is the list of parameters to feed to gnutls-boot
693 to finish setting up the connection. */)
694 (Lisp_Object proc
, Lisp_Object params
)
696 CHECK_PROCESS (proc
);
698 XPROCESS (proc
)->gnutls_boot_parameters
= params
;
702 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
703 doc
: /* Return the GnuTLS init stage of process PROC.
704 See also `gnutls-boot'. */)
707 CHECK_PROCESS (proc
);
709 return make_number (GNUTLS_INITSTAGE (proc
));
712 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
713 doc
: /* Return t if ERROR indicates a GnuTLS problem.
714 ERROR is an integer or a symbol with an integer `gnutls-code' property.
715 usage: (gnutls-errorp ERROR) */
719 if (EQ (err
, Qt
)) return Qnil
;
724 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
725 doc
: /* Return non-nil if ERROR is fatal.
726 ERROR is an integer or a symbol with an integer `gnutls-code' property.
727 Usage: (gnutls-error-fatalp ERROR) */)
732 if (EQ (err
, Qt
)) return Qnil
;
736 code
= Fget (err
, Qgnutls_code
);
743 error ("Symbol has no numeric gnutls-code property");
747 if (! TYPE_RANGED_INTEGERP (int, err
))
748 error ("Not an error symbol or code");
750 if (0 == gnutls_error_is_fatal (XINT (err
)))
756 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
757 doc
: /* Return a description of ERROR.
758 ERROR is an integer or a symbol with an integer `gnutls-code' property.
759 usage: (gnutls-error-string ERROR) */)
764 if (EQ (err
, Qt
)) return build_string ("Not an error");
768 code
= Fget (err
, Qgnutls_code
);
775 return build_string ("Symbol has no numeric gnutls-code property");
779 if (! TYPE_RANGED_INTEGERP (int, err
))
780 return build_string ("Not an error symbol or code");
782 return build_string (gnutls_strerror (XINT (err
)));
785 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
786 doc
: /* Deallocate GnuTLS resources associated with process PROC.
787 See also `gnutls-init'. */)
790 return emacs_gnutls_deinit (proc
);
794 gnutls_hex_string (unsigned char *buf
, ptrdiff_t buf_size
, const char *prefix
)
796 ptrdiff_t prefix_length
= strlen (prefix
);
798 if (INT_MULTIPLY_WRAPV (buf_size
, 3, &retlen
)
799 || INT_ADD_WRAPV (prefix_length
- (buf_size
!= 0), retlen
, &retlen
))
801 Lisp_Object ret
= make_uninit_string (retlen
);
802 char *string
= SSDATA (ret
);
803 strcpy (string
, prefix
);
805 for (ptrdiff_t i
= 0; i
< buf_size
; i
++)
806 sprintf (string
+ i
* 3 + prefix_length
,
807 i
== buf_size
- 1 ? "%02x" : "%02x:",
814 gnutls_certificate_details (gnutls_x509_crt_t cert
)
816 Lisp_Object res
= Qnil
;
822 int version
= gnutls_x509_crt_get_version (cert
);
823 check_memory_full (version
);
824 if (version
>= GNUTLS_E_SUCCESS
)
825 res
= nconc2 (res
, list2 (intern (":version"),
826 make_number (version
)));
831 err
= gnutls_x509_crt_get_serial (cert
, NULL
, &buf_size
);
832 check_memory_full (err
);
833 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
835 void *serial
= xmalloc (buf_size
);
836 err
= gnutls_x509_crt_get_serial (cert
, serial
, &buf_size
);
837 check_memory_full (err
);
838 if (err
>= GNUTLS_E_SUCCESS
)
839 res
= nconc2 (res
, list2 (intern (":serial-number"),
840 gnutls_hex_string (serial
, buf_size
, "")));
846 err
= gnutls_x509_crt_get_issuer_dn (cert
, NULL
, &buf_size
);
847 check_memory_full (err
);
848 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
850 char *dn
= xmalloc (buf_size
);
851 err
= gnutls_x509_crt_get_issuer_dn (cert
, dn
, &buf_size
);
852 check_memory_full (err
);
853 if (err
>= GNUTLS_E_SUCCESS
)
854 res
= nconc2 (res
, list2 (intern (":issuer"),
855 make_string (dn
, buf_size
)));
861 /* Add 1 to the buffer size, since 1900 is added to tm_year and
862 that might add 1 to the year length. */
863 char buf
[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
865 time_t tim
= gnutls_x509_crt_get_activation_time (cert
);
867 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
868 res
= nconc2 (res
, list2 (intern (":valid-from"), build_string (buf
)));
870 tim
= gnutls_x509_crt_get_expiration_time (cert
);
871 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
872 res
= nconc2 (res
, list2 (intern (":valid-to"), build_string (buf
)));
877 err
= gnutls_x509_crt_get_dn (cert
, NULL
, &buf_size
);
878 check_memory_full (err
);
879 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
881 char *dn
= xmalloc (buf_size
);
882 err
= gnutls_x509_crt_get_dn (cert
, dn
, &buf_size
);
883 check_memory_full (err
);
884 if (err
>= GNUTLS_E_SUCCESS
)
885 res
= nconc2 (res
, list2 (intern (":subject"),
886 make_string (dn
, buf_size
)));
890 /* Versions older than 2.11 doesn't have these four functions. */
891 #if GNUTLS_VERSION_NUMBER >= 0x020b00
892 /* SubjectPublicKeyInfo. */
896 err
= gnutls_x509_crt_get_pk_algorithm (cert
, &bits
);
897 check_memory_full (err
);
898 if (err
>= GNUTLS_E_SUCCESS
)
900 const char *name
= gnutls_pk_algorithm_get_name (err
);
902 res
= nconc2 (res
, list2 (intern (":public-key-algorithm"),
903 build_string (name
)));
905 name
= gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
907 res
= nconc2 (res
, list2 (intern (":certificate-security-level"),
908 build_string (name
)));
914 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, NULL
, &buf_size
);
915 check_memory_full (err
);
916 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
918 char *buf
= xmalloc (buf_size
);
919 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, buf
, &buf_size
);
920 check_memory_full (err
);
921 if (err
>= GNUTLS_E_SUCCESS
)
922 res
= nconc2 (res
, list2 (intern (":issuer-unique-id"),
923 make_string (buf
, buf_size
)));
928 err
= gnutls_x509_crt_get_subject_unique_id (cert
, NULL
, &buf_size
);
929 check_memory_full (err
);
930 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
932 char *buf
= xmalloc (buf_size
);
933 err
= gnutls_x509_crt_get_subject_unique_id (cert
, buf
, &buf_size
);
934 check_memory_full (err
);
935 if (err
>= GNUTLS_E_SUCCESS
)
936 res
= nconc2 (res
, list2 (intern (":subject-unique-id"),
937 make_string (buf
, buf_size
)));
943 err
= gnutls_x509_crt_get_signature_algorithm (cert
);
944 check_memory_full (err
);
945 if (err
>= GNUTLS_E_SUCCESS
)
947 const char *name
= gnutls_sign_get_name (err
);
949 res
= nconc2 (res
, list2 (intern (":signature-algorithm"),
950 build_string (name
)));
955 err
= gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
956 check_memory_full (err
);
957 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
959 void *buf
= xmalloc (buf_size
);
960 err
= gnutls_x509_crt_get_key_id (cert
, 0, buf
, &buf_size
);
961 check_memory_full (err
);
962 if (err
>= GNUTLS_E_SUCCESS
)
963 res
= nconc2 (res
, list2 (intern (":public-key-id"),
964 gnutls_hex_string (buf
, buf_size
, "sha1:")));
968 /* Certificate fingerprint. */
970 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
972 check_memory_full (err
);
973 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
975 void *buf
= xmalloc (buf_size
);
976 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
978 check_memory_full (err
);
979 if (err
>= GNUTLS_E_SUCCESS
)
980 res
= nconc2 (res
, list2 (intern (":certificate-id"),
981 gnutls_hex_string (buf
, buf_size
, "sha1:")));
988 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
989 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
990 (Lisp_Object status_symbol
)
992 CHECK_SYMBOL (status_symbol
);
994 if (EQ (status_symbol
, intern (":invalid")))
995 return build_string ("certificate could not be verified");
997 if (EQ (status_symbol
, intern (":revoked")))
998 return build_string ("certificate was revoked (CRL)");
1000 if (EQ (status_symbol
, intern (":self-signed")))
1001 return build_string ("certificate signer was not found (self-signed)");
1003 if (EQ (status_symbol
, intern (":unknown-ca")))
1004 return build_string ("the certificate was signed by an unknown "
1005 "and therefore untrusted authority");
1007 if (EQ (status_symbol
, intern (":not-ca")))
1008 return build_string ("certificate signer is not a CA");
1010 if (EQ (status_symbol
, intern (":insecure")))
1011 return build_string ("certificate was signed with an insecure algorithm");
1013 if (EQ (status_symbol
, intern (":not-activated")))
1014 return build_string ("certificate is not yet activated");
1016 if (EQ (status_symbol
, intern (":expired")))
1017 return build_string ("certificate has expired");
1019 if (EQ (status_symbol
, intern (":no-host-match")))
1020 return build_string ("certificate host does not match hostname");
1025 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
1026 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1027 The return value is a property list with top-level keys :warnings and
1028 :certificate. The :warnings entry is a list of symbols you can describe with
1029 `gnutls-peer-status-warning-describe'. */)
1032 Lisp_Object warnings
= Qnil
, result
= Qnil
;
1033 unsigned int verification
;
1034 gnutls_session_t state
;
1036 CHECK_PROCESS (proc
);
1038 if (GNUTLS_INITSTAGE (proc
) < GNUTLS_STAGE_INIT
)
1041 /* Then collect any warnings already computed by the handshake. */
1042 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
1044 if (verification
& GNUTLS_CERT_INVALID
)
1045 warnings
= Fcons (intern (":invalid"), warnings
);
1047 if (verification
& GNUTLS_CERT_REVOKED
)
1048 warnings
= Fcons (intern (":revoked"), warnings
);
1050 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1051 warnings
= Fcons (intern (":unknown-ca"), warnings
);
1053 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1054 warnings
= Fcons (intern (":not-ca"), warnings
);
1056 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1057 warnings
= Fcons (intern (":insecure"), warnings
);
1059 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1060 warnings
= Fcons (intern (":not-activated"), warnings
);
1062 if (verification
& GNUTLS_CERT_EXPIRED
)
1063 warnings
= Fcons (intern (":expired"), warnings
);
1065 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1066 CERTIFICATE_NOT_MATCHING
)
1067 warnings
= Fcons (intern (":no-host-match"), warnings
);
1069 /* This could get called in the INIT stage, when the certificate is
1071 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
&&
1072 gnutls_x509_crt_check_issuer(XPROCESS (proc
)->gnutls_certificate
,
1073 XPROCESS (proc
)->gnutls_certificate
))
1074 warnings
= Fcons (intern (":self-signed"), warnings
);
1076 if (!NILP (warnings
))
1077 result
= list2 (intern (":warnings"), warnings
);
1079 /* This could get called in the INIT stage, when the certificate is
1081 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1082 result
= nconc2 (result
, list2
1083 (intern (":certificate"),
1084 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1086 state
= XPROCESS (proc
)->gnutls_state
;
1088 /* Diffie-Hellman prime bits. */
1090 int bits
= gnutls_dh_get_prime_bits (state
);
1091 check_memory_full (bits
);
1093 result
= nconc2 (result
, list2 (intern (":diffie-hellman-prime-bits"),
1094 make_number (bits
)));
1099 (result
, list2 (intern (":key-exchange"),
1100 build_string (gnutls_kx_get_name
1101 (gnutls_kx_get (state
)))));
1103 /* Protocol name. */
1105 (result
, list2 (intern (":protocol"),
1106 build_string (gnutls_protocol_get_name
1107 (gnutls_protocol_get_version (state
)))));
1111 (result
, list2 (intern (":cipher"),
1112 build_string (gnutls_cipher_get_name
1113 (gnutls_cipher_get (state
)))));
1117 (result
, list2 (intern (":mac"),
1118 build_string (gnutls_mac_get_name
1119 (gnutls_mac_get (state
)))));
1125 /* Initialize global GnuTLS state to defaults.
1126 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1127 Return zero on success. */
1129 emacs_gnutls_global_init (void)
1131 int ret
= GNUTLS_E_SUCCESS
;
1133 if (!gnutls_global_initialized
)
1135 ret
= gnutls_global_init ();
1136 if (ret
== GNUTLS_E_SUCCESS
)
1137 gnutls_global_initialized
= 1;
1140 return gnutls_make_error (ret
);
1144 gnutls_ip_address_p (char *string
)
1148 while ((c
= *string
++) != 0)
1149 if (! ((c
== '.' || c
== ':' || (c
>= '0' && c
<= '9'))))
1156 /* Deinitialize global GnuTLS state.
1157 See also `gnutls-global-init'. */
1159 emacs_gnutls_global_deinit (void)
1161 if (gnutls_global_initialized
)
1162 gnutls_global_deinit ();
1164 gnutls_global_initialized
= 0;
1166 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1172 boot_error (struct Lisp_Process
*p
, const char *m
, ...)
1176 if (p
->is_non_blocking_client
)
1177 pset_status (p
, list2 (Qfailed
, vformat_string (m
, ap
)));
1183 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
1184 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1185 Currently only client mode is supported. Return a success/failure
1186 value you can check with `gnutls-errorp'.
1188 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1189 PROPLIST is a property list with the following keys:
1191 :hostname is a string naming the remote host.
1193 :priority is a GnuTLS priority string, defaults to "NORMAL".
1195 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1197 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1199 :keylist is an alist of PEM-encoded key files and PEM-encoded
1200 certificates for `gnutls-x509pki'.
1202 :callbacks is an alist of callback functions, see below.
1204 :loglevel is the debug level requested from GnuTLS, try 4.
1206 :verify-flags is a bitset as per GnuTLS'
1207 gnutls_certificate_set_verify_flags.
1209 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1212 :verify-error is a list of symbols to express verification checks or
1213 t to do all checks. Currently it can contain `:trustfiles' and
1214 `:hostname' to verify the certificate or the hostname respectively.
1216 :min-prime-bits is the minimum accepted number of bits the client will
1217 accept in Diffie-Hellman key exchange.
1219 The debug level will be set for this process AND globally for GnuTLS.
1220 So if you set it higher or lower at any point, it affects global
1223 Note that the priority is set on the client. The server does not use
1224 the protocols's priority except for disabling protocols that were not
1227 Processes must be initialized with this function before other GnuTLS
1228 functions are used. This function allocates resources which can only
1229 be deallocated by calling `gnutls-deinit' or by calling it again.
1231 The callbacks alist can have a `verify' key, associated with a
1232 verification function (UNUSED).
1234 Each authentication type may need additional information in order to
1235 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1236 one trustfile (usually a CA bundle). */)
1237 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
1239 int ret
= GNUTLS_E_SUCCESS
;
1240 int max_log_level
= 0;
1241 bool verify_error_all
= 0;
1243 gnutls_session_t state
;
1244 gnutls_certificate_credentials_t x509_cred
= NULL
;
1245 gnutls_anon_client_credentials_t anon_cred
= NULL
;
1246 Lisp_Object global_init
;
1247 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
1248 unsigned int peer_verification
;
1251 /* Placeholders for the property list elements. */
1252 Lisp_Object priority_string
;
1253 Lisp_Object trustfiles
;
1254 Lisp_Object crlfiles
;
1255 Lisp_Object keylist
;
1256 /* Lisp_Object callbacks; */
1257 Lisp_Object loglevel
;
1258 Lisp_Object hostname
;
1259 Lisp_Object verify_error
;
1260 Lisp_Object prime_bits
;
1261 Lisp_Object warnings
;
1262 struct Lisp_Process
*p
= XPROCESS (proc
);
1264 CHECK_PROCESS (proc
);
1265 CHECK_SYMBOL (type
);
1266 CHECK_LIST (proplist
);
1268 if (NILP (Fgnutls_available_p ()))
1270 boot_error (p
, "GnuTLS not available");
1274 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
1276 boot_error (p
, "Invalid GnuTLS credential type");
1280 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1281 priority_string
= Fplist_get (proplist
, QCgnutls_bootprop_priority
);
1282 trustfiles
= Fplist_get (proplist
, QCgnutls_bootprop_trustfiles
);
1283 keylist
= Fplist_get (proplist
, QCgnutls_bootprop_keylist
);
1284 crlfiles
= Fplist_get (proplist
, QCgnutls_bootprop_crlfiles
);
1285 loglevel
= Fplist_get (proplist
, QCgnutls_bootprop_loglevel
);
1286 verify_error
= Fplist_get (proplist
, QCgnutls_bootprop_verify_error
);
1287 prime_bits
= Fplist_get (proplist
, QCgnutls_bootprop_min_prime_bits
);
1289 if (EQ (verify_error
, Qt
))
1291 verify_error_all
= 1;
1293 else if (NILP (Flistp (verify_error
)))
1295 boot_error (p
, "gnutls-boot: invalid :verify_error parameter (not a list)");
1299 if (!STRINGP (hostname
))
1301 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1304 c_hostname
= SSDATA (hostname
);
1306 state
= XPROCESS (proc
)->gnutls_state
;
1308 if (TYPE_RANGED_INTEGERP (int, loglevel
))
1310 gnutls_global_set_log_function (gnutls_log_function
);
1312 gnutls_global_set_audit_log_function (gnutls_audit_log_function
);
1314 gnutls_global_set_log_level (XINT (loglevel
));
1315 max_log_level
= XINT (loglevel
);
1316 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
1319 GNUTLS_LOG2 (1, max_log_level
, "connecting to host:", c_hostname
);
1321 /* Always initialize globals. */
1322 global_init
= emacs_gnutls_global_init ();
1323 if (! NILP (Fgnutls_errorp (global_init
)))
1326 /* Before allocating new credentials, deallocate any credentials
1327 that PROC might already have. */
1328 emacs_gnutls_deinit (proc
);
1330 /* Mark PROC as a GnuTLS process. */
1331 XPROCESS (proc
)->gnutls_state
= NULL
;
1332 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
1333 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
1334 pset_gnutls_cred_type (XPROCESS (proc
), type
);
1335 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
1337 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
1338 if (EQ (type
, Qgnutls_x509pki
))
1340 Lisp_Object verify_flags
;
1341 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
1343 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
1344 check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred
));
1345 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
1347 verify_flags
= Fplist_get (proplist
, QCgnutls_bootprop_verify_flags
);
1348 if (NUMBERP (verify_flags
))
1350 gnutls_verify_flags
= XINT (verify_flags
);
1351 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
1353 else if (NILP (verify_flags
))
1354 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
1356 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
1358 gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
1360 else /* Qgnutls_anon: */
1362 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
1363 check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred
));
1364 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
1367 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
1369 if (EQ (type
, Qgnutls_x509pki
))
1371 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1372 int file_format
= GNUTLS_X509_FMT_PEM
;
1375 #if GNUTLS_VERSION_MAJOR + \
1376 (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
1377 ret
= gnutls_certificate_set_x509_system_trust (x509_cred
);
1378 if (ret
< GNUTLS_E_SUCCESS
)
1380 check_memory_full (ret
);
1381 GNUTLS_LOG2i (4, max_log_level
,
1382 "setting system trust failed with code ", ret
);
1386 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
1388 Lisp_Object trustfile
= XCAR (tail
);
1389 if (STRINGP (trustfile
))
1391 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
1392 SSDATA (trustfile
));
1393 trustfile
= ENCODE_FILE (trustfile
);
1395 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1396 file names on Windows, we need to re-encode the file
1397 name using the current ANSI codepage. */
1398 trustfile
= ansi_encode_filename (trustfile
);
1400 ret
= gnutls_certificate_set_x509_trust_file
1405 if (ret
< GNUTLS_E_SUCCESS
)
1406 return gnutls_make_error (ret
);
1410 emacs_gnutls_deinit (proc
);
1411 boot_error (p
, "Invalid trustfile");
1416 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
1418 Lisp_Object crlfile
= XCAR (tail
);
1419 if (STRINGP (crlfile
))
1421 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
1423 crlfile
= ENCODE_FILE (crlfile
);
1425 crlfile
= ansi_encode_filename (crlfile
);
1427 ret
= gnutls_certificate_set_x509_crl_file
1428 (x509_cred
, SSDATA (crlfile
), file_format
);
1430 if (ret
< GNUTLS_E_SUCCESS
)
1431 return gnutls_make_error (ret
);
1435 emacs_gnutls_deinit (proc
);
1436 boot_error (p
, "Invalid CRL file");
1441 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
1443 Lisp_Object keyfile
= Fcar (XCAR (tail
));
1444 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
1445 if (STRINGP (keyfile
) && STRINGP (certfile
))
1447 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
1449 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
1451 keyfile
= ENCODE_FILE (keyfile
);
1452 certfile
= ENCODE_FILE (certfile
);
1454 keyfile
= ansi_encode_filename (keyfile
);
1455 certfile
= ansi_encode_filename (certfile
);
1457 ret
= gnutls_certificate_set_x509_key_file
1458 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
1460 if (ret
< GNUTLS_E_SUCCESS
)
1461 return gnutls_make_error (ret
);
1465 emacs_gnutls_deinit (proc
);
1466 boot_error (p
, STRINGP (keyfile
) ? "Invalid client cert file"
1467 : "Invalid client key file");
1473 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
1474 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
1475 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
1477 /* Call gnutls_init here: */
1479 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
1480 ret
= gnutls_init (&state
, GNUTLS_CLIENT
);
1481 XPROCESS (proc
)->gnutls_state
= state
;
1482 if (ret
< GNUTLS_E_SUCCESS
)
1483 return gnutls_make_error (ret
);
1484 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
1486 if (STRINGP (priority_string
))
1488 priority_string_ptr
= SSDATA (priority_string
);
1489 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
1490 priority_string_ptr
);
1494 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
1495 priority_string_ptr
);
1498 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
1499 ret
= gnutls_priority_set_direct (state
, priority_string_ptr
, NULL
);
1500 if (ret
< GNUTLS_E_SUCCESS
)
1501 return gnutls_make_error (ret
);
1503 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
1505 if (INTEGERP (prime_bits
))
1506 gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
1508 ret
= EQ (type
, Qgnutls_x509pki
)
1509 ? gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
1510 : gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
1511 if (ret
< GNUTLS_E_SUCCESS
)
1512 return gnutls_make_error (ret
);
1514 if (!gnutls_ip_address_p (c_hostname
))
1516 ret
= gnutls_server_name_set (state
, GNUTLS_NAME_DNS
, c_hostname
,
1517 strlen (c_hostname
));
1518 if (ret
< GNUTLS_E_SUCCESS
)
1519 return gnutls_make_error (ret
);
1522 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
1523 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
1524 if (ret
< GNUTLS_E_SUCCESS
)
1525 return gnutls_make_error (ret
);
1527 /* Now verify the peer, following
1528 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1529 The peer should present at least one certificate in the chain; do a
1530 check of the certificate's hostname with
1531 gnutls_x509_crt_check_hostname against :hostname. */
1533 ret
= gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1534 if (ret
< GNUTLS_E_SUCCESS
)
1535 return gnutls_make_error (ret
);
1537 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1539 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1540 if (!NILP (warnings
))
1543 for (tail
= warnings
; CONSP (tail
); tail
= XCDR (tail
))
1545 Lisp_Object warning
= XCAR (tail
);
1546 Lisp_Object message
= Fgnutls_peer_status_warning_describe (warning
);
1547 if (!NILP (message
))
1548 GNUTLS_LOG2 (1, max_log_level
, "verification:", SSDATA (message
));
1552 if (peer_verification
!= 0)
1554 if (verify_error_all
1555 || !NILP (Fmember (QCgnutls_bootprop_trustfiles
, verify_error
)))
1557 emacs_gnutls_deinit (proc
);
1558 boot_error (p
, "Certificate validation failed %s, verification code %x",
1559 c_hostname
, peer_verification
);
1564 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1569 /* Up to here the process is the same for X.509 certificates and
1570 OpenPGP keys. From now on X.509 certificates are assumed. This
1571 can be easily extended to work with openpgp keys as well. */
1572 if (gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1574 gnutls_x509_crt_t gnutls_verify_cert
;
1575 const gnutls_datum_t
*gnutls_verify_cert_list
;
1576 unsigned int gnutls_verify_cert_list_size
;
1578 ret
= gnutls_x509_crt_init (&gnutls_verify_cert
);
1579 if (ret
< GNUTLS_E_SUCCESS
)
1580 return gnutls_make_error (ret
);
1582 gnutls_verify_cert_list
=
1583 gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1585 if (gnutls_verify_cert_list
== NULL
)
1587 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1588 emacs_gnutls_deinit (proc
);
1589 boot_error (p
, "No x509 certificate was found\n");
1593 /* We only check the first certificate in the given chain. */
1594 ret
= gnutls_x509_crt_import (gnutls_verify_cert
,
1595 &gnutls_verify_cert_list
[0],
1596 GNUTLS_X509_FMT_DER
);
1598 if (ret
< GNUTLS_E_SUCCESS
)
1600 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1601 return gnutls_make_error (ret
);
1604 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1606 int err
= gnutls_x509_crt_check_hostname (gnutls_verify_cert
,
1608 check_memory_full (err
);
1611 XPROCESS (proc
)->gnutls_extra_peer_verification
|=
1612 CERTIFICATE_NOT_MATCHING
;
1613 if (verify_error_all
1614 || !NILP (Fmember (QCgnutls_bootprop_hostname
, verify_error
)))
1616 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1617 emacs_gnutls_deinit (proc
);
1618 boot_error (p
, "The x509 certificate does not match \"%s\"", c_hostname
);
1623 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1629 /* Set this flag only if the whole initialization succeeded. */
1630 XPROCESS (proc
)->gnutls_p
= 1;
1632 return gnutls_make_error (ret
);
1635 DEFUN ("gnutls-bye", Fgnutls_bye
,
1636 Sgnutls_bye
, 2, 2, 0,
1637 doc
: /* Terminate current GnuTLS connection for process PROC.
1638 The connection should have been initiated using `gnutls-handshake'.
1640 If CONT is not nil the TLS connection gets terminated and further
1641 receives and sends will be disallowed. If the return value is zero you
1642 may continue using the connection. If CONT is nil, GnuTLS actually
1643 sends an alert containing a close request and waits for the peer to
1644 reply with the same message. In order to reuse the connection you
1645 should wait for an EOF from the peer.
1647 This function may also return `gnutls-e-again', or
1648 `gnutls-e-interrupted'. */)
1649 (Lisp_Object proc
, Lisp_Object cont
)
1651 gnutls_session_t state
;
1654 CHECK_PROCESS (proc
);
1656 state
= XPROCESS (proc
)->gnutls_state
;
1658 gnutls_x509_crt_deinit (XPROCESS (proc
)->gnutls_certificate
);
1660 ret
= gnutls_bye (state
, NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1662 return gnutls_make_error (ret
);
1665 #endif /* HAVE_GNUTLS */
1667 DEFUN ("gnutls-available-p", Fgnutls_available_p
, Sgnutls_available_p
, 0, 0, 0,
1668 doc
: /* Return t if GnuTLS is available in this instance of Emacs. */)
1673 Lisp_Object found
= Fassq (Qgnutls_dll
, Vlibrary_cache
);
1675 return XCDR (found
);
1679 status
= init_gnutls_functions () ? Qt
: Qnil
;
1680 Vlibrary_cache
= Fcons (Fcons (Qgnutls_dll
, status
), Vlibrary_cache
);
1683 # else /* !WINDOWSNT */
1685 # endif /* !WINDOWSNT */
1686 #else /* !HAVE_GNUTLS */
1688 #endif /* !HAVE_GNUTLS */
1692 syms_of_gnutls (void)
1694 DEFSYM (Qlibgnutls_version
, "libgnutls-version");
1695 Fset (Qlibgnutls_version
,
1697 make_number (GNUTLS_VERSION_MAJOR
* 10000
1698 + GNUTLS_VERSION_MINOR
* 100
1699 + GNUTLS_VERSION_PATCH
)
1705 gnutls_global_initialized
= 0;
1707 DEFSYM (Qgnutls_code
, "gnutls-code");
1708 DEFSYM (Qgnutls_anon
, "gnutls-anon");
1709 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
1711 /* The following are for the property list of 'gnutls-boot'. */
1712 DEFSYM (QCgnutls_bootprop_hostname
, ":hostname");
1713 DEFSYM (QCgnutls_bootprop_priority
, ":priority");
1714 DEFSYM (QCgnutls_bootprop_trustfiles
, ":trustfiles");
1715 DEFSYM (QCgnutls_bootprop_keylist
, ":keylist");
1716 DEFSYM (QCgnutls_bootprop_crlfiles
, ":crlfiles");
1717 DEFSYM (QCgnutls_bootprop_min_prime_bits
, ":min-prime-bits");
1718 DEFSYM (QCgnutls_bootprop_loglevel
, ":loglevel");
1719 DEFSYM (QCgnutls_bootprop_verify_flags
, ":verify-flags");
1720 DEFSYM (QCgnutls_bootprop_verify_error
, ":verify-error");
1722 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
1723 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
1724 make_number (GNUTLS_E_INTERRUPTED
));
1726 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
1727 Fput (Qgnutls_e_again
, Qgnutls_code
,
1728 make_number (GNUTLS_E_AGAIN
));
1730 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
1731 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
1732 make_number (GNUTLS_E_INVALID_SESSION
));
1734 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
1735 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
1736 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
1738 defsubr (&Sgnutls_get_initstage
);
1739 defsubr (&Sgnutls_asynchronous_parameters
);
1740 defsubr (&Sgnutls_errorp
);
1741 defsubr (&Sgnutls_error_fatalp
);
1742 defsubr (&Sgnutls_error_string
);
1743 defsubr (&Sgnutls_boot
);
1744 defsubr (&Sgnutls_deinit
);
1745 defsubr (&Sgnutls_bye
);
1746 defsubr (&Sgnutls_peer_status
);
1747 defsubr (&Sgnutls_peer_status_warning_describe
);
1749 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
1750 doc
: /* Logging level used by the GnuTLS functions.
1751 Set this larger than 0 to get debug output in the *Messages* buffer.
1752 1 is for important messages, 2 is for debug data, and higher numbers
1753 are as per the GnuTLS logging conventions. */);
1754 global_gnutls_log_level
= 0;
1756 #endif /* HAVE_GNUTLS */
1758 defsubr (&Sgnutls_available_p
);