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/>. */
35 static bool emacs_gnutls_handle_error (gnutls_session_t
, int);
37 static bool gnutls_global_initialized
;
39 static void gnutls_log_function (int, const char *);
40 static void gnutls_log_function2 (int, const char *, const char *);
42 static void gnutls_audit_log_function (gnutls_session_t
, const char *);
45 enum extra_peer_verification
47 CERTIFICATE_NOT_MATCHING
= 2
53 DEF_DLL_FN (gnutls_alert_description_t
, gnutls_alert_get
,
55 DEF_DLL_FN (const char *, gnutls_alert_get_name
,
56 (gnutls_alert_description_t
));
57 DEF_DLL_FN (int, gnutls_anon_allocate_client_credentials
,
58 (gnutls_anon_client_credentials_t
*));
59 DEF_DLL_FN (void, gnutls_anon_free_client_credentials
,
60 (gnutls_anon_client_credentials_t
));
61 DEF_DLL_FN (int, gnutls_bye
, (gnutls_session_t
, gnutls_close_request_t
));
62 DEF_DLL_FN (int, gnutls_certificate_allocate_credentials
,
63 (gnutls_certificate_credentials_t
*));
64 DEF_DLL_FN (void, gnutls_certificate_free_credentials
,
65 (gnutls_certificate_credentials_t
));
66 DEF_DLL_FN (const gnutls_datum_t
*, gnutls_certificate_get_peers
,
67 (gnutls_session_t
, unsigned int *));
68 DEF_DLL_FN (void, gnutls_certificate_set_verify_flags
,
69 (gnutls_certificate_credentials_t
, unsigned int));
70 DEF_DLL_FN (int, gnutls_certificate_set_x509_crl_file
,
71 (gnutls_certificate_credentials_t
, const char *,
72 gnutls_x509_crt_fmt_t
));
73 DEF_DLL_FN (int, gnutls_certificate_set_x509_key_file
,
74 (gnutls_certificate_credentials_t
, const char *, const char *,
75 gnutls_x509_crt_fmt_t
));
76 # if ((GNUTLS_VERSION_MAJOR \
77 + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20)) \
79 DEF_DLL_FN (int, gnutls_certificate_set_x509_system_trust
,
80 (gnutls_certificate_credentials_t
));
82 DEF_DLL_FN (int, gnutls_certificate_set_x509_trust_file
,
83 (gnutls_certificate_credentials_t
, const char *,
84 gnutls_x509_crt_fmt_t
));
85 DEF_DLL_FN (gnutls_certificate_type_t
, gnutls_certificate_type_get
,
87 DEF_DLL_FN (int, gnutls_certificate_verify_peers2
,
88 (gnutls_session_t
, unsigned int *));
89 DEF_DLL_FN (int, gnutls_credentials_set
,
90 (gnutls_session_t
, gnutls_credentials_type_t
, void *));
91 DEF_DLL_FN (void, gnutls_deinit
, (gnutls_session_t
));
92 DEF_DLL_FN (void, gnutls_dh_set_prime_bits
,
93 (gnutls_session_t
, unsigned int));
94 DEF_DLL_FN (int, gnutls_dh_get_prime_bits
, (gnutls_session_t
));
95 DEF_DLL_FN (int, gnutls_error_is_fatal
, (int));
96 DEF_DLL_FN (int, gnutls_global_init
, (void));
97 DEF_DLL_FN (void, gnutls_global_set_log_function
, (gnutls_log_func
));
99 DEF_DLL_FN (void, gnutls_global_set_audit_log_function
, (gnutls_audit_log_func
));
101 DEF_DLL_FN (void, gnutls_global_set_log_level
, (int));
102 DEF_DLL_FN (int, gnutls_handshake
, (gnutls_session_t
));
103 DEF_DLL_FN (int, gnutls_init
, (gnutls_session_t
*, unsigned int));
104 DEF_DLL_FN (int, gnutls_priority_set_direct
,
105 (gnutls_session_t
, const char *, const char **));
106 DEF_DLL_FN (size_t, gnutls_record_check_pending
, (gnutls_session_t
));
107 DEF_DLL_FN (ssize_t
, gnutls_record_recv
, (gnutls_session_t
, void *, size_t));
108 DEF_DLL_FN (ssize_t
, gnutls_record_send
,
109 (gnutls_session_t
, const void *, size_t));
110 DEF_DLL_FN (const char *, gnutls_strerror
, (int));
111 DEF_DLL_FN (void, gnutls_transport_set_errno
, (gnutls_session_t
, int));
112 DEF_DLL_FN (void, gnutls_transport_set_ptr2
,
113 (gnutls_session_t
, gnutls_transport_ptr_t
,
114 gnutls_transport_ptr_t
));
115 DEF_DLL_FN (void, gnutls_transport_set_pull_function
,
116 (gnutls_session_t
, gnutls_pull_func
));
117 DEF_DLL_FN (void, gnutls_transport_set_push_function
,
118 (gnutls_session_t
, gnutls_push_func
));
119 DEF_DLL_FN (int, gnutls_x509_crt_check_hostname
,
120 (gnutls_x509_crt_t
, const char *));
121 DEF_DLL_FN (int, gnutls_x509_crt_check_issuer
,
122 (gnutls_x509_crt_t
, gnutls_x509_crt_t
));
123 DEF_DLL_FN (void, gnutls_x509_crt_deinit
, (gnutls_x509_crt_t
));
124 DEF_DLL_FN (int, gnutls_x509_crt_import
,
125 (gnutls_x509_crt_t
, const gnutls_datum_t
*,
126 gnutls_x509_crt_fmt_t
));
127 DEF_DLL_FN (int, gnutls_x509_crt_init
, (gnutls_x509_crt_t
*));
128 DEF_DLL_FN (int, gnutls_x509_crt_get_fingerprint
,
130 gnutls_digest_algorithm_t
, void *, size_t *));
131 DEF_DLL_FN (int, gnutls_x509_crt_get_version
,
132 (gnutls_x509_crt_t
));
133 DEF_DLL_FN (int, gnutls_x509_crt_get_serial
,
134 (gnutls_x509_crt_t
, void *, size_t *));
135 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_dn
,
136 (gnutls_x509_crt_t
, char *, size_t *));
137 DEF_DLL_FN (time_t, gnutls_x509_crt_get_activation_time
,
138 (gnutls_x509_crt_t
));
139 DEF_DLL_FN (time_t, gnutls_x509_crt_get_expiration_time
,
140 (gnutls_x509_crt_t
));
141 DEF_DLL_FN (int, gnutls_x509_crt_get_dn
,
142 (gnutls_x509_crt_t
, char *, size_t *));
143 DEF_DLL_FN (int, gnutls_x509_crt_get_pk_algorithm
,
144 (gnutls_x509_crt_t
, unsigned int *));
145 DEF_DLL_FN (const char *, gnutls_pk_algorithm_get_name
,
146 (gnutls_pk_algorithm_t
));
147 DEF_DLL_FN (int, gnutls_pk_bits_to_sec_param
,
148 (gnutls_pk_algorithm_t
, unsigned int));
149 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_unique_id
,
150 (gnutls_x509_crt_t
, char *, size_t *));
151 DEF_DLL_FN (int, gnutls_x509_crt_get_subject_unique_id
,
152 (gnutls_x509_crt_t
, char *, size_t *));
153 DEF_DLL_FN (int, gnutls_x509_crt_get_signature_algorithm
,
154 (gnutls_x509_crt_t
));
155 DEF_DLL_FN (int, gnutls_x509_crt_get_key_id
,
156 (gnutls_x509_crt_t
, unsigned int, unsigned char *, size_t *_size
));
157 DEF_DLL_FN (const char *, gnutls_sec_param_get_name
, (gnutls_sec_param_t
));
158 DEF_DLL_FN (const char *, gnutls_sign_get_name
, (gnutls_sign_algorithm_t
));
159 DEF_DLL_FN (int, gnutls_server_name_set
,
160 (gnutls_session_t
, gnutls_server_name_type_t
,
161 const void *, size_t));
162 DEF_DLL_FN (gnutls_kx_algorithm_t
, gnutls_kx_get
, (gnutls_session_t
));
163 DEF_DLL_FN (const char *, gnutls_kx_get_name
, (gnutls_kx_algorithm_t
));
164 DEF_DLL_FN (gnutls_protocol_t
, gnutls_protocol_get_version
,
166 DEF_DLL_FN (const char *, gnutls_protocol_get_name
, (gnutls_protocol_t
));
167 DEF_DLL_FN (gnutls_cipher_algorithm_t
, gnutls_cipher_get
,
169 DEF_DLL_FN (const char *, gnutls_cipher_get_name
,
170 (gnutls_cipher_algorithm_t
));
171 DEF_DLL_FN (gnutls_mac_algorithm_t
, gnutls_mac_get
, (gnutls_session_t
));
172 DEF_DLL_FN (const char *, gnutls_mac_get_name
, (gnutls_mac_algorithm_t
));
176 init_gnutls_functions (void)
179 int max_log_level
= 1;
181 if (!(library
= w32_delayed_load (Qgnutls
)))
183 GNUTLS_LOG (1, max_log_level
, "GnuTLS library not found");
187 LOAD_DLL_FN (library
, gnutls_alert_get
);
188 LOAD_DLL_FN (library
, gnutls_alert_get_name
);
189 LOAD_DLL_FN (library
, gnutls_anon_allocate_client_credentials
);
190 LOAD_DLL_FN (library
, gnutls_anon_free_client_credentials
);
191 LOAD_DLL_FN (library
, gnutls_bye
);
192 LOAD_DLL_FN (library
, gnutls_certificate_allocate_credentials
);
193 LOAD_DLL_FN (library
, gnutls_certificate_free_credentials
);
194 LOAD_DLL_FN (library
, gnutls_certificate_get_peers
);
195 LOAD_DLL_FN (library
, gnutls_certificate_set_verify_flags
);
196 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_crl_file
);
197 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_key_file
);
198 # if ((GNUTLS_VERSION_MAJOR \
199 + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20)) \
201 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_system_trust
);
203 LOAD_DLL_FN (library
, gnutls_certificate_set_x509_trust_file
);
204 LOAD_DLL_FN (library
, gnutls_certificate_type_get
);
205 LOAD_DLL_FN (library
, gnutls_certificate_verify_peers2
);
206 LOAD_DLL_FN (library
, gnutls_credentials_set
);
207 LOAD_DLL_FN (library
, gnutls_deinit
);
208 LOAD_DLL_FN (library
, gnutls_dh_set_prime_bits
);
209 LOAD_DLL_FN (library
, gnutls_dh_get_prime_bits
);
210 LOAD_DLL_FN (library
, gnutls_error_is_fatal
);
211 LOAD_DLL_FN (library
, gnutls_global_init
);
212 LOAD_DLL_FN (library
, gnutls_global_set_log_function
);
214 LOAD_DLL_FN (library
, gnutls_global_set_audit_log_function
);
216 LOAD_DLL_FN (library
, gnutls_global_set_log_level
);
217 LOAD_DLL_FN (library
, gnutls_handshake
);
218 LOAD_DLL_FN (library
, gnutls_init
);
219 LOAD_DLL_FN (library
, gnutls_priority_set_direct
);
220 LOAD_DLL_FN (library
, gnutls_record_check_pending
);
221 LOAD_DLL_FN (library
, gnutls_record_recv
);
222 LOAD_DLL_FN (library
, gnutls_record_send
);
223 LOAD_DLL_FN (library
, gnutls_strerror
);
224 LOAD_DLL_FN (library
, gnutls_transport_set_errno
);
225 LOAD_DLL_FN (library
, gnutls_transport_set_ptr2
);
226 LOAD_DLL_FN (library
, gnutls_transport_set_pull_function
);
227 LOAD_DLL_FN (library
, gnutls_transport_set_push_function
);
228 LOAD_DLL_FN (library
, gnutls_x509_crt_check_hostname
);
229 LOAD_DLL_FN (library
, gnutls_x509_crt_check_issuer
);
230 LOAD_DLL_FN (library
, gnutls_x509_crt_deinit
);
231 LOAD_DLL_FN (library
, gnutls_x509_crt_import
);
232 LOAD_DLL_FN (library
, gnutls_x509_crt_init
);
233 LOAD_DLL_FN (library
, gnutls_x509_crt_get_fingerprint
);
234 LOAD_DLL_FN (library
, gnutls_x509_crt_get_version
);
235 LOAD_DLL_FN (library
, gnutls_x509_crt_get_serial
);
236 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_dn
);
237 LOAD_DLL_FN (library
, gnutls_x509_crt_get_activation_time
);
238 LOAD_DLL_FN (library
, gnutls_x509_crt_get_expiration_time
);
239 LOAD_DLL_FN (library
, gnutls_x509_crt_get_dn
);
240 LOAD_DLL_FN (library
, gnutls_x509_crt_get_pk_algorithm
);
241 LOAD_DLL_FN (library
, gnutls_pk_algorithm_get_name
);
242 LOAD_DLL_FN (library
, gnutls_pk_bits_to_sec_param
);
243 LOAD_DLL_FN (library
, gnutls_x509_crt_get_issuer_unique_id
);
244 LOAD_DLL_FN (library
, gnutls_x509_crt_get_subject_unique_id
);
245 LOAD_DLL_FN (library
, gnutls_x509_crt_get_signature_algorithm
);
246 LOAD_DLL_FN (library
, gnutls_x509_crt_get_key_id
);
247 LOAD_DLL_FN (library
, gnutls_sec_param_get_name
);
248 LOAD_DLL_FN (library
, gnutls_sign_get_name
);
249 LOAD_DLL_FN (library
, gnutls_server_name_set
);
250 LOAD_DLL_FN (library
, gnutls_kx_get
);
251 LOAD_DLL_FN (library
, gnutls_kx_get_name
);
252 LOAD_DLL_FN (library
, gnutls_protocol_get_version
);
253 LOAD_DLL_FN (library
, gnutls_protocol_get_name
);
254 LOAD_DLL_FN (library
, gnutls_cipher_get
);
255 LOAD_DLL_FN (library
, gnutls_cipher_get_name
);
256 LOAD_DLL_FN (library
, gnutls_mac_get
);
257 LOAD_DLL_FN (library
, gnutls_mac_get_name
);
259 max_log_level
= global_gnutls_log_level
;
262 Lisp_Object name
= CAR_SAFE (Fget (Qgnutls
, QCloaded_from
));
263 GNUTLS_LOG2 (1, max_log_level
, "GnuTLS library loaded:",
264 STRINGP (name
) ? (const char *) SDATA (name
) : "unknown");
270 # define gnutls_alert_get fn_gnutls_alert_get
271 # define gnutls_alert_get_name fn_gnutls_alert_get_name
272 # define gnutls_anon_allocate_client_credentials fn_gnutls_anon_allocate_client_credentials
273 # define gnutls_anon_free_client_credentials fn_gnutls_anon_free_client_credentials
274 # define gnutls_bye fn_gnutls_bye
275 # define gnutls_certificate_allocate_credentials fn_gnutls_certificate_allocate_credentials
276 # define gnutls_certificate_free_credentials fn_gnutls_certificate_free_credentials
277 # define gnutls_certificate_get_peers fn_gnutls_certificate_get_peers
278 # define gnutls_certificate_set_verify_flags fn_gnutls_certificate_set_verify_flags
279 # define gnutls_certificate_set_x509_crl_file fn_gnutls_certificate_set_x509_crl_file
280 # define gnutls_certificate_set_x509_key_file fn_gnutls_certificate_set_x509_key_file
281 # define gnutls_certificate_set_x509_system_trust fn_gnutls_certificate_set_x509_system_trust
282 # define gnutls_certificate_set_x509_trust_file fn_gnutls_certificate_set_x509_trust_file
283 # define gnutls_certificate_type_get fn_gnutls_certificate_type_get
284 # define gnutls_certificate_verify_peers2 fn_gnutls_certificate_verify_peers2
285 # define gnutls_cipher_get fn_gnutls_cipher_get
286 # define gnutls_cipher_get_name fn_gnutls_cipher_get_name
287 # define gnutls_credentials_set fn_gnutls_credentials_set
288 # define gnutls_deinit fn_gnutls_deinit
289 # define gnutls_dh_get_prime_bits fn_gnutls_dh_get_prime_bits
290 # define gnutls_dh_set_prime_bits fn_gnutls_dh_set_prime_bits
291 # define gnutls_error_is_fatal fn_gnutls_error_is_fatal
292 # define gnutls_global_init fn_gnutls_global_init
293 # define gnutls_global_set_audit_log_function fn_gnutls_global_set_audit_log_function
294 # define gnutls_global_set_log_function fn_gnutls_global_set_log_function
295 # define gnutls_global_set_log_level fn_gnutls_global_set_log_level
296 # define gnutls_handshake fn_gnutls_handshake
297 # define gnutls_init fn_gnutls_init
298 # define gnutls_kx_get fn_gnutls_kx_get
299 # define gnutls_kx_get_name fn_gnutls_kx_get_name
300 # define gnutls_mac_get fn_gnutls_mac_get
301 # define gnutls_mac_get_name fn_gnutls_mac_get_name
302 # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name
303 # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param
304 # define gnutls_priority_set_direct fn_gnutls_priority_set_direct
305 # define gnutls_protocol_get_name fn_gnutls_protocol_get_name
306 # define gnutls_protocol_get_version fn_gnutls_protocol_get_version
307 # define gnutls_record_check_pending fn_gnutls_record_check_pending
308 # define gnutls_record_recv fn_gnutls_record_recv
309 # define gnutls_record_send fn_gnutls_record_send
310 # define gnutls_sec_param_get_name fn_gnutls_sec_param_get_name
311 # define gnutls_server_name_set fn_gnutls_server_name_set
312 # define gnutls_sign_get_name fn_gnutls_sign_get_name
313 # define gnutls_strerror fn_gnutls_strerror
314 # define gnutls_transport_set_errno fn_gnutls_transport_set_errno
315 # define gnutls_transport_set_ptr2 fn_gnutls_transport_set_ptr2
316 # define gnutls_transport_set_pull_function fn_gnutls_transport_set_pull_function
317 # define gnutls_transport_set_push_function fn_gnutls_transport_set_push_function
318 # define gnutls_x509_crt_check_hostname fn_gnutls_x509_crt_check_hostname
319 # define gnutls_x509_crt_check_issuer fn_gnutls_x509_crt_check_issuer
320 # define gnutls_x509_crt_deinit fn_gnutls_x509_crt_deinit
321 # define gnutls_x509_crt_get_activation_time fn_gnutls_x509_crt_get_activation_time
322 # define gnutls_x509_crt_get_dn fn_gnutls_x509_crt_get_dn
323 # define gnutls_x509_crt_get_expiration_time fn_gnutls_x509_crt_get_expiration_time
324 # define gnutls_x509_crt_get_fingerprint fn_gnutls_x509_crt_get_fingerprint
325 # define gnutls_x509_crt_get_issuer_dn fn_gnutls_x509_crt_get_issuer_dn
326 # define gnutls_x509_crt_get_issuer_unique_id fn_gnutls_x509_crt_get_issuer_unique_id
327 # define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id
328 # define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm
329 # define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial
330 # define gnutls_x509_crt_get_signature_algorithm fn_gnutls_x509_crt_get_signature_algorithm
331 # define gnutls_x509_crt_get_subject_unique_id fn_gnutls_x509_crt_get_subject_unique_id
332 # define gnutls_x509_crt_get_version fn_gnutls_x509_crt_get_version
333 # define gnutls_x509_crt_import fn_gnutls_x509_crt_import
334 # define gnutls_x509_crt_init fn_gnutls_x509_crt_init
339 /* Report memory exhaustion if ERR is an out-of-memory indication. */
341 check_memory_full (int err
)
343 /* When GnuTLS exhausts memory, it doesn't say how much memory it
344 asked for, so tell the Emacs allocator that GnuTLS asked for no
345 bytes. This isn't accurate, but it's good enough. */
346 if (err
== GNUTLS_E_MEMORY_ERROR
)
351 /* Log a simple audit message. */
353 gnutls_audit_log_function (gnutls_session_t session
, const char *string
)
355 if (global_gnutls_log_level
>= 1)
357 message ("gnutls.c: [audit] %s", string
);
362 /* Log a simple message. */
364 gnutls_log_function (int level
, const char *string
)
366 message ("gnutls.c: [%d] %s", level
, string
);
369 /* Log a message and a string. */
371 gnutls_log_function2 (int level
, const char *string
, const char *extra
)
373 message ("gnutls.c: [%d] %s %s", level
, string
, extra
);
377 gnutls_try_handshake (struct Lisp_Process
*proc
)
379 gnutls_session_t state
= proc
->gnutls_state
;
381 bool non_blocking
= proc
->is_non_blocking_client
;
383 if (proc
->gnutls_complete_negotiation_p
)
384 non_blocking
= false;
387 proc
->gnutls_p
= true;
391 ret
= gnutls_handshake (state
);
392 emacs_gnutls_handle_error (state
, ret
);
396 && gnutls_error_is_fatal (ret
) == 0
399 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
401 if (ret
== GNUTLS_E_SUCCESS
)
403 /* Here we're finally done. */
404 proc
->gnutls_initstage
= GNUTLS_STAGE_READY
;
408 /* check_memory_full (gnutls_alert_send_appropriate (state, ret)); */
415 emacs_gnutls_nonblock_errno (gnutls_transport_ptr_t ptr
)
422 /* This is taken from the GnuTLS system_errno function circa 2016;
423 see <http://savannah.gnu.org/support/?107464>. */
439 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
441 gnutls_session_t state
= proc
->gnutls_state
;
443 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
446 if (proc
->gnutls_initstage
< GNUTLS_STAGE_TRANSPORT_POINTERS_SET
)
449 /* On W32 we cannot transfer socket handles between different runtime
450 libraries, so we tell GnuTLS to use our special push/pull
452 gnutls_transport_set_ptr2 (state
,
453 (gnutls_transport_ptr_t
) proc
,
454 (gnutls_transport_ptr_t
) proc
);
455 gnutls_transport_set_push_function (state
, &emacs_gnutls_push
);
456 gnutls_transport_set_pull_function (state
, &emacs_gnutls_pull
);
458 /* This is how GnuTLS takes sockets: as file descriptors passed
459 in. For an Emacs process socket, infd and outfd are the
460 same but we use this two-argument version for clarity. */
461 gnutls_transport_set_ptr2 (state
,
462 (void *) (intptr_t) proc
->infd
,
463 (void *) (intptr_t) proc
->outfd
);
464 if (proc
->is_non_blocking_client
)
465 gnutls_transport_set_errno_function (state
,
466 emacs_gnutls_nonblock_errno
);
469 proc
->gnutls_initstage
= GNUTLS_STAGE_TRANSPORT_POINTERS_SET
;
472 return gnutls_try_handshake (proc
);
476 emacs_gnutls_record_check_pending (gnutls_session_t state
)
478 return gnutls_record_check_pending (state
);
483 emacs_gnutls_transport_set_errno (gnutls_session_t state
, int err
)
485 gnutls_transport_set_errno (state
, err
);
490 emacs_gnutls_write (struct Lisp_Process
*proc
, const char *buf
, ptrdiff_t nbyte
)
493 ptrdiff_t bytes_written
;
494 gnutls_session_t state
= proc
->gnutls_state
;
496 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
506 rtnval
= gnutls_record_send (state
, buf
, nbyte
);
510 if (rtnval
== GNUTLS_E_INTERRUPTED
)
514 /* If we get GNUTLS_E_AGAIN, then set errno
515 appropriately so that send_process retries the
516 correct way instead of erroring out. */
517 if (rtnval
== GNUTLS_E_AGAIN
)
525 bytes_written
+= rtnval
;
528 emacs_gnutls_handle_error (state
, rtnval
);
529 return (bytes_written
);
533 emacs_gnutls_read (struct Lisp_Process
*proc
, char *buf
, ptrdiff_t nbyte
)
536 gnutls_session_t state
= proc
->gnutls_state
;
538 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
544 rtnval
= gnutls_record_recv (state
, buf
, nbyte
);
547 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
548 /* The peer closed the connection. */
550 else if (emacs_gnutls_handle_error (state
, rtnval
))
551 /* non-fatal error */
554 /* a fatal error occurred */
559 /* Report a GnuTLS error to the user.
560 Return true if the error code was successfully handled. */
562 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
564 int max_log_level
= 0;
569 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
573 check_memory_full (err
);
575 max_log_level
= global_gnutls_log_level
;
577 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
579 str
= gnutls_strerror (err
);
583 if (gnutls_error_is_fatal (err
))
586 /* Mostly ignore "The TLS connection was non-properly
587 terminated" message which just means that the peer closed the
590 if (err
== GNUTLS_E_PREMATURE_TERMINATION
)
594 GNUTLS_LOG2 (level
, max_log_level
, "fatal error:", str
);
617 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
618 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
620 int alert
= gnutls_alert_get (session
);
621 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
622 str
= gnutls_alert_get_name (alert
);
626 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
631 /* convert an integer error to a Lisp_Object; it will be either a
632 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
633 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
636 gnutls_make_error (int err
)
640 case GNUTLS_E_SUCCESS
:
643 return Qgnutls_e_again
;
644 case GNUTLS_E_INTERRUPTED
:
645 return Qgnutls_e_interrupted
;
646 case GNUTLS_E_INVALID_SESSION
:
647 return Qgnutls_e_invalid_session
;
650 check_memory_full (err
);
651 return make_number (err
);
655 emacs_gnutls_deinit (Lisp_Object proc
)
659 CHECK_PROCESS (proc
);
661 if (! XPROCESS (proc
)->gnutls_p
)
664 log_level
= XPROCESS (proc
)->gnutls_log_level
;
666 if (XPROCESS (proc
)->gnutls_x509_cred
)
668 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
669 gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
670 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
673 if (XPROCESS (proc
)->gnutls_anon_cred
)
675 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
676 gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
677 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
680 if (XPROCESS (proc
)->gnutls_state
)
682 gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
683 XPROCESS (proc
)->gnutls_state
= NULL
;
684 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
685 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
688 XPROCESS (proc
)->gnutls_p
= false;
692 DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters
,
693 Sgnutls_asynchronous_parameters
, 2, 2, 0,
694 doc
: /* Mark this process as being a pre-init GnuTLS process.
695 The second parameter is the list of parameters to feed to gnutls-boot
696 to finish setting up the connection. */)
697 (Lisp_Object proc
, Lisp_Object params
)
699 CHECK_PROCESS (proc
);
701 XPROCESS (proc
)->gnutls_boot_parameters
= params
;
705 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
706 doc
: /* Return the GnuTLS init stage of process PROC.
707 See also `gnutls-boot'. */)
710 CHECK_PROCESS (proc
);
712 return make_number (GNUTLS_INITSTAGE (proc
));
715 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
716 doc
: /* Return t if ERROR indicates a GnuTLS problem.
717 ERROR is an integer or a symbol with an integer `gnutls-code' property.
718 usage: (gnutls-errorp ERROR) */
723 || EQ (err
, Qgnutls_e_again
))
729 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
730 doc
: /* Return non-nil if ERROR is fatal.
731 ERROR is an integer or a symbol with an integer `gnutls-code' property.
732 Usage: (gnutls-error-fatalp ERROR) */)
737 if (EQ (err
, Qt
)) return Qnil
;
741 code
= Fget (err
, Qgnutls_code
);
748 error ("Symbol has no numeric gnutls-code property");
752 if (! TYPE_RANGED_INTEGERP (int, err
))
753 error ("Not an error symbol or code");
755 if (0 == gnutls_error_is_fatal (XINT (err
)))
761 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
762 doc
: /* Return a description of ERROR.
763 ERROR is an integer or a symbol with an integer `gnutls-code' property.
764 usage: (gnutls-error-string ERROR) */)
769 if (EQ (err
, Qt
)) return build_string ("Not an error");
773 code
= Fget (err
, Qgnutls_code
);
780 return build_string ("Symbol has no numeric gnutls-code property");
784 if (! TYPE_RANGED_INTEGERP (int, err
))
785 return build_string ("Not an error symbol or code");
787 return build_string (gnutls_strerror (XINT (err
)));
790 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
791 doc
: /* Deallocate GnuTLS resources associated with process PROC.
792 See also `gnutls-init'. */)
795 return emacs_gnutls_deinit (proc
);
799 gnutls_hex_string (unsigned char *buf
, ptrdiff_t buf_size
, const char *prefix
)
801 ptrdiff_t prefix_length
= strlen (prefix
);
803 if (INT_MULTIPLY_WRAPV (buf_size
, 3, &retlen
)
804 || INT_ADD_WRAPV (prefix_length
- (buf_size
!= 0), retlen
, &retlen
))
806 Lisp_Object ret
= make_uninit_string (retlen
);
807 char *string
= SSDATA (ret
);
808 strcpy (string
, prefix
);
810 for (ptrdiff_t i
= 0; i
< buf_size
; i
++)
811 sprintf (string
+ i
* 3 + prefix_length
,
812 i
== buf_size
- 1 ? "%02x" : "%02x:",
819 gnutls_certificate_details (gnutls_x509_crt_t cert
)
821 Lisp_Object res
= Qnil
;
827 int version
= gnutls_x509_crt_get_version (cert
);
828 check_memory_full (version
);
829 if (version
>= GNUTLS_E_SUCCESS
)
830 res
= nconc2 (res
, list2 (intern (":version"),
831 make_number (version
)));
836 err
= gnutls_x509_crt_get_serial (cert
, NULL
, &buf_size
);
837 check_memory_full (err
);
838 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
840 void *serial
= xmalloc (buf_size
);
841 err
= gnutls_x509_crt_get_serial (cert
, serial
, &buf_size
);
842 check_memory_full (err
);
843 if (err
>= GNUTLS_E_SUCCESS
)
844 res
= nconc2 (res
, list2 (intern (":serial-number"),
845 gnutls_hex_string (serial
, buf_size
, "")));
851 err
= gnutls_x509_crt_get_issuer_dn (cert
, NULL
, &buf_size
);
852 check_memory_full (err
);
853 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
855 char *dn
= xmalloc (buf_size
);
856 err
= gnutls_x509_crt_get_issuer_dn (cert
, dn
, &buf_size
);
857 check_memory_full (err
);
858 if (err
>= GNUTLS_E_SUCCESS
)
859 res
= nconc2 (res
, list2 (intern (":issuer"),
860 make_string (dn
, buf_size
)));
866 /* Add 1 to the buffer size, since 1900 is added to tm_year and
867 that might add 1 to the year length. */
868 char buf
[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
870 time_t tim
= gnutls_x509_crt_get_activation_time (cert
);
872 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
873 res
= nconc2 (res
, list2 (intern (":valid-from"), build_string (buf
)));
875 tim
= gnutls_x509_crt_get_expiration_time (cert
);
876 if (gmtime_r (&tim
, &t
) && strftime (buf
, sizeof buf
, "%Y-%m-%d", &t
))
877 res
= nconc2 (res
, list2 (intern (":valid-to"), build_string (buf
)));
882 err
= gnutls_x509_crt_get_dn (cert
, NULL
, &buf_size
);
883 check_memory_full (err
);
884 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
886 char *dn
= xmalloc (buf_size
);
887 err
= gnutls_x509_crt_get_dn (cert
, dn
, &buf_size
);
888 check_memory_full (err
);
889 if (err
>= GNUTLS_E_SUCCESS
)
890 res
= nconc2 (res
, list2 (intern (":subject"),
891 make_string (dn
, buf_size
)));
895 /* SubjectPublicKeyInfo. */
899 err
= gnutls_x509_crt_get_pk_algorithm (cert
, &bits
);
900 check_memory_full (err
);
901 if (err
>= GNUTLS_E_SUCCESS
)
903 const char *name
= gnutls_pk_algorithm_get_name (err
);
905 res
= nconc2 (res
, list2 (intern (":public-key-algorithm"),
906 build_string (name
)));
908 name
= gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
910 res
= nconc2 (res
, list2 (intern (":certificate-security-level"),
911 build_string (name
)));
917 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, NULL
, &buf_size
);
918 check_memory_full (err
);
919 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
921 char *buf
= xmalloc (buf_size
);
922 err
= gnutls_x509_crt_get_issuer_unique_id (cert
, buf
, &buf_size
);
923 check_memory_full (err
);
924 if (err
>= GNUTLS_E_SUCCESS
)
925 res
= nconc2 (res
, list2 (intern (":issuer-unique-id"),
926 make_string (buf
, buf_size
)));
931 err
= gnutls_x509_crt_get_subject_unique_id (cert
, NULL
, &buf_size
);
932 check_memory_full (err
);
933 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
935 char *buf
= xmalloc (buf_size
);
936 err
= gnutls_x509_crt_get_subject_unique_id (cert
, buf
, &buf_size
);
937 check_memory_full (err
);
938 if (err
>= GNUTLS_E_SUCCESS
)
939 res
= nconc2 (res
, list2 (intern (":subject-unique-id"),
940 make_string (buf
, buf_size
)));
945 err
= gnutls_x509_crt_get_signature_algorithm (cert
);
946 check_memory_full (err
);
947 if (err
>= GNUTLS_E_SUCCESS
)
949 const char *name
= gnutls_sign_get_name (err
);
951 res
= nconc2 (res
, list2 (intern (":signature-algorithm"),
952 build_string (name
)));
957 err
= gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
958 check_memory_full (err
);
959 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
961 void *buf
= xmalloc (buf_size
);
962 err
= gnutls_x509_crt_get_key_id (cert
, 0, buf
, &buf_size
);
963 check_memory_full (err
);
964 if (err
>= GNUTLS_E_SUCCESS
)
965 res
= nconc2 (res
, list2 (intern (":public-key-id"),
966 gnutls_hex_string (buf
, buf_size
, "sha1:")));
970 /* Certificate fingerprint. */
972 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
974 check_memory_full (err
);
975 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
977 void *buf
= xmalloc (buf_size
);
978 err
= gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
980 check_memory_full (err
);
981 if (err
>= GNUTLS_E_SUCCESS
)
982 res
= nconc2 (res
, list2 (intern (":certificate-id"),
983 gnutls_hex_string (buf
, buf_size
, "sha1:")));
990 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
991 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
992 (Lisp_Object status_symbol
)
994 CHECK_SYMBOL (status_symbol
);
996 if (EQ (status_symbol
, intern (":invalid")))
997 return build_string ("certificate could not be verified");
999 if (EQ (status_symbol
, intern (":revoked")))
1000 return build_string ("certificate was revoked (CRL)");
1002 if (EQ (status_symbol
, intern (":self-signed")))
1003 return build_string ("certificate signer was not found (self-signed)");
1005 if (EQ (status_symbol
, intern (":unknown-ca")))
1006 return build_string ("the certificate was signed by an unknown "
1007 "and therefore untrusted authority");
1009 if (EQ (status_symbol
, intern (":not-ca")))
1010 return build_string ("certificate signer is not a CA");
1012 if (EQ (status_symbol
, intern (":insecure")))
1013 return build_string ("certificate was signed with an insecure algorithm");
1015 if (EQ (status_symbol
, intern (":not-activated")))
1016 return build_string ("certificate is not yet activated");
1018 if (EQ (status_symbol
, intern (":expired")))
1019 return build_string ("certificate has expired");
1021 if (EQ (status_symbol
, intern (":no-host-match")))
1022 return build_string ("certificate host does not match hostname");
1027 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
1028 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1029 The return value is a property list with top-level keys :warnings and
1030 :certificate. The :warnings entry is a list of symbols you can describe with
1031 `gnutls-peer-status-warning-describe'. */)
1034 Lisp_Object warnings
= Qnil
, result
= Qnil
;
1035 unsigned int verification
;
1036 gnutls_session_t state
;
1038 CHECK_PROCESS (proc
);
1040 if (GNUTLS_INITSTAGE (proc
) != GNUTLS_STAGE_READY
)
1043 /* Then collect any warnings already computed by the handshake. */
1044 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
1046 if (verification
& GNUTLS_CERT_INVALID
)
1047 warnings
= Fcons (intern (":invalid"), warnings
);
1049 if (verification
& GNUTLS_CERT_REVOKED
)
1050 warnings
= Fcons (intern (":revoked"), warnings
);
1052 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1053 warnings
= Fcons (intern (":unknown-ca"), warnings
);
1055 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1056 warnings
= Fcons (intern (":not-ca"), warnings
);
1058 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1059 warnings
= Fcons (intern (":insecure"), warnings
);
1061 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1062 warnings
= Fcons (intern (":not-activated"), warnings
);
1064 if (verification
& GNUTLS_CERT_EXPIRED
)
1065 warnings
= Fcons (intern (":expired"), warnings
);
1067 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1068 CERTIFICATE_NOT_MATCHING
)
1069 warnings
= Fcons (intern (":no-host-match"), warnings
);
1071 /* This could get called in the INIT stage, when the certificate is
1073 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
&&
1074 gnutls_x509_crt_check_issuer(XPROCESS (proc
)->gnutls_certificate
,
1075 XPROCESS (proc
)->gnutls_certificate
))
1076 warnings
= Fcons (intern (":self-signed"), warnings
);
1078 if (!NILP (warnings
))
1079 result
= list2 (intern (":warnings"), warnings
);
1081 /* This could get called in the INIT stage, when the certificate is
1083 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1084 result
= nconc2 (result
, list2
1085 (intern (":certificate"),
1086 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1088 state
= XPROCESS (proc
)->gnutls_state
;
1090 /* Diffie-Hellman prime bits. */
1092 int bits
= gnutls_dh_get_prime_bits (state
);
1093 check_memory_full (bits
);
1095 result
= nconc2 (result
, list2 (intern (":diffie-hellman-prime-bits"),
1096 make_number (bits
)));
1101 (result
, list2 (intern (":key-exchange"),
1102 build_string (gnutls_kx_get_name
1103 (gnutls_kx_get (state
)))));
1105 /* Protocol name. */
1107 (result
, list2 (intern (":protocol"),
1108 build_string (gnutls_protocol_get_name
1109 (gnutls_protocol_get_version (state
)))));
1113 (result
, list2 (intern (":cipher"),
1114 build_string (gnutls_cipher_get_name
1115 (gnutls_cipher_get (state
)))));
1119 (result
, list2 (intern (":mac"),
1120 build_string (gnutls_mac_get_name
1121 (gnutls_mac_get (state
)))));
1127 /* Initialize global GnuTLS state to defaults.
1128 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1129 Return zero on success. */
1131 emacs_gnutls_global_init (void)
1133 int ret
= GNUTLS_E_SUCCESS
;
1135 if (!gnutls_global_initialized
)
1137 ret
= gnutls_global_init ();
1138 if (ret
== GNUTLS_E_SUCCESS
)
1139 gnutls_global_initialized
= 1;
1142 return gnutls_make_error (ret
);
1146 gnutls_ip_address_p (char *string
)
1150 while ((c
= *string
++) != 0)
1151 if (! ((c
== '.' || c
== ':' || (c
>= '0' && c
<= '9'))))
1158 /* Deinitialize global GnuTLS state.
1159 See also `gnutls-global-init'. */
1161 emacs_gnutls_global_deinit (void)
1163 if (gnutls_global_initialized
)
1164 gnutls_global_deinit ();
1166 gnutls_global_initialized
= 0;
1168 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1172 static void ATTRIBUTE_FORMAT_PRINTF (2, 3)
1173 boot_error (struct Lisp_Process
*p
, const char *m
, ...)
1177 if (p
->is_non_blocking_client
)
1178 pset_status (p
, list2 (Qfailed
, vformat_string (m
, ap
)));
1185 gnutls_verify_boot (Lisp_Object proc
, Lisp_Object proplist
)
1188 struct Lisp_Process
*p
= XPROCESS (proc
);
1189 gnutls_session_t state
= p
->gnutls_state
;
1190 unsigned int peer_verification
;
1191 Lisp_Object warnings
;
1192 int max_log_level
= p
->gnutls_log_level
;
1193 Lisp_Object hostname
, verify_error
;
1194 bool verify_error_all
= false;
1197 if (NILP (proplist
))
1198 proplist
= Fcdr (Fplist_get (p
->childp
, QCtls_parameters
));
1200 verify_error
= Fplist_get (proplist
, QCverify_error
);
1201 hostname
= Fplist_get (proplist
, QChostname
);
1203 if (EQ (verify_error
, Qt
))
1204 verify_error_all
= true;
1205 else if (NILP (Flistp (verify_error
)))
1208 "gnutls-boot: invalid :verify_error parameter (not a list)");
1212 if (!STRINGP (hostname
))
1214 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1217 c_hostname
= SSDATA (hostname
);
1219 /* Now verify the peer, following
1220 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1221 The peer should present at least one certificate in the chain; do a
1222 check of the certificate's hostname with
1223 gnutls_x509_crt_check_hostname against :hostname. */
1225 ret
= gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1226 if (ret
< GNUTLS_E_SUCCESS
)
1227 return gnutls_make_error (ret
);
1229 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1231 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1232 if (!NILP (warnings
))
1234 for (Lisp_Object tail
= warnings
; CONSP (tail
); tail
= XCDR (tail
))
1236 Lisp_Object warning
= XCAR (tail
);
1237 Lisp_Object message
= Fgnutls_peer_status_warning_describe (warning
);
1238 if (!NILP (message
))
1239 GNUTLS_LOG2 (1, max_log_level
, "verification:", SSDATA (message
));
1243 if (peer_verification
!= 0)
1245 if (verify_error_all
1246 || !NILP (Fmember (QCtrustfiles
, verify_error
)))
1248 emacs_gnutls_deinit (proc
);
1250 "Certificate validation failed %s, verification code %x",
1251 c_hostname
, peer_verification
);
1256 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1261 /* Up to here the process is the same for X.509 certificates and
1262 OpenPGP keys. From now on X.509 certificates are assumed. This
1263 can be easily extended to work with openpgp keys as well. */
1264 if (gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1266 gnutls_x509_crt_t gnutls_verify_cert
;
1267 const gnutls_datum_t
*gnutls_verify_cert_list
;
1268 unsigned int gnutls_verify_cert_list_size
;
1270 ret
= gnutls_x509_crt_init (&gnutls_verify_cert
);
1271 if (ret
< GNUTLS_E_SUCCESS
)
1272 return gnutls_make_error (ret
);
1274 gnutls_verify_cert_list
1275 = gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1277 if (gnutls_verify_cert_list
== NULL
)
1279 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1280 emacs_gnutls_deinit (proc
);
1281 boot_error (p
, "No x509 certificate was found\n");
1285 /* Check only the first certificate in the given chain. */
1286 ret
= gnutls_x509_crt_import (gnutls_verify_cert
,
1287 &gnutls_verify_cert_list
[0],
1288 GNUTLS_X509_FMT_DER
);
1290 if (ret
< GNUTLS_E_SUCCESS
)
1292 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1293 return gnutls_make_error (ret
);
1296 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1298 int err
= gnutls_x509_crt_check_hostname (gnutls_verify_cert
,
1300 check_memory_full (err
);
1303 XPROCESS (proc
)->gnutls_extra_peer_verification
1304 |= CERTIFICATE_NOT_MATCHING
;
1305 if (verify_error_all
1306 || !NILP (Fmember (QChostname
, verify_error
)))
1308 gnutls_x509_crt_deinit (gnutls_verify_cert
);
1309 emacs_gnutls_deinit (proc
);
1310 boot_error (p
, "The x509 certificate does not match \"%s\"",
1315 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1320 /* Set this flag only if the whole initialization succeeded. */
1321 XPROCESS (proc
)->gnutls_p
= true;
1323 return gnutls_make_error (ret
);
1326 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
1327 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1328 Currently only client mode is supported. Return a success/failure
1329 value you can check with `gnutls-errorp'.
1331 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1332 PROPLIST is a property list with the following keys:
1334 :hostname is a string naming the remote host.
1336 :priority is a GnuTLS priority string, defaults to "NORMAL".
1338 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1340 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1342 :keylist is an alist of PEM-encoded key files and PEM-encoded
1343 certificates for `gnutls-x509pki'.
1345 :callbacks is an alist of callback functions, see below.
1347 :loglevel is the debug level requested from GnuTLS, try 4.
1349 :verify-flags is a bitset as per GnuTLS'
1350 gnutls_certificate_set_verify_flags.
1352 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1355 :verify-error is a list of symbols to express verification checks or
1356 t to do all checks. Currently it can contain `:trustfiles' and
1357 `:hostname' to verify the certificate or the hostname respectively.
1359 :min-prime-bits is the minimum accepted number of bits the client will
1360 accept in Diffie-Hellman key exchange.
1362 :complete-negotiation, if non-nil, will make negotiation complete
1363 before returning even on non-blocking sockets.
1365 The debug level will be set for this process AND globally for GnuTLS.
1366 So if you set it higher or lower at any point, it affects global
1369 Note that the priority is set on the client. The server does not use
1370 the protocols's priority except for disabling protocols that were not
1373 Processes must be initialized with this function before other GnuTLS
1374 functions are used. This function allocates resources which can only
1375 be deallocated by calling `gnutls-deinit' or by calling it again.
1377 The callbacks alist can have a `verify' key, associated with a
1378 verification function (UNUSED).
1380 Each authentication type may need additional information in order to
1381 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1382 one trustfile (usually a CA bundle). */)
1383 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
1385 int ret
= GNUTLS_E_SUCCESS
;
1386 int max_log_level
= 0;
1388 gnutls_session_t state
;
1389 gnutls_certificate_credentials_t x509_cred
= NULL
;
1390 gnutls_anon_client_credentials_t anon_cred
= NULL
;
1391 Lisp_Object global_init
;
1392 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
1395 /* Placeholders for the property list elements. */
1396 Lisp_Object priority_string
;
1397 Lisp_Object trustfiles
;
1398 Lisp_Object crlfiles
;
1399 Lisp_Object keylist
;
1400 /* Lisp_Object callbacks; */
1401 Lisp_Object loglevel
;
1402 Lisp_Object hostname
;
1403 Lisp_Object prime_bits
;
1404 struct Lisp_Process
*p
= XPROCESS (proc
);
1406 CHECK_PROCESS (proc
);
1407 CHECK_SYMBOL (type
);
1408 CHECK_LIST (proplist
);
1410 if (NILP (Fgnutls_available_p ()))
1412 boot_error (p
, "GnuTLS not available");
1416 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
1418 boot_error (p
, "Invalid GnuTLS credential type");
1422 hostname
= Fplist_get (proplist
, QChostname
);
1423 priority_string
= Fplist_get (proplist
, QCpriority
);
1424 trustfiles
= Fplist_get (proplist
, QCtrustfiles
);
1425 keylist
= Fplist_get (proplist
, QCkeylist
);
1426 crlfiles
= Fplist_get (proplist
, QCcrlfiles
);
1427 loglevel
= Fplist_get (proplist
, QCloglevel
);
1428 prime_bits
= Fplist_get (proplist
, QCmin_prime_bits
);
1430 if (!STRINGP (hostname
))
1432 boot_error (p
, "gnutls-boot: invalid :hostname parameter (not a string)");
1435 c_hostname
= SSDATA (hostname
);
1437 state
= XPROCESS (proc
)->gnutls_state
;
1439 if (TYPE_RANGED_INTEGERP (int, loglevel
))
1441 gnutls_global_set_log_function (gnutls_log_function
);
1443 gnutls_global_set_audit_log_function (gnutls_audit_log_function
);
1445 gnutls_global_set_log_level (XINT (loglevel
));
1446 max_log_level
= XINT (loglevel
);
1447 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
1450 GNUTLS_LOG2 (1, max_log_level
, "connecting to host:", c_hostname
);
1452 /* Always initialize globals. */
1453 global_init
= emacs_gnutls_global_init ();
1454 if (! NILP (Fgnutls_errorp (global_init
)))
1457 /* Before allocating new credentials, deallocate any credentials
1458 that PROC might already have. */
1459 emacs_gnutls_deinit (proc
);
1461 /* Mark PROC as a GnuTLS process. */
1462 XPROCESS (proc
)->gnutls_state
= NULL
;
1463 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
1464 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
1465 pset_gnutls_cred_type (XPROCESS (proc
), type
);
1466 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
1468 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
1469 if (EQ (type
, Qgnutls_x509pki
))
1471 Lisp_Object verify_flags
;
1472 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
1474 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
1475 check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred
));
1476 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
1478 verify_flags
= Fplist_get (proplist
, QCverify_flags
);
1479 if (NUMBERP (verify_flags
))
1481 gnutls_verify_flags
= XINT (verify_flags
);
1482 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
1484 else if (NILP (verify_flags
))
1485 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
1487 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
1489 gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
1491 else /* Qgnutls_anon: */
1493 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
1494 check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred
));
1495 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
1498 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
1500 if (EQ (type
, Qgnutls_x509pki
))
1502 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1503 int file_format
= GNUTLS_X509_FMT_PEM
;
1506 #if GNUTLS_VERSION_MAJOR + \
1507 (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
1508 ret
= gnutls_certificate_set_x509_system_trust (x509_cred
);
1509 if (ret
< GNUTLS_E_SUCCESS
)
1511 check_memory_full (ret
);
1512 GNUTLS_LOG2i (4, max_log_level
,
1513 "setting system trust failed with code ", ret
);
1517 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
1519 Lisp_Object trustfile
= XCAR (tail
);
1520 if (STRINGP (trustfile
))
1522 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
1523 SSDATA (trustfile
));
1524 trustfile
= ENCODE_FILE (trustfile
);
1526 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1527 file names on Windows, we need to re-encode the file
1528 name using the current ANSI codepage. */
1529 trustfile
= ansi_encode_filename (trustfile
);
1531 ret
= gnutls_certificate_set_x509_trust_file
1536 if (ret
< GNUTLS_E_SUCCESS
)
1537 return gnutls_make_error (ret
);
1541 emacs_gnutls_deinit (proc
);
1542 boot_error (p
, "Invalid trustfile");
1547 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
1549 Lisp_Object crlfile
= XCAR (tail
);
1550 if (STRINGP (crlfile
))
1552 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
1554 crlfile
= ENCODE_FILE (crlfile
);
1556 crlfile
= ansi_encode_filename (crlfile
);
1558 ret
= gnutls_certificate_set_x509_crl_file
1559 (x509_cred
, SSDATA (crlfile
), file_format
);
1561 if (ret
< GNUTLS_E_SUCCESS
)
1562 return gnutls_make_error (ret
);
1566 emacs_gnutls_deinit (proc
);
1567 boot_error (p
, "Invalid CRL file");
1572 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
1574 Lisp_Object keyfile
= Fcar (XCAR (tail
));
1575 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
1576 if (STRINGP (keyfile
) && STRINGP (certfile
))
1578 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
1580 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
1582 keyfile
= ENCODE_FILE (keyfile
);
1583 certfile
= ENCODE_FILE (certfile
);
1585 keyfile
= ansi_encode_filename (keyfile
);
1586 certfile
= ansi_encode_filename (certfile
);
1588 ret
= gnutls_certificate_set_x509_key_file
1589 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
1591 if (ret
< GNUTLS_E_SUCCESS
)
1592 return gnutls_make_error (ret
);
1596 emacs_gnutls_deinit (proc
);
1597 boot_error (p
, STRINGP (keyfile
) ? "Invalid client cert file"
1598 : "Invalid client key file");
1604 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
1605 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
1606 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
1608 /* Call gnutls_init here: */
1610 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
1611 int gnutls_flags
= GNUTLS_CLIENT
;
1612 #ifdef GNUTLS_NONBLOCK
1613 if (XPROCESS (proc
)->is_non_blocking_client
)
1614 gnutls_flags
|= GNUTLS_NONBLOCK
;
1616 ret
= gnutls_init (&state
, gnutls_flags
);
1617 XPROCESS (proc
)->gnutls_state
= state
;
1618 if (ret
< GNUTLS_E_SUCCESS
)
1619 return gnutls_make_error (ret
);
1620 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
1622 if (STRINGP (priority_string
))
1624 priority_string_ptr
= SSDATA (priority_string
);
1625 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
1626 priority_string_ptr
);
1630 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
1631 priority_string_ptr
);
1634 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
1635 ret
= gnutls_priority_set_direct (state
, priority_string_ptr
, NULL
);
1636 if (ret
< GNUTLS_E_SUCCESS
)
1637 return gnutls_make_error (ret
);
1639 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
1641 if (INTEGERP (prime_bits
))
1642 gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
1644 ret
= EQ (type
, Qgnutls_x509pki
)
1645 ? gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
1646 : gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
1647 if (ret
< GNUTLS_E_SUCCESS
)
1648 return gnutls_make_error (ret
);
1650 if (!gnutls_ip_address_p (c_hostname
))
1652 ret
= gnutls_server_name_set (state
, GNUTLS_NAME_DNS
, c_hostname
,
1653 strlen (c_hostname
));
1654 if (ret
< GNUTLS_E_SUCCESS
)
1655 return gnutls_make_error (ret
);
1658 XPROCESS (proc
)->gnutls_complete_negotiation_p
=
1659 !NILP (Fplist_get (proplist
, QCcomplete_negotiation
));
1660 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
1661 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
1662 if (ret
< GNUTLS_E_SUCCESS
)
1663 return gnutls_make_error (ret
);
1665 return gnutls_verify_boot (proc
, proplist
);
1668 DEFUN ("gnutls-bye", Fgnutls_bye
,
1669 Sgnutls_bye
, 2, 2, 0,
1670 doc
: /* Terminate current GnuTLS connection for process PROC.
1671 The connection should have been initiated using `gnutls-handshake'.
1673 If CONT is not nil the TLS connection gets terminated and further
1674 receives and sends will be disallowed. If the return value is zero you
1675 may continue using the connection. If CONT is nil, GnuTLS actually
1676 sends an alert containing a close request and waits for the peer to
1677 reply with the same message. In order to reuse the connection you
1678 should wait for an EOF from the peer.
1680 This function may also return `gnutls-e-again', or
1681 `gnutls-e-interrupted'. */)
1682 (Lisp_Object proc
, Lisp_Object cont
)
1684 gnutls_session_t state
;
1687 CHECK_PROCESS (proc
);
1689 state
= XPROCESS (proc
)->gnutls_state
;
1691 gnutls_x509_crt_deinit (XPROCESS (proc
)->gnutls_certificate
);
1693 ret
= gnutls_bye (state
, NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1695 return gnutls_make_error (ret
);
1698 #endif /* HAVE_GNUTLS */
1700 DEFUN ("gnutls-available-p", Fgnutls_available_p
, Sgnutls_available_p
, 0, 0, 0,
1701 doc
: /* Return t if GnuTLS is available in this instance of Emacs. */)
1706 Lisp_Object found
= Fassq (Qgnutls
, Vlibrary_cache
);
1708 return XCDR (found
);
1712 status
= init_gnutls_functions () ? Qt
: Qnil
;
1713 Vlibrary_cache
= Fcons (Fcons (Qgnutls
, status
), Vlibrary_cache
);
1716 # else /* !WINDOWSNT */
1718 # endif /* !WINDOWSNT */
1719 #else /* !HAVE_GNUTLS */
1721 #endif /* !HAVE_GNUTLS */
1725 syms_of_gnutls (void)
1727 DEFSYM (Qlibgnutls_version
, "libgnutls-version");
1728 Fset (Qlibgnutls_version
,
1730 make_number (GNUTLS_VERSION_MAJOR
* 10000
1731 + GNUTLS_VERSION_MINOR
* 100
1732 + GNUTLS_VERSION_PATCH
)
1738 gnutls_global_initialized
= 0;
1740 DEFSYM (Qgnutls_code
, "gnutls-code");
1741 DEFSYM (Qgnutls_anon
, "gnutls-anon");
1742 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
1744 /* The following are for the property list of 'gnutls-boot'. */
1745 DEFSYM (QChostname
, ":hostname");
1746 DEFSYM (QCpriority
, ":priority");
1747 DEFSYM (QCtrustfiles
, ":trustfiles");
1748 DEFSYM (QCkeylist
, ":keylist");
1749 DEFSYM (QCcrlfiles
, ":crlfiles");
1750 DEFSYM (QCmin_prime_bits
, ":min-prime-bits");
1751 DEFSYM (QCloglevel
, ":loglevel");
1752 DEFSYM (QCcomplete_negotiation
, ":complete-negotiation");
1753 DEFSYM (QCverify_flags
, ":verify-flags");
1754 DEFSYM (QCverify_error
, ":verify-error");
1756 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
1757 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
1758 make_number (GNUTLS_E_INTERRUPTED
));
1760 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
1761 Fput (Qgnutls_e_again
, Qgnutls_code
,
1762 make_number (GNUTLS_E_AGAIN
));
1764 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
1765 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
1766 make_number (GNUTLS_E_INVALID_SESSION
));
1768 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
1769 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
1770 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
1772 defsubr (&Sgnutls_get_initstage
);
1773 defsubr (&Sgnutls_asynchronous_parameters
);
1774 defsubr (&Sgnutls_errorp
);
1775 defsubr (&Sgnutls_error_fatalp
);
1776 defsubr (&Sgnutls_error_string
);
1777 defsubr (&Sgnutls_boot
);
1778 defsubr (&Sgnutls_deinit
);
1779 defsubr (&Sgnutls_bye
);
1780 defsubr (&Sgnutls_peer_status
);
1781 defsubr (&Sgnutls_peer_status_warning_describe
);
1783 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
1784 doc
: /* Logging level used by the GnuTLS functions.
1785 Set this larger than 0 to get debug output in the *Messages* buffer.
1786 1 is for important messages, 2 is for debug data, and higher numbers
1787 are as per the GnuTLS logging conventions. */);
1788 global_gnutls_log_level
= 0;
1790 #endif /* HAVE_GNUTLS */
1792 defsubr (&Sgnutls_available_p
);