src/gnutls.c

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