src/gnutls.c

   1 /* GnuTLS glue for GNU Emacs.
   2    Copyright (C) 2010-2013 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
  22 #include "lisp.h"
  23 #include "process.h"
  24
  25 #ifdef HAVE_GNUTLS
  26 #include <gnutls/gnutls.h>
  27
  28 #ifdef WINDOWSNT
  29 #include <windows.h>
  30 #include "w32.h"
  31 #endif
  32
  33 static bool emacs_gnutls_handle_error (gnutls_session_t, int);
  34
  35 static Lisp_Object Qgnutls_dll;
  36 static Lisp_Object Qgnutls_code;
  37 static Lisp_Object Qgnutls_anon, Qgnutls_x509pki;
  38 static Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again,
  39   Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake;
  40 static bool gnutls_global_initialized;
  41
  42 /* The following are for the property list of `gnutls-boot'.  */
  43 static Lisp_Object QCgnutls_bootprop_priority;
  44 static Lisp_Object QCgnutls_bootprop_trustfiles;
  45 static Lisp_Object QCgnutls_bootprop_keylist;
  46 static Lisp_Object QCgnutls_bootprop_crlfiles;
  47 static Lisp_Object QCgnutls_bootprop_callbacks;
  48 static Lisp_Object QCgnutls_bootprop_loglevel;
  49 static Lisp_Object QCgnutls_bootprop_hostname;
  50 static Lisp_Object QCgnutls_bootprop_min_prime_bits;
  51 static Lisp_Object QCgnutls_bootprop_verify_flags;
  52 static Lisp_Object QCgnutls_bootprop_verify_hostname_error;
  53
  54 /* Callback keys for `gnutls-boot'.  Unused currently.  */
  55 static Lisp_Object QCgnutls_bootprop_callbacks_verify;
  56
  57 static void gnutls_log_function (int, const char *);
  58 static void gnutls_log_function2 (int, const char*, const char*);
  59
  60 \f
  61 #ifdef WINDOWSNT
  62
  63 /* Macro for defining functions that will be loaded from the GnuTLS DLL.  */
  64 #define DEF_GNUTLS_FN(rettype,func,args) static rettype (FAR CDECL *fn_##func)args
  65
  66 /* Macro for loading GnuTLS functions from the library.  */
  67 #define LOAD_GNUTLS_FN(lib,func) {                                      \
  68     fn_##func = (void *) GetProcAddress (lib, #func);                   \
  69     if (!fn_##func) return 0;                                           \
  70   }
  71
  72 DEF_GNUTLS_FN (gnutls_alert_description_t, gnutls_alert_get,
  73                (gnutls_session_t));
  74 DEF_GNUTLS_FN (const char *, gnutls_alert_get_name,
  75                (gnutls_alert_description_t));
  76 DEF_GNUTLS_FN (int, gnutls_alert_send_appropriate, (gnutls_session_t, int));
  77 DEF_GNUTLS_FN (int, gnutls_anon_allocate_client_credentials,
  78                (gnutls_anon_client_credentials_t *));
  79 DEF_GNUTLS_FN (void, gnutls_anon_free_client_credentials,
  80                (gnutls_anon_client_credentials_t));
  81 DEF_GNUTLS_FN (int, gnutls_bye, (gnutls_session_t, gnutls_close_request_t));
  82 DEF_GNUTLS_FN (int, gnutls_certificate_allocate_credentials,
  83                (gnutls_certificate_credentials_t *));
  84 DEF_GNUTLS_FN (void, gnutls_certificate_free_credentials,
  85                (gnutls_certificate_credentials_t));
  86 DEF_GNUTLS_FN (const gnutls_datum_t *, gnutls_certificate_get_peers,
  87                (gnutls_session_t, unsigned int *));
  88 DEF_GNUTLS_FN (void, gnutls_certificate_set_verify_flags,
  89                (gnutls_certificate_credentials_t, unsigned int));
  90 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_crl_file,
  91                (gnutls_certificate_credentials_t, const char *,
  92                 gnutls_x509_crt_fmt_t));
  93 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_key_file,
  94                (gnutls_certificate_credentials_t, const char *, const char *,
  95                 gnutls_x509_crt_fmt_t));
  96 DEF_GNUTLS_FN (int, gnutls_certificate_set_x509_trust_file,
  97                (gnutls_certificate_credentials_t, const char *,
  98                 gnutls_x509_crt_fmt_t));
  99 DEF_GNUTLS_FN (gnutls_certificate_type_t, gnutls_certificate_type_get,
 100                (gnutls_session_t));
 101 DEF_GNUTLS_FN (int, gnutls_certificate_verify_peers2,
 102                (gnutls_session_t, unsigned int *));
 103 DEF_GNUTLS_FN (int, gnutls_credentials_set,
 104                (gnutls_session_t, gnutls_credentials_type_t, void *));
 105 DEF_GNUTLS_FN (void, gnutls_deinit, (gnutls_session_t));
 106 DEF_GNUTLS_FN (void, gnutls_dh_set_prime_bits,
 107                (gnutls_session_t, unsigned int));
 108 DEF_GNUTLS_FN (int, gnutls_error_is_fatal, (int));
 109 DEF_GNUTLS_FN (int, gnutls_global_init, (void));
 110 DEF_GNUTLS_FN (void, gnutls_global_set_log_function, (gnutls_log_func));
 111 DEF_GNUTLS_FN (void, gnutls_global_set_log_level, (int));
 112 DEF_GNUTLS_FN (void, gnutls_global_set_mem_functions,
 113                (gnutls_alloc_function, gnutls_alloc_function,
 114                 gnutls_is_secure_function, gnutls_realloc_function,
 115                 gnutls_free_function));
 116 DEF_GNUTLS_FN (int, gnutls_handshake, (gnutls_session_t));
 117 DEF_GNUTLS_FN (int, gnutls_init, (gnutls_session_t *, gnutls_connection_end_t));
 118 DEF_GNUTLS_FN (int, gnutls_priority_set_direct,
 119                (gnutls_session_t, const char *, const char **));
 120 DEF_GNUTLS_FN (size_t, gnutls_record_check_pending, (gnutls_session_t));
 121 DEF_GNUTLS_FN (ssize_t, gnutls_record_recv, (gnutls_session_t, void *, size_t));
 122 DEF_GNUTLS_FN (ssize_t, gnutls_record_send,
 123                (gnutls_session_t, const void *, size_t));
 124 DEF_GNUTLS_FN (const char *, gnutls_strerror, (int));
 125 DEF_GNUTLS_FN (void, gnutls_transport_set_errno, (gnutls_session_t, int));
 126 DEF_GNUTLS_FN (const char *, gnutls_check_version, (const char *));
 127 DEF_GNUTLS_FN (void, gnutls_transport_set_lowat, (gnutls_session_t, int));
 128 DEF_GNUTLS_FN (void, gnutls_transport_set_ptr2,
 129                (gnutls_session_t, gnutls_transport_ptr_t,
 130                 gnutls_transport_ptr_t));
 131 DEF_GNUTLS_FN (void, gnutls_transport_set_pull_function,
 132                (gnutls_session_t, gnutls_pull_func));
 133 DEF_GNUTLS_FN (void, gnutls_transport_set_push_function,
 134                (gnutls_session_t, gnutls_push_func));
 135 DEF_GNUTLS_FN (int, gnutls_x509_crt_check_hostname,
 136                (gnutls_x509_crt_t, const char *));
 137 DEF_GNUTLS_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t));
 138 DEF_GNUTLS_FN (int, gnutls_x509_crt_import,
 139                (gnutls_x509_crt_t, const gnutls_datum_t *,
 140                 gnutls_x509_crt_fmt_t));
 141 DEF_GNUTLS_FN (int, gnutls_x509_crt_init, (gnutls_x509_crt_t *));
 142
 143 static bool
 144 init_gnutls_functions (void)
 145 {
 146   HMODULE library;
 147   int max_log_level = 1;
 148
 149   if (!(library = w32_delayed_load (Qgnutls_dll)))
 150     {
 151       GNUTLS_LOG (1, max_log_level, "GnuTLS library not found");
 152       return 0;
 153     }
 154
 155   LOAD_GNUTLS_FN (library, gnutls_alert_get);
 156   LOAD_GNUTLS_FN (library, gnutls_alert_get_name);
 157   LOAD_GNUTLS_FN (library, gnutls_alert_send_appropriate);
 158   LOAD_GNUTLS_FN (library, gnutls_anon_allocate_client_credentials);
 159   LOAD_GNUTLS_FN (library, gnutls_anon_free_client_credentials);
 160   LOAD_GNUTLS_FN (library, gnutls_bye);
 161   LOAD_GNUTLS_FN (library, gnutls_certificate_allocate_credentials);
 162   LOAD_GNUTLS_FN (library, gnutls_certificate_free_credentials);
 163   LOAD_GNUTLS_FN (library, gnutls_certificate_get_peers);
 164   LOAD_GNUTLS_FN (library, gnutls_certificate_set_verify_flags);
 165   LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_crl_file);
 166   LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_key_file);
 167   LOAD_GNUTLS_FN (library, gnutls_certificate_set_x509_trust_file);
 168   LOAD_GNUTLS_FN (library, gnutls_certificate_type_get);
 169   LOAD_GNUTLS_FN (library, gnutls_certificate_verify_peers2);
 170   LOAD_GNUTLS_FN (library, gnutls_credentials_set);
 171   LOAD_GNUTLS_FN (library, gnutls_deinit);
 172   LOAD_GNUTLS_FN (library, gnutls_dh_set_prime_bits);
 173   LOAD_GNUTLS_FN (library, gnutls_error_is_fatal);
 174   LOAD_GNUTLS_FN (library, gnutls_global_init);
 175   LOAD_GNUTLS_FN (library, gnutls_global_set_log_function);
 176   LOAD_GNUTLS_FN (library, gnutls_global_set_log_level);
 177   LOAD_GNUTLS_FN (library, gnutls_global_set_mem_functions);
 178   LOAD_GNUTLS_FN (library, gnutls_handshake);
 179   LOAD_GNUTLS_FN (library, gnutls_init);
 180   LOAD_GNUTLS_FN (library, gnutls_priority_set_direct);
 181   LOAD_GNUTLS_FN (library, gnutls_record_check_pending);
 182   LOAD_GNUTLS_FN (library, gnutls_record_recv);
 183   LOAD_GNUTLS_FN (library, gnutls_record_send);
 184   LOAD_GNUTLS_FN (library, gnutls_strerror);
 185   LOAD_GNUTLS_FN (library, gnutls_transport_set_errno);
 186   LOAD_GNUTLS_FN (library, gnutls_check_version);
 187   /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1
 188      and later, and the function was removed entirely in 3.0.0.  */
 189   if (!fn_gnutls_check_version ("2.11.1"))
 190     LOAD_GNUTLS_FN (library, gnutls_transport_set_lowat);
 191   LOAD_GNUTLS_FN (library, gnutls_transport_set_ptr2);
 192   LOAD_GNUTLS_FN (library, gnutls_transport_set_pull_function);
 193   LOAD_GNUTLS_FN (library, gnutls_transport_set_push_function);
 194   LOAD_GNUTLS_FN (library, gnutls_x509_crt_check_hostname);
 195   LOAD_GNUTLS_FN (library, gnutls_x509_crt_deinit);
 196   LOAD_GNUTLS_FN (library, gnutls_x509_crt_import);
 197   LOAD_GNUTLS_FN (library, gnutls_x509_crt_init);
 198
 199   max_log_level = global_gnutls_log_level;
 200
 201   {
 202     Lisp_Object name = CAR_SAFE (Fget (Qgnutls_dll, QCloaded_from));
 203     GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:",
 204                  STRINGP (name) ? (const char *) SDATA (name) : "unknown");
 205   }
 206
 207   return 1;
 208 }
 209
 210 #else /* !WINDOWSNT */
 211
 212 #define fn_gnutls_alert_get                     gnutls_alert_get
 213 #define fn_gnutls_alert_get_name                gnutls_alert_get_name
 214 #define fn_gnutls_alert_send_appropriate        gnutls_alert_send_appropriate
 215 #define fn_gnutls_anon_allocate_client_credentials gnutls_anon_allocate_client_credentials
 216 #define fn_gnutls_anon_free_client_credentials  gnutls_anon_free_client_credentials
 217 #define fn_gnutls_bye                           gnutls_bye
 218 #define fn_gnutls_certificate_allocate_credentials gnutls_certificate_allocate_credentials
 219 #define fn_gnutls_certificate_free_credentials  gnutls_certificate_free_credentials
 220 #define fn_gnutls_certificate_get_peers         gnutls_certificate_get_peers
 221 #define fn_gnutls_certificate_set_verify_flags  gnutls_certificate_set_verify_flags
 222 #define fn_gnutls_certificate_set_x509_crl_file gnutls_certificate_set_x509_crl_file
 223 #define fn_gnutls_certificate_set_x509_key_file gnutls_certificate_set_x509_key_file
 224 #define fn_gnutls_certificate_set_x509_trust_file gnutls_certificate_set_x509_trust_file
 225 #define fn_gnutls_certificate_type_get          gnutls_certificate_type_get
 226 #define fn_gnutls_certificate_verify_peers2     gnutls_certificate_verify_peers2
 227 #define fn_gnutls_credentials_set               gnutls_credentials_set
 228 #define fn_gnutls_deinit                        gnutls_deinit
 229 #define fn_gnutls_dh_set_prime_bits             gnutls_dh_set_prime_bits
 230 #define fn_gnutls_error_is_fatal                gnutls_error_is_fatal
 231 #define fn_gnutls_global_init                   gnutls_global_init
 232 #define fn_gnutls_global_set_log_function       gnutls_global_set_log_function
 233 #define fn_gnutls_global_set_log_level          gnutls_global_set_log_level
 234 #define fn_gnutls_global_set_mem_functions      gnutls_global_set_mem_functions
 235 #define fn_gnutls_handshake                     gnutls_handshake
 236 #define fn_gnutls_init                          gnutls_init
 237 #define fn_gnutls_priority_set_direct           gnutls_priority_set_direct
 238 #define fn_gnutls_record_check_pending          gnutls_record_check_pending
 239 #define fn_gnutls_record_recv                   gnutls_record_recv
 240 #define fn_gnutls_record_send                   gnutls_record_send
 241 #define fn_gnutls_strerror                      gnutls_strerror
 242 #define fn_gnutls_transport_set_errno           gnutls_transport_set_errno
 243 #define fn_gnutls_transport_set_ptr2            gnutls_transport_set_ptr2
 244 #define fn_gnutls_x509_crt_check_hostname       gnutls_x509_crt_check_hostname
 245 #define fn_gnutls_x509_crt_deinit               gnutls_x509_crt_deinit
 246 #define fn_gnutls_x509_crt_import               gnutls_x509_crt_import
 247 #define fn_gnutls_x509_crt_init                 gnutls_x509_crt_init
 248
 249 #endif /* !WINDOWSNT */
 250
 251 \f
 252 /* Function to log a simple message.  */
 253 static void
 254 gnutls_log_function (int level, const char* string)
 255 {
 256   message ("gnutls.c: [%d] %s", level, string);
 257 }
 258
 259 /* Function to log a message and a string.  */
 260 static void
 261 gnutls_log_function2 (int level, const char* string, const char* extra)
 262 {
 263   message ("gnutls.c: [%d] %s %s", level, string, extra);
 264 }
 265
 266 /* Function to log a message and an integer.  */
 267 static void
 268 gnutls_log_function2i (int level, const char* string, int extra)
 269 {
 270   message ("gnutls.c: [%d] %s %d", level, string, extra);
 271 }
 272
 273 static int
 274 emacs_gnutls_handshake (struct Lisp_Process *proc)
 275 {
 276   gnutls_session_t state = proc->gnutls_state;
 277   int ret;
 278
 279   if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
 280     return -1;
 281
 282   if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
 283     {
 284 #ifdef WINDOWSNT
 285       /* On W32 we cannot transfer socket handles between different runtime
 286          libraries, so we tell GnuTLS to use our special push/pull
 287          functions.  */
 288       fn_gnutls_transport_set_ptr2 (state,
 289                                     (gnutls_transport_ptr_t) proc,
 290                                     (gnutls_transport_ptr_t) proc);
 291       fn_gnutls_transport_set_push_function (state, &emacs_gnutls_push);
 292       fn_gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
 293
 294       /* For non blocking sockets or other custom made pull/push
 295          functions the gnutls_transport_set_lowat must be called, with
 296          a zero low water mark value. (GnuTLS 2.10.4 documentation)
 297
 298          (Note: this is probably not strictly necessary as the lowat
 299           value is only used when no custom pull/push functions are
 300           set.)  */
 301       /* According to GnuTLS NEWS file, lowat level has been set to
 302          zero by default in version 2.11.1, and the function
 303          gnutls_transport_set_lowat was removed from the library in
 304          version 2.99.0.  */
 305       if (!fn_gnutls_check_version ("2.11.1"))
 306         fn_gnutls_transport_set_lowat (state, 0);
 307 #else
 308       /* This is how GnuTLS takes sockets: as file descriptors passed
 309          in.  For an Emacs process socket, infd and outfd are the
 310          same but we use this two-argument version for clarity.  */
 311       fn_gnutls_transport_set_ptr2 (state,
 312                                     (gnutls_transport_ptr_t) (long) proc->infd,
 313                                     (gnutls_transport_ptr_t) (long) proc->outfd);
 314 #endif
 315
 316       proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
 317     }
 318
 319   do
 320     {
 321       ret = fn_gnutls_handshake (state);
 322       emacs_gnutls_handle_error (state, ret);
 323       QUIT;
 324     }
 325   while (ret < 0 && fn_gnutls_error_is_fatal (ret) == 0);
 326
 327   proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
 328
 329   if (ret == GNUTLS_E_SUCCESS)
 330     {
 331       /* Here we're finally done.  */
 332       proc->gnutls_initstage = GNUTLS_STAGE_READY;
 333     }
 334   else
 335     {
 336       fn_gnutls_alert_send_appropriate (state, ret);
 337     }
 338   return ret;
 339 }
 340
 341 int
 342 emacs_gnutls_record_check_pending (gnutls_session_t state)
 343 {
 344   return fn_gnutls_record_check_pending (state);
 345 }
 346
 347 void
 348 emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
 349 {
 350   fn_gnutls_transport_set_errno (state, err);
 351 }
 352
 353 ptrdiff_t
 354 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
 355 {
 356   ssize_t rtnval = 0;
 357   ptrdiff_t bytes_written;
 358   gnutls_session_t state = proc->gnutls_state;
 359
 360   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
 361     {
 362 #ifdef EWOULDBLOCK
 363       errno = EWOULDBLOCK;
 364 #endif
 365 #ifdef EAGAIN
 366       errno = EAGAIN;
 367 #endif
 368       return 0;
 369     }
 370
 371   bytes_written = 0;
 372
 373   while (nbyte > 0)
 374     {
 375       rtnval = fn_gnutls_record_send (state, buf, nbyte);
 376
 377       if (rtnval < 0)
 378         {
 379           if (rtnval == GNUTLS_E_INTERRUPTED)
 380             continue;
 381           else
 382             {
 383               /* If we get GNUTLS_E_AGAIN, then set errno
 384                  appropriately so that send_process retries the
 385                  correct way instead of erroring out. */
 386               if (rtnval == GNUTLS_E_AGAIN)
 387                 {
 388 #ifdef EWOULDBLOCK
 389                   errno = EWOULDBLOCK;
 390 #endif
 391 #ifdef EAGAIN
 392                   errno = EAGAIN;
 393 #endif
 394                 }
 395               break;
 396             }
 397         }
 398
 399       buf += rtnval;
 400       nbyte -= rtnval;
 401       bytes_written += rtnval;
 402     }
 403
 404   emacs_gnutls_handle_error (state, rtnval);
 405   return (bytes_written);
 406 }
 407
 408 ptrdiff_t
 409 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
 410 {
 411   ssize_t rtnval;
 412   gnutls_session_t state = proc->gnutls_state;
 413
 414   int log_level = proc->gnutls_log_level;
 415
 416   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
 417     {
 418       /* If the handshake count is under the limit, try the handshake
 419          again and increment the handshake count.  This count is kept
 420          per process (connection), not globally.  */
 421       if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT)
 422         {
 423           proc->gnutls_handshakes_tried++;
 424           emacs_gnutls_handshake (proc);
 425           GNUTLS_LOG2i (5, log_level, "Retried handshake",
 426                         proc->gnutls_handshakes_tried);
 427           return -1;
 428         }
 429
 430       GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
 431       proc->gnutls_handshakes_tried = 0;
 432       return 0;
 433     }
 434   rtnval = fn_gnutls_record_recv (state, buf, nbyte);
 435   if (rtnval >= 0)
 436     return rtnval;
 437   else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
 438     /* The peer closed the connection. */
 439     return 0;
 440   else if (emacs_gnutls_handle_error (state, rtnval))
 441     /* non-fatal error */
 442     return -1;
 443   else {
 444     /* a fatal error occurred */
 445     return 0;
 446   }
 447 }
 448
 449 /* Report a GnuTLS error to the user.
 450    Return true if the error code was successfully handled.  */
 451 static bool
 452 emacs_gnutls_handle_error (gnutls_session_t session, int err)
 453 {
 454   int max_log_level = 0;
 455
 456   bool ret;
 457   const char *str;
 458
 459   /* TODO: use a Lisp_Object generated by gnutls_make_error?  */
 460   if (err >= 0)
 461     return 1;
 462
 463   max_log_level = global_gnutls_log_level;
 464
 465   /* TODO: use gnutls-error-fatalp and gnutls-error-string.  */
 466
 467   str = fn_gnutls_strerror (err);
 468   if (!str)
 469     str = "unknown";
 470
 471   if (fn_gnutls_error_is_fatal (err))
 472     {
 473       ret = 0;
 474       GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
 475     }
 476   else
 477     {
 478       ret = 1;
 479       GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str);
 480       /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2.  */
 481     }
 482
 483   if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
 484       || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
 485     {
 486       int alert = fn_gnutls_alert_get (session);
 487       int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
 488       str = fn_gnutls_alert_get_name (alert);
 489       if (!str)
 490         str = "unknown";
 491
 492       GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
 493     }
 494   return ret;
 495 }
 496
 497 /* convert an integer error to a Lisp_Object; it will be either a
 498    known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
 499    simply the integer value of the error.  GNUTLS_E_SUCCESS is mapped
 500    to Qt.  */
 501 static Lisp_Object
 502 gnutls_make_error (int err)
 503 {
 504   switch (err)
 505     {
 506     case GNUTLS_E_SUCCESS:
 507       return Qt;
 508     case GNUTLS_E_AGAIN:
 509       return Qgnutls_e_again;
 510     case GNUTLS_E_INTERRUPTED:
 511       return Qgnutls_e_interrupted;
 512     case GNUTLS_E_INVALID_SESSION:
 513       return Qgnutls_e_invalid_session;
 514     }
 515
 516   return make_number (err);
 517 }
 518
 519 Lisp_Object
 520 emacs_gnutls_deinit (Lisp_Object proc)
 521 {
 522   int log_level;
 523
 524   CHECK_PROCESS (proc);
 525
 526   if (XPROCESS (proc)->gnutls_p == 0)
 527     return Qnil;
 528
 529   log_level = XPROCESS (proc)->gnutls_log_level;
 530
 531   if (XPROCESS (proc)->gnutls_x509_cred)
 532     {
 533       GNUTLS_LOG (2, log_level, "Deallocating x509 credentials");
 534       fn_gnutls_certificate_free_credentials (XPROCESS (proc)->gnutls_x509_cred);
 535       XPROCESS (proc)->gnutls_x509_cred = NULL;
 536     }
 537
 538   if (XPROCESS (proc)->gnutls_anon_cred)
 539     {
 540       GNUTLS_LOG (2, log_level, "Deallocating anon credentials");
 541       fn_gnutls_anon_free_client_credentials (XPROCESS (proc)->gnutls_anon_cred);
 542       XPROCESS (proc)->gnutls_anon_cred = NULL;
 543     }
 544
 545   if (XPROCESS (proc)->gnutls_state)
 546     {
 547       fn_gnutls_deinit (XPROCESS (proc)->gnutls_state);
 548       XPROCESS (proc)->gnutls_state = NULL;
 549       if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 550         GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
 551     }
 552
 553   XPROCESS (proc)->gnutls_p = 0;
 554   return Qt;
 555 }
 556
 557 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
 558        doc: /* Return the GnuTLS init stage of process PROC.
 559 See also `gnutls-boot'.  */)
 560   (Lisp_Object proc)
 561 {
 562   CHECK_PROCESS (proc);
 563
 564   return make_number (GNUTLS_INITSTAGE (proc));
 565 }
 566
 567 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
 568        doc: /* Return t if ERROR indicates a GnuTLS problem.
 569 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 570 usage: (gnutls-errorp ERROR)  */)
 571   (Lisp_Object err)
 572 {
 573   if (EQ (err, Qt)) return Qnil;
 574
 575   return Qt;
 576 }
 577
 578 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
 579        doc: /* Check if ERROR is fatal.
 580 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 581 usage: (gnutls-error-fatalp ERROR)  */)
 582   (Lisp_Object err)
 583 {
 584   Lisp_Object code;
 585
 586   if (EQ (err, Qt)) return Qnil;
 587
 588   if (SYMBOLP (err))
 589     {
 590       code = Fget (err, Qgnutls_code);
 591       if (NUMBERP (code))
 592         {
 593           err = code;
 594         }
 595       else
 596         {
 597           error ("Symbol has no numeric gnutls-code property");
 598         }
 599     }
 600
 601   if (! TYPE_RANGED_INTEGERP (int, err))
 602     error ("Not an error symbol or code");
 603
 604   if (0 == fn_gnutls_error_is_fatal (XINT (err)))
 605     return Qnil;
 606
 607   return Qt;
 608 }
 609
 610 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
 611        doc: /* Return a description of ERROR.
 612 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 613 usage: (gnutls-error-string ERROR)  */)
 614   (Lisp_Object err)
 615 {
 616   Lisp_Object code;
 617
 618   if (EQ (err, Qt)) return build_string ("Not an error");
 619
 620   if (SYMBOLP (err))
 621     {
 622       code = Fget (err, Qgnutls_code);
 623       if (NUMBERP (code))
 624         {
 625           err = code;
 626         }
 627       else
 628         {
 629           return build_string ("Symbol has no numeric gnutls-code property");
 630         }
 631     }
 632
 633   if (! TYPE_RANGED_INTEGERP (int, err))
 634     return build_string ("Not an error symbol or code");
 635
 636   return build_string (fn_gnutls_strerror (XINT (err)));
 637 }
 638
 639 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
 640        doc: /* Deallocate GnuTLS resources associated with process PROC.
 641 See also `gnutls-init'.  */)
 642   (Lisp_Object proc)
 643 {
 644   return emacs_gnutls_deinit (proc);
 645 }
 646
 647 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
 648        doc: /* Return t if GnuTLS is available in this instance of Emacs.  */)
 649      (void)
 650 {
 651 #ifdef WINDOWSNT
 652   Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
 653   if (CONSP (found))
 654     return XCDR (found);
 655   else
 656     {
 657       Lisp_Object status;
 658       status = init_gnutls_functions () ? Qt : Qnil;
 659       Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
 660       return status;
 661     }
 662 #else
 663   return Qt;
 664 #endif
 665 }
 666
 667
 668 /* Initializes global GnuTLS state to defaults.
 669 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
 670 Returns zero on success.  */
 671 static Lisp_Object
 672 emacs_gnutls_global_init (void)
 673 {
 674   int ret = GNUTLS_E_SUCCESS;
 675
 676   if (!gnutls_global_initialized)
 677     {
 678       fn_gnutls_global_set_mem_functions (xmalloc, xmalloc, NULL,
 679                                           xrealloc, xfree);
 680       ret = fn_gnutls_global_init ();
 681     }
 682   gnutls_global_initialized = 1;
 683
 684   return gnutls_make_error (ret);
 685 }
 686
 687 #if 0
 688 /* Deinitializes global GnuTLS state.
 689 See also `gnutls-global-init'.  */
 690 static Lisp_Object
 691 emacs_gnutls_global_deinit (void)
 692 {
 693   if (gnutls_global_initialized)
 694     gnutls_global_deinit ();
 695
 696   gnutls_global_initialized = 0;
 697
 698   return gnutls_make_error (GNUTLS_E_SUCCESS);
 699 }
 700 #endif
 701
 702 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 703        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
 704 Currently only client mode is supported.  Return a success/failure
 705 value you can check with `gnutls-errorp'.
 706
 707 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
 708 PROPLIST is a property list with the following keys:
 709
 710 :hostname is a string naming the remote host.
 711
 712 :priority is a GnuTLS priority string, defaults to "NORMAL".
 713
 714 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
 715
 716 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
 717
 718 :keylist is an alist of PEM-encoded key files and PEM-encoded
 719 certificates for `gnutls-x509pki'.
 720
 721 :callbacks is an alist of callback functions, see below.
 722
 723 :loglevel is the debug level requested from GnuTLS, try 4.
 724
 725 :verify-flags is a bitset as per GnuTLS'
 726 gnutls_certificate_set_verify_flags.
 727
 728 :verify-hostname-error, if non-nil, makes a hostname mismatch an
 729 error.  Otherwise it will be just a warning.
 730
 731 :min-prime-bits is the minimum accepted number of bits the client will
 732 accept in Diffie-Hellman key exchange.
 733
 734 The debug level will be set for this process AND globally for GnuTLS.
 735 So if you set it higher or lower at any point, it affects global
 736 debugging.
 737
 738 Note that the priority is set on the client.  The server does not use
 739 the protocols's priority except for disabling protocols that were not
 740 specified.
 741
 742 Processes must be initialized with this function before other GnuTLS
 743 functions are used.  This function allocates resources which can only
 744 be deallocated by calling `gnutls-deinit' or by calling it again.
 745
 746 The callbacks alist can have a `verify' key, associated with a
 747 verification function (UNUSED).
 748
 749 Each authentication type may need additional information in order to
 750 work.  For X.509 PKI (`gnutls-x509pki'), you probably need at least
 751 one trustfile (usually a CA bundle).  */)
 752   (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
 753 {
 754   int ret = GNUTLS_E_SUCCESS;
 755   int max_log_level = 0;
 756
 757   gnutls_session_t state;
 758   gnutls_certificate_credentials_t x509_cred = NULL;
 759   gnutls_anon_client_credentials_t anon_cred = NULL;
 760   Lisp_Object global_init;
 761   char const *priority_string_ptr = "NORMAL"; /* default priority string.  */
 762   unsigned int peer_verification;
 763   char* c_hostname;
 764
 765   /* Placeholders for the property list elements.  */
 766   Lisp_Object priority_string;
 767   Lisp_Object trustfiles;
 768   Lisp_Object crlfiles;
 769   Lisp_Object keylist;
 770   /* Lisp_Object callbacks; */
 771   Lisp_Object loglevel;
 772   Lisp_Object hostname;
 773   /* Lisp_Object verify_error; */
 774   Lisp_Object verify_hostname_error;
 775   Lisp_Object prime_bits;
 776
 777   CHECK_PROCESS (proc);
 778   CHECK_SYMBOL (type);
 779   CHECK_LIST (proplist);
 780
 781   if (NILP (Fgnutls_available_p ()))
 782     {
 783       error ("GnuTLS not available");
 784       return gnutls_make_error (GNUTLS_EMACS_ERROR_NOT_LOADED);
 785     }
 786
 787   if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
 788     {
 789       error ("Invalid GnuTLS credential type");
 790       return gnutls_make_error (GNUTLS_EMACS_ERROR_INVALID_TYPE);
 791     }
 792
 793   hostname              = Fplist_get (proplist, QCgnutls_bootprop_hostname);
 794   priority_string       = Fplist_get (proplist, QCgnutls_bootprop_priority);
 795   trustfiles            = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
 796   keylist               = Fplist_get (proplist, QCgnutls_bootprop_keylist);
 797   crlfiles              = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
 798   loglevel              = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
 799   verify_hostname_error = Fplist_get (proplist, QCgnutls_bootprop_verify_hostname_error);
 800   prime_bits            = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
 801
 802   if (!STRINGP (hostname))
 803     error ("gnutls-boot: invalid :hostname parameter");
 804   c_hostname = SSDATA (hostname);
 805
 806   state = XPROCESS (proc)->gnutls_state;
 807   XPROCESS (proc)->gnutls_p = 1;
 808
 809   if (TYPE_RANGED_INTEGERP (int, loglevel))
 810     {
 811       fn_gnutls_global_set_log_function (gnutls_log_function);
 812       fn_gnutls_global_set_log_level (XINT (loglevel));
 813       max_log_level = XINT (loglevel);
 814       XPROCESS (proc)->gnutls_log_level = max_log_level;
 815     }
 816
 817   /* always initialize globals.  */
 818   global_init = emacs_gnutls_global_init ();
 819   if (! NILP (Fgnutls_errorp (global_init)))
 820     return global_init;
 821
 822   /* Before allocating new credentials, deallocate any credentials
 823      that PROC might already have.  */
 824   emacs_gnutls_deinit (proc);
 825
 826   /* Mark PROC as a GnuTLS process.  */
 827   XPROCESS (proc)->gnutls_p = 1;
 828   XPROCESS (proc)->gnutls_state = NULL;
 829   XPROCESS (proc)->gnutls_x509_cred = NULL;
 830   XPROCESS (proc)->gnutls_anon_cred = NULL;
 831   pset_gnutls_cred_type (XPROCESS (proc), type);
 832   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
 833
 834   GNUTLS_LOG (1, max_log_level, "allocating credentials");
 835   if (EQ (type, Qgnutls_x509pki))
 836     {
 837       Lisp_Object verify_flags;
 838       unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
 839
 840       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
 841       fn_gnutls_certificate_allocate_credentials (&x509_cred);
 842       XPROCESS (proc)->gnutls_x509_cred = x509_cred;
 843
 844       verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
 845       if (NUMBERP (verify_flags))
 846         {
 847           gnutls_verify_flags = XINT (verify_flags);
 848           GNUTLS_LOG (2, max_log_level, "setting verification flags");
 849         }
 850       else if (NILP (verify_flags))
 851         GNUTLS_LOG (2, max_log_level, "using default verification flags");
 852       else
 853         GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
 854
 855       fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
 856     }
 857   else /* Qgnutls_anon: */
 858     {
 859       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
 860       fn_gnutls_anon_allocate_client_credentials (&anon_cred);
 861       XPROCESS (proc)->gnutls_anon_cred = anon_cred;
 862     }
 863
 864   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
 865
 866   if (EQ (type, Qgnutls_x509pki))
 867     {
 868       /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
 869       int file_format = GNUTLS_X509_FMT_PEM;
 870       Lisp_Object tail;
 871
 872       for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
 873         {
 874           Lisp_Object trustfile = XCAR (tail);
 875           if (STRINGP (trustfile))
 876             {
 877               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
 878                            SSDATA (trustfile));
 879               ret = fn_gnutls_certificate_set_x509_trust_file
 880                 (x509_cred,
 881                  SSDATA (trustfile),
 882                  file_format);
 883
 884               if (ret < GNUTLS_E_SUCCESS)
 885                 return gnutls_make_error (ret);
 886             }
 887           else
 888             {
 889               emacs_gnutls_deinit (proc);
 890               error ("Invalid trustfile");
 891             }
 892         }
 893
 894       for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
 895         {
 896           Lisp_Object crlfile = XCAR (tail);
 897           if (STRINGP (crlfile))
 898             {
 899               GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
 900                            SSDATA (crlfile));
 901               ret = fn_gnutls_certificate_set_x509_crl_file
 902                 (x509_cred, SSDATA (crlfile), file_format);
 903
 904               if (ret < GNUTLS_E_SUCCESS)
 905                 return gnutls_make_error (ret);
 906             }
 907           else
 908             {
 909               emacs_gnutls_deinit (proc);
 910               error ("Invalid CRL file");
 911             }
 912         }
 913
 914       for (tail = keylist; CONSP (tail); tail = XCDR (tail))
 915         {
 916           Lisp_Object keyfile = Fcar (XCAR (tail));
 917           Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
 918           if (STRINGP (keyfile) && STRINGP (certfile))
 919             {
 920               GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
 921                            SSDATA (keyfile));
 922               GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
 923                            SSDATA (certfile));
 924               ret = fn_gnutls_certificate_set_x509_key_file
 925                 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
 926
 927               if (ret < GNUTLS_E_SUCCESS)
 928                 return gnutls_make_error (ret);
 929             }
 930           else
 931             {
 932               emacs_gnutls_deinit (proc);
 933               error (STRINGP (keyfile) ? "Invalid client cert file"
 934                      : "Invalid client key file");
 935             }
 936         }
 937     }
 938
 939   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 940   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
 941   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
 942
 943   /* Call gnutls_init here: */
 944
 945   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 946   ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
 947   XPROCESS (proc)->gnutls_state = state;
 948   if (ret < GNUTLS_E_SUCCESS)
 949     return gnutls_make_error (ret);
 950   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
 951
 952   if (STRINGP (priority_string))
 953     {
 954       priority_string_ptr = SSDATA (priority_string);
 955       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
 956                    priority_string_ptr);
 957     }
 958   else
 959     {
 960       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
 961                    priority_string_ptr);
 962     }
 963
 964   GNUTLS_LOG (1, max_log_level, "setting the priority string");
 965   ret = fn_gnutls_priority_set_direct (state,
 966                                        priority_string_ptr,
 967                                        NULL);
 968   if (ret < GNUTLS_E_SUCCESS)
 969     return gnutls_make_error (ret);
 970
 971   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
 972
 973   if (INTEGERP (prime_bits))
 974     fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
 975
 976   ret = EQ (type, Qgnutls_x509pki)
 977     ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
 978     : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
 979   if (ret < GNUTLS_E_SUCCESS)
 980     return gnutls_make_error (ret);
 981
 982   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
 983   ret = emacs_gnutls_handshake (XPROCESS (proc));
 984   if (ret < GNUTLS_E_SUCCESS)
 985     return gnutls_make_error (ret);
 986
 987   /* Now verify the peer, following
 988      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
 989      The peer should present at least one certificate in the chain; do a
 990      check of the certificate's hostname with
 991      gnutls_x509_crt_check_hostname() against :hostname.  */
 992
 993   ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
 994   if (ret < GNUTLS_E_SUCCESS)
 995     return gnutls_make_error (ret);
 996
 997   if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
 998     message ("%s certificate could not be verified.", c_hostname);
 999
1000   if (peer_verification & GNUTLS_CERT_REVOKED)
1001     GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
1002                  c_hostname);
1003
1004   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
1005     GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
1006                  c_hostname);
1007
1008   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
1009     GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
1010                  c_hostname);
1011
1012   if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1013     GNUTLS_LOG2 (1, max_log_level,
1014                  "certificate was signed with an insecure algorithm:",
1015                  c_hostname);
1016
1017   if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
1018     GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
1019                  c_hostname);
1020
1021   if (peer_verification & GNUTLS_CERT_EXPIRED)
1022     GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
1023                  c_hostname);
1024
1025   if (peer_verification != 0)
1026     {
1027       if (NILP (verify_hostname_error))
1028         GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1029                      c_hostname);
1030       else
1031         {
1032           emacs_gnutls_deinit (proc);
1033           error ("Certificate validation failed %s, verification code %d",
1034                  c_hostname, peer_verification);
1035         }
1036     }
1037
1038   /* Up to here the process is the same for X.509 certificates and
1039      OpenPGP keys.  From now on X.509 certificates are assumed.  This
1040      can be easily extended to work with openpgp keys as well.  */
1041   if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1042     {
1043       gnutls_x509_crt_t gnutls_verify_cert;
1044       const gnutls_datum_t *gnutls_verify_cert_list;
1045       unsigned int gnutls_verify_cert_list_size;
1046
1047       ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
1048       if (ret < GNUTLS_E_SUCCESS)
1049         return gnutls_make_error (ret);
1050
1051       gnutls_verify_cert_list =
1052         fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1053
1054       if (gnutls_verify_cert_list == NULL)
1055         {
1056           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1057           emacs_gnutls_deinit (proc);
1058           error ("No x509 certificate was found\n");
1059         }
1060
1061       /* We only check the first certificate in the given chain.  */
1062       ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1063                                        &gnutls_verify_cert_list[0],
1064                                        GNUTLS_X509_FMT_DER);
1065
1066       if (ret < GNUTLS_E_SUCCESS)
1067         {
1068           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1069           return gnutls_make_error (ret);
1070         }
1071
1072       if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1073         {
1074           if (NILP (verify_hostname_error))
1075             GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1076                          c_hostname);
1077           else
1078             {
1079               fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1080               emacs_gnutls_deinit (proc);
1081               error ("The x509 certificate does not match \"%s\"", c_hostname);
1082             }
1083         }
1084       fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1085     }
1086
1087   return gnutls_make_error (ret);
1088 }
1089
1090 DEFUN ("gnutls-bye", Fgnutls_bye,
1091        Sgnutls_bye, 2, 2, 0,
1092        doc: /* Terminate current GnuTLS connection for process PROC.
1093 The connection should have been initiated using `gnutls-handshake'.
1094
1095 If CONT is not nil the TLS connection gets terminated and further
1096 receives and sends will be disallowed.  If the return value is zero you
1097 may continue using the connection.  If CONT is nil, GnuTLS actually
1098 sends an alert containing a close request and waits for the peer to
1099 reply with the same message.  In order to reuse the connection you
1100 should wait for an EOF from the peer.
1101
1102 This function may also return `gnutls-e-again', or
1103 `gnutls-e-interrupted'.  */)
1104     (Lisp_Object proc, Lisp_Object cont)
1105 {
1106   gnutls_session_t state;
1107   int ret;
1108
1109   CHECK_PROCESS (proc);
1110
1111   state = XPROCESS (proc)->gnutls_state;
1112
1113   ret = fn_gnutls_bye (state,
1114                        NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1115
1116   return gnutls_make_error (ret);
1117 }
1118
1119 void
1120 syms_of_gnutls (void)
1121 {
1122   gnutls_global_initialized = 0;
1123
1124   DEFSYM (Qgnutls_dll, "gnutls");
1125   DEFSYM (Qgnutls_code, "gnutls-code");
1126   DEFSYM (Qgnutls_anon, "gnutls-anon");
1127   DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1128   DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1129   DEFSYM (QCgnutls_bootprop_priority, ":priority");
1130   DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1131   DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1132   DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1133   DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1134   DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1135   DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1136   DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1137   DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1138   DEFSYM (QCgnutls_bootprop_verify_hostname_error, ":verify-hostname-error");
1139
1140   DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1141   Fput (Qgnutls_e_interrupted, Qgnutls_code,
1142         make_number (GNUTLS_E_INTERRUPTED));
1143
1144   DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1145   Fput (Qgnutls_e_again, Qgnutls_code,
1146         make_number (GNUTLS_E_AGAIN));
1147
1148   DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1149   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1150         make_number (GNUTLS_E_INVALID_SESSION));
1151
1152   DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1153   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1154         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1155
1156   defsubr (&Sgnutls_get_initstage);
1157   defsubr (&Sgnutls_errorp);
1158   defsubr (&Sgnutls_error_fatalp);
1159   defsubr (&Sgnutls_error_string);
1160   defsubr (&Sgnutls_boot);
1161   defsubr (&Sgnutls_deinit);
1162   defsubr (&Sgnutls_bye);
1163   defsubr (&Sgnutls_available_p);
1164
1165   DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1166               doc: /* Logging level used by the GnuTLS functions.
1167 Set this larger than 0 to get debug output in the *Messages* buffer.
1168 1 is for important messages, 2 is for debug data, and higher numbers
1169 are as per the GnuTLS logging conventions.  */);
1170   global_gnutls_log_level = 0;
1171 }
1172
1173 #endif /* HAVE_GNUTLS */