1 /* GnuTLS glue for GNU Emacs.
2 Copyright (C) 2010-2014 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include <gnutls/gnutls.h>
35 static bool emacs_gnutls_handle_error (gnutls_session_t
, int);
37 static Lisp_Object Qgnutls_dll
;
38 static Lisp_Object Qgnutls_code
;
39 static Lisp_Object Qgnutls_anon
, Qgnutls_x509pki
;
40 static Lisp_Object Qgnutls_e_interrupted
, Qgnutls_e_again
,
41 Qgnutls_e_invalid_session
, Qgnutls_e_not_ready_for_handshake
;
42 static bool gnutls_global_initialized
;
44 /* The following are for the property list of `gnutls-boot'. */
45 static Lisp_Object QCgnutls_bootprop_priority
;
46 static Lisp_Object QCgnutls_bootprop_trustfiles
;
47 static Lisp_Object QCgnutls_bootprop_keylist
;
48 static Lisp_Object QCgnutls_bootprop_crlfiles
;
49 static Lisp_Object QCgnutls_bootprop_callbacks
;
50 static Lisp_Object QCgnutls_bootprop_loglevel
;
51 static Lisp_Object QCgnutls_bootprop_hostname
;
52 static Lisp_Object QCgnutls_bootprop_min_prime_bits
;
53 static Lisp_Object QCgnutls_bootprop_verify_flags
;
54 static Lisp_Object QCgnutls_bootprop_verify_error
;
56 /* Callback keys for `gnutls-boot'. Unused currently. */
57 static Lisp_Object QCgnutls_bootprop_callbacks_verify
;
59 static void gnutls_log_function (int, const char *);
60 static void gnutls_log_function2 (int, const char *, const char *);
62 static void gnutls_audit_log_function (gnutls_session_t
, const char *);
65 enum extra_peer_verification
67 CERTIFICATE_NOT_MATCHING
= 2
73 /* Macro for defining functions that will be loaded from the GnuTLS DLL. */
74 #define DEF_GNUTLS_FN(rettype,func,args) static rettype (FAR CDECL *fn_##func)args
76 /* Macro for loading GnuTLS functions from the library. */
77 #define LOAD_GNUTLS_FN(lib,func) { \
78 fn_##func = (void *) GetProcAddress (lib, #func); \
79 if (!fn_##func) return 0; \
82 DEF_GNUTLS_FN (gnutls_alert_description_t
, gnutls_alert_get
,
84 DEF_GNUTLS_FN (const char *, gnutls_alert_get_name
,
85 (gnutls_alert_description_t
));
86 DEF_GNUTLS_FN (int, gnutls_alert_send_appropriate
, (gnutls_session_t
, int));
87 DEF_GNUTLS_FN (int, gnutls_anon_allocate_client_credentials
,
88 (gnutls_anon_client_credentials_t
*));
89 DEF_GNUTLS_FN (void, gnutls_anon_free_client_credentials
,
90 (gnutls_anon_client_credentials_t
));
91 DEF_GNUTLS_FN (int, gnutls_bye
, (gnutls_session_t
, gnutls_close_request_t
));
92 DEF_GNUTLS_FN (int, gnutls_certificate_allocate_credentials
,
93 (gnutls_certificate_credentials_t
*));
94 DEF_GNUTLS_FN (void, gnutls_certificate_free_credentials
,
95 (gnutls_certificate_credentials_t
));
96 DEF_GNUTLS_FN (const gnutls_datum_t
*, gnutls_certificate_get_peers
,
97 (gnutls_session_t
, unsigned int *));
98 DEF_GNUTLS_FN (void, gnutls_certificate_set_verify_flags
,
99 (gnutls_certificate_credentials_t
, unsigned int));
100 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_crl_file
,
101 (gnutls_certificate_credentials_t
, const char *,
102 gnutls_x509_crt_fmt_t
));
103 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_key_file
,
104 (gnutls_certificate_credentials_t
, const char *, const char *,
105 gnutls_x509_crt_fmt_t
));
106 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_trust_file
,
107 (gnutls_certificate_credentials_t
, const char *,
108 gnutls_x509_crt_fmt_t
));
109 DEF_GNUTLS_FN (gnutls_certificate_type_t
, gnutls_certificate_type_get
,
111 DEF_GNUTLS_FN (int, gnutls_certificate_verify_peers2
,
112 (gnutls_session_t
, unsigned int *));
113 DEF_GNUTLS_FN (int, gnutls_credentials_set
,
114 (gnutls_session_t
, gnutls_credentials_type_t
, void *));
115 DEF_GNUTLS_FN (void, gnutls_deinit
, (gnutls_session_t
));
116 DEF_GNUTLS_FN (void, gnutls_dh_set_prime_bits
,
117 (gnutls_session_t
, unsigned int));
118 DEF_GNUTLS_FN (int, gnutls_error_is_fatal
, (int));
119 DEF_GNUTLS_FN (int, gnutls_global_init
, (void));
120 DEF_GNUTLS_FN (void, gnutls_global_set_log_function
, (gnutls_log_func
));
122 DEF_GNUTLS_FN (void, gnutls_global_set_audit_log_function
, (gnutls_audit_log_func
));
124 DEF_GNUTLS_FN (void, gnutls_global_set_log_level
, (int));
125 DEF_GNUTLS_FN (void, gnutls_global_set_mem_functions
,
126 (gnutls_alloc_function
, gnutls_alloc_function
,
127 gnutls_is_secure_function
, gnutls_realloc_function
,
128 gnutls_free_function
));
129 DEF_GNUTLS_FN (int, gnutls_handshake
, (gnutls_session_t
));
130 DEF_GNUTLS_FN (int, gnutls_init
, (gnutls_session_t
*, gnutls_connection_end_t
));
131 DEF_GNUTLS_FN (int, gnutls_priority_set_direct
,
132 (gnutls_session_t
, const char *, const char **));
133 DEF_GNUTLS_FN (size_t, gnutls_record_check_pending
, (gnutls_session_t
));
134 DEF_GNUTLS_FN (ssize_t
, gnutls_record_recv
, (gnutls_session_t
, void *, size_t));
135 DEF_GNUTLS_FN (ssize_t
, gnutls_record_send
,
136 (gnutls_session_t
, const void *, size_t));
137 DEF_GNUTLS_FN (const char *, gnutls_strerror
, (int));
138 DEF_GNUTLS_FN (void, gnutls_transport_set_errno
, (gnutls_session_t
, int));
139 DEF_GNUTLS_FN (const char *, gnutls_check_version
, (const char *));
140 DEF_GNUTLS_FN (void, gnutls_transport_set_lowat
, (gnutls_session_t
, int));
141 DEF_GNUTLS_FN (void, gnutls_transport_set_ptr2
,
142 (gnutls_session_t
, gnutls_transport_ptr_t
,
143 gnutls_transport_ptr_t
));
144 DEF_GNUTLS_FN (void, gnutls_transport_set_pull_function
,
145 (gnutls_session_t
, gnutls_pull_func
));
146 DEF_GNUTLS_FN (void, gnutls_transport_set_push_function
,
147 (gnutls_session_t
, gnutls_push_func
));
148 DEF_GNUTLS_FN (int, gnutls_x509_crt_check_hostname
,
149 (gnutls_x509_crt_t
, const char *));
150 DEF_GNUTLS_FN (void, gnutls_x509_crt_deinit
, (gnutls_x509_crt_t
));
151 DEF_GNUTLS_FN (int, gnutls_x509_crt_import
,
152 (gnutls_x509_crt_t
, const gnutls_datum_t
*,
153 gnutls_x509_crt_fmt_t
));
154 DEF_GNUTLS_FN (int, gnutls_x509_crt_init
, (gnutls_x509_crt_t
*));
155 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_fingerprint
,
157 gnutls_digest_algorithm_t
, void *, size_t *));
158 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_version
,
159 (gnutls_x509_crt_t
));
160 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_serial
,
161 (gnutls_x509_crt_t
, void *, size_t *));
162 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_issuer_dn
,
163 (gnutls_x509_crt_t
, char *, size_t *));
164 DEF_GNUTLS_FN (time_t, gnutls_x509_crt_get_activation_time
,
165 (gnutls_x509_crt_t
));
166 DEF_GNUTLS_FN (time_t, gnutls_x509_crt_get_expiration_time
,
167 (gnutls_x509_crt_t
));
168 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_dn
,
169 (gnutls_x509_crt_t
, char *, size_t *));
170 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_pk_algorithm
,
171 (gnutls_x509_crt_t
, unsigned int *));
172 DEF_GNUTLS_FN (const char*, gnutls_pk_algorithm_get_name
,
173 (gnutls_pk_algorithm_t
));
174 DEF_GNUTLS_FN (int, gnutls_pk_bits_to_sec_param
,
175 (gnutls_pk_algorithm_t
, unsigned int));
176 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_issuer_unique_id
,
177 (gnutls_x509_crt_t
, char *, size_t *));
178 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_subject_unique_id
,
179 (gnutls_x509_crt_t
, char *, size_t *));
180 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_signature_algorithm
,
181 (gnutls_x509_crt_t
));
182 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_signature
,
183 (gnutls_x509_crt_t
, char *, size_t *));
184 DEF_GNUTLS_FN (int, gnutls_x509_crt_get_key_id
,
185 (gnutls_x509_crt_t
, unsigned int,
186 unsigned char *, size_t *_size
));
187 DEF_GNUTLS_FN (const char*, gnutls_sec_param_get_name
, (gnutls_sec_param_t
));
188 DEF_GNUTLS_FN (const char*, gnutls_sign_get_name
,
189 (gnutls_sign_algorithm_t
));
190 DEF_GNUTLS_FN (int, gnutls_server_name_set
, (gnutls_session_t
,
191 gnutls_server_name_type_t
,
192 const void *, size_t));
195 init_gnutls_functions (void)
198 int max_log_level
= 1;
200 if (!(library
= w32_delayed_load (Qgnutls_dll
)))
202 GNUTLS_LOG (1, max_log_level
, "GnuTLS library not found");
206 LOAD_GNUTLS_FN (library
, gnutls_alert_get
);
207 LOAD_GNUTLS_FN (library
, gnutls_alert_get_name
);
208 LOAD_GNUTLS_FN (library
, gnutls_alert_send_appropriate
);
209 LOAD_GNUTLS_FN (library
, gnutls_anon_allocate_client_credentials
);
210 LOAD_GNUTLS_FN (library
, gnutls_anon_free_client_credentials
);
211 LOAD_GNUTLS_FN (library
, gnutls_bye
);
212 LOAD_GNUTLS_FN (library
, gnutls_certificate_allocate_credentials
);
213 LOAD_GNUTLS_FN (library
, gnutls_certificate_free_credentials
);
214 LOAD_GNUTLS_FN (library
, gnutls_certificate_get_peers
);
215 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_verify_flags
);
216 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_x509_crl_file
);
217 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_x509_key_file
);
218 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_x509_trust_file
);
219 LOAD_GNUTLS_FN (library
, gnutls_certificate_type_get
);
220 LOAD_GNUTLS_FN (library
, gnutls_certificate_verify_peers2
);
221 LOAD_GNUTLS_FN (library
, gnutls_credentials_set
);
222 LOAD_GNUTLS_FN (library
, gnutls_deinit
);
223 LOAD_GNUTLS_FN (library
, gnutls_dh_set_prime_bits
);
224 LOAD_GNUTLS_FN (library
, gnutls_error_is_fatal
);
225 LOAD_GNUTLS_FN (library
, gnutls_global_init
);
226 LOAD_GNUTLS_FN (library
, gnutls_global_set_log_function
);
228 LOAD_GNUTLS_FN (library
, gnutls_global_set_audit_log_function
);
230 LOAD_GNUTLS_FN (library
, gnutls_global_set_log_level
);
231 LOAD_GNUTLS_FN (library
, gnutls_global_set_mem_functions
);
232 LOAD_GNUTLS_FN (library
, gnutls_handshake
);
233 LOAD_GNUTLS_FN (library
, gnutls_init
);
234 LOAD_GNUTLS_FN (library
, gnutls_priority_set_direct
);
235 LOAD_GNUTLS_FN (library
, gnutls_record_check_pending
);
236 LOAD_GNUTLS_FN (library
, gnutls_record_recv
);
237 LOAD_GNUTLS_FN (library
, gnutls_record_send
);
238 LOAD_GNUTLS_FN (library
, gnutls_strerror
);
239 LOAD_GNUTLS_FN (library
, gnutls_transport_set_errno
);
240 LOAD_GNUTLS_FN (library
, gnutls_check_version
);
241 /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
242 and later, and the function was removed entirely in 3.0.0. */
243 if (!fn_gnutls_check_version ("2.11.1"))
244 LOAD_GNUTLS_FN (library
, gnutls_transport_set_lowat
);
245 LOAD_GNUTLS_FN (library
, gnutls_transport_set_ptr2
);
246 LOAD_GNUTLS_FN (library
, gnutls_transport_set_pull_function
);
247 LOAD_GNUTLS_FN (library
, gnutls_transport_set_push_function
);
248 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_check_hostname
);
249 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_deinit
);
250 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_import
);
251 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_init
);
252 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_fingerprint
);
253 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_version
);
254 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_serial
);
255 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_issuer_dn
);
256 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_activation_time
);
257 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_expiration_time
);
258 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_dn
);
259 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_pk_algorithm
);
260 LOAD_GNUTLS_FN (library
, gnutls_pk_algorithm_get_name
);
261 LOAD_GNUTLS_FN (library
, gnutls_pk_bits_to_sec_param
);
262 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_issuer_unique_id
);
263 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_subject_unique_id
);
264 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_signature_algorithm
);
265 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_signature
);
266 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_key_id
);
267 LOAD_GNUTLS_FN (library
, gnutls_sec_param_get_name
);
268 LOAD_GNUTLS_FN (library
, gnutls_sign_get_name
);
269 LOAD_GNUTLS_FN (library
, gnutls_server_name_set
);
271 max_log_level
= global_gnutls_log_level
;
274 Lisp_Object name
= CAR_SAFE (Fget (Qgnutls_dll
, QCloaded_from
));
275 GNUTLS_LOG2 (1, max_log_level
, "GnuTLS library loaded:",
276 STRINGP (name
) ? (const char *) SDATA (name
) : "unknown");
282 #else /* !WINDOWSNT */
284 #define fn_gnutls_alert_get gnutls_alert_get
285 #define fn_gnutls_alert_get_name gnutls_alert_get_name
286 #define fn_gnutls_alert_send_appropriate gnutls_alert_send_appropriate
287 #define fn_gnutls_anon_allocate_client_credentials gnutls_anon_allocate_client_credentials
288 #define fn_gnutls_anon_free_client_credentials gnutls_anon_free_client_credentials
289 #define fn_gnutls_bye gnutls_bye
290 #define fn_gnutls_certificate_allocate_credentials gnutls_certificate_allocate_credentials
291 #define fn_gnutls_certificate_free_credentials gnutls_certificate_free_credentials
292 #define fn_gnutls_certificate_get_peers gnutls_certificate_get_peers
293 #define fn_gnutls_certificate_set_verify_flags gnutls_certificate_set_verify_flags
294 #define fn_gnutls_certificate_set_x509_crl_file gnutls_certificate_set_x509_crl_file
295 #define fn_gnutls_certificate_set_x509_key_file gnutls_certificate_set_x509_key_file
296 #define fn_gnutls_certificate_set_x509_trust_file gnutls_certificate_set_x509_trust_file
297 #define fn_gnutls_certificate_type_get gnutls_certificate_type_get
298 #define fn_gnutls_certificate_verify_peers2 gnutls_certificate_verify_peers2
299 #define fn_gnutls_credentials_set gnutls_credentials_set
300 #define fn_gnutls_deinit gnutls_deinit
301 #define fn_gnutls_dh_set_prime_bits gnutls_dh_set_prime_bits
302 #define fn_gnutls_error_is_fatal gnutls_error_is_fatal
303 #define fn_gnutls_global_init gnutls_global_init
304 #define fn_gnutls_global_set_log_function gnutls_global_set_log_function
306 #define fn_gnutls_global_set_audit_log_function gnutls_global_set_audit_log_function
308 #define fn_gnutls_global_set_log_level gnutls_global_set_log_level
309 #define fn_gnutls_global_set_mem_functions gnutls_global_set_mem_functions
310 #define fn_gnutls_handshake gnutls_handshake
311 #define fn_gnutls_init gnutls_init
312 #define fn_gnutls_priority_set_direct gnutls_priority_set_direct
313 #define fn_gnutls_record_check_pending gnutls_record_check_pending
314 #define fn_gnutls_record_recv gnutls_record_recv
315 #define fn_gnutls_record_send gnutls_record_send
316 #define fn_gnutls_strerror gnutls_strerror
318 #define fn_gnutls_transport_set_errno gnutls_transport_set_errno
320 #define fn_gnutls_transport_set_ptr2 gnutls_transport_set_ptr2
321 #define fn_gnutls_x509_crt_check_hostname gnutls_x509_crt_check_hostname
322 #define fn_gnutls_x509_crt_deinit gnutls_x509_crt_deinit
323 #define fn_gnutls_x509_crt_import gnutls_x509_crt_import
324 #define fn_gnutls_x509_crt_init gnutls_x509_crt_init
325 #define fn_gnutls_x509_crt_get_fingerprint gnutls_x509_crt_get_fingerprint
326 #define fn_gnutls_x509_crt_get_version gnutls_x509_crt_get_version
327 #define fn_gnutls_x509_crt_get_serial gnutls_x509_crt_get_serial
328 #define fn_gnutls_x509_crt_get_issuer_dn gnutls_x509_crt_get_issuer_dn
329 #define fn_gnutls_x509_crt_get_activation_time gnutls_x509_crt_get_activation_time
330 #define fn_gnutls_x509_crt_get_expiration_time gnutls_x509_crt_get_expiration_time
331 #define fn_gnutls_x509_crt_get_dn gnutls_x509_crt_get_dn
332 #define fn_gnutls_x509_crt_get_pk_algorithm gnutls_x509_crt_get_pk_algorithm
333 #define fn_gnutls_pk_algorithm_get_name gnutls_pk_algorithm_get_name
334 #define fn_gnutls_pk_bits_to_sec_param gnutls_pk_bits_to_sec_param
335 #define fn_gnutls_x509_crt_get_issuer_unique_id gnutls_x509_crt_get_issuer_unique_id
336 #define fn_gnutls_x509_crt_get_subject_unique_id gnutls_x509_crt_get_subject_unique_id
337 #define fn_gnutls_x509_crt_get_signature_algorithm gnutls_x509_crt_get_signature_algorithm
338 #define fn_gnutls_x509_crt_get_signature gnutls_x509_crt_get_signature
339 #define fn_gnutls_x509_crt_get_key_id gnutls_x509_crt_get_key_id
340 #define fn_gnutls_sec_param_get_name gnutls_sec_param_get_name
341 #define fn_gnutls_sign_get_name gnutls_sign_get_name
342 #define fn_gnutls_server_name_set gnutls_server_name_set
344 #endif /* !WINDOWSNT */
348 /* Function to log a simple audit message. */
350 gnutls_audit_log_function (gnutls_session_t session
, const char *string
)
352 if (global_gnutls_log_level
>= 1)
354 message ("gnutls.c: [audit] %s", string
);
359 /* Function to log a simple message. */
361 gnutls_log_function (int level
, const char *string
)
363 message ("gnutls.c: [%d] %s", level
, string
);
366 /* Function to log a message and a string. */
368 gnutls_log_function2 (int level
, const char *string
, const char *extra
)
370 message ("gnutls.c: [%d] %s %s", level
, string
, extra
);
373 /* Function to log a message and an integer. */
375 gnutls_log_function2i (int level
, const char *string
, int extra
)
377 message ("gnutls.c: [%d] %s %d", level
, string
, extra
);
381 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
383 gnutls_session_t state
= proc
->gnutls_state
;
386 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
389 if (proc
->gnutls_initstage
< GNUTLS_STAGE_TRANSPORT_POINTERS_SET
)
392 /* On W32 we cannot transfer socket handles between different runtime
393 libraries, so we tell GnuTLS to use our special push/pull
395 fn_gnutls_transport_set_ptr2 (state
,
396 (gnutls_transport_ptr_t
) proc
,
397 (gnutls_transport_ptr_t
) proc
);
398 fn_gnutls_transport_set_push_function (state
, &emacs_gnutls_push
);
399 fn_gnutls_transport_set_pull_function (state
, &emacs_gnutls_pull
);
401 /* For non blocking sockets or other custom made pull/push
402 functions the gnutls_transport_set_lowat must be called, with
403 a zero low water mark value. (GnuTLS 2.10.4 documentation)
405 (Note: this is probably not strictly necessary as the lowat
406 value is only used when no custom pull/push functions are
408 /* According to GnuTLS NEWS file, lowat level has been set to
409 zero by default in version 2.11.1, and the function
410 gnutls_transport_set_lowat was removed from the library in
412 if (!fn_gnutls_check_version ("2.11.1"))
413 fn_gnutls_transport_set_lowat (state
, 0);
415 /* This is how GnuTLS takes sockets: as file descriptors passed
416 in. For an Emacs process socket, infd and outfd are the
417 same but we use this two-argument version for clarity. */
418 fn_gnutls_transport_set_ptr2 (state
,
419 (void *) (intptr_t) proc
->infd
,
420 (void *) (intptr_t) proc
->outfd
);
423 proc
->gnutls_initstage
= GNUTLS_STAGE_TRANSPORT_POINTERS_SET
;
428 ret
= fn_gnutls_handshake (state
);
429 emacs_gnutls_handle_error (state
, ret
);
432 while (ret
< 0 && fn_gnutls_error_is_fatal (ret
) == 0);
434 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
436 if (ret
== GNUTLS_E_SUCCESS
)
438 /* Here we're finally done. */
439 proc
->gnutls_initstage
= GNUTLS_STAGE_READY
;
443 fn_gnutls_alert_send_appropriate (state
, ret
);
449 emacs_gnutls_record_check_pending (gnutls_session_t state
)
451 return fn_gnutls_record_check_pending (state
);
456 emacs_gnutls_transport_set_errno (gnutls_session_t state
, int err
)
458 fn_gnutls_transport_set_errno (state
, err
);
463 emacs_gnutls_write (struct Lisp_Process
*proc
, const char *buf
, ptrdiff_t nbyte
)
466 ptrdiff_t bytes_written
;
467 gnutls_session_t state
= proc
->gnutls_state
;
469 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
479 rtnval
= fn_gnutls_record_send (state
, buf
, nbyte
);
483 if (rtnval
== GNUTLS_E_INTERRUPTED
)
487 /* If we get GNUTLS_E_AGAIN, then set errno
488 appropriately so that send_process retries the
489 correct way instead of erroring out. */
490 if (rtnval
== GNUTLS_E_AGAIN
)
498 bytes_written
+= rtnval
;
501 emacs_gnutls_handle_error (state
, rtnval
);
502 return (bytes_written
);
506 emacs_gnutls_read (struct Lisp_Process
*proc
, char *buf
, ptrdiff_t nbyte
)
509 gnutls_session_t state
= proc
->gnutls_state
;
511 int log_level
= proc
->gnutls_log_level
;
513 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
515 /* If the handshake count is under the limit, try the handshake
516 again and increment the handshake count. This count is kept
517 per process (connection), not globally. */
518 if (proc
->gnutls_handshakes_tried
< GNUTLS_EMACS_HANDSHAKES_LIMIT
)
520 proc
->gnutls_handshakes_tried
++;
521 emacs_gnutls_handshake (proc
);
522 GNUTLS_LOG2i (5, log_level
, "Retried handshake",
523 proc
->gnutls_handshakes_tried
);
527 GNUTLS_LOG (2, log_level
, "Giving up on handshake; resetting retries");
528 proc
->gnutls_handshakes_tried
= 0;
531 rtnval
= fn_gnutls_record_recv (state
, buf
, nbyte
);
534 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
535 /* The peer closed the connection. */
537 else if (emacs_gnutls_handle_error (state
, rtnval
))
538 /* non-fatal error */
541 /* a fatal error occurred */
546 /* Report a GnuTLS error to the user.
547 Return true if the error code was successfully handled. */
549 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
551 int max_log_level
= 0;
556 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
560 max_log_level
= global_gnutls_log_level
;
562 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
564 str
= fn_gnutls_strerror (err
);
568 if (fn_gnutls_error_is_fatal (err
))
571 GNUTLS_LOG2 (0, max_log_level
, "fatal error:", str
);
592 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
593 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
595 int alert
= fn_gnutls_alert_get (session
);
596 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
597 str
= fn_gnutls_alert_get_name (alert
);
601 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
606 /* convert an integer error to a Lisp_Object; it will be either a
607 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
608 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
611 gnutls_make_error (int err
)
615 case GNUTLS_E_SUCCESS
:
618 return Qgnutls_e_again
;
619 case GNUTLS_E_INTERRUPTED
:
620 return Qgnutls_e_interrupted
;
621 case GNUTLS_E_INVALID_SESSION
:
622 return Qgnutls_e_invalid_session
;
625 return make_number (err
);
629 emacs_gnutls_deinit (Lisp_Object proc
)
633 CHECK_PROCESS (proc
);
635 if (XPROCESS (proc
)->gnutls_p
== 0)
638 log_level
= XPROCESS (proc
)->gnutls_log_level
;
640 if (XPROCESS (proc
)->gnutls_x509_cred
)
642 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
643 fn_gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
644 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
647 if (XPROCESS (proc
)->gnutls_anon_cred
)
649 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
650 fn_gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
651 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
654 if (XPROCESS (proc
)->gnutls_state
)
656 fn_gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
657 XPROCESS (proc
)->gnutls_state
= NULL
;
658 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
659 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
662 XPROCESS (proc
)->gnutls_p
= 0;
666 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
667 doc
: /* Return the GnuTLS init stage of process PROC.
668 See also `gnutls-boot'. */)
671 CHECK_PROCESS (proc
);
673 return make_number (GNUTLS_INITSTAGE (proc
));
676 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
677 doc
: /* Return t if ERROR indicates a GnuTLS problem.
678 ERROR is an integer or a symbol with an integer `gnutls-code' property.
679 usage: (gnutls-errorp ERROR) */)
682 if (EQ (err
, Qt
)) return Qnil
;
687 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
688 doc
: /* Check if ERROR is fatal.
689 ERROR is an integer or a symbol with an integer `gnutls-code' property.
690 usage: (gnutls-error-fatalp ERROR) */)
695 if (EQ (err
, Qt
)) return Qnil
;
699 code
= Fget (err
, Qgnutls_code
);
706 error ("Symbol has no numeric gnutls-code property");
710 if (! TYPE_RANGED_INTEGERP (int, err
))
711 error ("Not an error symbol or code");
713 if (0 == fn_gnutls_error_is_fatal (XINT (err
)))
719 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
720 doc
: /* Return a description of ERROR.
721 ERROR is an integer or a symbol with an integer `gnutls-code' property.
722 usage: (gnutls-error-string ERROR) */)
727 if (EQ (err
, Qt
)) return build_string ("Not an error");
731 code
= Fget (err
, Qgnutls_code
);
738 return build_string ("Symbol has no numeric gnutls-code property");
742 if (! TYPE_RANGED_INTEGERP (int, err
))
743 return build_string ("Not an error symbol or code");
745 return build_string (fn_gnutls_strerror (XINT (err
)));
748 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
749 doc
: /* Deallocate GnuTLS resources associated with process PROC.
750 See also `gnutls-init'. */)
753 return emacs_gnutls_deinit (proc
);
756 DEFUN ("gnutls-available-p", Fgnutls_available_p
, Sgnutls_available_p
, 0, 0, 0,
757 doc
: /* Return t if GnuTLS is available in this instance of Emacs. */)
761 Lisp_Object found
= Fassq (Qgnutls_dll
, Vlibrary_cache
);
767 status
= init_gnutls_functions () ? Qt
: Qnil
;
768 Vlibrary_cache
= Fcons (Fcons (Qgnutls_dll
, status
), Vlibrary_cache
);
777 gnutls_hex_string (char *buf
, size_t buf_size
, const char *prefix
)
779 size_t prefix_length
= strlen (prefix
);
780 char *string
= malloc (buf_size
* 3 + prefix_length
);
783 strcpy (string
, prefix
);
785 for (int i
= 0; i
< buf_size
; i
++)
786 sprintf (string
+ i
* 3 + prefix_length
,
787 i
== buf_size
- 1 ? "%02x" : "%02x:",
788 ((unsigned char*) buf
)[i
]);
790 ret
= build_string (string
);
796 gnutls_certificate_details (gnutls_x509_crt_t cert
)
798 Lisp_Object res
= Qnil
;
804 int version
= fn_gnutls_x509_crt_get_version (cert
);
805 if (version
>= GNUTLS_E_SUCCESS
)
806 res
= nconc2 (res
, list2 (intern (":version"),
807 make_number (version
)));
812 err
= fn_gnutls_x509_crt_get_serial (cert
, NULL
, &buf_size
);
813 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
815 char *serial
= malloc (buf_size
);
816 err
= fn_gnutls_x509_crt_get_serial (cert
, serial
, &buf_size
);
817 if (err
>= GNUTLS_E_SUCCESS
)
818 res
= nconc2 (res
, list2 (intern (":serial-number"),
819 gnutls_hex_string (serial
, buf_size
, "")));
825 err
= fn_gnutls_x509_crt_get_issuer_dn (cert
, NULL
, &buf_size
);
826 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
828 char *dn
= malloc (buf_size
);
829 err
= fn_gnutls_x509_crt_get_issuer_dn (cert
, dn
, &buf_size
);
830 if (err
>= GNUTLS_E_SUCCESS
)
831 res
= nconc2 (res
, list2 (intern (":issuer"),
832 make_string (dn
, buf_size
)));
839 size_t buf_size
= sizeof (buf
);
841 time_t tim
= fn_gnutls_x509_crt_get_activation_time (cert
);
843 if (gmtime_r (&tim
, &t
) != NULL
&&
844 strftime (buf
, buf_size
, "%Y-%m-%d", &t
) != 0)
845 res
= nconc2 (res
, list2 (intern (":valid-from"), build_string (buf
)));
847 tim
= fn_gnutls_x509_crt_get_expiration_time (cert
);
848 if (gmtime_r (&tim
, &t
) != NULL
&&
849 strftime (buf
, buf_size
, "%Y-%m-%d", &t
) != 0)
850 res
= nconc2 (res
, list2 (intern (":valid-to"), build_string (buf
)));
855 err
= fn_gnutls_x509_crt_get_dn (cert
, NULL
, &buf_size
);
856 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
858 char *dn
= malloc (buf_size
);
859 err
= fn_gnutls_x509_crt_get_dn (cert
, dn
, &buf_size
);
860 if (err
>= GNUTLS_E_SUCCESS
)
861 res
= nconc2 (res
, list2 (intern (":subject"),
862 make_string (dn
, buf_size
)));
866 /* Versions older than 2.11 doesn't have these four functions. */
867 #if GNUTLS_VERSION_NUMBER >= 0x020b00
868 /* SubjectPublicKeyInfo. */
872 err
= fn_gnutls_x509_crt_get_pk_algorithm (cert
, &bits
);
873 if (err
>= GNUTLS_E_SUCCESS
)
875 const char *name
= fn_gnutls_pk_algorithm_get_name (err
);
877 res
= nconc2 (res
, list2 (intern (":public-key-algorithm"),
878 build_string (name
)));
880 name
= fn_gnutls_sec_param_get_name (fn_gnutls_pk_bits_to_sec_param
882 res
= nconc2 (res
, list2 (intern (":certificate-security-level"),
883 build_string (name
)));
889 err
= fn_gnutls_x509_crt_get_issuer_unique_id (cert
, NULL
, &buf_size
);
890 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
892 char *buf
= malloc (buf_size
);
893 err
= fn_gnutls_x509_crt_get_issuer_unique_id (cert
, buf
, &buf_size
);
894 if (err
>= GNUTLS_E_SUCCESS
)
895 res
= nconc2 (res
, list2 (intern (":issuer-unique-id"),
896 make_string (buf
, buf_size
)));
901 err
= fn_gnutls_x509_crt_get_subject_unique_id (cert
, NULL
, &buf_size
);
902 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
904 char *buf
= malloc (buf_size
);
905 err
= fn_gnutls_x509_crt_get_subject_unique_id (cert
, buf
, &buf_size
);
906 if (err
>= GNUTLS_E_SUCCESS
)
907 res
= nconc2 (res
, list2 (intern (":subject-unique-id"),
908 make_string (buf
, buf_size
)));
915 err
= fn_gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
916 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
918 unsigned char *buf
= malloc (buf_size
);
919 err
= fn_gnutls_x509_crt_get_key_id (cert
, 0, buf
, &buf_size
);
920 if (err
>= GNUTLS_E_SUCCESS
)
921 res
= nconc2 (res
, list2 (intern (":public-key-id"),
922 gnutls_hex_string ((char *)buf
,
923 buf_size
, "sha1:")));
927 /* Certificate fingerprint. */
929 err
= fn_gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
931 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
933 unsigned char *buf
= malloc (buf_size
);
934 err
= fn_gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
936 if (err
>= GNUTLS_E_SUCCESS
)
937 res
= nconc2 (res
, list2 (intern (":certificate-id"),
938 gnutls_hex_string ((char *)buf
,
939 buf_size
, "sha1:")));
946 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
947 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'.*/)
948 (Lisp_Object status_symbol
)
950 CHECK_SYMBOL (status_symbol
);
952 if (EQ (status_symbol
, intern (":invalid")))
953 return build_string ("certificate could not be verified");
955 if (EQ (status_symbol
, intern (":revoked")))
956 return build_string ("certificate was revoked (CRL)");
958 if (EQ (status_symbol
, intern (":self-signed")))
959 return build_string ("certificate signer was not found (self-signed)");
961 if (EQ (status_symbol
, intern (":not-ca")))
962 return build_string ("certificate signer is not a CA");
964 if (EQ (status_symbol
, intern (":insecure")))
965 return build_string ("certificate was signed with an insecure algorithm");
967 if (EQ (status_symbol
, intern (":not-activated")))
968 return build_string ("certificate is not yet activated");
970 if (EQ (status_symbol
, intern (":expired")))
971 return build_string ("certificate has expired");
973 if (EQ (status_symbol
, intern (":no-host-match")))
974 return build_string ("certificate host does not match hostname");
979 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
980 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
981 The return value is a property list with top-level keys :warnings and
982 :certificate. The :warnings entry is a list of symbols you can describe with
983 `gnutls-peer-status-warning-describe'. */)
986 Lisp_Object warnings
= Qnil
, result
= Qnil
;
987 unsigned int verification
;
989 CHECK_PROCESS (proc
);
991 if (GNUTLS_INITSTAGE (proc
) < GNUTLS_STAGE_INIT
)
994 /* Then collect any warnings already computed by the handshake. */
995 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
997 if (verification
& GNUTLS_CERT_INVALID
)
998 warnings
= Fcons (intern (":invalid"), warnings
);
1000 if (verification
& GNUTLS_CERT_REVOKED
)
1001 warnings
= Fcons (intern (":revoked"), warnings
);
1003 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1004 warnings
= Fcons (intern (":self-signed"), warnings
);
1006 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1007 warnings
= Fcons (intern (":not-ca"), warnings
);
1009 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1010 warnings
= Fcons (intern (":insecure"), warnings
);
1012 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1013 warnings
= Fcons (intern (":not-activated"), warnings
);
1015 if (verification
& GNUTLS_CERT_EXPIRED
)
1016 warnings
= Fcons (intern (":expired"), warnings
);
1018 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1019 CERTIFICATE_NOT_MATCHING
)
1020 warnings
= Fcons (intern (":no-host-match"), warnings
);
1022 if (!NILP (warnings
))
1023 result
= list2 (intern (":warnings"), warnings
);
1025 /* This could get called in the INIT stage, when the certificate is
1027 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1028 result
= nconc2 (result
, list2
1029 (intern (":certificate"),
1030 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1036 /* Initializes global GnuTLS state to defaults.
1037 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1038 Returns zero on success. */
1040 emacs_gnutls_global_init (void)
1042 int ret
= GNUTLS_E_SUCCESS
;
1044 if (!gnutls_global_initialized
)
1046 fn_gnutls_global_set_mem_functions (xmalloc
, xmalloc
, NULL
,
1048 ret
= fn_gnutls_global_init ();
1050 gnutls_global_initialized
= 1;
1052 return gnutls_make_error (ret
);
1056 gnutls_ip_address_p (char *string
)
1060 while ((c
= *string
++) != 0)
1061 if (! ((c
== '.' || c
== ':' || (c
>= '0' && c
<= '9'))))
1068 /* Deinitializes global GnuTLS state.
1069 See also `gnutls-global-init'. */
1071 emacs_gnutls_global_deinit (void)
1073 if (gnutls_global_initialized
)
1074 gnutls_global_deinit ();
1076 gnutls_global_initialized
= 0;
1078 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1082 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
1083 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1084 Currently only client mode is supported. Return a success/failure
1085 value you can check with `gnutls-errorp'.
1087 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1088 PROPLIST is a property list with the following keys:
1090 :hostname is a string naming the remote host.
1092 :priority is a GnuTLS priority string, defaults to "NORMAL".
1094 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1096 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1098 :keylist is an alist of PEM-encoded key files and PEM-encoded
1099 certificates for `gnutls-x509pki'.
1101 :callbacks is an alist of callback functions, see below.
1103 :loglevel is the debug level requested from GnuTLS, try 4.
1105 :verify-flags is a bitset as per GnuTLS'
1106 gnutls_certificate_set_verify_flags.
1108 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1111 :verify-error is a list of symbols to express verification checks or
1112 `t' to do all checks. Currently it can contain `:trustfiles' and
1113 `:hostname' to verify the certificate or the hostname respectively.
1115 :min-prime-bits is the minimum accepted number of bits the client will
1116 accept in Diffie-Hellman key exchange.
1118 The debug level will be set for this process AND globally for GnuTLS.
1119 So if you set it higher or lower at any point, it affects global
1122 Note that the priority is set on the client. The server does not use
1123 the protocols's priority except for disabling protocols that were not
1126 Processes must be initialized with this function before other GnuTLS
1127 functions are used. This function allocates resources which can only
1128 be deallocated by calling `gnutls-deinit' or by calling it again.
1130 The callbacks alist can have a `verify' key, associated with a
1131 verification function (UNUSED).
1133 Each authentication type may need additional information in order to
1134 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1135 one trustfile (usually a CA bundle). */)
1136 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
1138 int ret
= GNUTLS_E_SUCCESS
;
1139 int max_log_level
= 0;
1140 bool verify_error_all
= 0;
1142 gnutls_session_t state
;
1143 gnutls_certificate_credentials_t x509_cred
= NULL
;
1144 gnutls_anon_client_credentials_t anon_cred
= NULL
;
1145 Lisp_Object global_init
;
1146 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
1147 unsigned int peer_verification
;
1150 /* Placeholders for the property list elements. */
1151 Lisp_Object priority_string
;
1152 Lisp_Object trustfiles
;
1153 Lisp_Object crlfiles
;
1154 Lisp_Object keylist
;
1155 /* Lisp_Object callbacks; */
1156 Lisp_Object loglevel
;
1157 Lisp_Object hostname
;
1158 Lisp_Object verify_error
;
1159 Lisp_Object prime_bits
;
1160 Lisp_Object warnings
;
1162 CHECK_PROCESS (proc
);
1163 CHECK_SYMBOL (type
);
1164 CHECK_LIST (proplist
);
1166 if (NILP (Fgnutls_available_p ()))
1167 error ("GnuTLS not available");
1169 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
1170 error ("Invalid GnuTLS credential type");
1172 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1173 priority_string
= Fplist_get (proplist
, QCgnutls_bootprop_priority
);
1174 trustfiles
= Fplist_get (proplist
, QCgnutls_bootprop_trustfiles
);
1175 keylist
= Fplist_get (proplist
, QCgnutls_bootprop_keylist
);
1176 crlfiles
= Fplist_get (proplist
, QCgnutls_bootprop_crlfiles
);
1177 loglevel
= Fplist_get (proplist
, QCgnutls_bootprop_loglevel
);
1178 verify_error
= Fplist_get (proplist
, QCgnutls_bootprop_verify_error
);
1179 prime_bits
= Fplist_get (proplist
, QCgnutls_bootprop_min_prime_bits
);
1181 if (EQ (verify_error
, Qt
))
1183 verify_error_all
= 1;
1185 else if (NILP (Flistp (verify_error
)))
1187 error ("gnutls-boot: invalid :verify_error parameter (not a list)");
1190 if (!STRINGP (hostname
))
1191 error ("gnutls-boot: invalid :hostname parameter (not a string)");
1192 c_hostname
= SSDATA (hostname
);
1194 state
= XPROCESS (proc
)->gnutls_state
;
1196 if (TYPE_RANGED_INTEGERP (int, loglevel
))
1198 fn_gnutls_global_set_log_function (gnutls_log_function
);
1200 fn_gnutls_global_set_audit_log_function (gnutls_audit_log_function
);
1202 fn_gnutls_global_set_log_level (XINT (loglevel
));
1203 max_log_level
= XINT (loglevel
);
1204 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
1207 GNUTLS_LOG2 (1, max_log_level
, "connecting to host:", c_hostname
);
1209 /* always initialize globals. */
1210 global_init
= emacs_gnutls_global_init ();
1211 if (! NILP (Fgnutls_errorp (global_init
)))
1214 /* Before allocating new credentials, deallocate any credentials
1215 that PROC might already have. */
1216 emacs_gnutls_deinit (proc
);
1218 /* Mark PROC as a GnuTLS process. */
1219 XPROCESS (proc
)->gnutls_state
= NULL
;
1220 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
1221 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
1222 pset_gnutls_cred_type (XPROCESS (proc
), type
);
1223 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
1225 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
1226 if (EQ (type
, Qgnutls_x509pki
))
1228 Lisp_Object verify_flags
;
1229 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
1231 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
1232 fn_gnutls_certificate_allocate_credentials (&x509_cred
);
1233 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
1235 verify_flags
= Fplist_get (proplist
, QCgnutls_bootprop_verify_flags
);
1236 if (NUMBERP (verify_flags
))
1238 gnutls_verify_flags
= XINT (verify_flags
);
1239 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
1241 else if (NILP (verify_flags
))
1242 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
1244 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
1246 fn_gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
1248 else /* Qgnutls_anon: */
1250 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
1251 fn_gnutls_anon_allocate_client_credentials (&anon_cred
);
1252 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
1255 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
1257 if (EQ (type
, Qgnutls_x509pki
))
1259 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1260 int file_format
= GNUTLS_X509_FMT_PEM
;
1263 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
1265 Lisp_Object trustfile
= XCAR (tail
);
1266 if (STRINGP (trustfile
))
1268 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
1269 SSDATA (trustfile
));
1270 trustfile
= ENCODE_FILE (trustfile
);
1272 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1273 file names on Windows, we need to re-encode the file
1274 name using the current ANSI codepage. */
1275 trustfile
= ansi_encode_filename (trustfile
);
1277 ret
= fn_gnutls_certificate_set_x509_trust_file
1282 if (ret
< GNUTLS_E_SUCCESS
)
1283 return gnutls_make_error (ret
);
1287 emacs_gnutls_deinit (proc
);
1288 error ("Invalid trustfile");
1292 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
1294 Lisp_Object crlfile
= XCAR (tail
);
1295 if (STRINGP (crlfile
))
1297 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
1299 crlfile
= ENCODE_FILE (crlfile
);
1301 crlfile
= ansi_encode_filename (crlfile
);
1303 ret
= fn_gnutls_certificate_set_x509_crl_file
1304 (x509_cred
, SSDATA (crlfile
), file_format
);
1306 if (ret
< GNUTLS_E_SUCCESS
)
1307 return gnutls_make_error (ret
);
1311 emacs_gnutls_deinit (proc
);
1312 error ("Invalid CRL file");
1316 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
1318 Lisp_Object keyfile
= Fcar (XCAR (tail
));
1319 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
1320 if (STRINGP (keyfile
) && STRINGP (certfile
))
1322 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
1324 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
1326 keyfile
= ENCODE_FILE (keyfile
);
1327 certfile
= ENCODE_FILE (certfile
);
1329 keyfile
= ansi_encode_filename (keyfile
);
1330 certfile
= ansi_encode_filename (certfile
);
1332 ret
= fn_gnutls_certificate_set_x509_key_file
1333 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
1335 if (ret
< GNUTLS_E_SUCCESS
)
1336 return gnutls_make_error (ret
);
1340 emacs_gnutls_deinit (proc
);
1341 error (STRINGP (keyfile
) ? "Invalid client cert file"
1342 : "Invalid client key file");
1347 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
1348 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
1349 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
1351 /* Call gnutls_init here: */
1353 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
1354 ret
= fn_gnutls_init (&state
, GNUTLS_CLIENT
);
1355 XPROCESS (proc
)->gnutls_state
= state
;
1356 if (ret
< GNUTLS_E_SUCCESS
)
1357 return gnutls_make_error (ret
);
1358 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
1360 if (STRINGP (priority_string
))
1362 priority_string_ptr
= SSDATA (priority_string
);
1363 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
1364 priority_string_ptr
);
1368 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
1369 priority_string_ptr
);
1372 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
1373 ret
= fn_gnutls_priority_set_direct (state
,
1374 priority_string_ptr
,
1376 if (ret
< GNUTLS_E_SUCCESS
)
1377 return gnutls_make_error (ret
);
1379 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
1381 if (INTEGERP (prime_bits
))
1382 fn_gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
1384 ret
= EQ (type
, Qgnutls_x509pki
)
1385 ? fn_gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
1386 : fn_gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
1387 if (ret
< GNUTLS_E_SUCCESS
)
1388 return gnutls_make_error (ret
);
1390 if (!gnutls_ip_address_p (c_hostname
))
1392 ret
= fn_gnutls_server_name_set (state
, GNUTLS_NAME_DNS
, c_hostname
,
1393 strlen (c_hostname
));
1394 if (ret
< GNUTLS_E_SUCCESS
)
1395 return gnutls_make_error (ret
);
1398 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
1399 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
1400 if (ret
< GNUTLS_E_SUCCESS
)
1401 return gnutls_make_error (ret
);
1403 /* Now verify the peer, following
1404 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1405 The peer should present at least one certificate in the chain; do a
1406 check of the certificate's hostname with
1407 gnutls_x509_crt_check_hostname against :hostname. */
1409 ret
= fn_gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1410 if (ret
< GNUTLS_E_SUCCESS
)
1411 return gnutls_make_error (ret
);
1413 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1415 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1416 if (!NILP (warnings
))
1419 for (tail
= warnings
; CONSP (tail
); tail
= XCDR (tail
))
1421 Lisp_Object warning
= XCAR (tail
);
1422 Lisp_Object message
= Fgnutls_peer_status_warning_describe (warning
);
1423 if (!NILP (message
))
1424 GNUTLS_LOG2 (1, max_log_level
, "verification:", SSDATA (message
));
1428 if (peer_verification
!= 0)
1430 if (verify_error_all
1431 || !NILP (Fmember (QCgnutls_bootprop_trustfiles
, verify_error
)))
1433 emacs_gnutls_deinit (proc
);
1434 error ("Certificate validation failed %s, verification code %d",
1435 c_hostname
, peer_verification
);
1439 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1444 /* Up to here the process is the same for X.509 certificates and
1445 OpenPGP keys. From now on X.509 certificates are assumed. This
1446 can be easily extended to work with openpgp keys as well. */
1447 if (fn_gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1449 gnutls_x509_crt_t gnutls_verify_cert
;
1450 const gnutls_datum_t
*gnutls_verify_cert_list
;
1451 unsigned int gnutls_verify_cert_list_size
;
1453 ret
= fn_gnutls_x509_crt_init (&gnutls_verify_cert
);
1454 if (ret
< GNUTLS_E_SUCCESS
)
1455 return gnutls_make_error (ret
);
1457 gnutls_verify_cert_list
=
1458 fn_gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1460 if (gnutls_verify_cert_list
== NULL
)
1462 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1463 emacs_gnutls_deinit (proc
);
1464 error ("No x509 certificate was found\n");
1467 /* We only check the first certificate in the given chain. */
1468 ret
= fn_gnutls_x509_crt_import (gnutls_verify_cert
,
1469 &gnutls_verify_cert_list
[0],
1470 GNUTLS_X509_FMT_DER
);
1472 if (ret
< GNUTLS_E_SUCCESS
)
1474 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1475 return gnutls_make_error (ret
);
1478 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1480 if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert
, c_hostname
))
1482 XPROCESS (proc
)->gnutls_extra_peer_verification
|=
1483 CERTIFICATE_NOT_MATCHING
;
1484 if (verify_error_all
1485 || !NILP (Fmember (QCgnutls_bootprop_hostname
, verify_error
)))
1487 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1488 emacs_gnutls_deinit (proc
);
1489 error ("The x509 certificate does not match \"%s\"", c_hostname
);
1493 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1499 /* Set this flag only if the whole initialization succeeded. */
1500 XPROCESS (proc
)->gnutls_p
= 1;
1502 return gnutls_make_error (ret
);
1505 DEFUN ("gnutls-bye", Fgnutls_bye
,
1506 Sgnutls_bye
, 2, 2, 0,
1507 doc
: /* Terminate current GnuTLS connection for process PROC.
1508 The connection should have been initiated using `gnutls-handshake'.
1510 If CONT is not nil the TLS connection gets terminated and further
1511 receives and sends will be disallowed. If the return value is zero you
1512 may continue using the connection. If CONT is nil, GnuTLS actually
1513 sends an alert containing a close request and waits for the peer to
1514 reply with the same message. In order to reuse the connection you
1515 should wait for an EOF from the peer.
1517 This function may also return `gnutls-e-again', or
1518 `gnutls-e-interrupted'. */)
1519 (Lisp_Object proc
, Lisp_Object cont
)
1521 gnutls_session_t state
;
1524 CHECK_PROCESS (proc
);
1526 state
= XPROCESS (proc
)->gnutls_state
;
1528 fn_gnutls_x509_crt_deinit (XPROCESS (proc
)->gnutls_certificate
);
1530 ret
= fn_gnutls_bye (state
,
1531 NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1533 return gnutls_make_error (ret
);
1537 syms_of_gnutls (void)
1539 gnutls_global_initialized
= 0;
1541 DEFSYM (Qgnutls_dll
, "gnutls");
1542 DEFSYM (Qgnutls_code
, "gnutls-code");
1543 DEFSYM (Qgnutls_anon
, "gnutls-anon");
1544 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
1545 DEFSYM (QCgnutls_bootprop_hostname
, ":hostname");
1546 DEFSYM (QCgnutls_bootprop_priority
, ":priority");
1547 DEFSYM (QCgnutls_bootprop_trustfiles
, ":trustfiles");
1548 DEFSYM (QCgnutls_bootprop_keylist
, ":keylist");
1549 DEFSYM (QCgnutls_bootprop_crlfiles
, ":crlfiles");
1550 DEFSYM (QCgnutls_bootprop_callbacks
, ":callbacks");
1551 DEFSYM (QCgnutls_bootprop_callbacks_verify
, "verify");
1552 DEFSYM (QCgnutls_bootprop_min_prime_bits
, ":min-prime-bits");
1553 DEFSYM (QCgnutls_bootprop_loglevel
, ":loglevel");
1554 DEFSYM (QCgnutls_bootprop_verify_flags
, ":verify-flags");
1555 DEFSYM (QCgnutls_bootprop_verify_error
, ":verify-error");
1557 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
1558 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
1559 make_number (GNUTLS_E_INTERRUPTED
));
1561 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
1562 Fput (Qgnutls_e_again
, Qgnutls_code
,
1563 make_number (GNUTLS_E_AGAIN
));
1565 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
1566 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
1567 make_number (GNUTLS_E_INVALID_SESSION
));
1569 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
1570 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
1571 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
1573 defsubr (&Sgnutls_get_initstage
);
1574 defsubr (&Sgnutls_errorp
);
1575 defsubr (&Sgnutls_error_fatalp
);
1576 defsubr (&Sgnutls_error_string
);
1577 defsubr (&Sgnutls_boot
);
1578 defsubr (&Sgnutls_deinit
);
1579 defsubr (&Sgnutls_bye
);
1580 defsubr (&Sgnutls_available_p
);
1581 defsubr (&Sgnutls_peer_status
);
1582 defsubr (&Sgnutls_peer_status_warning_describe
);
1584 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
1585 doc
: /* Logging level used by the GnuTLS functions.
1586 Set this larger than 0 to get debug output in the *Messages* buffer.
1587 1 is for important messages, 2 is for debug data, and higher numbers
1588 are as per the GnuTLS logging conventions. */);
1589 global_gnutls_log_level
= 0;
1592 #endif /* HAVE_GNUTLS */