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
)));
914 err
= fn_gnutls_x509_crt_get_signature_algorithm (cert
);
915 if (err
>= GNUTLS_E_SUCCESS
)
917 const char *name
= fn_gnutls_sign_get_name (err
);
919 res
= nconc2 (res
, list2 (intern (":signature-algorithm"),
920 build_string (name
)));
925 err
= fn_gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
926 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
928 unsigned char *buf
= malloc (buf_size
);
929 err
= fn_gnutls_x509_crt_get_key_id (cert
, 0, buf
, &buf_size
);
930 if (err
>= GNUTLS_E_SUCCESS
)
931 res
= nconc2 (res
, list2 (intern (":public-key-id"),
932 gnutls_hex_string ((char *)buf
,
933 buf_size
, "sha1:")));
937 /* Certificate fingerprint. */
939 err
= fn_gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
941 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
943 unsigned char *buf
= malloc (buf_size
);
944 err
= fn_gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
946 if (err
>= GNUTLS_E_SUCCESS
)
947 res
= nconc2 (res
, list2 (intern (":certificate-id"),
948 gnutls_hex_string ((char *)buf
,
949 buf_size
, "sha1:")));
956 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
957 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'.*/)
958 (Lisp_Object status_symbol
)
960 CHECK_SYMBOL (status_symbol
);
962 if (EQ (status_symbol
, intern (":invalid")))
963 return build_string ("certificate could not be verified");
965 if (EQ (status_symbol
, intern (":revoked")))
966 return build_string ("certificate was revoked (CRL)");
968 if (EQ (status_symbol
, intern (":self-signed")))
969 return build_string ("certificate signer was not found (self-signed)");
971 if (EQ (status_symbol
, intern (":not-ca")))
972 return build_string ("certificate signer is not a CA");
974 if (EQ (status_symbol
, intern (":insecure")))
975 return build_string ("certificate was signed with an insecure algorithm");
977 if (EQ (status_symbol
, intern (":not-activated")))
978 return build_string ("certificate is not yet activated");
980 if (EQ (status_symbol
, intern (":expired")))
981 return build_string ("certificate has expired");
983 if (EQ (status_symbol
, intern (":no-host-match")))
984 return build_string ("certificate host does not match hostname");
989 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
990 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
991 The return value is a property list with top-level keys :warnings and
992 :certificate. The :warnings entry is a list of symbols you can describe with
993 `gnutls-peer-status-warning-describe'. */)
996 Lisp_Object warnings
= Qnil
, result
= Qnil
;
997 unsigned int verification
;
999 CHECK_PROCESS (proc
);
1001 if (GNUTLS_INITSTAGE (proc
) < GNUTLS_STAGE_INIT
)
1004 /* Then collect any warnings already computed by the handshake. */
1005 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
1007 if (verification
& GNUTLS_CERT_INVALID
)
1008 warnings
= Fcons (intern (":invalid"), warnings
);
1010 if (verification
& GNUTLS_CERT_REVOKED
)
1011 warnings
= Fcons (intern (":revoked"), warnings
);
1013 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1014 warnings
= Fcons (intern (":self-signed"), warnings
);
1016 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1017 warnings
= Fcons (intern (":not-ca"), warnings
);
1019 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1020 warnings
= Fcons (intern (":insecure"), warnings
);
1022 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1023 warnings
= Fcons (intern (":not-activated"), warnings
);
1025 if (verification
& GNUTLS_CERT_EXPIRED
)
1026 warnings
= Fcons (intern (":expired"), warnings
);
1028 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1029 CERTIFICATE_NOT_MATCHING
)
1030 warnings
= Fcons (intern (":no-host-match"), warnings
);
1032 if (!NILP (warnings
))
1033 result
= list2 (intern (":warnings"), warnings
);
1035 /* This could get called in the INIT stage, when the certificate is
1037 if (XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1038 result
= nconc2 (result
, list2
1039 (intern (":certificate"),
1040 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1042 /* Diffie-Hellman prime bits. */
1044 int bits
= gnutls_dh_get_prime_bits (XPROCESS (proc
)->gnutls_state
);
1046 result
= nconc2 (result
, list2
1047 (intern (":diffie-hellman-prime-bits"),
1048 make_number (bits
)));
1055 /* Initializes global GnuTLS state to defaults.
1056 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1057 Returns zero on success. */
1059 emacs_gnutls_global_init (void)
1061 int ret
= GNUTLS_E_SUCCESS
;
1063 if (!gnutls_global_initialized
)
1065 fn_gnutls_global_set_mem_functions (xmalloc
, xmalloc
, NULL
,
1067 ret
= fn_gnutls_global_init ();
1069 gnutls_global_initialized
= 1;
1071 return gnutls_make_error (ret
);
1075 gnutls_ip_address_p (char *string
)
1079 while ((c
= *string
++) != 0)
1080 if (! ((c
== '.' || c
== ':' || (c
>= '0' && c
<= '9'))))
1087 /* Deinitializes global GnuTLS state.
1088 See also `gnutls-global-init'. */
1090 emacs_gnutls_global_deinit (void)
1092 if (gnutls_global_initialized
)
1093 gnutls_global_deinit ();
1095 gnutls_global_initialized
= 0;
1097 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1101 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
1102 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1103 Currently only client mode is supported. Return a success/failure
1104 value you can check with `gnutls-errorp'.
1106 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1107 PROPLIST is a property list with the following keys:
1109 :hostname is a string naming the remote host.
1111 :priority is a GnuTLS priority string, defaults to "NORMAL".
1113 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1115 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1117 :keylist is an alist of PEM-encoded key files and PEM-encoded
1118 certificates for `gnutls-x509pki'.
1120 :callbacks is an alist of callback functions, see below.
1122 :loglevel is the debug level requested from GnuTLS, try 4.
1124 :verify-flags is a bitset as per GnuTLS'
1125 gnutls_certificate_set_verify_flags.
1127 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1130 :verify-error is a list of symbols to express verification checks or
1131 `t' to do all checks. Currently it can contain `:trustfiles' and
1132 `:hostname' to verify the certificate or the hostname respectively.
1134 :min-prime-bits is the minimum accepted number of bits the client will
1135 accept in Diffie-Hellman key exchange.
1137 The debug level will be set for this process AND globally for GnuTLS.
1138 So if you set it higher or lower at any point, it affects global
1141 Note that the priority is set on the client. The server does not use
1142 the protocols's priority except for disabling protocols that were not
1145 Processes must be initialized with this function before other GnuTLS
1146 functions are used. This function allocates resources which can only
1147 be deallocated by calling `gnutls-deinit' or by calling it again.
1149 The callbacks alist can have a `verify' key, associated with a
1150 verification function (UNUSED).
1152 Each authentication type may need additional information in order to
1153 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1154 one trustfile (usually a CA bundle). */)
1155 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
1157 int ret
= GNUTLS_E_SUCCESS
;
1158 int max_log_level
= 0;
1159 bool verify_error_all
= 0;
1161 gnutls_session_t state
;
1162 gnutls_certificate_credentials_t x509_cred
= NULL
;
1163 gnutls_anon_client_credentials_t anon_cred
= NULL
;
1164 Lisp_Object global_init
;
1165 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
1166 unsigned int peer_verification
;
1169 /* Placeholders for the property list elements. */
1170 Lisp_Object priority_string
;
1171 Lisp_Object trustfiles
;
1172 Lisp_Object crlfiles
;
1173 Lisp_Object keylist
;
1174 /* Lisp_Object callbacks; */
1175 Lisp_Object loglevel
;
1176 Lisp_Object hostname
;
1177 Lisp_Object verify_error
;
1178 Lisp_Object prime_bits
;
1179 Lisp_Object warnings
;
1181 CHECK_PROCESS (proc
);
1182 CHECK_SYMBOL (type
);
1183 CHECK_LIST (proplist
);
1185 if (NILP (Fgnutls_available_p ()))
1186 error ("GnuTLS not available");
1188 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
1189 error ("Invalid GnuTLS credential type");
1191 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1192 priority_string
= Fplist_get (proplist
, QCgnutls_bootprop_priority
);
1193 trustfiles
= Fplist_get (proplist
, QCgnutls_bootprop_trustfiles
);
1194 keylist
= Fplist_get (proplist
, QCgnutls_bootprop_keylist
);
1195 crlfiles
= Fplist_get (proplist
, QCgnutls_bootprop_crlfiles
);
1196 loglevel
= Fplist_get (proplist
, QCgnutls_bootprop_loglevel
);
1197 verify_error
= Fplist_get (proplist
, QCgnutls_bootprop_verify_error
);
1198 prime_bits
= Fplist_get (proplist
, QCgnutls_bootprop_min_prime_bits
);
1200 if (EQ (verify_error
, Qt
))
1202 verify_error_all
= 1;
1204 else if (NILP (Flistp (verify_error
)))
1206 error ("gnutls-boot: invalid :verify_error parameter (not a list)");
1209 if (!STRINGP (hostname
))
1210 error ("gnutls-boot: invalid :hostname parameter (not a string)");
1211 c_hostname
= SSDATA (hostname
);
1213 state
= XPROCESS (proc
)->gnutls_state
;
1215 if (TYPE_RANGED_INTEGERP (int, loglevel
))
1217 fn_gnutls_global_set_log_function (gnutls_log_function
);
1219 fn_gnutls_global_set_audit_log_function (gnutls_audit_log_function
);
1221 fn_gnutls_global_set_log_level (XINT (loglevel
));
1222 max_log_level
= XINT (loglevel
);
1223 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
1226 GNUTLS_LOG2 (1, max_log_level
, "connecting to host:", c_hostname
);
1228 /* always initialize globals. */
1229 global_init
= emacs_gnutls_global_init ();
1230 if (! NILP (Fgnutls_errorp (global_init
)))
1233 /* Before allocating new credentials, deallocate any credentials
1234 that PROC might already have. */
1235 emacs_gnutls_deinit (proc
);
1237 /* Mark PROC as a GnuTLS process. */
1238 XPROCESS (proc
)->gnutls_state
= NULL
;
1239 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
1240 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
1241 pset_gnutls_cred_type (XPROCESS (proc
), type
);
1242 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
1244 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
1245 if (EQ (type
, Qgnutls_x509pki
))
1247 Lisp_Object verify_flags
;
1248 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
1250 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
1251 fn_gnutls_certificate_allocate_credentials (&x509_cred
);
1252 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
1254 verify_flags
= Fplist_get (proplist
, QCgnutls_bootprop_verify_flags
);
1255 if (NUMBERP (verify_flags
))
1257 gnutls_verify_flags
= XINT (verify_flags
);
1258 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
1260 else if (NILP (verify_flags
))
1261 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
1263 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
1265 fn_gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
1267 else /* Qgnutls_anon: */
1269 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
1270 fn_gnutls_anon_allocate_client_credentials (&anon_cred
);
1271 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
1274 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
1276 if (EQ (type
, Qgnutls_x509pki
))
1278 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1279 int file_format
= GNUTLS_X509_FMT_PEM
;
1282 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
1284 Lisp_Object trustfile
= XCAR (tail
);
1285 if (STRINGP (trustfile
))
1287 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
1288 SSDATA (trustfile
));
1289 trustfile
= ENCODE_FILE (trustfile
);
1291 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1292 file names on Windows, we need to re-encode the file
1293 name using the current ANSI codepage. */
1294 trustfile
= ansi_encode_filename (trustfile
);
1296 ret
= fn_gnutls_certificate_set_x509_trust_file
1301 if (ret
< GNUTLS_E_SUCCESS
)
1302 return gnutls_make_error (ret
);
1306 emacs_gnutls_deinit (proc
);
1307 error ("Invalid trustfile");
1311 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
1313 Lisp_Object crlfile
= XCAR (tail
);
1314 if (STRINGP (crlfile
))
1316 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
1318 crlfile
= ENCODE_FILE (crlfile
);
1320 crlfile
= ansi_encode_filename (crlfile
);
1322 ret
= fn_gnutls_certificate_set_x509_crl_file
1323 (x509_cred
, SSDATA (crlfile
), file_format
);
1325 if (ret
< GNUTLS_E_SUCCESS
)
1326 return gnutls_make_error (ret
);
1330 emacs_gnutls_deinit (proc
);
1331 error ("Invalid CRL file");
1335 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
1337 Lisp_Object keyfile
= Fcar (XCAR (tail
));
1338 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
1339 if (STRINGP (keyfile
) && STRINGP (certfile
))
1341 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
1343 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
1345 keyfile
= ENCODE_FILE (keyfile
);
1346 certfile
= ENCODE_FILE (certfile
);
1348 keyfile
= ansi_encode_filename (keyfile
);
1349 certfile
= ansi_encode_filename (certfile
);
1351 ret
= fn_gnutls_certificate_set_x509_key_file
1352 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
1354 if (ret
< GNUTLS_E_SUCCESS
)
1355 return gnutls_make_error (ret
);
1359 emacs_gnutls_deinit (proc
);
1360 error (STRINGP (keyfile
) ? "Invalid client cert file"
1361 : "Invalid client key file");
1366 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
1367 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
1368 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
1370 /* Call gnutls_init here: */
1372 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
1373 ret
= fn_gnutls_init (&state
, GNUTLS_CLIENT
);
1374 XPROCESS (proc
)->gnutls_state
= state
;
1375 if (ret
< GNUTLS_E_SUCCESS
)
1376 return gnutls_make_error (ret
);
1377 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
1379 if (STRINGP (priority_string
))
1381 priority_string_ptr
= SSDATA (priority_string
);
1382 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
1383 priority_string_ptr
);
1387 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
1388 priority_string_ptr
);
1391 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
1392 ret
= fn_gnutls_priority_set_direct (state
,
1393 priority_string_ptr
,
1395 if (ret
< GNUTLS_E_SUCCESS
)
1396 return gnutls_make_error (ret
);
1398 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
1400 if (INTEGERP (prime_bits
))
1401 fn_gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
1403 ret
= EQ (type
, Qgnutls_x509pki
)
1404 ? fn_gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
1405 : fn_gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
1406 if (ret
< GNUTLS_E_SUCCESS
)
1407 return gnutls_make_error (ret
);
1409 if (!gnutls_ip_address_p (c_hostname
))
1411 ret
= fn_gnutls_server_name_set (state
, GNUTLS_NAME_DNS
, c_hostname
,
1412 strlen (c_hostname
));
1413 if (ret
< GNUTLS_E_SUCCESS
)
1414 return gnutls_make_error (ret
);
1417 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
1418 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
1419 if (ret
< GNUTLS_E_SUCCESS
)
1420 return gnutls_make_error (ret
);
1422 /* Now verify the peer, following
1423 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1424 The peer should present at least one certificate in the chain; do a
1425 check of the certificate's hostname with
1426 gnutls_x509_crt_check_hostname against :hostname. */
1428 ret
= fn_gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1429 if (ret
< GNUTLS_E_SUCCESS
)
1430 return gnutls_make_error (ret
);
1432 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1434 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1435 if (!NILP (warnings
))
1438 for (tail
= warnings
; CONSP (tail
); tail
= XCDR (tail
))
1440 Lisp_Object warning
= XCAR (tail
);
1441 Lisp_Object message
= Fgnutls_peer_status_warning_describe (warning
);
1442 if (!NILP (message
))
1443 GNUTLS_LOG2 (1, max_log_level
, "verification:", SSDATA (message
));
1447 if (peer_verification
!= 0)
1449 if (verify_error_all
1450 || !NILP (Fmember (QCgnutls_bootprop_trustfiles
, verify_error
)))
1452 emacs_gnutls_deinit (proc
);
1453 error ("Certificate validation failed %s, verification code %d",
1454 c_hostname
, peer_verification
);
1458 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1463 /* Up to here the process is the same for X.509 certificates and
1464 OpenPGP keys. From now on X.509 certificates are assumed. This
1465 can be easily extended to work with openpgp keys as well. */
1466 if (fn_gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1468 gnutls_x509_crt_t gnutls_verify_cert
;
1469 const gnutls_datum_t
*gnutls_verify_cert_list
;
1470 unsigned int gnutls_verify_cert_list_size
;
1472 ret
= fn_gnutls_x509_crt_init (&gnutls_verify_cert
);
1473 if (ret
< GNUTLS_E_SUCCESS
)
1474 return gnutls_make_error (ret
);
1476 gnutls_verify_cert_list
=
1477 fn_gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1479 if (gnutls_verify_cert_list
== NULL
)
1481 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1482 emacs_gnutls_deinit (proc
);
1483 error ("No x509 certificate was found\n");
1486 /* We only check the first certificate in the given chain. */
1487 ret
= fn_gnutls_x509_crt_import (gnutls_verify_cert
,
1488 &gnutls_verify_cert_list
[0],
1489 GNUTLS_X509_FMT_DER
);
1491 if (ret
< GNUTLS_E_SUCCESS
)
1493 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1494 return gnutls_make_error (ret
);
1497 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1499 if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert
, c_hostname
))
1501 XPROCESS (proc
)->gnutls_extra_peer_verification
|=
1502 CERTIFICATE_NOT_MATCHING
;
1503 if (verify_error_all
1504 || !NILP (Fmember (QCgnutls_bootprop_hostname
, verify_error
)))
1506 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1507 emacs_gnutls_deinit (proc
);
1508 error ("The x509 certificate does not match \"%s\"", c_hostname
);
1512 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1518 /* Set this flag only if the whole initialization succeeded. */
1519 XPROCESS (proc
)->gnutls_p
= 1;
1521 return gnutls_make_error (ret
);
1524 DEFUN ("gnutls-bye", Fgnutls_bye
,
1525 Sgnutls_bye
, 2, 2, 0,
1526 doc
: /* Terminate current GnuTLS connection for process PROC.
1527 The connection should have been initiated using `gnutls-handshake'.
1529 If CONT is not nil the TLS connection gets terminated and further
1530 receives and sends will be disallowed. If the return value is zero you
1531 may continue using the connection. If CONT is nil, GnuTLS actually
1532 sends an alert containing a close request and waits for the peer to
1533 reply with the same message. In order to reuse the connection you
1534 should wait for an EOF from the peer.
1536 This function may also return `gnutls-e-again', or
1537 `gnutls-e-interrupted'. */)
1538 (Lisp_Object proc
, Lisp_Object cont
)
1540 gnutls_session_t state
;
1543 CHECK_PROCESS (proc
);
1545 state
= XPROCESS (proc
)->gnutls_state
;
1547 fn_gnutls_x509_crt_deinit (XPROCESS (proc
)->gnutls_certificate
);
1549 ret
= fn_gnutls_bye (state
,
1550 NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1552 return gnutls_make_error (ret
);
1556 syms_of_gnutls (void)
1558 gnutls_global_initialized
= 0;
1560 DEFSYM (Qgnutls_dll
, "gnutls");
1561 DEFSYM (Qgnutls_code
, "gnutls-code");
1562 DEFSYM (Qgnutls_anon
, "gnutls-anon");
1563 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
1564 DEFSYM (QCgnutls_bootprop_hostname
, ":hostname");
1565 DEFSYM (QCgnutls_bootprop_priority
, ":priority");
1566 DEFSYM (QCgnutls_bootprop_trustfiles
, ":trustfiles");
1567 DEFSYM (QCgnutls_bootprop_keylist
, ":keylist");
1568 DEFSYM (QCgnutls_bootprop_crlfiles
, ":crlfiles");
1569 DEFSYM (QCgnutls_bootprop_callbacks
, ":callbacks");
1570 DEFSYM (QCgnutls_bootprop_callbacks_verify
, "verify");
1571 DEFSYM (QCgnutls_bootprop_min_prime_bits
, ":min-prime-bits");
1572 DEFSYM (QCgnutls_bootprop_loglevel
, ":loglevel");
1573 DEFSYM (QCgnutls_bootprop_verify_flags
, ":verify-flags");
1574 DEFSYM (QCgnutls_bootprop_verify_error
, ":verify-error");
1576 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
1577 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
1578 make_number (GNUTLS_E_INTERRUPTED
));
1580 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
1581 Fput (Qgnutls_e_again
, Qgnutls_code
,
1582 make_number (GNUTLS_E_AGAIN
));
1584 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
1585 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
1586 make_number (GNUTLS_E_INVALID_SESSION
));
1588 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
1589 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
1590 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
1592 defsubr (&Sgnutls_get_initstage
);
1593 defsubr (&Sgnutls_errorp
);
1594 defsubr (&Sgnutls_error_fatalp
);
1595 defsubr (&Sgnutls_error_string
);
1596 defsubr (&Sgnutls_boot
);
1597 defsubr (&Sgnutls_deinit
);
1598 defsubr (&Sgnutls_bye
);
1599 defsubr (&Sgnutls_available_p
);
1600 defsubr (&Sgnutls_peer_status
);
1601 defsubr (&Sgnutls_peer_status_warning_describe
);
1603 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
1604 doc
: /* Logging level used by the GnuTLS functions.
1605 Set this larger than 0 to get debug output in the *Messages* buffer.
1606 1 is for important messages, 2 is for debug data, and higher numbers
1607 are as per the GnuTLS logging conventions. */);
1608 global_gnutls_log_level
= 0;
1611 #endif /* HAVE_GNUTLS */