Restore follow-scroll-up/down to scrolling by the combined size of all windows
[emacs.git] / src / gnutls.c
blobf0354d7fedf31680902272d900b78b7c5439036e
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 (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/>. */
19 #include <config.h>
20 #include <errno.h>
21 #include <stdio.h>
23 #include "lisp.h"
24 #include "process.h"
25 #include "gnutls.h"
26 #include "coding.h"
28 #ifdef HAVE_GNUTLS
29 #include <gnutls/gnutls.h>
31 #ifdef WINDOWSNT
32 #include <windows.h>
33 #include "w32.h"
34 #endif
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 *);
42 #ifdef HAVE_GNUTLS3
43 static void gnutls_audit_log_function (gnutls_session_t, const char *);
44 #endif
46 enum extra_peer_verification
48 CERTIFICATE_NOT_MATCHING = 2
52 #ifdef WINDOWSNT
54 DEF_DLL_FN (gnutls_alert_description_t, gnutls_alert_get,
55 (gnutls_session_t));
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)) \
80 > 3)
81 DEF_DLL_FN (int, gnutls_certificate_set_x509_system_trust,
82 (gnutls_certificate_credentials_t));
83 # endif
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,
88 (gnutls_session_t));
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));
100 # ifdef HAVE_GNUTLS3
101 DEF_DLL_FN (void, gnutls_global_set_audit_log_function, (gnutls_audit_log_func));
102 # endif
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,
133 (gnutls_x509_crt_t,
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,
171 (gnutls_session_t));
172 DEF_DLL_FN (const char*, gnutls_protocol_get_name, (gnutls_protocol_t));
173 DEF_DLL_FN (gnutls_cipher_algorithm_t, gnutls_cipher_get,
174 (gnutls_session_t));
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));
181 static bool
182 init_gnutls_functions (void)
184 HMODULE library;
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");
190 return 0;
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)) \
207 > 3)
208 LOAD_DLL_FN (library, gnutls_certificate_set_x509_system_trust);
209 # endif
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);
220 # ifdef HAVE_GNUTLS3
221 LOAD_DLL_FN (library, gnutls_global_set_audit_log_function);
222 # endif
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");
280 return 1;
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
353 #endif
356 /* Report memory exhaustion if ERR is an out-of-memory indication. */
357 static void
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)
364 memory_full (0);
367 #ifdef HAVE_GNUTLS3
368 /* Log a simple audit message. */
369 static void
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);
377 #endif
379 /* Log a simple message. */
380 static void
381 gnutls_log_function (int level, const char *string)
383 message ("gnutls.c: [%d] %s", level, string);
386 /* Log a message and a string. */
387 static void
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. */
394 static void
395 gnutls_log_function2i (int level, const char *string, int extra)
397 message ("gnutls.c: [%d] %s %d", level, string, extra);
400 static int
401 emacs_gnutls_handshake (struct Lisp_Process *proc)
403 gnutls_session_t state = proc->gnutls_state;
404 int ret;
406 if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
407 return -1;
409 if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
411 #ifdef WINDOWSNT
412 /* On W32 we cannot transfer socket handles between different runtime
413 libraries, so we tell GnuTLS to use our special push/pull
414 functions. */
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
427 set.) */
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
431 version 2.99.0. */
432 if (!gnutls_check_version ("2.11.1"))
433 gnutls_transport_set_lowat (state, 0);
434 #else
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);
441 #endif
443 proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
448 ret = gnutls_handshake (state);
449 emacs_gnutls_handle_error (state, ret);
450 QUIT;
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;
461 else
463 check_memory_full (gnutls_alert_send_appropriate (state, ret));
465 return ret;
468 ptrdiff_t
469 emacs_gnutls_record_check_pending (gnutls_session_t state)
471 return gnutls_record_check_pending (state);
474 #ifdef WINDOWSNT
475 void
476 emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
478 gnutls_transport_set_errno (state, err);
480 #endif
482 ptrdiff_t
483 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
485 ssize_t rtnval = 0;
486 ptrdiff_t bytes_written;
487 gnutls_session_t state = proc->gnutls_state;
489 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
491 errno = EAGAIN;
492 return 0;
495 bytes_written = 0;
497 while (nbyte > 0)
499 rtnval = gnutls_record_send (state, buf, nbyte);
501 if (rtnval < 0)
503 if (rtnval == GNUTLS_E_INTERRUPTED)
504 continue;
505 else
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)
511 errno = EAGAIN;
512 break;
516 buf += rtnval;
517 nbyte -= rtnval;
518 bytes_written += rtnval;
521 emacs_gnutls_handle_error (state, rtnval);
522 return (bytes_written);
525 ptrdiff_t
526 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
528 ssize_t rtnval;
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);
544 return -1;
547 GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
548 proc->gnutls_handshakes_tried = 0;
549 return 0;
551 rtnval = gnutls_record_recv (state, buf, nbyte);
552 if (rtnval >= 0)
553 return rtnval;
554 else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
555 /* The peer closed the connection. */
556 return 0;
557 else if (emacs_gnutls_handle_error (state, rtnval))
558 /* non-fatal error */
559 return -1;
560 else {
561 /* a fatal error occurred */
562 return 0;
566 /* Report a GnuTLS error to the user.
567 Return true if the error code was successfully handled. */
568 static bool
569 emacs_gnutls_handle_error (gnutls_session_t session, int err)
571 int max_log_level = 0;
573 bool ret;
574 const char *str;
576 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
577 if (err >= 0)
578 return 1;
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);
587 if (!str)
588 str = "unknown";
590 if (gnutls_error_is_fatal (err))
592 ret = 0;
593 GNUTLS_LOG2 (1, max_log_level, "fatal error:", str);
595 else
597 ret = 1;
599 switch (err)
601 case GNUTLS_E_AGAIN:
602 GNUTLS_LOG2 (3,
603 max_log_level,
604 "retry:",
605 str);
606 default:
607 GNUTLS_LOG2 (1,
608 max_log_level,
609 "non-fatal error:",
610 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);
620 if (!str)
621 str = "unknown";
623 GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
625 return ret;
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
631 to Qt. */
632 static Lisp_Object
633 gnutls_make_error (int err)
635 switch (err)
637 case GNUTLS_E_SUCCESS:
638 return Qt;
639 case GNUTLS_E_AGAIN:
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);
651 Lisp_Object
652 emacs_gnutls_deinit (Lisp_Object proc)
654 int log_level;
656 CHECK_PROCESS (proc);
658 if (XPROCESS (proc)->gnutls_p == 0)
659 return Qnil;
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;
686 return Qt;
689 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
690 doc: /* Return the GnuTLS init stage of process PROC.
691 See also `gnutls-boot'. */)
692 (Lisp_Object proc)
694 CHECK_PROCESS (proc);
696 return make_number (GNUTLS_INITSTAGE (proc));
699 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
700 doc: /* Return t if ERROR indicates a GnuTLS problem.
701 ERROR is an integer or a symbol with an integer `gnutls-code' property.
702 usage: (gnutls-errorp ERROR) */
703 attributes: const)
704 (Lisp_Object err)
706 if (EQ (err, Qt)) return Qnil;
708 return Qt;
711 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
712 doc: /* Return non-nil if ERROR is fatal.
713 ERROR is an integer or a symbol with an integer `gnutls-code' property.
714 Usage: (gnutls-error-fatalp ERROR) */)
715 (Lisp_Object err)
717 Lisp_Object code;
719 if (EQ (err, Qt)) return Qnil;
721 if (SYMBOLP (err))
723 code = Fget (err, Qgnutls_code);
724 if (NUMBERP (code))
726 err = code;
728 else
730 error ("Symbol has no numeric gnutls-code property");
734 if (! TYPE_RANGED_INTEGERP (int, err))
735 error ("Not an error symbol or code");
737 if (0 == gnutls_error_is_fatal (XINT (err)))
738 return Qnil;
740 return Qt;
743 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
744 doc: /* Return a description of ERROR.
745 ERROR is an integer or a symbol with an integer `gnutls-code' property.
746 usage: (gnutls-error-string ERROR) */)
747 (Lisp_Object err)
749 Lisp_Object code;
751 if (EQ (err, Qt)) return build_string ("Not an error");
753 if (SYMBOLP (err))
755 code = Fget (err, Qgnutls_code);
756 if (NUMBERP (code))
758 err = code;
760 else
762 return build_string ("Symbol has no numeric gnutls-code property");
766 if (! TYPE_RANGED_INTEGERP (int, err))
767 return build_string ("Not an error symbol or code");
769 return build_string (gnutls_strerror (XINT (err)));
772 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
773 doc: /* Deallocate GnuTLS resources associated with process PROC.
774 See also `gnutls-init'. */)
775 (Lisp_Object proc)
777 return emacs_gnutls_deinit (proc);
780 static Lisp_Object
781 gnutls_hex_string (unsigned char *buf, ptrdiff_t buf_size, const char *prefix)
783 ptrdiff_t prefix_length = strlen (prefix);
784 ptrdiff_t retlen;
785 if (INT_MULTIPLY_WRAPV (buf_size, 3, &retlen)
786 || INT_ADD_WRAPV (prefix_length - (buf_size != 0), retlen, &retlen))
787 string_overflow ();
788 Lisp_Object ret = make_uninit_string (retlen);
789 char *string = SSDATA (ret);
790 strcpy (string, prefix);
792 for (ptrdiff_t i = 0; i < buf_size; i++)
793 sprintf (string + i * 3 + prefix_length,
794 i == buf_size - 1 ? "%02x" : "%02x:",
795 buf[i]);
797 return ret;
800 static Lisp_Object
801 gnutls_certificate_details (gnutls_x509_crt_t cert)
803 Lisp_Object res = Qnil;
804 int err;
805 size_t buf_size;
807 /* Version. */
809 int version = gnutls_x509_crt_get_version (cert);
810 check_memory_full (version);
811 if (version >= GNUTLS_E_SUCCESS)
812 res = nconc2 (res, list2 (intern (":version"),
813 make_number (version)));
816 /* Serial. */
817 buf_size = 0;
818 err = gnutls_x509_crt_get_serial (cert, NULL, &buf_size);
819 check_memory_full (err);
820 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
822 void *serial = xmalloc (buf_size);
823 err = gnutls_x509_crt_get_serial (cert, serial, &buf_size);
824 check_memory_full (err);
825 if (err >= GNUTLS_E_SUCCESS)
826 res = nconc2 (res, list2 (intern (":serial-number"),
827 gnutls_hex_string (serial, buf_size, "")));
828 xfree (serial);
831 /* Issuer. */
832 buf_size = 0;
833 err = gnutls_x509_crt_get_issuer_dn (cert, NULL, &buf_size);
834 check_memory_full (err);
835 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
837 char *dn = xmalloc (buf_size);
838 err = gnutls_x509_crt_get_issuer_dn (cert, dn, &buf_size);
839 check_memory_full (err);
840 if (err >= GNUTLS_E_SUCCESS)
841 res = nconc2 (res, list2 (intern (":issuer"),
842 make_string (dn, buf_size)));
843 xfree (dn);
846 /* Validity. */
848 /* Add 1 to the buffer size, since 1900 is added to tm_year and
849 that might add 1 to the year length. */
850 char buf[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
851 struct tm t;
852 time_t tim = gnutls_x509_crt_get_activation_time (cert);
854 if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t))
855 res = nconc2 (res, list2 (intern (":valid-from"), build_string (buf)));
857 tim = gnutls_x509_crt_get_expiration_time (cert);
858 if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t))
859 res = nconc2 (res, list2 (intern (":valid-to"), build_string (buf)));
862 /* Subject. */
863 buf_size = 0;
864 err = gnutls_x509_crt_get_dn (cert, NULL, &buf_size);
865 check_memory_full (err);
866 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
868 char *dn = xmalloc (buf_size);
869 err = gnutls_x509_crt_get_dn (cert, dn, &buf_size);
870 check_memory_full (err);
871 if (err >= GNUTLS_E_SUCCESS)
872 res = nconc2 (res, list2 (intern (":subject"),
873 make_string (dn, buf_size)));
874 xfree (dn);
877 /* Versions older than 2.11 doesn't have these four functions. */
878 #if GNUTLS_VERSION_NUMBER >= 0x020b00
879 /* SubjectPublicKeyInfo. */
881 unsigned int bits;
883 err = gnutls_x509_crt_get_pk_algorithm (cert, &bits);
884 check_memory_full (err);
885 if (err >= GNUTLS_E_SUCCESS)
887 const char *name = gnutls_pk_algorithm_get_name (err);
888 if (name)
889 res = nconc2 (res, list2 (intern (":public-key-algorithm"),
890 build_string (name)));
892 name = gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
893 (err, bits));
894 res = nconc2 (res, list2 (intern (":certificate-security-level"),
895 build_string (name)));
899 /* Unique IDs. */
900 buf_size = 0;
901 err = gnutls_x509_crt_get_issuer_unique_id (cert, NULL, &buf_size);
902 check_memory_full (err);
903 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
905 char *buf = xmalloc (buf_size);
906 err = gnutls_x509_crt_get_issuer_unique_id (cert, buf, &buf_size);
907 check_memory_full (err);
908 if (err >= GNUTLS_E_SUCCESS)
909 res = nconc2 (res, list2 (intern (":issuer-unique-id"),
910 make_string (buf, buf_size)));
911 xfree (buf);
914 buf_size = 0;
915 err = gnutls_x509_crt_get_subject_unique_id (cert, NULL, &buf_size);
916 check_memory_full (err);
917 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
919 char *buf = xmalloc (buf_size);
920 err = gnutls_x509_crt_get_subject_unique_id (cert, buf, &buf_size);
921 check_memory_full (err);
922 if (err >= GNUTLS_E_SUCCESS)
923 res = nconc2 (res, list2 (intern (":subject-unique-id"),
924 make_string (buf, buf_size)));
925 xfree (buf);
927 #endif
929 /* Signature. */
930 err = gnutls_x509_crt_get_signature_algorithm (cert);
931 check_memory_full (err);
932 if (err >= GNUTLS_E_SUCCESS)
934 const char *name = gnutls_sign_get_name (err);
935 if (name)
936 res = nconc2 (res, list2 (intern (":signature-algorithm"),
937 build_string (name)));
940 /* Public key ID. */
941 buf_size = 0;
942 err = gnutls_x509_crt_get_key_id (cert, 0, NULL, &buf_size);
943 check_memory_full (err);
944 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
946 void *buf = xmalloc (buf_size);
947 err = gnutls_x509_crt_get_key_id (cert, 0, buf, &buf_size);
948 check_memory_full (err);
949 if (err >= GNUTLS_E_SUCCESS)
950 res = nconc2 (res, list2 (intern (":public-key-id"),
951 gnutls_hex_string (buf, buf_size, "sha1:")));
952 xfree (buf);
955 /* Certificate fingerprint. */
956 buf_size = 0;
957 err = gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1,
958 NULL, &buf_size);
959 check_memory_full (err);
960 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
962 void *buf = xmalloc (buf_size);
963 err = gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1,
964 buf, &buf_size);
965 check_memory_full (err);
966 if (err >= GNUTLS_E_SUCCESS)
967 res = nconc2 (res, list2 (intern (":certificate-id"),
968 gnutls_hex_string (buf, buf_size, "sha1:")));
969 xfree (buf);
972 return res;
975 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe, Sgnutls_peer_status_warning_describe, 1, 1, 0,
976 doc: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'. */)
977 (Lisp_Object status_symbol)
979 CHECK_SYMBOL (status_symbol);
981 if (EQ (status_symbol, intern (":invalid")))
982 return build_string ("certificate could not be verified");
984 if (EQ (status_symbol, intern (":revoked")))
985 return build_string ("certificate was revoked (CRL)");
987 if (EQ (status_symbol, intern (":self-signed")))
988 return build_string ("certificate signer was not found (self-signed)");
990 if (EQ (status_symbol, intern (":unknown-ca")))
991 return build_string ("the certificate was signed by an unknown "
992 "and therefore untrusted authority");
994 if (EQ (status_symbol, intern (":not-ca")))
995 return build_string ("certificate signer is not a CA");
997 if (EQ (status_symbol, intern (":insecure")))
998 return build_string ("certificate was signed with an insecure algorithm");
1000 if (EQ (status_symbol, intern (":not-activated")))
1001 return build_string ("certificate is not yet activated");
1003 if (EQ (status_symbol, intern (":expired")))
1004 return build_string ("certificate has expired");
1006 if (EQ (status_symbol, intern (":no-host-match")))
1007 return build_string ("certificate host does not match hostname");
1009 return Qnil;
1012 DEFUN ("gnutls-peer-status", Fgnutls_peer_status, Sgnutls_peer_status, 1, 1, 0,
1013 doc: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1014 The return value is a property list with top-level keys :warnings and
1015 :certificate. The :warnings entry is a list of symbols you can describe with
1016 `gnutls-peer-status-warning-describe'. */)
1017 (Lisp_Object proc)
1019 Lisp_Object warnings = Qnil, result = Qnil;
1020 unsigned int verification;
1021 gnutls_session_t state;
1023 CHECK_PROCESS (proc);
1025 if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_INIT)
1026 return Qnil;
1028 /* Then collect any warnings already computed by the handshake. */
1029 verification = XPROCESS (proc)->gnutls_peer_verification;
1031 if (verification & GNUTLS_CERT_INVALID)
1032 warnings = Fcons (intern (":invalid"), warnings);
1034 if (verification & GNUTLS_CERT_REVOKED)
1035 warnings = Fcons (intern (":revoked"), warnings);
1037 if (verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
1038 warnings = Fcons (intern (":unknown-ca"), warnings);
1040 if (verification & GNUTLS_CERT_SIGNER_NOT_CA)
1041 warnings = Fcons (intern (":not-ca"), warnings);
1043 if (verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1044 warnings = Fcons (intern (":insecure"), warnings);
1046 if (verification & GNUTLS_CERT_NOT_ACTIVATED)
1047 warnings = Fcons (intern (":not-activated"), warnings);
1049 if (verification & GNUTLS_CERT_EXPIRED)
1050 warnings = Fcons (intern (":expired"), warnings);
1052 if (XPROCESS (proc)->gnutls_extra_peer_verification &
1053 CERTIFICATE_NOT_MATCHING)
1054 warnings = Fcons (intern (":no-host-match"), warnings);
1056 /* This could get called in the INIT stage, when the certificate is
1057 not yet set. */
1058 if (XPROCESS (proc)->gnutls_certificate != NULL &&
1059 gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificate,
1060 XPROCESS (proc)->gnutls_certificate))
1061 warnings = Fcons (intern (":self-signed"), warnings);
1063 if (!NILP (warnings))
1064 result = list2 (intern (":warnings"), warnings);
1066 /* This could get called in the INIT stage, when the certificate is
1067 not yet set. */
1068 if (XPROCESS (proc)->gnutls_certificate != NULL)
1069 result = nconc2 (result, list2
1070 (intern (":certificate"),
1071 gnutls_certificate_details (XPROCESS (proc)->gnutls_certificate)));
1073 state = XPROCESS (proc)->gnutls_state;
1075 /* Diffie-Hellman prime bits. */
1077 int bits = gnutls_dh_get_prime_bits (state);
1078 check_memory_full (bits);
1079 if (bits > 0)
1080 result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"),
1081 make_number (bits)));
1084 /* Key exchange. */
1085 result = nconc2
1086 (result, list2 (intern (":key-exchange"),
1087 build_string (gnutls_kx_get_name
1088 (gnutls_kx_get (state)))));
1090 /* Protocol name. */
1091 result = nconc2
1092 (result, list2 (intern (":protocol"),
1093 build_string (gnutls_protocol_get_name
1094 (gnutls_protocol_get_version (state)))));
1096 /* Cipher name. */
1097 result = nconc2
1098 (result, list2 (intern (":cipher"),
1099 build_string (gnutls_cipher_get_name
1100 (gnutls_cipher_get (state)))));
1102 /* MAC name. */
1103 result = nconc2
1104 (result, list2 (intern (":mac"),
1105 build_string (gnutls_mac_get_name
1106 (gnutls_mac_get (state)))));
1109 return result;
1112 /* Initialize global GnuTLS state to defaults.
1113 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1114 Return zero on success. */
1115 Lisp_Object
1116 emacs_gnutls_global_init (void)
1118 int ret = GNUTLS_E_SUCCESS;
1120 if (!gnutls_global_initialized)
1122 ret = gnutls_global_init ();
1123 if (ret == GNUTLS_E_SUCCESS)
1124 gnutls_global_initialized = 1;
1127 return gnutls_make_error (ret);
1130 static bool
1131 gnutls_ip_address_p (char *string)
1133 char c;
1135 while ((c = *string++) != 0)
1136 if (! ((c == '.' || c == ':' || (c >= '0' && c <= '9'))))
1137 return false;
1139 return true;
1142 #if 0
1143 /* Deinitialize global GnuTLS state.
1144 See also `gnutls-global-init'. */
1145 static Lisp_Object
1146 emacs_gnutls_global_deinit (void)
1148 if (gnutls_global_initialized)
1149 gnutls_global_deinit ();
1151 gnutls_global_initialized = 0;
1153 return gnutls_make_error (GNUTLS_E_SUCCESS);
1155 #endif
1157 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
1158 doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1159 Currently only client mode is supported. Return a success/failure
1160 value you can check with `gnutls-errorp'.
1162 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1163 PROPLIST is a property list with the following keys:
1165 :hostname is a string naming the remote host.
1167 :priority is a GnuTLS priority string, defaults to "NORMAL".
1169 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1171 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1173 :keylist is an alist of PEM-encoded key files and PEM-encoded
1174 certificates for `gnutls-x509pki'.
1176 :callbacks is an alist of callback functions, see below.
1178 :loglevel is the debug level requested from GnuTLS, try 4.
1180 :verify-flags is a bitset as per GnuTLS'
1181 gnutls_certificate_set_verify_flags.
1183 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1184 instead.
1186 :verify-error is a list of symbols to express verification checks or
1187 t to do all checks. Currently it can contain `:trustfiles' and
1188 `:hostname' to verify the certificate or the hostname respectively.
1190 :min-prime-bits is the minimum accepted number of bits the client will
1191 accept in Diffie-Hellman key exchange.
1193 The debug level will be set for this process AND globally for GnuTLS.
1194 So if you set it higher or lower at any point, it affects global
1195 debugging.
1197 Note that the priority is set on the client. The server does not use
1198 the protocols's priority except for disabling protocols that were not
1199 specified.
1201 Processes must be initialized with this function before other GnuTLS
1202 functions are used. This function allocates resources which can only
1203 be deallocated by calling `gnutls-deinit' or by calling it again.
1205 The callbacks alist can have a `verify' key, associated with a
1206 verification function (UNUSED).
1208 Each authentication type may need additional information in order to
1209 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1210 one trustfile (usually a CA bundle). */)
1211 (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
1213 int ret = GNUTLS_E_SUCCESS;
1214 int max_log_level = 0;
1215 bool verify_error_all = 0;
1217 gnutls_session_t state;
1218 gnutls_certificate_credentials_t x509_cred = NULL;
1219 gnutls_anon_client_credentials_t anon_cred = NULL;
1220 Lisp_Object global_init;
1221 char const *priority_string_ptr = "NORMAL"; /* default priority string. */
1222 unsigned int peer_verification;
1223 char *c_hostname;
1225 /* Placeholders for the property list elements. */
1226 Lisp_Object priority_string;
1227 Lisp_Object trustfiles;
1228 Lisp_Object crlfiles;
1229 Lisp_Object keylist;
1230 /* Lisp_Object callbacks; */
1231 Lisp_Object loglevel;
1232 Lisp_Object hostname;
1233 Lisp_Object verify_error;
1234 Lisp_Object prime_bits;
1235 Lisp_Object warnings;
1237 CHECK_PROCESS (proc);
1238 CHECK_SYMBOL (type);
1239 CHECK_LIST (proplist);
1241 if (NILP (Fgnutls_available_p ()))
1242 error ("GnuTLS not available");
1244 if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
1245 error ("Invalid GnuTLS credential type");
1247 hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
1248 priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority);
1249 trustfiles = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
1250 keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist);
1251 crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
1252 loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
1253 verify_error = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
1254 prime_bits = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
1256 if (EQ (verify_error, Qt))
1258 verify_error_all = 1;
1260 else if (NILP (Flistp (verify_error)))
1262 error ("gnutls-boot: invalid :verify_error parameter (not a list)");
1265 if (!STRINGP (hostname))
1266 error ("gnutls-boot: invalid :hostname parameter (not a string)");
1267 c_hostname = SSDATA (hostname);
1269 state = XPROCESS (proc)->gnutls_state;
1271 if (TYPE_RANGED_INTEGERP (int, loglevel))
1273 gnutls_global_set_log_function (gnutls_log_function);
1274 #ifdef HAVE_GNUTLS3
1275 gnutls_global_set_audit_log_function (gnutls_audit_log_function);
1276 #endif
1277 gnutls_global_set_log_level (XINT (loglevel));
1278 max_log_level = XINT (loglevel);
1279 XPROCESS (proc)->gnutls_log_level = max_log_level;
1282 GNUTLS_LOG2 (1, max_log_level, "connecting to host:", c_hostname);
1284 /* Always initialize globals. */
1285 global_init = emacs_gnutls_global_init ();
1286 if (! NILP (Fgnutls_errorp (global_init)))
1287 return global_init;
1289 /* Before allocating new credentials, deallocate any credentials
1290 that PROC might already have. */
1291 emacs_gnutls_deinit (proc);
1293 /* Mark PROC as a GnuTLS process. */
1294 XPROCESS (proc)->gnutls_state = NULL;
1295 XPROCESS (proc)->gnutls_x509_cred = NULL;
1296 XPROCESS (proc)->gnutls_anon_cred = NULL;
1297 pset_gnutls_cred_type (XPROCESS (proc), type);
1298 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
1300 GNUTLS_LOG (1, max_log_level, "allocating credentials");
1301 if (EQ (type, Qgnutls_x509pki))
1303 Lisp_Object verify_flags;
1304 unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
1306 GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
1307 check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred));
1308 XPROCESS (proc)->gnutls_x509_cred = x509_cred;
1310 verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
1311 if (NUMBERP (verify_flags))
1313 gnutls_verify_flags = XINT (verify_flags);
1314 GNUTLS_LOG (2, max_log_level, "setting verification flags");
1316 else if (NILP (verify_flags))
1317 GNUTLS_LOG (2, max_log_level, "using default verification flags");
1318 else
1319 GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
1321 gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
1323 else /* Qgnutls_anon: */
1325 GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
1326 check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred));
1327 XPROCESS (proc)->gnutls_anon_cred = anon_cred;
1330 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
1332 if (EQ (type, Qgnutls_x509pki))
1334 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1335 int file_format = GNUTLS_X509_FMT_PEM;
1336 Lisp_Object tail;
1338 #if GNUTLS_VERSION_MAJOR + \
1339 (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
1340 ret = gnutls_certificate_set_x509_system_trust (x509_cred);
1341 if (ret < GNUTLS_E_SUCCESS)
1343 check_memory_full (ret);
1344 GNUTLS_LOG2i (4, max_log_level,
1345 "setting system trust failed with code ", ret);
1347 #endif
1349 for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
1351 Lisp_Object trustfile = XCAR (tail);
1352 if (STRINGP (trustfile))
1354 GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
1355 SSDATA (trustfile));
1356 trustfile = ENCODE_FILE (trustfile);
1357 #ifdef WINDOWSNT
1358 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1359 file names on Windows, we need to re-encode the file
1360 name using the current ANSI codepage. */
1361 trustfile = ansi_encode_filename (trustfile);
1362 #endif
1363 ret = gnutls_certificate_set_x509_trust_file
1364 (x509_cred,
1365 SSDATA (trustfile),
1366 file_format);
1368 if (ret < GNUTLS_E_SUCCESS)
1369 return gnutls_make_error (ret);
1371 else
1373 emacs_gnutls_deinit (proc);
1374 error ("Invalid trustfile");
1378 for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
1380 Lisp_Object crlfile = XCAR (tail);
1381 if (STRINGP (crlfile))
1383 GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
1384 SSDATA (crlfile));
1385 crlfile = ENCODE_FILE (crlfile);
1386 #ifdef WINDOWSNT
1387 crlfile = ansi_encode_filename (crlfile);
1388 #endif
1389 ret = gnutls_certificate_set_x509_crl_file
1390 (x509_cred, SSDATA (crlfile), file_format);
1392 if (ret < GNUTLS_E_SUCCESS)
1393 return gnutls_make_error (ret);
1395 else
1397 emacs_gnutls_deinit (proc);
1398 error ("Invalid CRL file");
1402 for (tail = keylist; CONSP (tail); tail = XCDR (tail))
1404 Lisp_Object keyfile = Fcar (XCAR (tail));
1405 Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
1406 if (STRINGP (keyfile) && STRINGP (certfile))
1408 GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
1409 SSDATA (keyfile));
1410 GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
1411 SSDATA (certfile));
1412 keyfile = ENCODE_FILE (keyfile);
1413 certfile = ENCODE_FILE (certfile);
1414 #ifdef WINDOWSNT
1415 keyfile = ansi_encode_filename (keyfile);
1416 certfile = ansi_encode_filename (certfile);
1417 #endif
1418 ret = gnutls_certificate_set_x509_key_file
1419 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
1421 if (ret < GNUTLS_E_SUCCESS)
1422 return gnutls_make_error (ret);
1424 else
1426 emacs_gnutls_deinit (proc);
1427 error (STRINGP (keyfile) ? "Invalid client cert file"
1428 : "Invalid client key file");
1433 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
1434 GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
1435 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
1437 /* Call gnutls_init here: */
1439 GNUTLS_LOG (1, max_log_level, "gnutls_init");
1440 ret = gnutls_init (&state, GNUTLS_CLIENT);
1441 XPROCESS (proc)->gnutls_state = state;
1442 if (ret < GNUTLS_E_SUCCESS)
1443 return gnutls_make_error (ret);
1444 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
1446 if (STRINGP (priority_string))
1448 priority_string_ptr = SSDATA (priority_string);
1449 GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
1450 priority_string_ptr);
1452 else
1454 GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
1455 priority_string_ptr);
1458 GNUTLS_LOG (1, max_log_level, "setting the priority string");
1459 ret = gnutls_priority_set_direct (state, priority_string_ptr, NULL);
1460 if (ret < GNUTLS_E_SUCCESS)
1461 return gnutls_make_error (ret);
1463 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
1465 if (INTEGERP (prime_bits))
1466 gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
1468 ret = EQ (type, Qgnutls_x509pki)
1469 ? gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
1470 : gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
1471 if (ret < GNUTLS_E_SUCCESS)
1472 return gnutls_make_error (ret);
1474 if (!gnutls_ip_address_p (c_hostname))
1476 ret = gnutls_server_name_set (state, GNUTLS_NAME_DNS, c_hostname,
1477 strlen (c_hostname));
1478 if (ret < GNUTLS_E_SUCCESS)
1479 return gnutls_make_error (ret);
1482 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
1483 ret = emacs_gnutls_handshake (XPROCESS (proc));
1484 if (ret < GNUTLS_E_SUCCESS)
1485 return gnutls_make_error (ret);
1487 /* Now verify the peer, following
1488 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1489 The peer should present at least one certificate in the chain; do a
1490 check of the certificate's hostname with
1491 gnutls_x509_crt_check_hostname against :hostname. */
1493 ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
1494 if (ret < GNUTLS_E_SUCCESS)
1495 return gnutls_make_error (ret);
1497 XPROCESS (proc)->gnutls_peer_verification = peer_verification;
1499 warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
1500 if (!NILP (warnings))
1502 Lisp_Object tail;
1503 for (tail = warnings; CONSP (tail); tail = XCDR (tail))
1505 Lisp_Object warning = XCAR (tail);
1506 Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
1507 if (!NILP (message))
1508 GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
1512 if (peer_verification != 0)
1514 if (verify_error_all
1515 || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
1517 emacs_gnutls_deinit (proc);
1518 error ("Certificate validation failed %s, verification code %x",
1519 c_hostname, peer_verification);
1521 else
1523 GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1524 c_hostname);
1528 /* Up to here the process is the same for X.509 certificates and
1529 OpenPGP keys. From now on X.509 certificates are assumed. This
1530 can be easily extended to work with openpgp keys as well. */
1531 if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1533 gnutls_x509_crt_t gnutls_verify_cert;
1534 const gnutls_datum_t *gnutls_verify_cert_list;
1535 unsigned int gnutls_verify_cert_list_size;
1537 ret = gnutls_x509_crt_init (&gnutls_verify_cert);
1538 if (ret < GNUTLS_E_SUCCESS)
1539 return gnutls_make_error (ret);
1541 gnutls_verify_cert_list =
1542 gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1544 if (gnutls_verify_cert_list == NULL)
1546 gnutls_x509_crt_deinit (gnutls_verify_cert);
1547 emacs_gnutls_deinit (proc);
1548 error ("No x509 certificate was found\n");
1551 /* We only check the first certificate in the given chain. */
1552 ret = gnutls_x509_crt_import (gnutls_verify_cert,
1553 &gnutls_verify_cert_list[0],
1554 GNUTLS_X509_FMT_DER);
1556 if (ret < GNUTLS_E_SUCCESS)
1558 gnutls_x509_crt_deinit (gnutls_verify_cert);
1559 return gnutls_make_error (ret);
1562 XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
1564 int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
1565 c_hostname);
1566 check_memory_full (err);
1567 if (!err)
1569 XPROCESS (proc)->gnutls_extra_peer_verification |=
1570 CERTIFICATE_NOT_MATCHING;
1571 if (verify_error_all
1572 || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
1574 gnutls_x509_crt_deinit (gnutls_verify_cert);
1575 emacs_gnutls_deinit (proc);
1576 error ("The x509 certificate does not match \"%s\"", c_hostname);
1578 else
1580 GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1581 c_hostname);
1586 /* Set this flag only if the whole initialization succeeded. */
1587 XPROCESS (proc)->gnutls_p = 1;
1589 return gnutls_make_error (ret);
1592 DEFUN ("gnutls-bye", Fgnutls_bye,
1593 Sgnutls_bye, 2, 2, 0,
1594 doc: /* Terminate current GnuTLS connection for process PROC.
1595 The connection should have been initiated using `gnutls-handshake'.
1597 If CONT is not nil the TLS connection gets terminated and further
1598 receives and sends will be disallowed. If the return value is zero you
1599 may continue using the connection. If CONT is nil, GnuTLS actually
1600 sends an alert containing a close request and waits for the peer to
1601 reply with the same message. In order to reuse the connection you
1602 should wait for an EOF from the peer.
1604 This function may also return `gnutls-e-again', or
1605 `gnutls-e-interrupted'. */)
1606 (Lisp_Object proc, Lisp_Object cont)
1608 gnutls_session_t state;
1609 int ret;
1611 CHECK_PROCESS (proc);
1613 state = XPROCESS (proc)->gnutls_state;
1615 gnutls_x509_crt_deinit (XPROCESS (proc)->gnutls_certificate);
1617 ret = gnutls_bye (state, NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1619 return gnutls_make_error (ret);
1622 #endif /* HAVE_GNUTLS */
1624 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
1625 doc: /* Return t if GnuTLS is available in this instance of Emacs. */)
1626 (void)
1628 #ifdef HAVE_GNUTLS
1629 # ifdef WINDOWSNT
1630 Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
1631 if (CONSP (found))
1632 return XCDR (found);
1633 else
1635 Lisp_Object status;
1636 status = init_gnutls_functions () ? Qt : Qnil;
1637 Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
1638 return status;
1640 # else /* !WINDOWSNT */
1641 return Qt;
1642 # endif /* !WINDOWSNT */
1643 #else /* !HAVE_GNUTLS */
1644 return Qnil;
1645 #endif /* !HAVE_GNUTLS */
1648 void
1649 syms_of_gnutls (void)
1651 DEFSYM (Qlibgnutls_version, "libgnutls-version");
1652 Fset (Qlibgnutls_version,
1653 #ifdef HAVE_GNUTLS
1654 make_number (GNUTLS_VERSION_MAJOR * 10000
1655 + GNUTLS_VERSION_MINOR * 100
1656 + GNUTLS_VERSION_PATCH)
1657 #else
1658 make_number (-1)
1659 #endif
1661 #ifdef HAVE_GNUTLS
1662 gnutls_global_initialized = 0;
1664 DEFSYM (Qgnutls_code, "gnutls-code");
1665 DEFSYM (Qgnutls_anon, "gnutls-anon");
1666 DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1668 /* The following are for the property list of 'gnutls-boot'. */
1669 DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1670 DEFSYM (QCgnutls_bootprop_priority, ":priority");
1671 DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1672 DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1673 DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1674 DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1675 DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1676 DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1677 DEFSYM (QCgnutls_bootprop_verify_error, ":verify-error");
1679 DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1680 Fput (Qgnutls_e_interrupted, Qgnutls_code,
1681 make_number (GNUTLS_E_INTERRUPTED));
1683 DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1684 Fput (Qgnutls_e_again, Qgnutls_code,
1685 make_number (GNUTLS_E_AGAIN));
1687 DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1688 Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1689 make_number (GNUTLS_E_INVALID_SESSION));
1691 DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1692 Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1693 make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1695 defsubr (&Sgnutls_get_initstage);
1696 defsubr (&Sgnutls_errorp);
1697 defsubr (&Sgnutls_error_fatalp);
1698 defsubr (&Sgnutls_error_string);
1699 defsubr (&Sgnutls_boot);
1700 defsubr (&Sgnutls_deinit);
1701 defsubr (&Sgnutls_bye);
1702 defsubr (&Sgnutls_peer_status);
1703 defsubr (&Sgnutls_peer_status_warning_describe);
1705 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1706 doc: /* Logging level used by the GnuTLS functions.
1707 Set this larger than 0 to get debug output in the *Messages* buffer.
1708 1 is for important messages, 2 is for debug data, and higher numbers
1709 are as per the GnuTLS logging conventions. */);
1710 global_gnutls_log_level = 0;
1712 #endif /* HAVE_GNUTLS */
1714 defsubr (&Sgnutls_available_p);