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