src/gnutls.c

   1 /* GnuTLS glue for GNU Emacs.
   2    Copyright (C) 2010-2016 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 (at
   9 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 Lisp_Object
1116 emacs_gnutls_global_init (void)
1117 {
1118   int ret = GNUTLS_E_SUCCESS;
1119
1120   if (!gnutls_global_initialized)
1121     {
1122       ret = gnutls_global_init ();
1123       if (ret == GNUTLS_E_SUCCESS)
1124         gnutls_global_initialized = 1;
1125     }
1126
1127   return gnutls_make_error (ret);
1128 }
1129
1130 static bool
1131 gnutls_ip_address_p (char *string)
1132 {
1133   char c;
1134
1135   while ((c = *string++) != 0)
1136     if (! ((c == '.' || c == ':' || (c >= '0' && c <= '9'))))
1137       return false;
1138
1139   return true;
1140 }
1141
1142 #if 0
1143 /* Deinitialize global GnuTLS state.
1144    See also `gnutls-global-init'.  */
1145 static Lisp_Object
1146 emacs_gnutls_global_deinit (void)
1147 {
1148   if (gnutls_global_initialized)
1149     gnutls_global_deinit ();
1150
1151   gnutls_global_initialized = 0;
1152
1153   return gnutls_make_error (GNUTLS_E_SUCCESS);
1154 }
1155 #endif
1156
1157 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
1158        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1159 Currently only client mode is supported.  Return a success/failure
1160 value you can check with `gnutls-errorp'.
1161
1162 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
1163 PROPLIST is a property list with the following keys:
1164
1165 :hostname is a string naming the remote host.
1166
1167 :priority is a GnuTLS priority string, defaults to "NORMAL".
1168
1169 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
1170
1171 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
1172
1173 :keylist is an alist of PEM-encoded key files and PEM-encoded
1174 certificates for `gnutls-x509pki'.
1175
1176 :callbacks is an alist of callback functions, see below.
1177
1178 :loglevel is the debug level requested from GnuTLS, try 4.
1179
1180 :verify-flags is a bitset as per GnuTLS'
1181 gnutls_certificate_set_verify_flags.
1182
1183 :verify-hostname-error is ignored.  Pass :hostname in :verify-error
1184 instead.
1185
1186 :verify-error is a list of symbols to express verification checks or
1187 t to do all checks.  Currently it can contain `:trustfiles' and
1188 `:hostname' to verify the certificate or the hostname respectively.
1189
1190 :min-prime-bits is the minimum accepted number of bits the client will
1191 accept in Diffie-Hellman key exchange.
1192
1193 The debug level will be set for this process AND globally for GnuTLS.
1194 So if you set it higher or lower at any point, it affects global
1195 debugging.
1196
1197 Note that the priority is set on the client.  The server does not use
1198 the protocols's priority except for disabling protocols that were not
1199 specified.
1200
1201 Processes must be initialized with this function before other GnuTLS
1202 functions are used.  This function allocates resources which can only
1203 be deallocated by calling `gnutls-deinit' or by calling it again.
1204
1205 The callbacks alist can have a `verify' key, associated with a
1206 verification function (UNUSED).
1207
1208 Each authentication type may need additional information in order to
1209 work.  For X.509 PKI (`gnutls-x509pki'), you probably need at least
1210 one trustfile (usually a CA bundle).  */)
1211   (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
1212 {
1213   int ret = GNUTLS_E_SUCCESS;
1214   int max_log_level = 0;
1215   bool verify_error_all = 0;
1216
1217   gnutls_session_t state;
1218   gnutls_certificate_credentials_t x509_cred = NULL;
1219   gnutls_anon_client_credentials_t anon_cred = NULL;
1220   Lisp_Object global_init;
1221   char const *priority_string_ptr = "NORMAL"; /* default priority string.  */
1222   unsigned int peer_verification;
1223   char *c_hostname;
1224
1225   /* Placeholders for the property list elements.  */
1226   Lisp_Object priority_string;
1227   Lisp_Object trustfiles;
1228   Lisp_Object crlfiles;
1229   Lisp_Object keylist;
1230   /* Lisp_Object callbacks; */
1231   Lisp_Object loglevel;
1232   Lisp_Object hostname;
1233   Lisp_Object verify_error;
1234   Lisp_Object prime_bits;
1235   Lisp_Object warnings;
1236
1237   CHECK_PROCESS (proc);
1238   CHECK_SYMBOL (type);
1239   CHECK_LIST (proplist);
1240
1241   if (NILP (Fgnutls_available_p ()))
1242     error ("GnuTLS not available");
1243
1244   if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
1245     error ("Invalid GnuTLS credential type");
1246
1247   hostname              = Fplist_get (proplist, QCgnutls_bootprop_hostname);
1248   priority_string       = Fplist_get (proplist, QCgnutls_bootprop_priority);
1249   trustfiles            = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
1250   keylist               = Fplist_get (proplist, QCgnutls_bootprop_keylist);
1251   crlfiles              = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
1252   loglevel              = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
1253   verify_error          = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
1254   prime_bits            = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
1255
1256   if (EQ (verify_error, Qt))
1257     {
1258       verify_error_all = 1;
1259     }
1260   else if (NILP (Flistp (verify_error)))
1261     {
1262       error ("gnutls-boot: invalid :verify_error parameter (not a list)");
1263     }
1264
1265   if (!STRINGP (hostname))
1266     error ("gnutls-boot: invalid :hostname parameter (not a string)");
1267   c_hostname = SSDATA (hostname);
1268
1269   state = XPROCESS (proc)->gnutls_state;
1270
1271   if (TYPE_RANGED_INTEGERP (int, loglevel))
1272     {
1273       gnutls_global_set_log_function (gnutls_log_function);
1274 #ifdef HAVE_GNUTLS3
1275       gnutls_global_set_audit_log_function (gnutls_audit_log_function);
1276 #endif
1277       gnutls_global_set_log_level (XINT (loglevel));
1278       max_log_level = XINT (loglevel);
1279       XPROCESS (proc)->gnutls_log_level = max_log_level;
1280     }
1281
1282   GNUTLS_LOG2 (1, max_log_level, "connecting to host:", c_hostname);
1283
1284   /* Always initialize globals.  */
1285   global_init = emacs_gnutls_global_init ();
1286   if (! NILP (Fgnutls_errorp (global_init)))
1287     return global_init;
1288
1289   /* Before allocating new credentials, deallocate any credentials
1290      that PROC might already have.  */
1291   emacs_gnutls_deinit (proc);
1292
1293   /* Mark PROC as a GnuTLS process.  */
1294   XPROCESS (proc)->gnutls_state = NULL;
1295   XPROCESS (proc)->gnutls_x509_cred = NULL;
1296   XPROCESS (proc)->gnutls_anon_cred = NULL;
1297   pset_gnutls_cred_type (XPROCESS (proc), type);
1298   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
1299
1300   GNUTLS_LOG (1, max_log_level, "allocating credentials");
1301   if (EQ (type, Qgnutls_x509pki))
1302     {
1303       Lisp_Object verify_flags;
1304       unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
1305
1306       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
1307       check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred));
1308       XPROCESS (proc)->gnutls_x509_cred = x509_cred;
1309
1310       verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
1311       if (NUMBERP (verify_flags))
1312         {
1313           gnutls_verify_flags = XINT (verify_flags);
1314           GNUTLS_LOG (2, max_log_level, "setting verification flags");
1315         }
1316       else if (NILP (verify_flags))
1317         GNUTLS_LOG (2, max_log_level, "using default verification flags");
1318       else
1319         GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
1320
1321       gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
1322     }
1323   else /* Qgnutls_anon: */
1324     {
1325       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
1326       check_memory_full (gnutls_anon_allocate_client_credentials (&anon_cred));
1327       XPROCESS (proc)->gnutls_anon_cred = anon_cred;
1328     }
1329
1330   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
1331
1332   if (EQ (type, Qgnutls_x509pki))
1333     {
1334       /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
1335       int file_format = GNUTLS_X509_FMT_PEM;
1336       Lisp_Object tail;
1337
1338 #if GNUTLS_VERSION_MAJOR +                                      \
1339   (GNUTLS_VERSION_MINOR > 0 || GNUTLS_VERSION_PATCH >= 20) > 3
1340       ret = gnutls_certificate_set_x509_system_trust (x509_cred);
1341       if (ret < GNUTLS_E_SUCCESS)
1342         {
1343           check_memory_full (ret);
1344           GNUTLS_LOG2i (4, max_log_level,
1345                         "setting system trust failed with code ", ret);
1346         }
1347 #endif
1348
1349       for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
1350         {
1351           Lisp_Object trustfile = XCAR (tail);
1352           if (STRINGP (trustfile))
1353             {
1354               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
1355                            SSDATA (trustfile));
1356               trustfile = ENCODE_FILE (trustfile);
1357 #ifdef WINDOWSNT
1358               /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
1359                  file names on Windows, we need to re-encode the file
1360                  name using the current ANSI codepage.  */
1361               trustfile = ansi_encode_filename (trustfile);
1362 #endif
1363               ret = gnutls_certificate_set_x509_trust_file
1364                 (x509_cred,
1365                  SSDATA (trustfile),
1366                  file_format);
1367
1368               if (ret < GNUTLS_E_SUCCESS)
1369                 return gnutls_make_error (ret);
1370             }
1371           else
1372             {
1373               emacs_gnutls_deinit (proc);
1374               error ("Invalid trustfile");
1375             }
1376         }
1377
1378       for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
1379         {
1380           Lisp_Object crlfile = XCAR (tail);
1381           if (STRINGP (crlfile))
1382             {
1383               GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
1384                            SSDATA (crlfile));
1385               crlfile = ENCODE_FILE (crlfile);
1386 #ifdef WINDOWSNT
1387               crlfile = ansi_encode_filename (crlfile);
1388 #endif
1389               ret = gnutls_certificate_set_x509_crl_file
1390                 (x509_cred, SSDATA (crlfile), file_format);
1391
1392               if (ret < GNUTLS_E_SUCCESS)
1393                 return gnutls_make_error (ret);
1394             }
1395           else
1396             {
1397               emacs_gnutls_deinit (proc);
1398               error ("Invalid CRL file");
1399             }
1400         }
1401
1402       for (tail = keylist; CONSP (tail); tail = XCDR (tail))
1403         {
1404           Lisp_Object keyfile = Fcar (XCAR (tail));
1405           Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
1406           if (STRINGP (keyfile) && STRINGP (certfile))
1407             {
1408               GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
1409                            SSDATA (keyfile));
1410               GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
1411                            SSDATA (certfile));
1412               keyfile = ENCODE_FILE (keyfile);
1413               certfile = ENCODE_FILE (certfile);
1414 #ifdef WINDOWSNT
1415               keyfile = ansi_encode_filename (keyfile);
1416               certfile = ansi_encode_filename (certfile);
1417 #endif
1418               ret = gnutls_certificate_set_x509_key_file
1419                 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
1420
1421               if (ret < GNUTLS_E_SUCCESS)
1422                 return gnutls_make_error (ret);
1423             }
1424           else
1425             {
1426               emacs_gnutls_deinit (proc);
1427               error (STRINGP (keyfile) ? "Invalid client cert file"
1428                      : "Invalid client key file");
1429             }
1430         }
1431     }
1432
1433   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
1434   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
1435   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
1436
1437   /* Call gnutls_init here: */
1438
1439   GNUTLS_LOG (1, max_log_level, "gnutls_init");
1440   ret = gnutls_init (&state, GNUTLS_CLIENT);
1441   XPROCESS (proc)->gnutls_state = state;
1442   if (ret < GNUTLS_E_SUCCESS)
1443     return gnutls_make_error (ret);
1444   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
1445
1446   if (STRINGP (priority_string))
1447     {
1448       priority_string_ptr = SSDATA (priority_string);
1449       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
1450                    priority_string_ptr);
1451     }
1452   else
1453     {
1454       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
1455                    priority_string_ptr);
1456     }
1457
1458   GNUTLS_LOG (1, max_log_level, "setting the priority string");
1459   ret = gnutls_priority_set_direct (state, priority_string_ptr, NULL);
1460   if (ret < GNUTLS_E_SUCCESS)
1461     return gnutls_make_error (ret);
1462
1463   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
1464
1465   if (INTEGERP (prime_bits))
1466     gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
1467
1468   ret = EQ (type, Qgnutls_x509pki)
1469     ? gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
1470     : gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
1471   if (ret < GNUTLS_E_SUCCESS)
1472     return gnutls_make_error (ret);
1473
1474   if (!gnutls_ip_address_p (c_hostname))
1475     {
1476       ret = gnutls_server_name_set (state, GNUTLS_NAME_DNS, c_hostname,
1477                                     strlen (c_hostname));
1478       if (ret < GNUTLS_E_SUCCESS)
1479         return gnutls_make_error (ret);
1480     }
1481
1482   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
1483   ret = emacs_gnutls_handshake (XPROCESS (proc));
1484   if (ret < GNUTLS_E_SUCCESS)
1485     return gnutls_make_error (ret);
1486
1487   /* Now verify the peer, following
1488      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1489      The peer should present at least one certificate in the chain; do a
1490      check of the certificate's hostname with
1491      gnutls_x509_crt_check_hostname against :hostname.  */
1492
1493   ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
1494   if (ret < GNUTLS_E_SUCCESS)
1495     return gnutls_make_error (ret);
1496
1497   XPROCESS (proc)->gnutls_peer_verification = peer_verification;
1498
1499   warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
1500   if (!NILP (warnings))
1501     {
1502       Lisp_Object tail;
1503       for (tail = warnings; CONSP (tail); tail = XCDR (tail))
1504         {
1505           Lisp_Object warning = XCAR (tail);
1506           Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
1507           if (!NILP (message))
1508             GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
1509         }
1510     }
1511
1512   if (peer_verification != 0)
1513     {
1514       if (verify_error_all
1515           || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
1516         {
1517           emacs_gnutls_deinit (proc);
1518           error ("Certificate validation failed %s, verification code %x",
1519                  c_hostname, peer_verification);
1520         }
1521       else
1522         {
1523           GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1524                        c_hostname);
1525         }
1526     }
1527
1528   /* Up to here the process is the same for X.509 certificates and
1529      OpenPGP keys.  From now on X.509 certificates are assumed.  This
1530      can be easily extended to work with openpgp keys as well.  */
1531   if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1532     {
1533       gnutls_x509_crt_t gnutls_verify_cert;
1534       const gnutls_datum_t *gnutls_verify_cert_list;
1535       unsigned int gnutls_verify_cert_list_size;
1536
1537       ret = gnutls_x509_crt_init (&gnutls_verify_cert);
1538       if (ret < GNUTLS_E_SUCCESS)
1539         return gnutls_make_error (ret);
1540
1541       gnutls_verify_cert_list =
1542         gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1543
1544       if (gnutls_verify_cert_list == NULL)
1545         {
1546           gnutls_x509_crt_deinit (gnutls_verify_cert);
1547           emacs_gnutls_deinit (proc);
1548           error ("No x509 certificate was found\n");
1549         }
1550
1551       /* We only check the first certificate in the given chain.  */
1552       ret = gnutls_x509_crt_import (gnutls_verify_cert,
1553                                        &gnutls_verify_cert_list[0],
1554                                        GNUTLS_X509_FMT_DER);
1555
1556       if (ret < GNUTLS_E_SUCCESS)
1557         {
1558           gnutls_x509_crt_deinit (gnutls_verify_cert);
1559           return gnutls_make_error (ret);
1560         }
1561
1562       XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
1563
1564       int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
1565                                                 c_hostname);
1566       check_memory_full (err);
1567       if (!err)
1568         {
1569           XPROCESS (proc)->gnutls_extra_peer_verification |=
1570             CERTIFICATE_NOT_MATCHING;
1571           if (verify_error_all
1572               || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
1573             {
1574               gnutls_x509_crt_deinit (gnutls_verify_cert);
1575               emacs_gnutls_deinit (proc);
1576               error ("The x509 certificate does not match \"%s\"", c_hostname);
1577             }
1578           else
1579             {
1580               GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1581                            c_hostname);
1582             }
1583         }
1584     }
1585
1586   /* Set this flag only if the whole initialization succeeded.  */
1587   XPROCESS (proc)->gnutls_p = 1;
1588
1589   return gnutls_make_error (ret);
1590 }
1591
1592 DEFUN ("gnutls-bye", Fgnutls_bye,
1593        Sgnutls_bye, 2, 2, 0,
1594        doc: /* Terminate current GnuTLS connection for process PROC.
1595 The connection should have been initiated using `gnutls-handshake'.
1596
1597 If CONT is not nil the TLS connection gets terminated and further
1598 receives and sends will be disallowed.  If the return value is zero you
1599 may continue using the connection.  If CONT is nil, GnuTLS actually
1600 sends an alert containing a close request and waits for the peer to
1601 reply with the same message.  In order to reuse the connection you
1602 should wait for an EOF from the peer.
1603
1604 This function may also return `gnutls-e-again', or
1605 `gnutls-e-interrupted'.  */)
1606     (Lisp_Object proc, Lisp_Object cont)
1607 {
1608   gnutls_session_t state;
1609   int ret;
1610
1611   CHECK_PROCESS (proc);
1612
1613   state = XPROCESS (proc)->gnutls_state;
1614
1615   gnutls_x509_crt_deinit (XPROCESS (proc)->gnutls_certificate);
1616
1617   ret = gnutls_bye (state, NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1618
1619   return gnutls_make_error (ret);
1620 }
1621
1622 #endif  /* HAVE_GNUTLS */
1623
1624 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
1625        doc: /* Return t if GnuTLS is available in this instance of Emacs.  */)
1626      (void)
1627 {
1628 #ifdef HAVE_GNUTLS
1629 # ifdef WINDOWSNT
1630   Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
1631   if (CONSP (found))
1632     return XCDR (found);
1633   else
1634     {
1635       Lisp_Object status;
1636       status = init_gnutls_functions () ? Qt : Qnil;
1637       Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
1638       return status;
1639     }
1640 # else  /* !WINDOWSNT */
1641   return Qt;
1642 # endif  /* !WINDOWSNT */
1643 #else  /* !HAVE_GNUTLS */
1644   return Qnil;
1645 #endif  /* !HAVE_GNUTLS */
1646 }
1647
1648 void
1649 syms_of_gnutls (void)
1650 {
1651   DEFSYM (Qlibgnutls_version, "libgnutls-version");
1652   Fset (Qlibgnutls_version,
1653 #ifdef HAVE_GNUTLS
1654         make_number (GNUTLS_VERSION_MAJOR * 10000
1655                      + GNUTLS_VERSION_MINOR * 100
1656                      + GNUTLS_VERSION_PATCH)
1657 #else
1658         make_number (-1)
1659 #endif
1660         );
1661 #ifdef HAVE_GNUTLS
1662   gnutls_global_initialized = 0;
1663
1664   DEFSYM (Qgnutls_code, "gnutls-code");
1665   DEFSYM (Qgnutls_anon, "gnutls-anon");
1666   DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1667
1668   /* The following are for the property list of 'gnutls-boot'.  */
1669   DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1670   DEFSYM (QCgnutls_bootprop_priority, ":priority");
1671   DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1672   DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1673   DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1674   DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1675   DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1676   DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1677   DEFSYM (QCgnutls_bootprop_verify_error, ":verify-error");
1678
1679   DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1680   Fput (Qgnutls_e_interrupted, Qgnutls_code,
1681         make_number (GNUTLS_E_INTERRUPTED));
1682
1683   DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1684   Fput (Qgnutls_e_again, Qgnutls_code,
1685         make_number (GNUTLS_E_AGAIN));
1686
1687   DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1688   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1689         make_number (GNUTLS_E_INVALID_SESSION));
1690
1691   DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1692   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1693         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1694
1695   defsubr (&Sgnutls_get_initstage);
1696   defsubr (&Sgnutls_errorp);
1697   defsubr (&Sgnutls_error_fatalp);
1698   defsubr (&Sgnutls_error_string);
1699   defsubr (&Sgnutls_boot);
1700   defsubr (&Sgnutls_deinit);
1701   defsubr (&Sgnutls_bye);
1702   defsubr (&Sgnutls_peer_status);
1703   defsubr (&Sgnutls_peer_status_warning_describe);
1704
1705   DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1706               doc: /* Logging level used by the GnuTLS functions.
1707 Set this larger than 0 to get debug output in the *Messages* buffer.
1708 1 is for important messages, 2 is for debug data, and higher numbers
1709 are as per the GnuTLS logging conventions.  */);
1710   global_gnutls_log_level = 0;
1711
1712 #endif  /* HAVE_GNUTLS */
1713
1714   defsubr (&Sgnutls_available_p);
1715 }