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     }
 326   while (ret < 0 && fn_gnutls_error_is_fatal (ret) == 0);
 327
 328   proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
 329
 330   if (ret == GNUTLS_E_SUCCESS)
 331     {
 332       /* Here we're finally done.  */
 333       proc->gnutls_initstage = GNUTLS_STAGE_READY;
 334     }
 335   else
 336     {
 337       fn_gnutls_alert_send_appropriate (state, ret);
 338     }
 339   return ret;
 340 }
 341
 342 int
 343 emacs_gnutls_record_check_pending (gnutls_session_t state)
 344 {
 345   return fn_gnutls_record_check_pending (state);
 346 }
 347
 348 void
 349 emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
 350 {
 351   fn_gnutls_transport_set_errno (state, err);
 352 }
 353
 354 ptrdiff_t
 355 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
 356 {
 357   ssize_t rtnval = 0;
 358   ptrdiff_t bytes_written;
 359   gnutls_session_t state = proc->gnutls_state;
 360
 361   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
 362     {
 363 #ifdef EWOULDBLOCK
 364       errno = EWOULDBLOCK;
 365 #endif
 366 #ifdef EAGAIN
 367       errno = EAGAIN;
 368 #endif
 369       return 0;
 370     }
 371
 372   bytes_written = 0;
 373
 374   while (nbyte > 0)
 375     {
 376       rtnval = fn_gnutls_record_send (state, buf, nbyte);
 377
 378       if (rtnval < 0)
 379         {
 380           if (rtnval == GNUTLS_E_INTERRUPTED)
 381             continue;
 382           else
 383             {
 384               /* If we get GNUTLS_E_AGAIN, then set errno
 385                  appropriately so that send_process retries the
 386                  correct way instead of erroring out. */
 387               if (rtnval == GNUTLS_E_AGAIN)
 388                 {
 389 #ifdef EWOULDBLOCK
 390                   errno = EWOULDBLOCK;
 391 #endif
 392 #ifdef EAGAIN
 393                   errno = EAGAIN;
 394 #endif
 395                 }
 396               break;
 397             }
 398         }
 399
 400       buf += rtnval;
 401       nbyte -= rtnval;
 402       bytes_written += rtnval;
 403     }
 404
 405   emacs_gnutls_handle_error (state, rtnval);
 406   return (bytes_written);
 407 }
 408
 409 ptrdiff_t
 410 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
 411 {
 412   ssize_t rtnval;
 413   gnutls_session_t state = proc->gnutls_state;
 414
 415   int log_level = proc->gnutls_log_level;
 416
 417   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
 418     {
 419       /* If the handshake count is under the limit, try the handshake
 420          again and increment the handshake count.  This count is kept
 421          per process (connection), not globally.  */
 422       if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT)
 423         {
 424           proc->gnutls_handshakes_tried++;
 425           emacs_gnutls_handshake (proc);
 426           GNUTLS_LOG2i (5, log_level, "Retried handshake",
 427                         proc->gnutls_handshakes_tried);
 428           return -1;
 429         }
 430
 431       GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
 432       proc->gnutls_handshakes_tried = 0;
 433       return 0;
 434     }
 435   rtnval = fn_gnutls_record_recv (state, buf, nbyte);
 436   if (rtnval >= 0)
 437     return rtnval;
 438   else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
 439     /* The peer closed the connection. */
 440     return 0;
 441   else if (emacs_gnutls_handle_error (state, rtnval) == 0)
 442     /* non-fatal error */
 443     return -1;
 444   else {
 445     /* a fatal error occurred */
 446     return 0;
 447   }
 448 }
 449
 450 /* report a GnuTLS error to the user.
 451    Returns zero if the error code was successfully handled. */
 452 static int
 453 emacs_gnutls_handle_error (gnutls_session_t session, int err)
 454 {
 455   int max_log_level = 0;
 456
 457   int ret;
 458   const char *str;
 459
 460   /* TODO: use a Lisp_Object generated by gnutls_make_error?  */
 461   if (err >= 0)
 462     return 0;
 463
 464   max_log_level = global_gnutls_log_level;
 465
 466   /* TODO: use gnutls-error-fatalp and gnutls-error-string.  */
 467
 468   str = fn_gnutls_strerror (err);
 469   if (!str)
 470     str = "unknown";
 471
 472   if (fn_gnutls_error_is_fatal (err))
 473     {
 474       ret = err;
 475       GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
 476     }
 477   else
 478     {
 479       ret = 0;
 480       GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str);
 481       /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2.  */
 482     }
 483
 484   if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
 485       || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
 486     {
 487       int alert = fn_gnutls_alert_get (session);
 488       int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
 489       str = fn_gnutls_alert_get_name (alert);
 490       if (!str)
 491         str = "unknown";
 492
 493       GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
 494     }
 495   return ret;
 496 }
 497
 498 /* convert an integer error to a Lisp_Object; it will be either a
 499    known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
 500    simply the integer value of the error.  GNUTLS_E_SUCCESS is mapped
 501    to Qt.  */
 502 static Lisp_Object
 503 gnutls_make_error (int err)
 504 {
 505   switch (err)
 506     {
 507     case GNUTLS_E_SUCCESS:
 508       return Qt;
 509     case GNUTLS_E_AGAIN:
 510       return Qgnutls_e_again;
 511     case GNUTLS_E_INTERRUPTED:
 512       return Qgnutls_e_interrupted;
 513     case GNUTLS_E_INVALID_SESSION:
 514       return Qgnutls_e_invalid_session;
 515     }
 516
 517   return make_number (err);
 518 }
 519
 520 Lisp_Object
 521 emacs_gnutls_deinit (Lisp_Object proc)
 522 {
 523   int log_level;
 524
 525   CHECK_PROCESS (proc);
 526
 527   if (XPROCESS (proc)->gnutls_p == 0)
 528     return Qnil;
 529
 530   log_level = XPROCESS (proc)->gnutls_log_level;
 531
 532   if (XPROCESS (proc)->gnutls_x509_cred)
 533     {
 534       GNUTLS_LOG (2, log_level, "Deallocating x509 credentials");
 535       fn_gnutls_certificate_free_credentials (XPROCESS (proc)->gnutls_x509_cred);
 536       XPROCESS (proc)->gnutls_x509_cred = NULL;
 537     }
 538
 539   if (XPROCESS (proc)->gnutls_anon_cred)
 540     {
 541       GNUTLS_LOG (2, log_level, "Deallocating anon credentials");
 542       fn_gnutls_anon_free_client_credentials (XPROCESS (proc)->gnutls_anon_cred);
 543       XPROCESS (proc)->gnutls_anon_cred = NULL;
 544     }
 545
 546   if (XPROCESS (proc)->gnutls_state)
 547     {
 548       fn_gnutls_deinit (XPROCESS (proc)->gnutls_state);
 549       XPROCESS (proc)->gnutls_state = NULL;
 550       if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 551         GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
 552     }
 553
 554   XPROCESS (proc)->gnutls_p = 0;
 555   return Qt;
 556 }
 557
 558 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
 559        doc: /* Return the GnuTLS init stage of process PROC.
 560 See also `gnutls-boot'.  */)
 561   (Lisp_Object proc)
 562 {
 563   CHECK_PROCESS (proc);
 564
 565   return make_number (GNUTLS_INITSTAGE (proc));
 566 }
 567
 568 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
 569        doc: /* Return t if ERROR indicates a GnuTLS problem.
 570 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 571 usage: (gnutls-errorp ERROR)  */)
 572   (Lisp_Object err)
 573 {
 574   if (EQ (err, Qt)) return Qnil;
 575
 576   return Qt;
 577 }
 578
 579 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
 580        doc: /* Check if ERROR is fatal.
 581 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 582 usage: (gnutls-error-fatalp ERROR)  */)
 583   (Lisp_Object err)
 584 {
 585   Lisp_Object code;
 586
 587   if (EQ (err, Qt)) return Qnil;
 588
 589   if (SYMBOLP (err))
 590     {
 591       code = Fget (err, Qgnutls_code);
 592       if (NUMBERP (code))
 593         {
 594           err = code;
 595         }
 596       else
 597         {
 598           error ("Symbol has no numeric gnutls-code property");
 599         }
 600     }
 601
 602   if (! TYPE_RANGED_INTEGERP (int, err))
 603     error ("Not an error symbol or code");
 604
 605   if (0 == fn_gnutls_error_is_fatal (XINT (err)))
 606     return Qnil;
 607
 608   return Qt;
 609 }
 610
 611 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
 612        doc: /* Return a description of ERROR.
 613 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 614 usage: (gnutls-error-string ERROR)  */)
 615   (Lisp_Object err)
 616 {
 617   Lisp_Object code;
 618
 619   if (EQ (err, Qt)) return build_string ("Not an error");
 620
 621   if (SYMBOLP (err))
 622     {
 623       code = Fget (err, Qgnutls_code);
 624       if (NUMBERP (code))
 625         {
 626           err = code;
 627         }
 628       else
 629         {
 630           return build_string ("Symbol has no numeric gnutls-code property");
 631         }
 632     }
 633
 634   if (! TYPE_RANGED_INTEGERP (int, err))
 635     return build_string ("Not an error symbol or code");
 636
 637   return build_string (fn_gnutls_strerror (XINT (err)));
 638 }
 639
 640 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
 641        doc: /* Deallocate GnuTLS resources associated with process PROC.
 642 See also `gnutls-init'.  */)
 643   (Lisp_Object proc)
 644 {
 645   return emacs_gnutls_deinit (proc);
 646 }
 647
 648 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
 649        doc: /* Return t if GnuTLS is available in this instance of Emacs.  */)
 650      (void)
 651 {
 652 #ifdef WINDOWSNT
 653   Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
 654   if (CONSP (found))
 655     return XCDR (found);
 656   else
 657     {
 658       Lisp_Object status;
 659       status = init_gnutls_functions (Vdynamic_library_alist) ? Qt : Qnil;
 660       Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
 661       return status;
 662     }
 663 #else
 664   return Qt;
 665 #endif
 666 }
 667
 668
 669 /* Initializes global GnuTLS state to defaults.
 670 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
 671 Returns zero on success.  */
 672 static Lisp_Object
 673 emacs_gnutls_global_init (void)
 674 {
 675   int ret = GNUTLS_E_SUCCESS;
 676
 677   if (!gnutls_global_initialized)
 678     {
 679       fn_gnutls_global_set_mem_functions (xmalloc, xmalloc, NULL,
 680                                           xrealloc, xfree);
 681       ret = fn_gnutls_global_init ();
 682     }
 683   gnutls_global_initialized = 1;
 684
 685   return gnutls_make_error (ret);
 686 }
 687
 688 #if 0
 689 /* Deinitializes global GnuTLS state.
 690 See also `gnutls-global-init'.  */
 691 static Lisp_Object
 692 emacs_gnutls_global_deinit (void)
 693 {
 694   if (gnutls_global_initialized)
 695     gnutls_global_deinit ();
 696
 697   gnutls_global_initialized = 0;
 698
 699   return gnutls_make_error (GNUTLS_E_SUCCESS);
 700 }
 701 #endif
 702
 703 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 704        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
 705 Currently only client mode is supported.  Return a success/failure
 706 value you can check with `gnutls-errorp'.
 707
 708 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
 709 PROPLIST is a property list with the following keys:
 710
 711 :hostname is a string naming the remote host.
 712
 713 :priority is a GnuTLS priority string, defaults to "NORMAL".
 714
 715 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
 716
 717 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
 718
 719 :keylist is an alist of PEM-encoded key files and PEM-encoded
 720 certificates for `gnutls-x509pki'.
 721
 722 :callbacks is an alist of callback functions, see below.
 723
 724 :loglevel is the debug level requested from GnuTLS, try 4.
 725
 726 :verify-flags is a bitset as per GnuTLS'
 727 gnutls_certificate_set_verify_flags.
 728
 729 :verify-hostname-error, if non-nil, makes a hostname mismatch an
 730 error.  Otherwise it will be just a warning.
 731
 732 :min-prime-bits is the minimum accepted number of bits the client will
 733 accept in Diffie-Hellman key exchange.
 734
 735 The debug level will be set for this process AND globally for GnuTLS.
 736 So if you set it higher or lower at any point, it affects global
 737 debugging.
 738
 739 Note that the priority is set on the client.  The server does not use
 740 the protocols's priority except for disabling protocols that were not
 741 specified.
 742
 743 Processes must be initialized with this function before other GnuTLS
 744 functions are used.  This function allocates resources which can only
 745 be deallocated by calling `gnutls-deinit' or by calling it again.
 746
 747 The callbacks alist can have a `verify' key, associated with a
 748 verification function (UNUSED).
 749
 750 Each authentication type may need additional information in order to
 751 work.  For X.509 PKI (`gnutls-x509pki'), you probably need at least
 752 one trustfile (usually a CA bundle).  */)
 753   (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
 754 {
 755   int ret = GNUTLS_E_SUCCESS;
 756   int max_log_level = 0;
 757
 758   gnutls_session_t state;
 759   gnutls_certificate_credentials_t x509_cred = NULL;
 760   gnutls_anon_client_credentials_t anon_cred = NULL;
 761   Lisp_Object global_init;
 762   char const *priority_string_ptr = "NORMAL"; /* default priority string.  */
 763   unsigned int peer_verification;
 764   char* c_hostname;
 765
 766   /* Placeholders for the property list elements.  */
 767   Lisp_Object priority_string;
 768   Lisp_Object trustfiles;
 769   Lisp_Object crlfiles;
 770   Lisp_Object keylist;
 771   /* Lisp_Object callbacks; */
 772   Lisp_Object loglevel;
 773   Lisp_Object hostname;
 774   /* Lisp_Object verify_error; */
 775   Lisp_Object verify_hostname_error;
 776   Lisp_Object prime_bits;
 777
 778   CHECK_PROCESS (proc);
 779   CHECK_SYMBOL (type);
 780   CHECK_LIST (proplist);
 781
 782   if (NILP (Fgnutls_available_p ()))
 783     {
 784       error ("GnuTLS not available");
 785       return gnutls_make_error (GNUTLS_EMACS_ERROR_NOT_LOADED);
 786     }
 787
 788   if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
 789     {
 790       error ("Invalid GnuTLS credential type");
 791       return gnutls_make_error (GNUTLS_EMACS_ERROR_INVALID_TYPE);
 792     }
 793
 794   hostname              = Fplist_get (proplist, QCgnutls_bootprop_hostname);
 795   priority_string       = Fplist_get (proplist, QCgnutls_bootprop_priority);
 796   trustfiles            = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
 797   keylist               = Fplist_get (proplist, QCgnutls_bootprop_keylist);
 798   crlfiles              = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
 799   loglevel              = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
 800   verify_hostname_error = Fplist_get (proplist, QCgnutls_bootprop_verify_hostname_error);
 801   prime_bits            = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
 802
 803   if (!STRINGP (hostname))
 804     error ("gnutls-boot: invalid :hostname parameter");
 805   c_hostname = SSDATA (hostname);
 806
 807   state = XPROCESS (proc)->gnutls_state;
 808   XPROCESS (proc)->gnutls_p = 1;
 809
 810   if (TYPE_RANGED_INTEGERP (int, loglevel))
 811     {
 812       fn_gnutls_global_set_log_function (gnutls_log_function);
 813       fn_gnutls_global_set_log_level (XINT (loglevel));
 814       max_log_level = XINT (loglevel);
 815       XPROCESS (proc)->gnutls_log_level = max_log_level;
 816     }
 817
 818   /* always initialize globals.  */
 819   global_init = emacs_gnutls_global_init ();
 820   if (! NILP (Fgnutls_errorp (global_init)))
 821     return global_init;
 822
 823   /* Before allocating new credentials, deallocate any credentials
 824      that PROC might already have.  */
 825   emacs_gnutls_deinit (proc);
 826
 827   /* Mark PROC as a GnuTLS process.  */
 828   XPROCESS (proc)->gnutls_p = 1;
 829   XPROCESS (proc)->gnutls_state = NULL;
 830   XPROCESS (proc)->gnutls_x509_cred = NULL;
 831   XPROCESS (proc)->gnutls_anon_cred = NULL;
 832   XPROCESS (proc)->gnutls_cred_type = type;
 833   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
 834
 835   GNUTLS_LOG (1, max_log_level, "allocating credentials");
 836   if (EQ (type, Qgnutls_x509pki))
 837     {
 838       Lisp_Object verify_flags;
 839       unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
 840
 841       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
 842       fn_gnutls_certificate_allocate_credentials (&x509_cred);
 843       XPROCESS (proc)->gnutls_x509_cred = x509_cred;
 844
 845       verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
 846       if (NUMBERP (verify_flags))
 847         {
 848           gnutls_verify_flags = XINT (verify_flags);
 849           GNUTLS_LOG (2, max_log_level, "setting verification flags");
 850         }
 851       else if (NILP (verify_flags))
 852         GNUTLS_LOG (2, max_log_level, "using default verification flags");
 853       else
 854         GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
 855
 856       fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
 857     }
 858   else /* Qgnutls_anon: */
 859     {
 860       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
 861       fn_gnutls_anon_allocate_client_credentials (&anon_cred);
 862       XPROCESS (proc)->gnutls_anon_cred = anon_cred;
 863     }
 864
 865   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
 866
 867   if (EQ (type, Qgnutls_x509pki))
 868     {
 869       /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
 870       int file_format = GNUTLS_X509_FMT_PEM;
 871       Lisp_Object tail;
 872
 873       for (tail = trustfiles; !NILP (tail); tail = Fcdr (tail))
 874         {
 875           Lisp_Object trustfile = Fcar (tail);
 876           if (STRINGP (trustfile))
 877             {
 878               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
 879                            SSDATA (trustfile));
 880               ret = fn_gnutls_certificate_set_x509_trust_file
 881                 (x509_cred,
 882                  SSDATA (trustfile),
 883                  file_format);
 884
 885               if (ret < GNUTLS_E_SUCCESS)
 886                 return gnutls_make_error (ret);
 887             }
 888           else
 889             {
 890               emacs_gnutls_deinit (proc);
 891               error ("Invalid trustfile");
 892             }
 893         }
 894
 895       for (tail = crlfiles; !NILP (tail); tail = Fcdr (tail))
 896         {
 897           Lisp_Object crlfile = Fcar (tail);
 898           if (STRINGP (crlfile))
 899             {
 900               GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
 901                            SSDATA (crlfile));
 902               ret = fn_gnutls_certificate_set_x509_crl_file
 903                 (x509_cred, SSDATA (crlfile), file_format);
 904
 905               if (ret < GNUTLS_E_SUCCESS)
 906                 return gnutls_make_error (ret);
 907             }
 908           else
 909             {
 910               emacs_gnutls_deinit (proc);
 911               error ("Invalid CRL file");
 912             }
 913         }
 914
 915       for (tail = keylist; !NILP (tail); tail = Fcdr (tail))
 916         {
 917           Lisp_Object keyfile = Fcar (Fcar (tail));
 918           Lisp_Object certfile = Fcar (Fcdr (tail));
 919           if (STRINGP (keyfile) && STRINGP (certfile))
 920             {
 921               GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
 922                            SSDATA (keyfile));
 923               GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
 924                            SSDATA (certfile));
 925               ret = fn_gnutls_certificate_set_x509_key_file
 926                 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
 927
 928               if (ret < GNUTLS_E_SUCCESS)
 929                 return gnutls_make_error (ret);
 930             }
 931           else
 932             {
 933               emacs_gnutls_deinit (proc);
 934               error (STRINGP (keyfile) ? "Invalid client cert file"
 935                      : "Invalid client key file");
 936             }
 937         }
 938     }
 939
 940   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 941   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
 942   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
 943
 944   /* Call gnutls_init here: */
 945
 946   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 947   ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
 948   XPROCESS (proc)->gnutls_state = state;
 949   if (ret < GNUTLS_E_SUCCESS)
 950     return gnutls_make_error (ret);
 951   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
 952
 953   if (STRINGP (priority_string))
 954     {
 955       priority_string_ptr = SSDATA (priority_string);
 956       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
 957                    priority_string_ptr);
 958     }
 959   else
 960     {
 961       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
 962                    priority_string_ptr);
 963     }
 964
 965   GNUTLS_LOG (1, max_log_level, "setting the priority string");
 966   ret = fn_gnutls_priority_set_direct (state,
 967                                        priority_string_ptr,
 968                                        NULL);
 969   if (ret < GNUTLS_E_SUCCESS)
 970     return gnutls_make_error (ret);
 971
 972   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
 973
 974   if (INTEGERP (prime_bits))
 975     fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
 976
 977   ret = EQ (type, Qgnutls_x509pki)
 978     ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
 979     : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
 980   if (ret < GNUTLS_E_SUCCESS)
 981     return gnutls_make_error (ret);
 982
 983   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
 984   ret = emacs_gnutls_handshake (XPROCESS (proc));
 985   if (ret < GNUTLS_E_SUCCESS)
 986     return gnutls_make_error (ret);
 987
 988   /* Now verify the peer, following
 989      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
 990      The peer should present at least one certificate in the chain; do a
 991      check of the certificate's hostname with
 992      gnutls_x509_crt_check_hostname() against :hostname.  */
 993
 994   ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
 995   if (ret < GNUTLS_E_SUCCESS)
 996     return gnutls_make_error (ret);
 997
 998   if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
 999     message ("%s certificate could not be verified.", c_hostname);
1000
1001   if (peer_verification & GNUTLS_CERT_REVOKED)
1002     GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
1003                  c_hostname);
1004
1005   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
1006     GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
1007                  c_hostname);
1008
1009   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
1010     GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
1011                  c_hostname);
1012
1013   if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1014     GNUTLS_LOG2 (1, max_log_level,
1015                  "certificate was signed with an insecure algorithm:",
1016                  c_hostname);
1017
1018   if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
1019     GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
1020                  c_hostname);
1021
1022   if (peer_verification & GNUTLS_CERT_EXPIRED)
1023     GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
1024                  c_hostname);
1025
1026   if (peer_verification != 0)
1027     {
1028       if (NILP (verify_hostname_error))
1029         GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1030                      c_hostname);
1031       else
1032         {
1033           emacs_gnutls_deinit (proc);
1034           error ("Certificate validation failed %s, verification code %d",
1035                  c_hostname, peer_verification);
1036         }
1037     }
1038
1039   /* Up to here the process is the same for X.509 certificates and
1040      OpenPGP keys.  From now on X.509 certificates are assumed.  This
1041      can be easily extended to work with openpgp keys as well.  */
1042   if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1043     {
1044       gnutls_x509_crt_t gnutls_verify_cert;
1045       const gnutls_datum_t *gnutls_verify_cert_list;
1046       unsigned int gnutls_verify_cert_list_size;
1047
1048       ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
1049       if (ret < GNUTLS_E_SUCCESS)
1050         return gnutls_make_error (ret);
1051
1052       gnutls_verify_cert_list =
1053         fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1054
1055       if (gnutls_verify_cert_list == NULL)
1056         {
1057           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1058           emacs_gnutls_deinit (proc);
1059           error ("No x509 certificate was found\n");
1060         }
1061
1062       /* We only check the first certificate in the given chain.  */
1063       ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1064                                        &gnutls_verify_cert_list[0],
1065                                        GNUTLS_X509_FMT_DER);
1066
1067       if (ret < GNUTLS_E_SUCCESS)
1068         {
1069           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1070           return gnutls_make_error (ret);
1071         }
1072
1073       if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1074         {
1075           if (NILP (verify_hostname_error))
1076             GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1077                          c_hostname);
1078           else
1079             {
1080               fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1081               emacs_gnutls_deinit (proc);
1082               error ("The x509 certificate does not match \"%s\"", c_hostname);
1083             }
1084         }
1085       fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1086     }
1087
1088   return gnutls_make_error (ret);
1089 }
1090
1091 DEFUN ("gnutls-bye", Fgnutls_bye,
1092        Sgnutls_bye, 2, 2, 0,
1093        doc: /* Terminate current GnuTLS connection for process PROC.
1094 The connection should have been initiated using `gnutls-handshake'.
1095
1096 If CONT is not nil the TLS connection gets terminated and further
1097 receives and sends will be disallowed.  If the return value is zero you
1098 may continue using the connection.  If CONT is nil, GnuTLS actually
1099 sends an alert containing a close request and waits for the peer to
1100 reply with the same message.  In order to reuse the connection you
1101 should wait for an EOF from the peer.
1102
1103 This function may also return `gnutls-e-again', or
1104 `gnutls-e-interrupted'.  */)
1105     (Lisp_Object proc, Lisp_Object cont)
1106 {
1107   gnutls_session_t state;
1108   int ret;
1109
1110   CHECK_PROCESS (proc);
1111
1112   state = XPROCESS (proc)->gnutls_state;
1113
1114   ret = fn_gnutls_bye (state,
1115                        NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1116
1117   return gnutls_make_error (ret);
1118 }
1119
1120 void
1121 syms_of_gnutls (void)
1122 {
1123   gnutls_global_initialized = 0;
1124
1125   DEFSYM (Qgnutls_dll, "gnutls");
1126   DEFSYM (Qgnutls_code, "gnutls-code");
1127   DEFSYM (Qgnutls_anon, "gnutls-anon");
1128   DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1129   DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1130   DEFSYM (QCgnutls_bootprop_priority, ":priority");
1131   DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1132   DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1133   DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1134   DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1135   DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1136   DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1137   DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1138   DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1139   DEFSYM (QCgnutls_bootprop_verify_hostname_error, ":verify-hostname-error");
1140
1141   DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1142   Fput (Qgnutls_e_interrupted, Qgnutls_code,
1143         make_number (GNUTLS_E_INTERRUPTED));
1144
1145   DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1146   Fput (Qgnutls_e_again, Qgnutls_code,
1147         make_number (GNUTLS_E_AGAIN));
1148
1149   DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1150   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1151         make_number (GNUTLS_E_INVALID_SESSION));
1152
1153   DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1154   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1155         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1156
1157   defsubr (&Sgnutls_get_initstage);
1158   defsubr (&Sgnutls_errorp);
1159   defsubr (&Sgnutls_error_fatalp);
1160   defsubr (&Sgnutls_error_string);
1161   defsubr (&Sgnutls_boot);
1162   defsubr (&Sgnutls_deinit);
1163   defsubr (&Sgnutls_bye);
1164   defsubr (&Sgnutls_available_p);
1165
1166   DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1167               doc: /* Logging level used by the GnuTLS functions.
1168 Set this larger than 0 to get debug output in the *Messages* buffer.
1169 1 is for important messages, 2 is for debug data, and higher numbers
1170 are as per the GnuTLS logging conventions.  */);
1171   global_gnutls_log_level = 0;
1172 }
1173
1174 #endif /* HAVE_GNUTLS */