src/gnutls.c

   1 /* GnuTLS glue for GNU Emacs.
   2    Copyright (C) 2010-2015 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   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.
  10
  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.
  15
  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/>.  */
  18
  19 #include <config.h>
  20 #include <errno.h>
  21 #include <stdio.h>
  22
  23 #include "lisp.h"
  24 #include "process.h"
  25 #include "gnutls.h"
  26 #include "coding.h"
  27
  28 #ifdef HAVE_GNUTLS
  29 #include <gnutls/gnutls.h>
  30
  31 #ifdef WINDOWSNT
  32 #include <windows.h>
  33 #include "w32.h"
  34 #endif
  35
  36 static bool emacs_gnutls_handle_error (gnutls_session_t, int);
  37
  38 static bool gnutls_global_initialized;
  39
  40 static void gnutls_log_function (int, const char *);
  41 static void gnutls_log_function2 (int, const char *, const char *);
  42 #ifdef HAVE_GNUTLS3
  43 static void gnutls_audit_log_function (gnutls_session_t, const char *);
  44 #endif
  45
  46 enum extra_peer_verification
  47 {
  48     CERTIFICATE_NOT_MATCHING = 2
  49 };
  50
  51 \f
  52 #ifdef WINDOWSNT
  53
  54 DEF_DLL_FN (gnutls_alert_description_t, gnutls_alert_get,
  55             (gnutls_session_t));
  56 DEF_DLL_FN (const char *, gnutls_alert_get_name,
  57             (gnutls_alert_description_t));
  58 DEF_DLL_FN (int, gnutls_alert_send_appropriate, (gnutls_session_t, int));
  59 DEF_DLL_FN (int, gnutls_anon_allocate_client_credentials,
  60             (gnutls_anon_client_credentials_t *));
  61 DEF_DLL_FN (void, gnutls_anon_free_client_credentials,
  62             (gnutls_anon_client_credentials_t));
  63 DEF_DLL_FN (int, gnutls_bye, (gnutls_session_t, gnutls_close_request_t));
  64 DEF_DLL_FN (int, gnutls_certificate_allocate_credentials,
  65             (gnutls_certificate_credentials_t *));
  66 DEF_DLL_FN (void, gnutls_certificate_free_credentials,
  67             (gnutls_certificate_credentials_t));
  68 DEF_DLL_FN (const gnutls_datum_t *, gnutls_certificate_get_peers,
  69             (gnutls_session_t, unsigned int *));
  70 DEF_DLL_FN (void, gnutls_certificate_set_verify_flags,
  71             (gnutls_certificate_credentials_t, unsigned int));
  72 DEF_DLL_FN (int, gnutls_certificate_set_x509_crl_file,
  73             (gnutls_certificate_credentials_t, const char *,
  74              gnutls_x509_crt_fmt_t));
  75 DEF_DLL_FN (int, gnutls_certificate_set_x509_key_file,
  76             (gnutls_certificate_credentials_t, const char *, const char *,
  77              gnutls_x509_crt_fmt_t));
  78 # if ((GNUTLS_VERSION_MAJOR                                             \
  79        + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20))      \
  80       > 3)
  81 DEF_DLL_FN (int, gnutls_certificate_set_x509_system_trust,
  82             (gnutls_certificate_credentials_t));
  83 # endif
  84 DEF_DLL_FN (int, gnutls_certificate_set_x509_trust_file,
  85             (gnutls_certificate_credentials_t, const char *,
  86              gnutls_x509_crt_fmt_t));
  87 DEF_DLL_FN (gnutls_certificate_type_t, gnutls_certificate_type_get,
  88             (gnutls_session_t));
  89 DEF_DLL_FN (int, gnutls_certificate_verify_peers2,
  90             (gnutls_session_t, unsigned int *));
  91 DEF_DLL_FN (int, gnutls_credentials_set,
  92             (gnutls_session_t, gnutls_credentials_type_t, void *));
  93 DEF_DLL_FN (void, gnutls_deinit, (gnutls_session_t));
  94 DEF_DLL_FN (void, gnutls_dh_set_prime_bits,
  95             (gnutls_session_t, unsigned int));
  96 DEF_DLL_FN (int, gnutls_dh_get_prime_bits, (gnutls_session_t));
  97 DEF_DLL_FN (int, gnutls_error_is_fatal, (int));
  98 DEF_DLL_FN (int, gnutls_global_init, (void));
  99 DEF_DLL_FN (void, gnutls_global_set_log_function, (gnutls_log_func));
 100 # ifdef HAVE_GNUTLS3
 101 DEF_DLL_FN (void, gnutls_global_set_audit_log_function, (gnutls_audit_log_func));
 102 # endif
 103 DEF_DLL_FN (void, gnutls_global_set_log_level, (int));
 104 DEF_DLL_FN (int, gnutls_handshake, (gnutls_session_t));
 105 DEF_DLL_FN (int, gnutls_init, (gnutls_session_t *, unsigned int));
 106 DEF_DLL_FN (int, gnutls_priority_set_direct,
 107             (gnutls_session_t, const char *, const char **));
 108 DEF_DLL_FN (size_t, gnutls_record_check_pending, (gnutls_session_t));
 109 DEF_DLL_FN (ssize_t, gnutls_record_recv, (gnutls_session_t, void *, size_t));
 110 DEF_DLL_FN (ssize_t, gnutls_record_send,
 111             (gnutls_session_t, const void *, size_t));
 112 DEF_DLL_FN (const char *, gnutls_strerror, (int));
 113 DEF_DLL_FN (void, gnutls_transport_set_errno, (gnutls_session_t, int));
 114 DEF_DLL_FN (const char *, gnutls_check_version, (const char *));
 115 DEF_DLL_FN (void, gnutls_transport_set_lowat, (gnutls_session_t, int));
 116 DEF_DLL_FN (void, gnutls_transport_set_ptr2,
 117             (gnutls_session_t, gnutls_transport_ptr_t,
 118              gnutls_transport_ptr_t));
 119 DEF_DLL_FN (void, gnutls_transport_set_pull_function,
 120             (gnutls_session_t, gnutls_pull_func));
 121 DEF_DLL_FN (void, gnutls_transport_set_push_function,
 122             (gnutls_session_t, gnutls_push_func));
 123 DEF_DLL_FN (int, gnutls_x509_crt_check_hostname,
 124             (gnutls_x509_crt_t, const char *));
 125 DEF_DLL_FN (int, gnutls_x509_crt_check_issuer,
 126               (gnutls_x509_crt_t, gnutls_x509_crt_t));
 127 DEF_DLL_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t));
 128 DEF_DLL_FN (int, gnutls_x509_crt_import,
 129             (gnutls_x509_crt_t, const gnutls_datum_t *,
 130              gnutls_x509_crt_fmt_t));
 131 DEF_DLL_FN (int, gnutls_x509_crt_init, (gnutls_x509_crt_t *));
 132 DEF_DLL_FN (int, gnutls_x509_crt_get_fingerprint,
 133             (gnutls_x509_crt_t,
 134              gnutls_digest_algorithm_t, void *, size_t *));
 135 DEF_DLL_FN (int, gnutls_x509_crt_get_version,
 136             (gnutls_x509_crt_t));
 137 DEF_DLL_FN (int, gnutls_x509_crt_get_serial,
 138             (gnutls_x509_crt_t, void *, size_t *));
 139 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_dn,
 140             (gnutls_x509_crt_t, char *, size_t *));
 141 DEF_DLL_FN (time_t, gnutls_x509_crt_get_activation_time,
 142             (gnutls_x509_crt_t));
 143 DEF_DLL_FN (time_t, gnutls_x509_crt_get_expiration_time,
 144             (gnutls_x509_crt_t));
 145 DEF_DLL_FN (int, gnutls_x509_crt_get_dn,
 146             (gnutls_x509_crt_t, char *, size_t *));
 147 DEF_DLL_FN (int, gnutls_x509_crt_get_pk_algorithm,
 148             (gnutls_x509_crt_t, unsigned int *));
 149 DEF_DLL_FN (const char*, gnutls_pk_algorithm_get_name,
 150             (gnutls_pk_algorithm_t));
 151 DEF_DLL_FN (int, gnutls_pk_bits_to_sec_param,
 152             (gnutls_pk_algorithm_t, unsigned int));
 153 DEF_DLL_FN (int, gnutls_x509_crt_get_issuer_unique_id,
 154             (gnutls_x509_crt_t, char *, size_t *));
 155 DEF_DLL_FN (int, gnutls_x509_crt_get_subject_unique_id,
 156             (gnutls_x509_crt_t, char *, size_t *));
 157 DEF_DLL_FN (int, gnutls_x509_crt_get_signature_algorithm,
 158             (gnutls_x509_crt_t));
 159 DEF_DLL_FN (int, gnutls_x509_crt_get_signature,
 160             (gnutls_x509_crt_t, char *, size_t *));
 161 DEF_DLL_FN (int, gnutls_x509_crt_get_key_id,
 162             (gnutls_x509_crt_t, unsigned int, unsigned char *, size_t *_size));
 163 DEF_DLL_FN (const char*, gnutls_sec_param_get_name, (gnutls_sec_param_t));
 164 DEF_DLL_FN (const char*, gnutls_sign_get_name, (gnutls_sign_algorithm_t));
 165 DEF_DLL_FN (int, gnutls_server_name_set,
 166             (gnutls_session_t, gnutls_server_name_type_t,
 167              const void *, size_t));
 168 DEF_DLL_FN (gnutls_kx_algorithm_t, gnutls_kx_get, (gnutls_session_t));
 169 DEF_DLL_FN (const char*, gnutls_kx_get_name, (gnutls_kx_algorithm_t));
 170 DEF_DLL_FN (gnutls_protocol_t, gnutls_protocol_get_version,
 171             (gnutls_session_t));
 172 DEF_DLL_FN (const char*, gnutls_protocol_get_name, (gnutls_protocol_t));
 173 DEF_DLL_FN (gnutls_cipher_algorithm_t, gnutls_cipher_get,
 174             (gnutls_session_t));
 175 DEF_DLL_FN (const char*, gnutls_cipher_get_name,
 176             (gnutls_cipher_algorithm_t));
 177 DEF_DLL_FN (gnutls_mac_algorithm_t, gnutls_mac_get, (gnutls_session_t));
 178 DEF_DLL_FN (const char*, gnutls_mac_get_name, (gnutls_mac_algorithm_t));
 179
 180
 181 static bool
 182 init_gnutls_functions (void)
 183 {
 184   HMODULE library;
 185   int max_log_level = 1;
 186
 187   if (!(library = w32_delayed_load (Qgnutls_dll)))
 188     {
 189       GNUTLS_LOG (1, max_log_level, "GnuTLS library not found");
 190       return 0;
 191     }
 192
 193   LOAD_DLL_FN (library, gnutls_alert_get);
 194   LOAD_DLL_FN (library, gnutls_alert_get_name);
 195   LOAD_DLL_FN (library, gnutls_alert_send_appropriate);
 196   LOAD_DLL_FN (library, gnutls_anon_allocate_client_credentials);
 197   LOAD_DLL_FN (library, gnutls_anon_free_client_credentials);
 198   LOAD_DLL_FN (library, gnutls_bye);
 199   LOAD_DLL_FN (library, gnutls_certificate_allocate_credentials);
 200   LOAD_DLL_FN (library, gnutls_certificate_free_credentials);
 201   LOAD_DLL_FN (library, gnutls_certificate_get_peers);
 202   LOAD_DLL_FN (library, gnutls_certificate_set_verify_flags);
 203   LOAD_DLL_FN (library, gnutls_certificate_set_x509_crl_file);
 204   LOAD_DLL_FN (library, gnutls_certificate_set_x509_key_file);
 205 # if ((GNUTLS_VERSION_MAJOR                                             \
 206        + (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20))      \
 207       > 3)
 208   LOAD_DLL_FN (library, gnutls_certificate_set_x509_system_trust);
 209 # endif
 210   LOAD_DLL_FN (library, gnutls_certificate_set_x509_trust_file);
 211   LOAD_DLL_FN (library, gnutls_certificate_type_get);
 212   LOAD_DLL_FN (library, gnutls_certificate_verify_peers2);
 213   LOAD_DLL_FN (library, gnutls_credentials_set);
 214   LOAD_DLL_FN (library, gnutls_deinit);
 215   LOAD_DLL_FN (library, gnutls_dh_set_prime_bits);
 216   LOAD_DLL_FN (library, gnutls_dh_get_prime_bits);
 217   LOAD_DLL_FN (library, gnutls_error_is_fatal);
 218   LOAD_DLL_FN (library, gnutls_global_init);
 219   LOAD_DLL_FN (library, gnutls_global_set_log_function);
 220 # ifdef HAVE_GNUTLS3
 221   LOAD_DLL_FN (library, gnutls_global_set_audit_log_function);
 222 # endif
 223   LOAD_DLL_FN (library, gnutls_global_set_log_level);
 224   LOAD_DLL_FN (library, gnutls_handshake);
 225   LOAD_DLL_FN (library, gnutls_init);
 226   LOAD_DLL_FN (library, gnutls_priority_set_direct);
 227   LOAD_DLL_FN (library, gnutls_record_check_pending);
 228   LOAD_DLL_FN (library, gnutls_record_recv);
 229   LOAD_DLL_FN (library, gnutls_record_send);
 230   LOAD_DLL_FN (library, gnutls_strerror);
 231   LOAD_DLL_FN (library, gnutls_transport_set_errno);
 232   LOAD_DLL_FN (library, gnutls_check_version);
 233   /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
 234      and later, and the function was removed entirely in 3.0.0.  */
 235   if (!fn_gnutls_check_version ("2.11.1"))
 236     LOAD_DLL_FN (library, gnutls_transport_set_lowat);
 237   LOAD_DLL_FN (library, gnutls_transport_set_ptr2);
 238   LOAD_DLL_FN (library, gnutls_transport_set_pull_function);
 239   LOAD_DLL_FN (library, gnutls_transport_set_push_function);
 240   LOAD_DLL_FN (library, gnutls_x509_crt_check_hostname);
 241   LOAD_DLL_FN (library, gnutls_x509_crt_check_issuer);
 242   LOAD_DLL_FN (library, gnutls_x509_crt_deinit);
 243   LOAD_DLL_FN (library, gnutls_x509_crt_import);
 244   LOAD_DLL_FN (library, gnutls_x509_crt_init);
 245   LOAD_DLL_FN (library, gnutls_x509_crt_get_fingerprint);
 246   LOAD_DLL_FN (library, gnutls_x509_crt_get_version);
 247   LOAD_DLL_FN (library, gnutls_x509_crt_get_serial);
 248   LOAD_DLL_FN (library, gnutls_x509_crt_get_issuer_dn);
 249   LOAD_DLL_FN (library, gnutls_x509_crt_get_activation_time);
 250   LOAD_DLL_FN (library, gnutls_x509_crt_get_expiration_time);
 251   LOAD_DLL_FN (library, gnutls_x509_crt_get_dn);
 252   LOAD_DLL_FN (library, gnutls_x509_crt_get_pk_algorithm);
 253   LOAD_DLL_FN (library, gnutls_pk_algorithm_get_name);
 254   LOAD_DLL_FN (library, gnutls_pk_bits_to_sec_param);
 255   LOAD_DLL_FN (library, gnutls_x509_crt_get_issuer_unique_id);
 256   LOAD_DLL_FN (library, gnutls_x509_crt_get_subject_unique_id);
 257   LOAD_DLL_FN (library, gnutls_x509_crt_get_signature_algorithm);
 258   LOAD_DLL_FN (library, gnutls_x509_crt_get_signature);
 259   LOAD_DLL_FN (library, gnutls_x509_crt_get_key_id);
 260   LOAD_DLL_FN (library, gnutls_sec_param_get_name);
 261   LOAD_DLL_FN (library, gnutls_sign_get_name);
 262   LOAD_DLL_FN (library, gnutls_server_name_set);
 263   LOAD_DLL_FN (library, gnutls_kx_get);
 264   LOAD_DLL_FN (library, gnutls_kx_get_name);
 265   LOAD_DLL_FN (library, gnutls_protocol_get_version);
 266   LOAD_DLL_FN (library, gnutls_protocol_get_name);
 267   LOAD_DLL_FN (library, gnutls_cipher_get);
 268   LOAD_DLL_FN (library, gnutls_cipher_get_name);
 269   LOAD_DLL_FN (library, gnutls_mac_get);
 270   LOAD_DLL_FN (library, gnutls_mac_get_name);
 271
 272   max_log_level = global_gnutls_log_level;
 273
 274   {
 275     Lisp_Object name = CAR_SAFE (Fget (Qgnutls_dll, QCloaded_from));
 276     GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:",
 277                  STRINGP (name) ? (const char *) SDATA (name) : "unknown");
 278   }
 279
 280   return 1;
 281 }
 282
 283 # define gnutls_alert_get fn_gnutls_alert_get
 284 # define gnutls_alert_get_name fn_gnutls_alert_get_name
 285 # define gnutls_alert_send_appropriate fn_gnutls_alert_send_appropriate
 286 # define gnutls_anon_allocate_client_credentials fn_gnutls_anon_allocate_client_credentials
 287 # define gnutls_anon_free_client_credentials fn_gnutls_anon_free_client_credentials
 288 # define gnutls_bye fn_gnutls_bye
 289 # define gnutls_certificate_allocate_credentials fn_gnutls_certificate_allocate_credentials
 290 # define gnutls_certificate_free_credentials fn_gnutls_certificate_free_credentials
 291 # define gnutls_certificate_get_peers fn_gnutls_certificate_get_peers
 292 # define gnutls_certificate_set_verify_flags fn_gnutls_certificate_set_verify_flags
 293 # define gnutls_certificate_set_x509_crl_file fn_gnutls_certificate_set_x509_crl_file
 294 # define gnutls_certificate_set_x509_key_file fn_gnutls_certificate_set_x509_key_file
 295 # define gnutls_certificate_set_x509_system_trust fn_gnutls_certificate_set_x509_system_trust
 296 # define gnutls_certificate_set_x509_trust_file fn_gnutls_certificate_set_x509_trust_file
 297 # define gnutls_certificate_type_get fn_gnutls_certificate_type_get
 298 # define gnutls_certificate_verify_peers2 fn_gnutls_certificate_verify_peers2
 299 # define gnutls_check_version fn_gnutls_check_version
 300 # define gnutls_cipher_get fn_gnutls_cipher_get
 301 # define gnutls_cipher_get_name fn_gnutls_cipher_get_name
 302 # define gnutls_credentials_set fn_gnutls_credentials_set
 303 # define gnutls_deinit fn_gnutls_deinit
 304 # define gnutls_dh_get_prime_bits fn_gnutls_dh_get_prime_bits
 305 # define gnutls_dh_set_prime_bits fn_gnutls_dh_set_prime_bits
 306 # define gnutls_error_is_fatal fn_gnutls_error_is_fatal
 307 # define gnutls_global_init fn_gnutls_global_init
 308 # define gnutls_global_set_audit_log_function fn_gnutls_global_set_audit_log_function
 309 # define gnutls_global_set_log_function fn_gnutls_global_set_log_function
 310 # define gnutls_global_set_log_level fn_gnutls_global_set_log_level
 311 # define gnutls_handshake fn_gnutls_handshake
 312 # define gnutls_init fn_gnutls_init
 313 # define gnutls_kx_get fn_gnutls_kx_get
 314 # define gnutls_kx_get_name fn_gnutls_kx_get_name
 315 # define gnutls_mac_get fn_gnutls_mac_get
 316 # define gnutls_mac_get_name fn_gnutls_mac_get_name
 317 # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name
 318 # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param
 319 # define gnutls_priority_set_direct fn_gnutls_priority_set_direct
 320 # define gnutls_protocol_get_name fn_gnutls_protocol_get_name
 321 # define gnutls_protocol_get_version fn_gnutls_protocol_get_version
 322 # define gnutls_record_check_pending fn_gnutls_record_check_pending
 323 # define gnutls_record_recv fn_gnutls_record_recv
 324 # define gnutls_record_send fn_gnutls_record_send
 325 # define gnutls_sec_param_get_name fn_gnutls_sec_param_get_name
 326 # define gnutls_server_name_set fn_gnutls_server_name_set
 327 # define gnutls_sign_get_name fn_gnutls_sign_get_name
 328 # define gnutls_strerror fn_gnutls_strerror
 329 # define gnutls_transport_set_errno fn_gnutls_transport_set_errno
 330 # define gnutls_transport_set_lowat fn_gnutls_transport_set_lowat
 331 # define gnutls_transport_set_ptr2 fn_gnutls_transport_set_ptr2
 332 # define gnutls_transport_set_pull_function fn_gnutls_transport_set_pull_function
 333 # define gnutls_transport_set_push_function fn_gnutls_transport_set_push_function
 334 # define gnutls_x509_crt_check_hostname fn_gnutls_x509_crt_check_hostname
 335 # define gnutls_x509_crt_check_issuer fn_gnutls_x509_crt_check_issuer
 336 # define gnutls_x509_crt_deinit fn_gnutls_x509_crt_deinit
 337 # define gnutls_x509_crt_get_activation_time fn_gnutls_x509_crt_get_activation_time
 338 # define gnutls_x509_crt_get_dn fn_gnutls_x509_crt_get_dn
 339 # define gnutls_x509_crt_get_expiration_time fn_gnutls_x509_crt_get_expiration_time
 340 # define gnutls_x509_crt_get_fingerprint fn_gnutls_x509_crt_get_fingerprint
 341 # define gnutls_x509_crt_get_issuer_dn fn_gnutls_x509_crt_get_issuer_dn
 342 # define gnutls_x509_crt_get_issuer_unique_id fn_gnutls_x509_crt_get_issuer_unique_id
 343 # define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id
 344 # define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm
 345 # define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial
 346 # define gnutls_x509_crt_get_signature fn_gnutls_x509_crt_get_signature
 347 # define gnutls_x509_crt_get_signature_algorithm fn_gnutls_x509_crt_get_signature_algorithm
 348 # define gnutls_x509_crt_get_subject_unique_id fn_gnutls_x509_crt_get_subject_unique_id
 349 # define gnutls_x509_crt_get_version fn_gnutls_x509_crt_get_version
 350 # define gnutls_x509_crt_import fn_gnutls_x509_crt_import
 351 # define gnutls_x509_crt_init fn_gnutls_x509_crt_init
 352
 353 #endif
 354
 355 \f
 356 /* Report memory exhaustion if ERR is an out-of-memory indication.  */
 357 static void
 358 check_memory_full (int err)
 359 {
 360   /* When GnuTLS exhausts memory, it doesn't say how much memory it
 361      asked for, so tell the Emacs allocator that GnuTLS asked for no
 362      bytes.  This isn't accurate, but it's good enough.  */
 363   if (err == GNUTLS_E_MEMORY_ERROR)
 364     memory_full (0);
 365 }
 366
 367 #ifdef HAVE_GNUTLS3
 368 /* Log a simple audit message.  */
 369 static void
 370 gnutls_audit_log_function (gnutls_session_t session, const char *string)
 371 {
 372   if (global_gnutls_log_level >= 1)
 373     {
 374       message ("gnutls.c: [audit] %s", string);
 375     }
 376 }
 377 #endif
 378
 379 /* Log a simple message.  */
 380 static void
 381 gnutls_log_function (int level, const char *string)
 382 {
 383   message ("gnutls.c: [%d] %s", level, string);
 384 }
 385
 386 /* Log a message and a string.  */
 387 static void
 388 gnutls_log_function2 (int level, const char *string, const char *extra)
 389 {
 390   message ("gnutls.c: [%d] %s %s", level, string, extra);
 391 }
 392
 393 /* Log a message and an integer.  */
 394 static void
 395 gnutls_log_function2i (int level, const char *string, int extra)
 396 {
 397   message ("gnutls.c: [%d] %s %d", level, string, extra);
 398 }
 399
 400 static int
 401 emacs_gnutls_handshake (struct Lisp_Process *proc)
 402 {
 403   gnutls_session_t state = proc->gnutls_state;
 404   int ret;
 405
 406   if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
 407     return -1;
 408
 409   if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
 410     {
 411 #ifdef WINDOWSNT
 412       /* On W32 we cannot transfer socket handles between different runtime
 413          libraries, so we tell GnuTLS to use our special push/pull
 414          functions.  */
 415       gnutls_transport_set_ptr2 (state,
 416                                  (gnutls_transport_ptr_t) proc,
 417                                  (gnutls_transport_ptr_t) proc);
 418       gnutls_transport_set_push_function (state, &emacs_gnutls_push);
 419       gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
 420
 421       /* For non blocking sockets or other custom made pull/push
 422          functions the gnutls_transport_set_lowat must be called, with
 423          a zero low water mark value. (GnuTLS 2.10.4 documentation)
 424
 425          (Note: this is probably not strictly necessary as the lowat
 426           value is only used when no custom pull/push functions are
 427           set.)  */
 428       /* According to GnuTLS NEWS file, lowat level has been set to
 429          zero by default in version 2.11.1, and the function
 430          gnutls_transport_set_lowat was removed from the library in
 431          version 2.99.0.  */
 432       if (!gnutls_check_version ("2.11.1"))
 433         gnutls_transport_set_lowat (state, 0);
 434 #else
 435       /* This is how GnuTLS takes sockets: as file descriptors passed
 436          in.  For an Emacs process socket, infd and outfd are the
 437          same but we use this two-argument version for clarity.  */
 438       gnutls_transport_set_ptr2 (state,
 439                                  (void *) (intptr_t) proc->infd,
 440                                  (void *) (intptr_t) proc->outfd);
 441 #endif
 442
 443       proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
 444     }
 445
 446   do
 447     {
 448       ret = gnutls_handshake (state);
 449       emacs_gnutls_handle_error (state, ret);
 450       QUIT;
 451     }
 452   while (ret < 0 && gnutls_error_is_fatal (ret) == 0);
 453
 454   proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
 455
 456   if (ret == GNUTLS_E_SUCCESS)
 457     {
 458       /* Here we're finally done.  */
 459       proc->gnutls_initstage = GNUTLS_STAGE_READY;
 460     }
 461   else
 462     {
 463       check_memory_full (gnutls_alert_send_appropriate (state, ret));
 464     }
 465   return ret;
 466 }
 467
 468 ptrdiff_t
 469 emacs_gnutls_record_check_pending (gnutls_session_t state)
 470 {
 471   return gnutls_record_check_pending (state);
 472 }
 473
 474 #ifdef WINDOWSNT
 475 void
 476 emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
 477 {
 478   gnutls_transport_set_errno (state, err);
 479 }
 480 #endif
 481
 482 ptrdiff_t
 483 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
 484 {
 485   ssize_t rtnval = 0;
 486   ptrdiff_t bytes_written;
 487   gnutls_session_t state = proc->gnutls_state;
 488
 489   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
 490     {
 491       errno = EAGAIN;
 492       return 0;
 493     }
 494
 495   bytes_written = 0;
 496
 497   while (nbyte > 0)
 498     {
 499       rtnval = gnutls_record_send (state, buf, nbyte);
 500
 501       if (rtnval < 0)
 502         {
 503           if (rtnval == GNUTLS_E_INTERRUPTED)
 504             continue;
 505           else
 506             {
 507               /* If we get GNUTLS_E_AGAIN, then set errno
 508                  appropriately so that send_process retries the
 509                  correct way instead of erroring out. */
 510               if (rtnval == GNUTLS_E_AGAIN)
 511                 errno = EAGAIN;
 512               break;
 513             }
 514         }
 515
 516       buf += rtnval;
 517       nbyte -= rtnval;
 518       bytes_written += rtnval;
 519     }
 520
 521   emacs_gnutls_handle_error (state, rtnval);
 522   return (bytes_written);
 523 }
 524
 525 ptrdiff_t
 526 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
 527 {
 528   ssize_t rtnval;
 529   gnutls_session_t state = proc->gnutls_state;
 530
 531   int log_level = proc->gnutls_log_level;
 532
 533   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
 534     {
 535       /* If the handshake count is under the limit, try the handshake
 536          again and increment the handshake count.  This count is kept
 537          per process (connection), not globally.  */
 538       if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT)
 539         {
 540           proc->gnutls_handshakes_tried++;
 541           emacs_gnutls_handshake (proc);
 542           GNUTLS_LOG2i (5, log_level, "Retried handshake",
 543                         proc->gnutls_handshakes_tried);
 544           return -1;
 545         }
 546
 547       GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
 548       proc->gnutls_handshakes_tried = 0;
 549       return 0;
 550     }
 551   rtnval = gnutls_record_recv (state, buf, nbyte);
 552   if (rtnval >= 0)
 553     return rtnval;
 554   else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
 555     /* The peer closed the connection. */
 556     return 0;
 557   else if (emacs_gnutls_handle_error (state, rtnval))
 558     /* non-fatal error */
 559     return -1;
 560   else {
 561     /* a fatal error occurred */
 562     return 0;
 563   }
 564 }
 565
 566 /* Report a GnuTLS error to the user.
 567    Return true if the error code was successfully handled.  */
 568 static bool
 569 emacs_gnutls_handle_error (gnutls_session_t session, int err)
 570 {
 571   int max_log_level = 0;
 572
 573   bool ret;
 574   const char *str;
 575
 576   /* TODO: use a Lisp_Object generated by gnutls_make_error?  */
 577   if (err >= 0)
 578     return 1;
 579
 580   check_memory_full (err);
 581
 582   max_log_level = global_gnutls_log_level;
 583
 584   /* TODO: use gnutls-error-fatalp and gnutls-error-string.  */
 585
 586   str = gnutls_strerror (err);
 587   if (!str)
 588     str = "unknown";
 589
 590   if (gnutls_error_is_fatal (err))
 591     {
 592       ret = 0;
 593       GNUTLS_LOG2 (1, max_log_level, "fatal error:", str);
 594     }
 595   else
 596     {
 597       ret = 1;
 598
 599       switch (err)
 600         {
 601         case GNUTLS_E_AGAIN:
 602           GNUTLS_LOG2 (3,
 603                        max_log_level,
 604                        "retry:",
 605                        str);
 606         default:
 607           GNUTLS_LOG2 (1,
 608                        max_log_level,
 609                        "non-fatal error:",
 610                        str);
 611         }
 612     }
 613
 614   if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
 615       || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
 616     {
 617       int alert = gnutls_alert_get (session);
 618       int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
 619       str = gnutls_alert_get_name (alert);
 620       if (!str)
 621         str = "unknown";
 622
 623       GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
 624     }
 625   return ret;
 626 }
 627
 628 /* convert an integer error to a Lisp_Object; it will be either a
 629    known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
 630    simply the integer value of the error.  GNUTLS_E_SUCCESS is mapped
 631    to Qt.  */
 632 static Lisp_Object
 633 gnutls_make_error (int err)
 634 {
 635   switch (err)
 636     {
 637     case GNUTLS_E_SUCCESS:
 638       return Qt;
 639     case GNUTLS_E_AGAIN:
 640       return Qgnutls_e_again;
 641     case GNUTLS_E_INTERRUPTED:
 642       return Qgnutls_e_interrupted;
 643     case GNUTLS_E_INVALID_SESSION:
 644       return Qgnutls_e_invalid_session;
 645     }
 646
 647   check_memory_full (err);
 648   return make_number (err);
 649 }
 650
 651 Lisp_Object
 652 emacs_gnutls_deinit (Lisp_Object proc)
 653 {
 654   int log_level;
 655
 656   CHECK_PROCESS (proc);
 657
 658   if (XPROCESS (proc)->gnutls_p == 0)
 659     return Qnil;
 660
 661   log_level = XPROCESS (proc)->gnutls_log_level;
 662
 663   if (XPROCESS (proc)->gnutls_x509_cred)
 664     {
 665       GNUTLS_LOG (2, log_level, "Deallocating x509 credentials");
 666       gnutls_certificate_free_credentials (XPROCESS (proc)->gnutls_x509_cred);
 667       XPROCESS (proc)->gnutls_x509_cred = NULL;
 668     }
 669
 670   if (XPROCESS (proc)->gnutls_anon_cred)
 671     {
 672       GNUTLS_LOG (2, log_level, "Deallocating anon credentials");
 673       gnutls_anon_free_client_credentials (XPROCESS (proc)->gnutls_anon_cred);
 674       XPROCESS (proc)->gnutls_anon_cred = NULL;
 675     }
 676
 677   if (XPROCESS (proc)->gnutls_state)
 678     {
 679       gnutls_deinit (XPROCESS (proc)->gnutls_state);
 680       XPROCESS (proc)->gnutls_state = NULL;
 681       if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 682         GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
 683     }
 684
 685   XPROCESS (proc)->gnutls_p = 0;
 686   return Qt;
 687 }
 688
 689 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
 690        doc: /* Return the GnuTLS init stage of process PROC.
 691 See also `gnutls-boot'.  */)
 692   (Lisp_Object proc)
 693 {
 694   CHECK_PROCESS (proc);
 695
 696   return make_number (GNUTLS_INITSTAGE (proc));
 697 }
 698
 699 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
 700        doc: /* Return t if ERROR indicates a GnuTLS problem.
 701 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 702 usage: (gnutls-errorp ERROR)  */
 703        attributes: const)
 704   (Lisp_Object err)
 705 {
 706   if (EQ (err, Qt)) return Qnil;
 707
 708   return Qt;
 709 }
 710
 711 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
 712        doc: /* Return non-nil if ERROR is fatal.
 713 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 714 Usage: (gnutls-error-fatalp ERROR)  */)
 715   (Lisp_Object err)
 716 {
 717   Lisp_Object code;
 718
 719   if (EQ (err, Qt)) return Qnil;
 720
 721   if (SYMBOLP (err))
 722     {
 723       code = Fget (err, Qgnutls_code);
 724       if (NUMBERP (code))
 725         {
 726           err = code;
 727         }
 728       else
 729         {
 730           error ("Symbol has no numeric gnutls-code property");
 731         }
 732     }
 733
 734   if (! TYPE_RANGED_INTEGERP (int, err))
 735     error ("Not an error symbol or code");
 736
 737   if (0 == gnutls_error_is_fatal (XINT (err)))
 738     return Qnil;
 739
 740   return Qt;
 741 }
 742
 743 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
 744        doc: /* Return a description of ERROR.
 745 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 746 usage: (gnutls-error-string ERROR)  */)
 747   (Lisp_Object err)
 748 {
 749   Lisp_Object code;
 750
 751   if (EQ (err, Qt)) return build_string ("Not an error");
 752
 753   if (SYMBOLP (err))
 754     {
 755       code = Fget (err, Qgnutls_code);
 756       if (NUMBERP (code))
 757         {
 758           err = code;
 759         }
 760       else
 761         {
 762           return build_string ("Symbol has no numeric gnutls-code property");
 763         }
 764     }
 765
 766   if (! TYPE_RANGED_INTEGERP (int, err))
 767     return build_string ("Not an error symbol or code");
 768
 769   return build_string (gnutls_strerror (XINT (err)));
 770 }
 771
 772 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
 773        doc: /* Deallocate GnuTLS resources associated with process PROC.
 774 See also `gnutls-init'.  */)
 775   (Lisp_Object proc)
 776 {
 777   return emacs_gnutls_deinit (proc);
 778 }
 779
 780 static Lisp_Object
 781 gnutls_hex_string (unsigned char *buf, ptrdiff_t buf_size, const char *prefix)
 782 {
 783   ptrdiff_t prefix_length = strlen (prefix);
 784   ptrdiff_t retlen;
 785   if (INT_MULTIPLY_WRAPV (buf_size, 3, &retlen)
 786       || INT_ADD_WRAPV (prefix_length - (buf_size != 0), retlen, &retlen))
 787     string_overflow ();
 788   Lisp_Object ret = make_uninit_string (retlen);
 789   char *string = SSDATA (ret);
 790   strcpy (string, prefix);
 791
 792   for (ptrdiff_t i = 0; i < buf_size; i++)
 793     sprintf (string + i * 3 + prefix_length,
 794              i == buf_size - 1 ? "%02x" : "%02x:",
 795              buf[i]);
 796
 797   return ret;
 798 }
 799
 800 static Lisp_Object
 801 gnutls_certificate_details (gnutls_x509_crt_t cert)
 802 {
 803   Lisp_Object res = Qnil;
 804   int err;
 805   size_t buf_size;
 806
 807   /* Version. */
 808   {
 809     int version = gnutls_x509_crt_get_version (cert);
 810     check_memory_full (version);
 811     if (version >= GNUTLS_E_SUCCESS)
 812       res = nconc2 (res, list2 (intern (":version"),
 813                                 make_number (version)));
 814   }
 815
 816   /* Serial. */
 817   buf_size = 0;
 818   err = gnutls_x509_crt_get_serial (cert, NULL, &buf_size);
 819   check_memory_full (err);
 820   if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
 821     {
 822       void *serial = xmalloc (buf_size);
 823       err = gnutls_x509_crt_get_serial (cert, serial, &buf_size);
 824       check_memory_full (err);
 825       if (err >= GNUTLS_E_SUCCESS)
 826         res = nconc2 (res, list2 (intern (":serial-number"),
 827                                   gnutls_hex_string (serial, buf_size, "")));
 828       xfree (serial);
 829     }
 830
 831   /* Issuer. */
 832   buf_size = 0;
 833   err = gnutls_x509_crt_get_issuer_dn (cert, NULL, &buf_size);
 834   check_memory_full (err);
 835   if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
 836     {
 837       char *dn = xmalloc (buf_size);
 838       err = gnutls_x509_crt_get_issuer_dn (cert, dn, &buf_size);
 839       check_memory_full (err);
 840       if (err >= GNUTLS_E_SUCCESS)
 841         res = nconc2 (res, list2 (intern (":issuer"),
 842                                   make_string (dn, buf_size)));
 843       xfree (dn);
 844     }
 845
 846   /* Validity. */
 847   {
 848     /* Add 1 to the buffer size, since 1900 is added to tm_year and
 849        that might add 1 to the year length.  */
 850     char buf[INT_STRLEN_BOUND (int) + 1 + sizeof "-12-31"];
 851     struct tm t;
 852     time_t tim = gnutls_x509_crt_get_activation_time (cert);
 853
 854     if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t))
 855       res = nconc2 (res, list2 (intern (":valid-from"), build_string (buf)));
 856
 857     tim = gnutls_x509_crt_get_expiration_time (cert);
 858     if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t))
 859       res = nconc2 (res, list2 (intern (":valid-to"), build_string (buf)));
 860   }
 861
 862   /* Subject. */
 863   buf_size = 0;
 864   err = gnutls_x509_crt_get_dn (cert, NULL, &buf_size);
 865   check_memory_full (err);
 866   if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
 867     {
 868       char *dn = xmalloc (buf_size);
 869       err = gnutls_x509_crt_get_dn (cert, dn, &buf_size);
 870       check_memory_full (err);
 871       if (err >= GNUTLS_E_SUCCESS)
 872         res = nconc2 (res, list2 (intern (":subject"),
 873                                   make_string (dn, buf_size)));
 874       xfree (dn);
 875     }
 876
 877   /* Versions older than 2.11 doesn't have these four functions. */
 878 #if GNUTLS_VERSION_NUMBER >= 0x020b00
 879   /* SubjectPublicKeyInfo. */
 880   {
 881     unsigned int bits;
 882
 883     err = gnutls_x509_crt_get_pk_algorithm (cert, &bits);
 884     check_memory_full (err);
 885     if (err >= GNUTLS_E_SUCCESS)
 886       {
 887         const char *name = gnutls_pk_algorithm_get_name (err);
 888         if (name)
 889           res = nconc2 (res, list2 (intern (":public-key-algorithm"),
 890                                     build_string (name)));
 891
 892         name = gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param
 893                                           (err, bits));
 894         res = nconc2 (res, list2 (intern (":certificate-security-level"),
 895                                   build_string (name)));
 896       }
 897   }
 898
 899   /* Unique IDs. */
 900   buf_size = 0;
 901   err = gnutls_x509_crt_get_issuer_unique_id (cert, NULL, &buf_size);
 902   check_memory_full (err);
 903   if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
 904     {
 905       char *buf = xmalloc (buf_size);
 906       err = gnutls_x509_crt_get_issuer_unique_id (cert, buf, &buf_size);
 907       check_memory_full (err);
 908       if (err >= GNUTLS_E_SUCCESS)
 909         res = nconc2 (res, list2 (intern (":issuer-unique-id"),
 910                                   make_string (buf, buf_size)));
 911       xfree (buf);
 912     }
 913
 914   buf_size = 0;
 915   err = gnutls_x509_crt_get_subject_unique_id (cert, NULL, &buf_size);
 916   check_memory_full (err);
 917   if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
 918     {
 919       char *buf = xmalloc (buf_size);
 920       err = gnutls_x509_crt_get_subject_unique_id (cert, buf, &buf_size);
 921       check_memory_full (err);
 922       if (err >= GNUTLS_E_SUCCESS)
 923         res = nconc2 (res, list2 (intern (":subject-unique-id"),
 924                                   make_string (buf, buf_size)));
 925       xfree (buf);
 926     }
 927 #endif
 928
 929   /* Signature. */
 930   err = gnutls_x509_crt_get_signature_algorithm (cert);
 931   check_memory_full (err);
 932   if (err >= GNUTLS_E_SUCCESS)
 933     {
 934       const char *name = gnutls_sign_get_name (err);
 935       if (name)
 936         res = nconc2 (res, list2 (intern (":signature-algorithm"),
 937                                   build_string (name)));
 938     }
 939
 940   /* Public key ID. */
 941   buf_size = 0;
 942   err = gnutls_x509_crt_get_key_id (cert, 0, NULL, &buf_size);
 943   check_memory_full (err);
 944   if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
 945     {
 946       void *buf = xmalloc (buf_size);
 947       err = gnutls_x509_crt_get_key_id (cert, 0, buf, &buf_size);
 948       check_memory_full (err);
 949       if (err >= GNUTLS_E_SUCCESS)
 950         res = nconc2 (res, list2 (intern (":public-key-id"),
 951                                   gnutls_hex_string (buf, buf_size, "sha1:")));
 952       xfree (buf);
 953     }
 954
 955   /* Certificate fingerprint. */
 956   buf_size = 0;
 957   err = gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1,
 958                                          NULL, &buf_size);
 959   check_memory_full (err);
 960   if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
 961     {
 962       void *buf = xmalloc (buf_size);
 963       err = gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1,
 964                                              buf, &buf_size);
 965       check_memory_full (err);
 966       if (err >= GNUTLS_E_SUCCESS)
 967         res = nconc2 (res, list2 (intern (":certificate-id"),
 968                                   gnutls_hex_string (buf, buf_size, "sha1:")));
 969       xfree (buf);
 970     }
 971
 972   return res;
 973 }
 974
 975 DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_describe, Sgnutls_peer_status_warning_describe, 1, 1, 0,
 976        doc: /* Describe the warning of a GnuTLS peer status from `gnutls-peer-status'.  */)
 977   (Lisp_Object status_symbol)
 978 {
 979   CHECK_SYMBOL (status_symbol);
 980
 981   if (EQ (status_symbol, intern (":invalid")))
 982     return build_string ("certificate could not be verified");
 983
 984   if (EQ (status_symbol, intern (":revoked")))
 985     return build_string ("certificate was revoked (CRL)");
 986
 987   if (EQ (status_symbol, intern (":self-signed")))
 988     return build_string ("certificate signer was not found (self-signed)");
 989
 990   if (EQ (status_symbol, intern (":unknown-ca")))
 991     return build_string ("the certificate was signed by an unknown "
 992                          "and therefore untrusted authority");
 993
 994   if (EQ (status_symbol, intern (":not-ca")))
 995     return build_string ("certificate signer is not a CA");
 996
 997   if (EQ (status_symbol, intern (":insecure")))
 998     return build_string ("certificate was signed with an insecure algorithm");
 999
1000   if (EQ (status_symbol, intern (":not-activated")))
1001     return build_string ("certificate is not yet activated");
1002
1003   if (EQ (status_symbol, intern (":expired")))
1004     return build_string ("certificate has expired");
1005
1006   if (EQ (status_symbol, intern (":no-host-match")))
1007     return build_string ("certificate host does not match hostname");
1008
1009   return Qnil;
1010 }
1011
1012 DEFUN ("gnutls-peer-status", Fgnutls_peer_status, Sgnutls_peer_status, 1, 1, 0,
1013        doc: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
1014 The return value is a property list with top-level keys :warnings and
1015 :certificate.  The :warnings entry is a list of symbols you can describe with
1016 `gnutls-peer-status-warning-describe'. */)
1017   (Lisp_Object proc)
1018 {
1019   Lisp_Object warnings = Qnil, result = Qnil;
1020   unsigned int verification;
1021   gnutls_session_t state;
1022
1023   CHECK_PROCESS (proc);
1024
1025   if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_INIT)
1026     return Qnil;
1027
1028   /* Then collect any warnings already computed by the handshake. */
1029   verification = XPROCESS (proc)->gnutls_peer_verification;
1030
1031   if (verification & GNUTLS_CERT_INVALID)
1032     warnings = Fcons (intern (":invalid"), warnings);
1033
1034   if (verification & GNUTLS_CERT_REVOKED)
1035     warnings = Fcons (intern (":revoked"), warnings);
1036
1037   if (verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
1038     warnings = Fcons (intern (":unknown-ca"), warnings);
1039
1040   if (verification & GNUTLS_CERT_SIGNER_NOT_CA)
1041     warnings = Fcons (intern (":not-ca"), warnings);
1042
1043   if (verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1044     warnings = Fcons (intern (":insecure"), warnings);
1045
1046   if (verification & GNUTLS_CERT_NOT_ACTIVATED)
1047     warnings = Fcons (intern (":not-activated"), warnings);
1048
1049   if (verification & GNUTLS_CERT_EXPIRED)
1050     warnings = Fcons (intern (":expired"), warnings);
1051
1052   if (XPROCESS (proc)->gnutls_extra_peer_verification &
1053       CERTIFICATE_NOT_MATCHING)
1054     warnings = Fcons (intern (":no-host-match"), warnings);
1055
1056   /* This could get called in the INIT stage, when the certificate is
1057      not yet set. */
1058   if (XPROCESS (proc)->gnutls_certificate != NULL &&
1059       gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificate,
1060                                    XPROCESS (proc)->gnutls_certificate))
1061     warnings = Fcons (intern (":self-signed"), warnings);
1062
1063   if (!NILP (warnings))
1064     result = list2 (intern (":warnings"), warnings);
1065
1066   /* This could get called in the INIT stage, when the certificate is
1067      not yet set. */
1068   if (XPROCESS (proc)->gnutls_certificate != NULL)
1069     result = nconc2 (result, list2
1070                      (intern (":certificate"),
1071                       gnutls_certificate_details (XPROCESS (proc)->gnutls_certificate)));
1072
1073   state = XPROCESS (proc)->gnutls_state;
1074
1075   /* Diffie-Hellman prime bits. */
1076   {
1077     int bits = gnutls_dh_get_prime_bits (state);
1078     check_memory_full (bits);
1079     if (bits > 0)
1080       result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"),
1081                                       make_number (bits)));
1082   }
1083
1084   /* Key exchange. */
1085   result = nconc2
1086     (result, list2 (intern (":key-exchange"),
1087                     build_string (gnutls_kx_get_name
1088                                   (gnutls_kx_get (state)))));
1089
1090   /* Protocol name. */
1091   result = nconc2
1092     (result, list2 (intern (":protocol"),
1093                     build_string (gnutls_protocol_get_name
1094                                   (gnutls_protocol_get_version (state)))));
1095
1096   /* Cipher name. */
1097   result = nconc2
1098     (result, list2 (intern (":cipher"),
1099                     build_string (gnutls_cipher_get_name
1100                                   (gnutls_cipher_get (state)))));
1101
1102   /* MAC name. */
1103   result = nconc2
1104     (result, list2 (intern (":mac"),
1105                     build_string (gnutls_mac_get_name
1106                                   (gnutls_mac_get (state)))));
1107
1108
1109   return result;
1110 }
1111
1112 /* Initialize global GnuTLS state to defaults.
1113    Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
1114    Return zero on success.  */
1115 static Lisp_Object
1116 emacs_gnutls_global_init (void)
1117 {
1118   int ret = GNUTLS_E_SUCCESS;
1119
1120   if (!gnutls_global_initialized)
1121     ret = gnutls_global_init ();
1122
1123   gnutls_global_initialized = 1;
1124
1125   return gnutls_make_error (ret);
1126 }
1127
1128 static bool
1129 gnutls_ip_address_p (char *string)
1130 {
1131   char c;
1132
1133   while ((c = *string++) != 0)
1134     if (! ((c == '.' || c == ':' || (c >= '0' && c <= '9'))))
1135       return false;
1136
1137   return true;
1138 }
1139
1140 #if 0
1141 /* Deinitialize global GnuTLS state.
1142    See also `gnutls-global-init'.  */
1143 static Lisp_Object
1144 emacs_gnutls_global_deinit (void)
1145 {
1146   if (gnutls_global_initialized)
1147     gnutls_global_deinit ();
1148
1149   gnutls_global_initialized = 0;
1150
1151   return gnutls_make_error (GNUTLS_E_SUCCESS);
1152 }
1153 #endif
1154
1155 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
1156        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1157 Currently only client mode is supported.  Return a success/failure
1158 value you can check with `gnutls-errorp'.
1159
1160 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1161 PROPLIST is a property list with the following keys:
1162
1163 :hostname is a string naming the remote host.
1164
1165 :priority is a GnuTLS priority string, defaults to "NORMAL".
1166
1167 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1168
1169 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1170
1171 :keylist is an alist of PEM-encoded key files and PEM-encoded
1172 certificates for `gnutls-x509pki'.
1173
1174 :callbacks is an alist of callback functions, see below.
1175
1176 :loglevel is the debug level requested from GnuTLS, try 4.
1177
1178 :verify-flags is a bitset as per GnuTLS'
1179 gnutls_certificate_set_verify_flags.
1180
1181 :verify-hostname-error is ignored.  Pass :hostname in :verify-error
1182 instead.
1183
1184 :verify-error is a list of symbols to express verification checks or
1185 t to do all checks.  Currently it can contain `:trustfiles' and
1186 `:hostname' to verify the certificate or the hostname respectively.
1187
1188 :min-prime-bits is the minimum accepted number of bits the client will
1189 accept in Diffie-Hellman key exchange.
1190
1191 The debug level will be set for this process AND globally for GnuTLS.
1192 So if you set it higher or lower at any point, it affects global
1193 debugging.
1194
1195 Note that the priority is set on the client.  The server does not use
1196 the protocols's priority except for disabling protocols that were not
1197 specified.
1198
1199 Processes must be initialized with this function before other GnuTLS
1200 functions are used.  This function allocates resources which can only
1201 be deallocated by calling `gnutls-deinit' or by calling it again.
1202
1203 The callbacks alist can have a `verify' key, associated with a
1204 verification function (UNUSED).
1205
1206 Each authentication type may need additional information in order to
1207 work.  For X.509 PKI (`gnutls-x509pki'), you probably need at least
1208 one trustfile (usually a CA bundle).  */)
1209   (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
1210 {
1211   int ret = GNUTLS_E_SUCCESS;
1212   int max_log_level = 0;
1213   bool verify_error_all = 0;
1214
1215   gnutls_session_t state;
1216   gnutls_certificate_credentials_t x509_cred = NULL;
1217   gnutls_anon_client_credentials_t anon_cred = NULL;
1218   Lisp_Object global_init;
1219   char const *priority_string_ptr = "NORMAL"; /* default priority string.  */
1220   unsigned int peer_verification;
1221   char *c_hostname;
1222
1223   /* Placeholders for the property list elements.  */
1224   Lisp_Object priority_string;
1225   Lisp_Object trustfiles;
1226   Lisp_Object crlfiles;
1227   Lisp_Object keylist;
1228   /* Lisp_Object callbacks; */
1229   Lisp_Object loglevel;
1230   Lisp_Object hostname;
1231   Lisp_Object verify_error;
1232   Lisp_Object prime_bits;
1233   Lisp_Object warnings;
1234
1235   CHECK_PROCESS (proc);
1236   CHECK_SYMBOL (type);
1237   CHECK_LIST (proplist);
1238
1239   if (NILP (Fgnutls_available_p ()))
1240     error ("GnuTLS not available");
1241
1242   if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
1243     error ("Invalid GnuTLS credential type");
1244
1245   hostname              = Fplist_get (proplist, QCgnutls_bootprop_hostname);
1246   priority_string       = Fplist_get (proplist, QCgnutls_bootprop_priority);
1247   trustfiles            = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
1248   keylist               = Fplist_get (proplist, QCgnutls_bootprop_keylist);
1249   crlfiles              = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
1250   loglevel              = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
1251   verify_error          = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
1252   prime_bits            = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
1253
1254   if (EQ (verify_error, Qt))
1255     {
1256       verify_error_all = 1;
1257     }
1258   else if (NILP (Flistp (verify_error)))
1259     {
1260       error ("gnutls-boot: invalid :verify_error parameter (not a list)");
1261     }
1262
1263   if (!STRINGP (hostname))
1264     error ("gnutls-boot: invalid :hostname parameter (not a string)");
1265   c_hostname = SSDATA (hostname);
1266
1267   state = XPROCESS (proc)->gnutls_state;
1268
1269   if (TYPE_RANGED_INTEGERP (int, loglevel))
1270     {
1271       gnutls_global_set_log_function (gnutls_log_function);
1272 #ifdef HAVE_GNUTLS3
1273       gnutls_global_set_audit_log_function (gnutls_audit_log_function);
1274 #endif
1275       gnutls_global_set_log_level (XINT (loglevel));
1276       max_log_level = XINT (loglevel);
1277       XPROCESS (proc)->gnutls_log_level = max_log_level;
1278     }
1279
1280   GNUTLS_LOG2 (1, max_log_level, "connecting to host:", c_hostname);
1281
1282   /* Always initialize globals.  */
1283   global_init = emacs_gnutls_global_init ();
1284   if (! NILP (Fgnutls_errorp (global_init)))
1285     return global_init;
1286
1287   /* Before allocating new credentials, deallocate any credentials
1288      that PROC might already have.  */
1289   emacs_gnutls_deinit (proc);
1290
1291   /* Mark PROC as a GnuTLS process.  */
1292   XPROCESS (proc)->gnutls_state = NULL;
1293   XPROCESS (proc)->gnutls_x509_cred = NULL;
1294   XPROCESS (proc)->gnutls_anon_cred = NULL;
1295   pset_gnutls_cred_type (XPROCESS (proc), type);
1296   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
1297
1298   GNUTLS_LOG (1, max_log_level, "allocating credentials");
1299   if (EQ (type, Qgnutls_x509pki))
1300     {
1301       Lisp_Object verify_flags;
1302       unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
1303
1304       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
1305       check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred));
1306       XPROCESS (proc)->gnutls_x509_cred = x509_cred;
1307
1308       verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
1309       if (NUMBERP (verify_flags))
1310         {
1311           gnutls_verify_flags = XINT (verify_flags);
1312           GNUTLS_LOG (2, max_log_level, "setting verification flags");
1313         }
1314       else if (NILP (verify_flags))
1315         GNUTLS_LOG (2, max_log_level, "using default verification flags");
1316       else
1317         GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
1318
1319       gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
1320     }
1321   else /* Qgnutls_anon: */
1322     {
1323       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
1324       check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred));
1325       XPROCESS (proc)->gnutls_anon_cred = anon_cred;
1326     }
1327
1328   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
1329
1330   if (EQ (type, Qgnutls_x509pki))
1331     {
1332       /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
1333       int file_format = GNUTLS_X509_FMT_PEM;
1334       Lisp_Object tail;
1335
1336 #if GNUTLS_VERSION_MAJOR +                                      \
1337   (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
1338       ret = gnutls_certificate_set_x509_system_trust (x509_cred);
1339       if (ret < GNUTLS_E_SUCCESS)
1340         {
1341           check_memory_full (ret);
1342           GNUTLS_LOG2i (4, max_log_level,
1343                         "setting system trust failed with code ", ret);
1344         }
1345 #endif
1346
1347       for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
1348         {
1349           Lisp_Object trustfile = XCAR (tail);
1350           if (STRINGP (trustfile))
1351             {
1352               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
1353                            SSDATA (trustfile));
1354               trustfile = ENCODE_FILE (trustfile);
1355 #ifdef WINDOWSNT
1356               /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1357                  file names on Windows, we need to re-encode the file
1358                  name using the current ANSI codepage.  */
1359               trustfile = ansi_encode_filename (trustfile);
1360 #endif
1361               ret = gnutls_certificate_set_x509_trust_file
1362                 (x509_cred,
1363                  SSDATA (trustfile),
1364                  file_format);
1365
1366               if (ret < GNUTLS_E_SUCCESS)
1367                 return gnutls_make_error (ret);
1368             }
1369           else
1370             {
1371               emacs_gnutls_deinit (proc);
1372               error ("Invalid trustfile");
1373             }
1374         }
1375
1376       for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
1377         {
1378           Lisp_Object crlfile = XCAR (tail);
1379           if (STRINGP (crlfile))
1380             {
1381               GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
1382                            SSDATA (crlfile));
1383               crlfile = ENCODE_FILE (crlfile);
1384 #ifdef WINDOWSNT
1385               crlfile = ansi_encode_filename (crlfile);
1386 #endif
1387               ret = gnutls_certificate_set_x509_crl_file
1388                 (x509_cred, SSDATA (crlfile), file_format);
1389
1390               if (ret < GNUTLS_E_SUCCESS)
1391                 return gnutls_make_error (ret);
1392             }
1393           else
1394             {
1395               emacs_gnutls_deinit (proc);
1396               error ("Invalid CRL file");
1397             }
1398         }
1399
1400       for (tail = keylist; CONSP (tail); tail = XCDR (tail))
1401         {
1402           Lisp_Object keyfile = Fcar (XCAR (tail));
1403           Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
1404           if (STRINGP (keyfile) && STRINGP (certfile))
1405             {
1406               GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
1407                            SSDATA (keyfile));
1408               GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
1409                            SSDATA (certfile));
1410               keyfile = ENCODE_FILE (keyfile);
1411               certfile = ENCODE_FILE (certfile);
1412 #ifdef WINDOWSNT
1413               keyfile = ansi_encode_filename (keyfile);
1414               certfile = ansi_encode_filename (certfile);
1415 #endif
1416               ret = gnutls_certificate_set_x509_key_file
1417                 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
1418
1419               if (ret < GNUTLS_E_SUCCESS)
1420                 return gnutls_make_error (ret);
1421             }
1422           else
1423             {
1424               emacs_gnutls_deinit (proc);
1425               error (STRINGP (keyfile) ? "Invalid client cert file"
1426                      : "Invalid client key file");
1427             }
1428         }
1429     }
1430
1431   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
1432   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
1433   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
1434
1435   /* Call gnutls_init here: */
1436
1437   GNUTLS_LOG (1, max_log_level, "gnutls_init");
1438   ret = gnutls_init (&state, GNUTLS_CLIENT);
1439   XPROCESS (proc)->gnutls_state = state;
1440   if (ret < GNUTLS_E_SUCCESS)
1441     return gnutls_make_error (ret);
1442   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
1443
1444   if (STRINGP (priority_string))
1445     {
1446       priority_string_ptr = SSDATA (priority_string);
1447       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
1448                    priority_string_ptr);
1449     }
1450   else
1451     {
1452       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
1453                    priority_string_ptr);
1454     }
1455
1456   GNUTLS_LOG (1, max_log_level, "setting the priority string");
1457   ret = gnutls_priority_set_direct (state, priority_string_ptr, NULL);
1458   if (ret < GNUTLS_E_SUCCESS)
1459     return gnutls_make_error (ret);
1460
1461   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
1462
1463   if (INTEGERP (prime_bits))
1464     gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
1465
1466   ret = EQ (type, Qgnutls_x509pki)
1467     ? gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
1468     : gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
1469   if (ret < GNUTLS_E_SUCCESS)
1470     return gnutls_make_error (ret);
1471
1472   if (!gnutls_ip_address_p (c_hostname))
1473     {
1474       ret = gnutls_server_name_set (state, GNUTLS_NAME_DNS, c_hostname,
1475                                     strlen (c_hostname));
1476       if (ret < GNUTLS_E_SUCCESS)
1477         return gnutls_make_error (ret);
1478     }
1479
1480   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
1481   ret = emacs_gnutls_handshake (XPROCESS (proc));
1482   if (ret < GNUTLS_E_SUCCESS)
1483     return gnutls_make_error (ret);
1484
1485   /* Now verify the peer, following
1486      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1487      The peer should present at least one certificate in the chain; do a
1488      check of the certificate's hostname with
1489      gnutls_x509_crt_check_hostname against :hostname.  */
1490
1491   ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
1492   if (ret < GNUTLS_E_SUCCESS)
1493     return gnutls_make_error (ret);
1494
1495   XPROCESS (proc)->gnutls_peer_verification = peer_verification;
1496
1497   warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
1498   if (!NILP (warnings))
1499     {
1500       Lisp_Object tail;
1501       for (tail = warnings; CONSP (tail); tail = XCDR (tail))
1502         {
1503           Lisp_Object warning = XCAR (tail);
1504           Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
1505           if (!NILP (message))
1506             GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
1507         }
1508     }
1509
1510   if (peer_verification != 0)
1511     {
1512       if (verify_error_all
1513           || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
1514         {
1515           emacs_gnutls_deinit (proc);
1516           error ("Certificate validation failed %s, verification code %x",
1517                  c_hostname, peer_verification);
1518         }
1519       else
1520         {
1521           GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1522                        c_hostname);
1523         }
1524     }
1525
1526   /* Up to here the process is the same for X.509 certificates and
1527      OpenPGP keys.  From now on X.509 certificates are assumed.  This
1528      can be easily extended to work with openpgp keys as well.  */
1529   if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1530     {
1531       gnutls_x509_crt_t gnutls_verify_cert;
1532       const gnutls_datum_t *gnutls_verify_cert_list;
1533       unsigned int gnutls_verify_cert_list_size;
1534
1535       ret = gnutls_x509_crt_init (&gnutls_verify_cert);
1536       if (ret < GNUTLS_E_SUCCESS)
1537         return gnutls_make_error (ret);
1538
1539       gnutls_verify_cert_list =
1540         gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1541
1542       if (gnutls_verify_cert_list == NULL)
1543         {
1544           gnutls_x509_crt_deinit (gnutls_verify_cert);
1545           emacs_gnutls_deinit (proc);
1546           error ("No x509 certificate was found\n");
1547         }
1548
1549       /* We only check the first certificate in the given chain.  */
1550       ret = gnutls_x509_crt_import (gnutls_verify_cert,
1551                                        &gnutls_verify_cert_list[0],
1552                                        GNUTLS_X509_FMT_DER);
1553
1554       if (ret < GNUTLS_E_SUCCESS)
1555         {
1556           gnutls_x509_crt_deinit (gnutls_verify_cert);
1557           return gnutls_make_error (ret);
1558         }
1559
1560       XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
1561
1562       int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
1563                                                 c_hostname);
1564       check_memory_full (err);
1565       if (!err)
1566         {
1567           XPROCESS (proc)->gnutls_extra_peer_verification |=
1568             CERTIFICATE_NOT_MATCHING;
1569           if (verify_error_all
1570               || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
1571             {
1572               gnutls_x509_crt_deinit (gnutls_verify_cert);
1573               emacs_gnutls_deinit (proc);
1574               error ("The x509 certificate does not match \"%s\"", c_hostname);
1575             }
1576           else
1577             {
1578               GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1579                            c_hostname);
1580             }
1581         }
1582     }
1583
1584   /* Set this flag only if the whole initialization succeeded.  */
1585   XPROCESS (proc)->gnutls_p = 1;
1586
1587   return gnutls_make_error (ret);
1588 }
1589
1590 DEFUN ("gnutls-bye", Fgnutls_bye,
1591        Sgnutls_bye, 2, 2, 0,
1592        doc: /* Terminate current GnuTLS connection for process PROC.
1593 The connection should have been initiated using `gnutls-handshake'.
1594
1595 If CONT is not nil the TLS connection gets terminated and further
1596 receives and sends will be disallowed.  If the return value is zero you
1597 may continue using the connection.  If CONT is nil, GnuTLS actually
1598 sends an alert containing a close request and waits for the peer to
1599 reply with the same message.  In order to reuse the connection you
1600 should wait for an EOF from the peer.
1601
1602 This function may also return `gnutls-e-again', or
1603 `gnutls-e-interrupted'.  */)
1604     (Lisp_Object proc, Lisp_Object cont)
1605 {
1606   gnutls_session_t state;
1607   int ret;
1608
1609   CHECK_PROCESS (proc);
1610
1611   state = XPROCESS (proc)->gnutls_state;
1612
1613   gnutls_x509_crt_deinit (XPROCESS (proc)->gnutls_certificate);
1614
1615   ret = gnutls_bye (state, NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1616
1617   return gnutls_make_error (ret);
1618 }
1619
1620 #endif  /* HAVE_GNUTLS */
1621
1622 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
1623        doc: /* Return t if GnuTLS is available in this instance of Emacs.  */)
1624      (void)
1625 {
1626 #ifdef HAVE_GNUTLS
1627 # ifdef WINDOWSNT
1628   Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
1629   if (CONSP (found))
1630     return XCDR (found);
1631   else
1632     {
1633       Lisp_Object status;
1634       status = init_gnutls_functions () ? Qt : Qnil;
1635       Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
1636       return status;
1637     }
1638 # else  /* !WINDOWSNT */
1639   return Qt;
1640 # endif  /* !WINDOWSNT */
1641 #else  /* !HAVE_GNUTLS */
1642   return Qnil;
1643 #endif  /* !HAVE_GNUTLS */
1644 }
1645
1646 void
1647 syms_of_gnutls (void)
1648 {
1649   DEFSYM (Qlibgnutls_version, "libgnutls-version");
1650   Fset (Qlibgnutls_version,
1651 #ifdef HAVE_GNUTLS
1652         make_number (GNUTLS_VERSION_MAJOR * 10000
1653                      + GNUTLS_VERSION_MINOR * 100
1654                      + GNUTLS_VERSION_PATCH)
1655 #else
1656         make_number (-1)
1657 #endif
1658         );
1659 #ifdef HAVE_GNUTLS
1660   gnutls_global_initialized = 0;
1661
1662   DEFSYM (Qgnutls_code, "gnutls-code");
1663   DEFSYM (Qgnutls_anon, "gnutls-anon");
1664   DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1665
1666   /* The following are for the property list of 'gnutls-boot'.  */
1667   DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1668   DEFSYM (QCgnutls_bootprop_priority, ":priority");
1669   DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1670   DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1671   DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1672   DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1673   DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1674   DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1675   DEFSYM (QCgnutls_bootprop_verify_error, ":verify-error");
1676
1677   DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1678   Fput (Qgnutls_e_interrupted, Qgnutls_code,
1679         make_number (GNUTLS_E_INTERRUPTED));
1680
1681   DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1682   Fput (Qgnutls_e_again, Qgnutls_code,
1683         make_number (GNUTLS_E_AGAIN));
1684
1685   DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1686   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1687         make_number (GNUTLS_E_INVALID_SESSION));
1688
1689   DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1690   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1691         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1692
1693   defsubr (&Sgnutls_get_initstage);
1694   defsubr (&Sgnutls_errorp);
1695   defsubr (&Sgnutls_error_fatalp);
1696   defsubr (&Sgnutls_error_string);
1697   defsubr (&Sgnutls_boot);
1698   defsubr (&Sgnutls_deinit);
1699   defsubr (&Sgnutls_bye);
1700   defsubr (&Sgnutls_peer_status);
1701   defsubr (&Sgnutls_peer_status_warning_describe);
1702
1703   DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1704               doc: /* Logging level used by the GnuTLS functions.
1705 Set this larger than 0 to get debug output in the *Messages* buffer.
1706 1 is for important messages, 2 is for debug data, and higher numbers
1707 are as per the GnuTLS logging conventions.  */);
1708   global_gnutls_log_level = 0;
1709
1710 #endif  /* HAVE_GNUTLS */
1711
1712   defsubr (&Sgnutls_available_p);
1713 }