src/gnutls.c

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