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