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