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