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_algorithm_get_name
,
189 (gnutls_sign_algorithm_t
));
192 init_gnutls_functions (void)
195 int max_log_level
= 1;
197 if (!(library
= w32_delayed_load (Qgnutls_dll
)))
199 GNUTLS_LOG (1, max_log_level
, "GnuTLS library not found");
203 LOAD_GNUTLS_FN (library
, gnutls_alert_get
);
204 LOAD_GNUTLS_FN (library
, gnutls_alert_get_name
);
205 LOAD_GNUTLS_FN (library
, gnutls_alert_send_appropriate
);
206 LOAD_GNUTLS_FN (library
, gnutls_anon_allocate_client_credentials
);
207 LOAD_GNUTLS_FN (library
, gnutls_anon_free_client_credentials
);
208 LOAD_GNUTLS_FN (library
, gnutls_bye
);
209 LOAD_GNUTLS_FN (library
, gnutls_certificate_allocate_credentials
);
210 LOAD_GNUTLS_FN (library
, gnutls_certificate_free_credentials
);
211 LOAD_GNUTLS_FN (library
, gnutls_certificate_get_peers
);
212 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_verify_flags
);
213 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_x509_crl_file
);
214 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_x509_key_file
);
215 LOAD_GNUTLS_FN (library
, gnutls_certificate_set_x509_trust_file
);
216 LOAD_GNUTLS_FN (library
, gnutls_certificate_type_get
);
217 LOAD_GNUTLS_FN (library
, gnutls_certificate_verify_peers2
);
218 LOAD_GNUTLS_FN (library
, gnutls_credentials_set
);
219 LOAD_GNUTLS_FN (library
, gnutls_deinit
);
220 LOAD_GNUTLS_FN (library
, gnutls_dh_set_prime_bits
);
221 LOAD_GNUTLS_FN (library
, gnutls_error_is_fatal
);
222 LOAD_GNUTLS_FN (library
, gnutls_global_init
);
223 LOAD_GNUTLS_FN (library
, gnutls_global_set_log_function
);
225 LOAD_GNUTLS_FN (library
, gnutls_global_set_audit_log_function
);
227 LOAD_GNUTLS_FN (library
, gnutls_global_set_log_level
);
228 LOAD_GNUTLS_FN (library
, gnutls_global_set_mem_functions
);
229 LOAD_GNUTLS_FN (library
, gnutls_handshake
);
230 LOAD_GNUTLS_FN (library
, gnutls_init
);
231 LOAD_GNUTLS_FN (library
, gnutls_priority_set_direct
);
232 LOAD_GNUTLS_FN (library
, gnutls_record_check_pending
);
233 LOAD_GNUTLS_FN (library
, gnutls_record_recv
);
234 LOAD_GNUTLS_FN (library
, gnutls_record_send
);
235 LOAD_GNUTLS_FN (library
, gnutls_strerror
);
236 LOAD_GNUTLS_FN (library
, gnutls_transport_set_errno
);
237 LOAD_GNUTLS_FN (library
, gnutls_check_version
);
238 /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
239 and later, and the function was removed entirely in 3.0.0. */
240 if (!fn_gnutls_check_version ("2.11.1"))
241 LOAD_GNUTLS_FN (library
, gnutls_transport_set_lowat
);
242 LOAD_GNUTLS_FN (library
, gnutls_transport_set_ptr2
);
243 LOAD_GNUTLS_FN (library
, gnutls_transport_set_pull_function
);
244 LOAD_GNUTLS_FN (library
, gnutls_transport_set_push_function
);
245 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_check_hostname
);
246 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_deinit
);
247 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_import
);
248 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_init
);
249 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_fingerprint
);
250 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_version
);
251 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_serial
);
252 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_issuer_dn
);
253 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_activation_time
);
254 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_expiration_time
);
255 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_dn
);
256 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_pk_algorithm
);
257 LOAD_GNUTLS_FN (library
, gnutls_pk_algorithm_get_name
);
258 LOAD_GNUTLS_FN (library
, gnutls_pk_bits_to_sec_param
);
259 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_issuer_unique_id
);
260 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_subject_unique_id
);
261 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_signature_algorithm
);
262 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_signature
);
263 LOAD_GNUTLS_FN (library
, gnutls_x509_crt_get_key_id
);
264 LOAD_GNUTLS_FN (library
, gnutls_sec_param_get_name
);
265 LOAD_GNUTLS_FN (library
, gnutls_sign_algorithm_get_name
);
267 max_log_level
= global_gnutls_log_level
;
270 Lisp_Object name
= CAR_SAFE (Fget (Qgnutls_dll
, QCloaded_from
));
271 GNUTLS_LOG2 (1, max_log_level
, "GnuTLS library loaded:",
272 STRINGP (name
) ? (const char *) SDATA (name
) : "unknown");
278 #else /* !WINDOWSNT */
280 #define fn_gnutls_alert_get gnutls_alert_get
281 #define fn_gnutls_alert_get_name gnutls_alert_get_name
282 #define fn_gnutls_alert_send_appropriate gnutls_alert_send_appropriate
283 #define fn_gnutls_anon_allocate_client_credentials gnutls_anon_allocate_client_credentials
284 #define fn_gnutls_anon_free_client_credentials gnutls_anon_free_client_credentials
285 #define fn_gnutls_bye gnutls_bye
286 #define fn_gnutls_certificate_allocate_credentials gnutls_certificate_allocate_credentials
287 #define fn_gnutls_certificate_free_credentials gnutls_certificate_free_credentials
288 #define fn_gnutls_certificate_get_peers gnutls_certificate_get_peers
289 #define fn_gnutls_certificate_set_verify_flags gnutls_certificate_set_verify_flags
290 #define fn_gnutls_certificate_set_x509_crl_file gnutls_certificate_set_x509_crl_file
291 #define fn_gnutls_certificate_set_x509_key_file gnutls_certificate_set_x509_key_file
292 #define fn_gnutls_certificate_set_x509_trust_file gnutls_certificate_set_x509_trust_file
293 #define fn_gnutls_certificate_type_get gnutls_certificate_type_get
294 #define fn_gnutls_certificate_verify_peers2 gnutls_certificate_verify_peers2
295 #define fn_gnutls_credentials_set gnutls_credentials_set
296 #define fn_gnutls_deinit gnutls_deinit
297 #define fn_gnutls_dh_set_prime_bits gnutls_dh_set_prime_bits
298 #define fn_gnutls_error_is_fatal gnutls_error_is_fatal
299 #define fn_gnutls_global_init gnutls_global_init
300 #define fn_gnutls_global_set_log_function gnutls_global_set_log_function
302 #define fn_gnutls_global_set_audit_log_function gnutls_global_set_audit_log_function
304 #define fn_gnutls_global_set_log_level gnutls_global_set_log_level
305 #define fn_gnutls_global_set_mem_functions gnutls_global_set_mem_functions
306 #define fn_gnutls_handshake gnutls_handshake
307 #define fn_gnutls_init gnutls_init
308 #define fn_gnutls_priority_set_direct gnutls_priority_set_direct
309 #define fn_gnutls_record_check_pending gnutls_record_check_pending
310 #define fn_gnutls_record_recv gnutls_record_recv
311 #define fn_gnutls_record_send gnutls_record_send
312 #define fn_gnutls_strerror gnutls_strerror
314 #define fn_gnutls_transport_set_errno gnutls_transport_set_errno
316 #define fn_gnutls_transport_set_ptr2 gnutls_transport_set_ptr2
317 #define fn_gnutls_x509_crt_check_hostname gnutls_x509_crt_check_hostname
318 #define fn_gnutls_x509_crt_deinit gnutls_x509_crt_deinit
319 #define fn_gnutls_x509_crt_import gnutls_x509_crt_import
320 #define fn_gnutls_x509_crt_init gnutls_x509_crt_init
321 #define fn_gnutls_x509_crt_get_fingerprint gnutls_x509_crt_get_fingerprint
322 #define fn_gnutls_x509_crt_get_version gnutls_x509_crt_get_version
323 #define fn_gnutls_x509_crt_get_serial gnutls_x509_crt_get_serial
324 #define fn_gnutls_x509_crt_get_issuer_dn gnutls_x509_crt_get_issuer_dn
325 #define fn_gnutls_x509_crt_get_activation_time gnutls_x509_crt_get_activation_time
326 #define fn_gnutls_x509_crt_get_expiration_time gnutls_x509_crt_get_expiration_time
327 #define fn_gnutls_x509_crt_get_dn gnutls_x509_crt_get_dn
328 #define fn_gnutls_x509_crt_get_pk_algorithm gnutls_x509_crt_get_pk_algorithm
329 #define fn_gnutls_pk_algorithm_get_name gnutls_pk_algorithm_get_name
330 #define fn_gnutls_pk_bits_to_sec_param gnutls_pk_bits_to_sec_param
331 #define fn_gnutls_x509_crt_get_issuer_unique_id gnutls_x509_crt_get_issuer_unique_id
332 #define fn_gnutls_x509_crt_get_subject_unique_id gnutls_x509_crt_get_subject_unique_id
333 #define fn_gnutls_x509_crt_get_signature_algorithm gnutls_x509_crt_get_signature_algorithm
334 #define fn_gnutls_x509_crt_get_signature gnutls_x509_crt_get_signature
335 #define fn_gnutls_x509_crt_get_key_id gnutls_x509_crt_get_key_id
336 #define fn_gnutls_sec_param_get_name gnutls_sec_param_get_name
337 #define fn_gnutls_sign_algorithm_get_name gnutls_sign_algorithm_get_name
339 #endif /* !WINDOWSNT */
343 /* Function to log a simple audit message. */
345 gnutls_audit_log_function (gnutls_session_t session
, const char *string
)
347 if (global_gnutls_log_level
>= 1)
349 message ("gnutls.c: [audit] %s", string
);
354 /* Function to log a simple message. */
356 gnutls_log_function (int level
, const char *string
)
358 message ("gnutls.c: [%d] %s", level
, string
);
361 /* Function to log a message and a string. */
363 gnutls_log_function2 (int level
, const char *string
, const char *extra
)
365 message ("gnutls.c: [%d] %s %s", level
, string
, extra
);
368 /* Function to log a message and an integer. */
370 gnutls_log_function2i (int level
, const char *string
, int extra
)
372 message ("gnutls.c: [%d] %s %d", level
, string
, extra
);
376 emacs_gnutls_handshake (struct Lisp_Process
*proc
)
378 gnutls_session_t state
= proc
->gnutls_state
;
381 if (proc
->gnutls_initstage
< GNUTLS_STAGE_HANDSHAKE_CANDO
)
384 if (proc
->gnutls_initstage
< GNUTLS_STAGE_TRANSPORT_POINTERS_SET
)
387 /* On W32 we cannot transfer socket handles between different runtime
388 libraries, so we tell GnuTLS to use our special push/pull
390 fn_gnutls_transport_set_ptr2 (state
,
391 (gnutls_transport_ptr_t
) proc
,
392 (gnutls_transport_ptr_t
) proc
);
393 fn_gnutls_transport_set_push_function (state
, &emacs_gnutls_push
);
394 fn_gnutls_transport_set_pull_function (state
, &emacs_gnutls_pull
);
396 /* For non blocking sockets or other custom made pull/push
397 functions the gnutls_transport_set_lowat must be called, with
398 a zero low water mark value. (GnuTLS 2.10.4 documentation)
400 (Note: this is probably not strictly necessary as the lowat
401 value is only used when no custom pull/push functions are
403 /* According to GnuTLS NEWS file, lowat level has been set to
404 zero by default in version 2.11.1, and the function
405 gnutls_transport_set_lowat was removed from the library in
407 if (!fn_gnutls_check_version ("2.11.1"))
408 fn_gnutls_transport_set_lowat (state
, 0);
410 /* This is how GnuTLS takes sockets: as file descriptors passed
411 in. For an Emacs process socket, infd and outfd are the
412 same but we use this two-argument version for clarity. */
413 fn_gnutls_transport_set_ptr2 (state
,
414 (void *) (intptr_t) proc
->infd
,
415 (void *) (intptr_t) proc
->outfd
);
418 proc
->gnutls_initstage
= GNUTLS_STAGE_TRANSPORT_POINTERS_SET
;
423 ret
= fn_gnutls_handshake (state
);
424 emacs_gnutls_handle_error (state
, ret
);
427 while (ret
< 0 && fn_gnutls_error_is_fatal (ret
) == 0);
429 proc
->gnutls_initstage
= GNUTLS_STAGE_HANDSHAKE_TRIED
;
431 if (ret
== GNUTLS_E_SUCCESS
)
433 /* Here we're finally done. */
434 proc
->gnutls_initstage
= GNUTLS_STAGE_READY
;
438 fn_gnutls_alert_send_appropriate (state
, ret
);
444 emacs_gnutls_record_check_pending (gnutls_session_t state
)
446 return fn_gnutls_record_check_pending (state
);
451 emacs_gnutls_transport_set_errno (gnutls_session_t state
, int err
)
453 fn_gnutls_transport_set_errno (state
, err
);
458 emacs_gnutls_write (struct Lisp_Process
*proc
, const char *buf
, ptrdiff_t nbyte
)
461 ptrdiff_t bytes_written
;
462 gnutls_session_t state
= proc
->gnutls_state
;
464 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
474 rtnval
= fn_gnutls_record_send (state
, buf
, nbyte
);
478 if (rtnval
== GNUTLS_E_INTERRUPTED
)
482 /* If we get GNUTLS_E_AGAIN, then set errno
483 appropriately so that send_process retries the
484 correct way instead of erroring out. */
485 if (rtnval
== GNUTLS_E_AGAIN
)
493 bytes_written
+= rtnval
;
496 emacs_gnutls_handle_error (state
, rtnval
);
497 return (bytes_written
);
501 emacs_gnutls_read (struct Lisp_Process
*proc
, char *buf
, ptrdiff_t nbyte
)
504 gnutls_session_t state
= proc
->gnutls_state
;
506 int log_level
= proc
->gnutls_log_level
;
508 if (proc
->gnutls_initstage
!= GNUTLS_STAGE_READY
)
510 /* If the handshake count is under the limit, try the handshake
511 again and increment the handshake count. This count is kept
512 per process (connection), not globally. */
513 if (proc
->gnutls_handshakes_tried
< GNUTLS_EMACS_HANDSHAKES_LIMIT
)
515 proc
->gnutls_handshakes_tried
++;
516 emacs_gnutls_handshake (proc
);
517 GNUTLS_LOG2i (5, log_level
, "Retried handshake",
518 proc
->gnutls_handshakes_tried
);
522 GNUTLS_LOG (2, log_level
, "Giving up on handshake; resetting retries");
523 proc
->gnutls_handshakes_tried
= 0;
526 rtnval
= fn_gnutls_record_recv (state
, buf
, nbyte
);
529 else if (rtnval
== GNUTLS_E_UNEXPECTED_PACKET_LENGTH
)
530 /* The peer closed the connection. */
532 else if (emacs_gnutls_handle_error (state
, rtnval
))
533 /* non-fatal error */
536 /* a fatal error occurred */
541 /* Report a GnuTLS error to the user.
542 Return true if the error code was successfully handled. */
544 emacs_gnutls_handle_error (gnutls_session_t session
, int err
)
546 int max_log_level
= 0;
551 /* TODO: use a Lisp_Object generated by gnutls_make_error? */
555 max_log_level
= global_gnutls_log_level
;
557 /* TODO: use gnutls-error-fatalp and gnutls-error-string. */
559 str
= fn_gnutls_strerror (err
);
563 if (fn_gnutls_error_is_fatal (err
))
566 GNUTLS_LOG2 (0, max_log_level
, "fatal error:", str
);
587 if (err
== GNUTLS_E_WARNING_ALERT_RECEIVED
588 || err
== GNUTLS_E_FATAL_ALERT_RECEIVED
)
590 int alert
= fn_gnutls_alert_get (session
);
591 int level
= (err
== GNUTLS_E_FATAL_ALERT_RECEIVED
) ? 0 : 1;
592 str
= fn_gnutls_alert_get_name (alert
);
596 GNUTLS_LOG2 (level
, max_log_level
, "Received alert: ", str
);
601 /* convert an integer error to a Lisp_Object; it will be either a
602 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
603 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped
606 gnutls_make_error (int err
)
610 case GNUTLS_E_SUCCESS
:
613 return Qgnutls_e_again
;
614 case GNUTLS_E_INTERRUPTED
:
615 return Qgnutls_e_interrupted
;
616 case GNUTLS_E_INVALID_SESSION
:
617 return Qgnutls_e_invalid_session
;
620 return make_number (err
);
624 emacs_gnutls_deinit (Lisp_Object proc
)
628 CHECK_PROCESS (proc
);
630 if (XPROCESS (proc
)->gnutls_p
== 0)
633 log_level
= XPROCESS (proc
)->gnutls_log_level
;
635 if (XPROCESS (proc
)->gnutls_x509_cred
)
637 GNUTLS_LOG (2, log_level
, "Deallocating x509 credentials");
638 fn_gnutls_certificate_free_credentials (XPROCESS (proc
)->gnutls_x509_cred
);
639 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
642 if (XPROCESS (proc
)->gnutls_anon_cred
)
644 GNUTLS_LOG (2, log_level
, "Deallocating anon credentials");
645 fn_gnutls_anon_free_client_credentials (XPROCESS (proc
)->gnutls_anon_cred
);
646 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
649 if (XPROCESS (proc
)->gnutls_state
)
651 fn_gnutls_deinit (XPROCESS (proc
)->gnutls_state
);
652 XPROCESS (proc
)->gnutls_state
= NULL
;
653 if (GNUTLS_INITSTAGE (proc
) >= GNUTLS_STAGE_INIT
)
654 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
- 1;
657 XPROCESS (proc
)->gnutls_p
= 0;
661 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage
, Sgnutls_get_initstage
, 1, 1, 0,
662 doc
: /* Return the GnuTLS init stage of process PROC.
663 See also `gnutls-boot'. */)
666 CHECK_PROCESS (proc
);
668 return make_number (GNUTLS_INITSTAGE (proc
));
671 DEFUN ("gnutls-errorp", Fgnutls_errorp
, Sgnutls_errorp
, 1, 1, 0,
672 doc
: /* Return t if ERROR indicates a GnuTLS problem.
673 ERROR is an integer or a symbol with an integer `gnutls-code' property.
674 usage: (gnutls-errorp ERROR) */)
677 if (EQ (err
, Qt
)) return Qnil
;
682 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp
, Sgnutls_error_fatalp
, 1, 1, 0,
683 doc
: /* Check if ERROR is fatal.
684 ERROR is an integer or a symbol with an integer `gnutls-code' property.
685 usage: (gnutls-error-fatalp ERROR) */)
690 if (EQ (err
, Qt
)) return Qnil
;
694 code
= Fget (err
, Qgnutls_code
);
701 error ("Symbol has no numeric gnutls-code property");
705 if (! TYPE_RANGED_INTEGERP (int, err
))
706 error ("Not an error symbol or code");
708 if (0 == fn_gnutls_error_is_fatal (XINT (err
)))
714 DEFUN ("gnutls-error-string", Fgnutls_error_string
, Sgnutls_error_string
, 1, 1, 0,
715 doc
: /* Return a description of ERROR.
716 ERROR is an integer or a symbol with an integer `gnutls-code' property.
717 usage: (gnutls-error-string ERROR) */)
722 if (EQ (err
, Qt
)) return build_string ("Not an error");
726 code
= Fget (err
, Qgnutls_code
);
733 return build_string ("Symbol has no numeric gnutls-code property");
737 if (! TYPE_RANGED_INTEGERP (int, err
))
738 return build_string ("Not an error symbol or code");
740 return build_string (fn_gnutls_strerror (XINT (err
)));
743 DEFUN ("gnutls-deinit", Fgnutls_deinit
, Sgnutls_deinit
, 1, 1, 0,
744 doc
: /* Deallocate GnuTLS resources associated with process PROC.
745 See also `gnutls-init'. */)
748 return emacs_gnutls_deinit (proc
);
751 DEFUN ("gnutls-available-p", Fgnutls_available_p
, Sgnutls_available_p
, 0, 0, 0,
752 doc
: /* Return t if GnuTLS is available in this instance of Emacs. */)
756 Lisp_Object found
= Fassq (Qgnutls_dll
, Vlibrary_cache
);
762 status
= init_gnutls_functions () ? Qt
: Qnil
;
763 Vlibrary_cache
= Fcons (Fcons (Qgnutls_dll
, status
), Vlibrary_cache
);
772 gnutls_hex_string (char *buf
, size_t buf_size
, const char *prefix
) {
773 size_t prefix_length
= strlen (prefix
);
774 char *string
= malloc (buf_size
* 3 + prefix_length
);
777 strcpy (string
, prefix
);
779 for (int i
= 0; i
< buf_size
; i
++)
780 sprintf (string
+ i
* 3 + prefix_length
,
781 i
== buf_size
- 1? "%02x": "%02x:",
782 ((unsigned char*)buf
)[i
]);
784 ret
= build_string (string
);
790 gnutls_certificate_details (gnutls_x509_crt_t cert
)
792 Lisp_Object res
= Qnil
;
797 int version
= fn_gnutls_x509_crt_get_version (cert
);
798 if (version
>= GNUTLS_E_SUCCESS
)
799 res
= nconc2 (res
, list2 (intern (":version"),
800 make_number (version
)));
805 size_t serial_size
= 0;
807 err
= fn_gnutls_x509_crt_get_serial (cert
, NULL
, &serial_size
);
808 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
) {
809 char *serial
= malloc (serial_size
);
810 err
= fn_gnutls_x509_crt_get_serial (cert
, serial
, &serial_size
);
811 if (err
>= GNUTLS_E_SUCCESS
) {
812 res
= nconc2 (res
, list2 (intern (":serial-number"),
813 gnutls_hex_string (serial
, serial_size
, "")));
823 err
= fn_gnutls_x509_crt_get_issuer_dn (cert
, NULL
, &dn_size
);
824 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
) {
825 char *dn
= malloc (dn_size
);
826 err
= fn_gnutls_x509_crt_get_issuer_dn (cert
, dn
, &dn_size
);
827 if (err
>= GNUTLS_E_SUCCESS
)
828 res
= nconc2 (res
, list2 (intern (":issuer"),
829 make_string (dn
, dn_size
)));
837 size_t buf_size
= sizeof (buf
);
839 time_t tim
= fn_gnutls_x509_crt_get_activation_time (cert
);
841 if (gmtime_r (&tim
, &t
) != NULL
&&
842 strftime (buf
, buf_size
, "%Y-%m-%d", &t
) != 0)
843 res
= nconc2 (res
, list2 (intern (":valid-from"), build_string (buf
)));
845 tim
= fn_gnutls_x509_crt_get_expiration_time (cert
);
846 if (gmtime_r (&tim
, &t
) != NULL
&&
847 strftime (buf
, buf_size
, "%Y-%m-%d", &t
) != 0)
848 res
= nconc2 (res
, list2 (intern (":valid-to"), build_string (buf
)));
855 err
= fn_gnutls_x509_crt_get_dn (cert
, NULL
, &dn_size
);
856 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
) {
857 char *dn
= malloc (dn_size
);
858 err
= fn_gnutls_x509_crt_get_dn (cert
, dn
, &dn_size
);
859 if (err
>= GNUTLS_E_SUCCESS
)
860 res
= nconc2 (res
, list2 (intern (":subject"),
861 make_string (dn
, dn_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
) {
874 const char *name
= fn_gnutls_pk_algorithm_get_name (err
);
876 res
= nconc2 (res
, list2 (intern (":public-key-algorithm"),
877 build_string (name
)));
879 name
= fn_gnutls_sec_param_get_name (fn_gnutls_pk_bits_to_sec_param
881 res
= nconc2 (res
, list2 (intern (":certificate-security-level"),
882 build_string (name
)));
890 err
= fn_gnutls_x509_crt_get_issuer_unique_id (cert
, NULL
, &buf_size
);
891 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
) {
903 char *buf
= malloc (buf_size
);
904 err
= fn_gnutls_x509_crt_get_subject_unique_id (cert
, buf
, &buf_size
);
905 if (err
>= GNUTLS_E_SUCCESS
)
906 res
= nconc2 (res
, list2 (intern (":subject-unique-id"),
907 make_string (buf
, buf_size
)));
917 err
= fn_gnutls_x509_crt_get_signature_algorithm (cert
);
918 if (err
>= GNUTLS_E_SUCCESS
) {
919 const char *name
= fn_gnutls_sign_algorithm_get_name (err
);
921 res
= nconc2 (res
, list2 (intern (":signature-algorithm"),
922 build_string (name
)));
924 err
= fn_gnutls_x509_crt_get_signature (cert
, NULL
, &buf_size
);
925 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
) {
926 char *buf
= malloc (buf_size
);
927 err
= fn_gnutls_x509_crt_get_signature (cert
, buf
, &buf_size
);
928 if (err
>= GNUTLS_E_SUCCESS
) {
929 res
= nconc2 (res
, list2 (intern (":signature"),
930 gnutls_hex_string (buf
, buf_size
, "")));
941 err
= fn_gnutls_x509_crt_get_key_id (cert
, 0, NULL
, &buf_size
);
942 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
) {
943 unsigned char *buf
= malloc (buf_size
);
944 err
= fn_gnutls_x509_crt_get_key_id (cert
, 0, buf
, &buf_size
);
945 if (err
>= GNUTLS_E_SUCCESS
)
946 res
= nconc2 (res
, list2 (intern (":public-key-id"),
947 gnutls_hex_string ((char *)buf
,
948 buf_size
, "sha1:")));
953 /* Certificate fingerprint. */
957 err
= fn_gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
959 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
) {
960 unsigned char *buf
= malloc (buf_size
);
961 err
= fn_gnutls_x509_crt_get_fingerprint (cert
, GNUTLS_DIG_SHA1
,
963 if (err
>= GNUTLS_E_SUCCESS
)
964 res
= nconc2 (res
, list2 (intern (":certificate-id"),
965 gnutls_hex_string ((char *)buf
,
966 buf_size
, "sha1:")));
974 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe
, Sgnutls_peer_status_warning_describe
, 1, 1, 0,
975 doc
: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'.*/)
976 (Lisp_Object status_symbol
)
978 CHECK_SYMBOL (status_symbol
);
980 if ( EQ (status_symbol
, intern (":invalid")))
981 return build_string ("certificate could not be verified");
983 if ( EQ (status_symbol
, intern (":revoked")) )
984 return build_string ("certificate was revoked (CRL)");
986 if ( EQ (status_symbol
, intern (":self-signed")) )
987 return build_string ("certificate signer was not found (self-signed)");
989 if ( EQ (status_symbol
, intern (":not-ca")) )
990 return build_string ("certificate signer is not a CA");
992 if ( EQ (status_symbol
, intern (":insecure")) )
993 return build_string ("certificate was signed with an insecure algorithm");
995 if ( EQ (status_symbol
, intern (":not-activated")) )
996 return build_string ("certificate is not yet activated");
998 if ( EQ (status_symbol
, intern (":expired")) )
999 return build_string ("certificate has expired");
1001 if ( EQ (status_symbol
, intern (":no-host-match")) )
1002 return build_string ("certificate host does not match hostname");
1007 DEFUN ("gnutls-peer-status", Fgnutls_peer_status
, Sgnutls_peer_status
, 1, 1, 0,
1008 doc
: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1009 The return value is a property list with top-level keys :warnings and
1010 :certificate. The :warnings entry is a list of symbols you can describe with
1011 `gnutls-peer-status-warning-describe'. */)
1014 Lisp_Object warnings
= Qnil
, result
= Qnil
;
1015 unsigned int verification
;
1017 CHECK_PROCESS (proc
);
1019 if ( GNUTLS_INITSTAGE (proc
) < GNUTLS_STAGE_INIT
)
1022 /* Then collect any warnings already computed by the handshake. */
1023 verification
= XPROCESS (proc
)->gnutls_peer_verification
;
1025 if (verification
& GNUTLS_CERT_INVALID
)
1026 warnings
= Fcons (intern (":invalid"), warnings
);
1028 if (verification
& GNUTLS_CERT_REVOKED
)
1029 warnings
= Fcons (intern (":revoked"), warnings
);
1031 if (verification
& GNUTLS_CERT_SIGNER_NOT_FOUND
)
1032 warnings
= Fcons (intern (":self-signed"), warnings
);
1034 if (verification
& GNUTLS_CERT_SIGNER_NOT_CA
)
1035 warnings
= Fcons (intern (":not-ca"), warnings
);
1037 if (verification
& GNUTLS_CERT_INSECURE_ALGORITHM
)
1038 warnings
= Fcons (intern (":insecure"), warnings
);
1040 if (verification
& GNUTLS_CERT_NOT_ACTIVATED
)
1041 warnings
= Fcons (intern (":not-activated"), warnings
);
1043 if (verification
& GNUTLS_CERT_EXPIRED
)
1044 warnings
= Fcons (intern (":expired"), warnings
);
1046 if (XPROCESS (proc
)->gnutls_extra_peer_verification
&
1047 CERTIFICATE_NOT_MATCHING
)
1048 warnings
= Fcons (intern (":no-host-match"), warnings
);
1050 if (!NILP (warnings
))
1051 result
= list2 (intern (":warnings"), warnings
);
1053 /* This could get called in the INIT stage, when the certificate is
1055 if ( XPROCESS (proc
)->gnutls_certificate
!= NULL
)
1056 result
= nconc2 (result
, list2
1057 (intern (":certificate"),
1058 gnutls_certificate_details (XPROCESS (proc
)->gnutls_certificate
)));
1064 /* Initializes global GnuTLS state to defaults.
1065 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1066 Returns zero on success. */
1068 emacs_gnutls_global_init (void)
1070 int ret
= GNUTLS_E_SUCCESS
;
1072 if (!gnutls_global_initialized
)
1074 fn_gnutls_global_set_mem_functions (xmalloc
, xmalloc
, NULL
,
1076 ret
= fn_gnutls_global_init ();
1078 gnutls_global_initialized
= 1;
1080 return gnutls_make_error (ret
);
1084 /* Deinitializes global GnuTLS state.
1085 See also `gnutls-global-init'. */
1087 emacs_gnutls_global_deinit (void)
1089 if (gnutls_global_initialized
)
1090 gnutls_global_deinit ();
1092 gnutls_global_initialized
= 0;
1094 return gnutls_make_error (GNUTLS_E_SUCCESS
);
1098 DEFUN ("gnutls-boot", Fgnutls_boot
, Sgnutls_boot
, 3, 3, 0,
1099 doc
: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1100 Currently only client mode is supported. Return a success/failure
1101 value you can check with `gnutls-errorp'.
1103 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1104 PROPLIST is a property list with the following keys:
1106 :hostname is a string naming the remote host.
1108 :priority is a GnuTLS priority string, defaults to "NORMAL".
1110 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1112 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1114 :keylist is an alist of PEM-encoded key files and PEM-encoded
1115 certificates for `gnutls-x509pki'.
1117 :callbacks is an alist of callback functions, see below.
1119 :loglevel is the debug level requested from GnuTLS, try 4.
1121 :verify-flags is a bitset as per GnuTLS'
1122 gnutls_certificate_set_verify_flags.
1124 :verify-hostname-error is ignored. Pass :hostname in :verify-error
1127 :verify-error is a list of symbols to express verification checks or
1128 `t' to do all checks. Currently it can contain `:trustfiles' and
1129 `:hostname' to verify the certificate or the hostname respectively.
1131 :min-prime-bits is the minimum accepted number of bits the client will
1132 accept in Diffie-Hellman key exchange.
1134 The debug level will be set for this process AND globally for GnuTLS.
1135 So if you set it higher or lower at any point, it affects global
1138 Note that the priority is set on the client. The server does not use
1139 the protocols's priority except for disabling protocols that were not
1142 Processes must be initialized with this function before other GnuTLS
1143 functions are used. This function allocates resources which can only
1144 be deallocated by calling `gnutls-deinit' or by calling it again.
1146 The callbacks alist can have a `verify' key, associated with a
1147 verification function (UNUSED).
1149 Each authentication type may need additional information in order to
1150 work. For X.509 PKI (`gnutls-x509pki'), you probably need at least
1151 one trustfile (usually a CA bundle). */)
1152 (Lisp_Object proc
, Lisp_Object type
, Lisp_Object proplist
)
1154 int ret
= GNUTLS_E_SUCCESS
;
1155 int max_log_level
= 0;
1156 bool verify_error_all
= 0;
1158 gnutls_session_t state
;
1159 gnutls_certificate_credentials_t x509_cred
= NULL
;
1160 gnutls_anon_client_credentials_t anon_cred
= NULL
;
1161 Lisp_Object global_init
;
1162 char const *priority_string_ptr
= "NORMAL"; /* default priority string. */
1163 unsigned int peer_verification
;
1166 /* Placeholders for the property list elements. */
1167 Lisp_Object priority_string
;
1168 Lisp_Object trustfiles
;
1169 Lisp_Object crlfiles
;
1170 Lisp_Object keylist
;
1171 /* Lisp_Object callbacks; */
1172 Lisp_Object loglevel
;
1173 Lisp_Object hostname
;
1174 Lisp_Object verify_error
;
1175 Lisp_Object prime_bits
;
1176 Lisp_Object warnings
;
1177 Lisp_Object warning
;
1179 CHECK_PROCESS (proc
);
1180 CHECK_SYMBOL (type
);
1181 CHECK_LIST (proplist
);
1183 if (NILP (Fgnutls_available_p ()))
1184 error ("GnuTLS not available");
1186 if (!EQ (type
, Qgnutls_x509pki
) && !EQ (type
, Qgnutls_anon
))
1187 error ("Invalid GnuTLS credential type");
1189 hostname
= Fplist_get (proplist
, QCgnutls_bootprop_hostname
);
1190 priority_string
= Fplist_get (proplist
, QCgnutls_bootprop_priority
);
1191 trustfiles
= Fplist_get (proplist
, QCgnutls_bootprop_trustfiles
);
1192 keylist
= Fplist_get (proplist
, QCgnutls_bootprop_keylist
);
1193 crlfiles
= Fplist_get (proplist
, QCgnutls_bootprop_crlfiles
);
1194 loglevel
= Fplist_get (proplist
, QCgnutls_bootprop_loglevel
);
1195 verify_error
= Fplist_get (proplist
, QCgnutls_bootprop_verify_error
);
1196 prime_bits
= Fplist_get (proplist
, QCgnutls_bootprop_min_prime_bits
);
1198 if (EQ (verify_error
, Qt
))
1200 verify_error_all
= 1;
1202 else if (NILP (Flistp (verify_error
)))
1204 error ("gnutls-boot: invalid :verify_error parameter (not a list)");
1207 if (!STRINGP (hostname
))
1208 error ("gnutls-boot: invalid :hostname parameter (not a string)");
1209 c_hostname
= SSDATA (hostname
);
1211 state
= XPROCESS (proc
)->gnutls_state
;
1213 if (TYPE_RANGED_INTEGERP (int, loglevel
))
1215 fn_gnutls_global_set_log_function (gnutls_log_function
);
1217 fn_gnutls_global_set_audit_log_function (gnutls_audit_log_function
);
1219 fn_gnutls_global_set_log_level (XINT (loglevel
));
1220 max_log_level
= XINT (loglevel
);
1221 XPROCESS (proc
)->gnutls_log_level
= max_log_level
;
1224 GNUTLS_LOG2 (1, max_log_level
, "connecting to host:", c_hostname
);
1226 /* always initialize globals. */
1227 global_init
= emacs_gnutls_global_init ();
1228 if (! NILP (Fgnutls_errorp (global_init
)))
1231 /* Before allocating new credentials, deallocate any credentials
1232 that PROC might already have. */
1233 emacs_gnutls_deinit (proc
);
1235 /* Mark PROC as a GnuTLS process. */
1236 XPROCESS (proc
)->gnutls_state
= NULL
;
1237 XPROCESS (proc
)->gnutls_x509_cred
= NULL
;
1238 XPROCESS (proc
)->gnutls_anon_cred
= NULL
;
1239 pset_gnutls_cred_type (XPROCESS (proc
), type
);
1240 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_EMPTY
;
1242 GNUTLS_LOG (1, max_log_level
, "allocating credentials");
1243 if (EQ (type
, Qgnutls_x509pki
))
1245 Lisp_Object verify_flags
;
1246 unsigned int gnutls_verify_flags
= GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT
;
1248 GNUTLS_LOG (2, max_log_level
, "allocating x509 credentials");
1249 fn_gnutls_certificate_allocate_credentials (&x509_cred
);
1250 XPROCESS (proc
)->gnutls_x509_cred
= x509_cred
;
1252 verify_flags
= Fplist_get (proplist
, QCgnutls_bootprop_verify_flags
);
1253 if (NUMBERP (verify_flags
))
1255 gnutls_verify_flags
= XINT (verify_flags
);
1256 GNUTLS_LOG (2, max_log_level
, "setting verification flags");
1258 else if (NILP (verify_flags
))
1259 GNUTLS_LOG (2, max_log_level
, "using default verification flags");
1261 GNUTLS_LOG (2, max_log_level
, "ignoring invalid verify-flags");
1263 fn_gnutls_certificate_set_verify_flags (x509_cred
, gnutls_verify_flags
);
1265 else /* Qgnutls_anon: */
1267 GNUTLS_LOG (2, max_log_level
, "allocating anon credentials");
1268 fn_gnutls_anon_allocate_client_credentials (&anon_cred
);
1269 XPROCESS (proc
)->gnutls_anon_cred
= anon_cred
;
1272 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_ALLOC
;
1274 if (EQ (type
, Qgnutls_x509pki
))
1276 /* TODO: GNUTLS_X509_FMT_DER is also an option. */
1277 int file_format
= GNUTLS_X509_FMT_PEM
;
1280 for (tail
= trustfiles
; CONSP (tail
); tail
= XCDR (tail
))
1282 Lisp_Object trustfile
= XCAR (tail
);
1283 if (STRINGP (trustfile
))
1285 GNUTLS_LOG2 (1, max_log_level
, "setting the trustfile: ",
1286 SSDATA (trustfile
));
1287 trustfile
= ENCODE_FILE (trustfile
);
1289 /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1290 file names on Windows, we need to re-encode the file
1291 name using the current ANSI codepage. */
1292 trustfile
= ansi_encode_filename (trustfile
);
1294 ret
= fn_gnutls_certificate_set_x509_trust_file
1299 if (ret
< GNUTLS_E_SUCCESS
)
1300 return gnutls_make_error (ret
);
1304 emacs_gnutls_deinit (proc
);
1305 error ("Invalid trustfile");
1309 for (tail
= crlfiles
; CONSP (tail
); tail
= XCDR (tail
))
1311 Lisp_Object crlfile
= XCAR (tail
);
1312 if (STRINGP (crlfile
))
1314 GNUTLS_LOG2 (1, max_log_level
, "setting the CRL file: ",
1316 crlfile
= ENCODE_FILE (crlfile
);
1318 crlfile
= ansi_encode_filename (crlfile
);
1320 ret
= fn_gnutls_certificate_set_x509_crl_file
1321 (x509_cred
, SSDATA (crlfile
), file_format
);
1323 if (ret
< GNUTLS_E_SUCCESS
)
1324 return gnutls_make_error (ret
);
1328 emacs_gnutls_deinit (proc
);
1329 error ("Invalid CRL file");
1333 for (tail
= keylist
; CONSP (tail
); tail
= XCDR (tail
))
1335 Lisp_Object keyfile
= Fcar (XCAR (tail
));
1336 Lisp_Object certfile
= Fcar (Fcdr (XCAR (tail
)));
1337 if (STRINGP (keyfile
) && STRINGP (certfile
))
1339 GNUTLS_LOG2 (1, max_log_level
, "setting the client key file: ",
1341 GNUTLS_LOG2 (1, max_log_level
, "setting the client cert file: ",
1343 keyfile
= ENCODE_FILE (keyfile
);
1344 certfile
= ENCODE_FILE (certfile
);
1346 keyfile
= ansi_encode_filename (keyfile
);
1347 certfile
= ansi_encode_filename (certfile
);
1349 ret
= fn_gnutls_certificate_set_x509_key_file
1350 (x509_cred
, SSDATA (certfile
), SSDATA (keyfile
), file_format
);
1352 if (ret
< GNUTLS_E_SUCCESS
)
1353 return gnutls_make_error (ret
);
1357 emacs_gnutls_deinit (proc
);
1358 error (STRINGP (keyfile
) ? "Invalid client cert file"
1359 : "Invalid client key file");
1364 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_FILES
;
1365 GNUTLS_LOG (1, max_log_level
, "gnutls callbacks");
1366 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CALLBACKS
;
1368 /* Call gnutls_init here: */
1370 GNUTLS_LOG (1, max_log_level
, "gnutls_init");
1371 ret
= fn_gnutls_init (&state
, GNUTLS_CLIENT
);
1372 XPROCESS (proc
)->gnutls_state
= state
;
1373 if (ret
< GNUTLS_E_SUCCESS
)
1374 return gnutls_make_error (ret
);
1375 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_INIT
;
1377 if (STRINGP (priority_string
))
1379 priority_string_ptr
= SSDATA (priority_string
);
1380 GNUTLS_LOG2 (1, max_log_level
, "got non-default priority string:",
1381 priority_string_ptr
);
1385 GNUTLS_LOG2 (1, max_log_level
, "using default priority string:",
1386 priority_string_ptr
);
1389 GNUTLS_LOG (1, max_log_level
, "setting the priority string");
1390 ret
= fn_gnutls_priority_set_direct (state
,
1391 priority_string_ptr
,
1393 if (ret
< GNUTLS_E_SUCCESS
)
1394 return gnutls_make_error (ret
);
1396 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_PRIORITY
;
1398 if (INTEGERP (prime_bits
))
1399 fn_gnutls_dh_set_prime_bits (state
, XUINT (prime_bits
));
1401 ret
= EQ (type
, Qgnutls_x509pki
)
1402 ? fn_gnutls_credentials_set (state
, GNUTLS_CRD_CERTIFICATE
, x509_cred
)
1403 : fn_gnutls_credentials_set (state
, GNUTLS_CRD_ANON
, anon_cred
);
1404 if (ret
< GNUTLS_E_SUCCESS
)
1405 return gnutls_make_error (ret
);
1407 GNUTLS_INITSTAGE (proc
) = GNUTLS_STAGE_CRED_SET
;
1408 ret
= emacs_gnutls_handshake (XPROCESS (proc
));
1409 if (ret
< GNUTLS_E_SUCCESS
)
1410 return gnutls_make_error (ret
);
1412 /* Now verify the peer, following
1413 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1414 The peer should present at least one certificate in the chain; do a
1415 check of the certificate's hostname with
1416 gnutls_x509_crt_check_hostname() against :hostname. */
1418 ret
= fn_gnutls_certificate_verify_peers2 (state
, &peer_verification
);
1419 if (ret
< GNUTLS_E_SUCCESS
)
1420 return gnutls_make_error (ret
);
1422 XPROCESS (proc
)->gnutls_peer_verification
= peer_verification
;
1424 warnings
= Fplist_get (Fgnutls_peer_status (proc
), intern (":warnings"));
1425 if ( !NILP (warnings
) )
1428 for (tail
= warnings
; CONSP (tail
); tail
= XCDR (tail
))
1430 Lisp_Object warning
= XCAR (tail
);
1431 Lisp_Object message
= Fgnutls_peer_status_warning_describe (warning
);
1432 if ( !NILP (message
) )
1433 GNUTLS_LOG2 (1, max_log_level
, "verification:", SDATA(message
));
1437 if (peer_verification
!= 0)
1439 if (verify_error_all
1440 || !NILP (Fmember (QCgnutls_bootprop_trustfiles
, verify_error
)))
1442 emacs_gnutls_deinit (proc
);
1443 error ("Certificate validation failed %s, verification code %d",
1444 c_hostname
, peer_verification
);
1448 GNUTLS_LOG2 (1, max_log_level
, "certificate validation failed:",
1453 /* Up to here the process is the same for X.509 certificates and
1454 OpenPGP keys. From now on X.509 certificates are assumed. This
1455 can be easily extended to work with openpgp keys as well. */
1456 if (fn_gnutls_certificate_type_get (state
) == GNUTLS_CRT_X509
)
1458 gnutls_x509_crt_t gnutls_verify_cert
;
1459 const gnutls_datum_t
*gnutls_verify_cert_list
;
1460 unsigned int gnutls_verify_cert_list_size
;
1462 ret
= fn_gnutls_x509_crt_init (&gnutls_verify_cert
);
1463 if (ret
< GNUTLS_E_SUCCESS
)
1464 return gnutls_make_error (ret
);
1466 gnutls_verify_cert_list
=
1467 fn_gnutls_certificate_get_peers (state
, &gnutls_verify_cert_list_size
);
1469 if (gnutls_verify_cert_list
== NULL
)
1471 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1472 emacs_gnutls_deinit (proc
);
1473 error ("No x509 certificate was found\n");
1476 /* We only check the first certificate in the given chain. */
1477 ret
= fn_gnutls_x509_crt_import (gnutls_verify_cert
,
1478 &gnutls_verify_cert_list
[0],
1479 GNUTLS_X509_FMT_DER
);
1481 if (ret
< GNUTLS_E_SUCCESS
)
1483 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1484 return gnutls_make_error (ret
);
1487 XPROCESS (proc
)->gnutls_certificate
= gnutls_verify_cert
;
1489 if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert
, c_hostname
))
1491 XPROCESS (proc
)->gnutls_extra_peer_verification
|=
1492 CERTIFICATE_NOT_MATCHING
;
1493 if (verify_error_all
1494 || !NILP (Fmember (QCgnutls_bootprop_hostname
, verify_error
)))
1496 fn_gnutls_x509_crt_deinit (gnutls_verify_cert
);
1497 emacs_gnutls_deinit (proc
);
1498 error ("The x509 certificate does not match \"%s\"", c_hostname
);
1502 GNUTLS_LOG2 (1, max_log_level
, "x509 certificate does not match:",
1508 /* Set this flag only if the whole initialization succeeded. */
1509 XPROCESS (proc
)->gnutls_p
= 1;
1511 return gnutls_make_error (ret
);
1514 DEFUN ("gnutls-bye", Fgnutls_bye
,
1515 Sgnutls_bye
, 2, 2, 0,
1516 doc
: /* Terminate current GnuTLS connection for process PROC.
1517 The connection should have been initiated using `gnutls-handshake'.
1519 If CONT is not nil the TLS connection gets terminated and further
1520 receives and sends will be disallowed. If the return value is zero you
1521 may continue using the connection. If CONT is nil, GnuTLS actually
1522 sends an alert containing a close request and waits for the peer to
1523 reply with the same message. In order to reuse the connection you
1524 should wait for an EOF from the peer.
1526 This function may also return `gnutls-e-again', or
1527 `gnutls-e-interrupted'. */)
1528 (Lisp_Object proc
, Lisp_Object cont
)
1530 gnutls_session_t state
;
1533 CHECK_PROCESS (proc
);
1535 state
= XPROCESS (proc
)->gnutls_state
;
1537 fn_gnutls_x509_crt_deinit (XPROCESS (proc
)->gnutls_certificate
);
1539 ret
= fn_gnutls_bye (state
,
1540 NILP (cont
) ? GNUTLS_SHUT_RDWR
: GNUTLS_SHUT_WR
);
1542 return gnutls_make_error (ret
);
1546 syms_of_gnutls (void)
1548 gnutls_global_initialized
= 0;
1550 DEFSYM (Qgnutls_dll
, "gnutls");
1551 DEFSYM (Qgnutls_code
, "gnutls-code");
1552 DEFSYM (Qgnutls_anon
, "gnutls-anon");
1553 DEFSYM (Qgnutls_x509pki
, "gnutls-x509pki");
1554 DEFSYM (QCgnutls_bootprop_hostname
, ":hostname");
1555 DEFSYM (QCgnutls_bootprop_priority
, ":priority");
1556 DEFSYM (QCgnutls_bootprop_trustfiles
, ":trustfiles");
1557 DEFSYM (QCgnutls_bootprop_keylist
, ":keylist");
1558 DEFSYM (QCgnutls_bootprop_crlfiles
, ":crlfiles");
1559 DEFSYM (QCgnutls_bootprop_callbacks
, ":callbacks");
1560 DEFSYM (QCgnutls_bootprop_callbacks_verify
, "verify");
1561 DEFSYM (QCgnutls_bootprop_min_prime_bits
, ":min-prime-bits");
1562 DEFSYM (QCgnutls_bootprop_loglevel
, ":loglevel");
1563 DEFSYM (QCgnutls_bootprop_verify_flags
, ":verify-flags");
1564 DEFSYM (QCgnutls_bootprop_verify_error
, ":verify-error");
1566 DEFSYM (Qgnutls_e_interrupted
, "gnutls-e-interrupted");
1567 Fput (Qgnutls_e_interrupted
, Qgnutls_code
,
1568 make_number (GNUTLS_E_INTERRUPTED
));
1570 DEFSYM (Qgnutls_e_again
, "gnutls-e-again");
1571 Fput (Qgnutls_e_again
, Qgnutls_code
,
1572 make_number (GNUTLS_E_AGAIN
));
1574 DEFSYM (Qgnutls_e_invalid_session
, "gnutls-e-invalid-session");
1575 Fput (Qgnutls_e_invalid_session
, Qgnutls_code
,
1576 make_number (GNUTLS_E_INVALID_SESSION
));
1578 DEFSYM (Qgnutls_e_not_ready_for_handshake
, "gnutls-e-not-ready-for-handshake");
1579 Fput (Qgnutls_e_not_ready_for_handshake
, Qgnutls_code
,
1580 make_number (GNUTLS_E_APPLICATION_ERROR_MIN
));
1582 defsubr (&Sgnutls_get_initstage
);
1583 defsubr (&Sgnutls_errorp
);
1584 defsubr (&Sgnutls_error_fatalp
);
1585 defsubr (&Sgnutls_error_string
);
1586 defsubr (&Sgnutls_boot
);
1587 defsubr (&Sgnutls_deinit
);
1588 defsubr (&Sgnutls_bye
);
1589 defsubr (&Sgnutls_available_p
);
1590 defsubr (&Sgnutls_peer_status
);
1591 defsubr (&Sgnutls_peer_status_warning_describe
);
1593 DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level
,
1594 doc
: /* Logging level used by the GnuTLS functions.
1595 Set this larger than 0 to get debug output in the *Messages* buffer.
1596 1 is for important messages, 2 is for debug data, and higher numbers
1597 are as per the GnuTLS logging conventions. */);
1598 global_gnutls_log_level
= 0;
1601 #endif /* HAVE_GNUTLS */