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 EMACS_INT
 342 emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, EMACS_INT nbyte)
 343 {
 344   ssize_t rtnval = 0;
 345   EMACS_INT 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 EMACS_INT
 397 emacs_gnutls_read (struct Lisp_Process *proc, char *buf, EMACS_INT 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 (!NUMBERP (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 (!NUMBERP (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   if (NUMBERP (loglevel))
 780     {
 781       fn_gnutls_global_set_log_function (gnutls_log_function);
 782       fn_gnutls_global_set_log_level (XINT (loglevel));
 783       max_log_level = XINT (loglevel);
 784       XPROCESS (proc)->gnutls_log_level = max_log_level;
 785     }
 786
 787   /* always initialize globals.  */
 788   global_init = emacs_gnutls_global_init ();
 789   if (! NILP (Fgnutls_errorp (global_init)))
 790     return global_init;
 791
 792   /* Before allocating new credentials, deallocate any credentials
 793      that PROC might already have.  */
 794   emacs_gnutls_deinit (proc);
 795
 796   /* Mark PROC as a GnuTLS process.  */
 797   XPROCESS (proc)->gnutls_p = 1;
 798   XPROCESS (proc)->gnutls_state = NULL;
 799   XPROCESS (proc)->gnutls_x509_cred = NULL;
 800   XPROCESS (proc)->gnutls_anon_cred = NULL;
 801   XPROCESS (proc)->gnutls_cred_type = type;
 802   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
 803
 804   GNUTLS_LOG (1, max_log_level, "allocating credentials");
 805   if (EQ (type, Qgnutls_x509pki))
 806     {
 807       Lisp_Object verify_flags;
 808       unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
 809
 810       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
 811       fn_gnutls_certificate_allocate_credentials (&x509_cred);
 812       XPROCESS (proc)->gnutls_x509_cred = x509_cred;
 813
 814       verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
 815       if (NUMBERP (verify_flags))
 816         {
 817           gnutls_verify_flags = XINT (verify_flags);
 818           GNUTLS_LOG (2, max_log_level, "setting verification flags");
 819         }
 820       else if (NILP (verify_flags))
 821         GNUTLS_LOG (2, max_log_level, "using default verification flags");
 822       else
 823         GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
 824
 825       fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
 826     }
 827   else /* Qgnutls_anon: */
 828     {
 829       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
 830       fn_gnutls_anon_allocate_client_credentials (&anon_cred);
 831       XPROCESS (proc)->gnutls_anon_cred = anon_cred;
 832     }
 833
 834   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
 835
 836   if (EQ (type, Qgnutls_x509pki))
 837     {
 838       /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
 839       int file_format = GNUTLS_X509_FMT_PEM;
 840       Lisp_Object tail;
 841
 842       for (tail = trustfiles; !NILP (tail); tail = Fcdr (tail))
 843         {
 844           Lisp_Object trustfile = Fcar (tail);
 845           if (STRINGP (trustfile))
 846             {
 847               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
 848                            SSDATA (trustfile));
 849               ret = fn_gnutls_certificate_set_x509_trust_file
 850                 (x509_cred,
 851                  SSDATA (trustfile),
 852                  file_format);
 853
 854               if (ret < GNUTLS_E_SUCCESS)
 855                 return gnutls_make_error (ret);
 856             }
 857           else
 858             {
 859               emacs_gnutls_deinit (proc);
 860               error ("Invalid trustfile");
 861             }
 862         }
 863
 864       for (tail = crlfiles; !NILP (tail); tail = Fcdr (tail))
 865         {
 866           Lisp_Object crlfile = Fcar (tail);
 867           if (STRINGP (crlfile))
 868             {
 869               GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
 870                            SSDATA (crlfile));
 871               ret = fn_gnutls_certificate_set_x509_crl_file
 872                 (x509_cred, SSDATA (crlfile), file_format);
 873
 874               if (ret < GNUTLS_E_SUCCESS)
 875                 return gnutls_make_error (ret);
 876             }
 877           else
 878             {
 879               emacs_gnutls_deinit (proc);
 880               error ("Invalid CRL file");
 881             }
 882         }
 883
 884       for (tail = keylist; !NILP (tail); tail = Fcdr (tail))
 885         {
 886           Lisp_Object keyfile = Fcar (Fcar (tail));
 887           Lisp_Object certfile = Fcar (Fcdr (tail));
 888           if (STRINGP (keyfile) && STRINGP (certfile))
 889             {
 890               GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
 891                            SSDATA (keyfile));
 892               GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
 893                            SSDATA (certfile));
 894               ret = fn_gnutls_certificate_set_x509_key_file
 895                 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
 896
 897               if (ret < GNUTLS_E_SUCCESS)
 898                 return gnutls_make_error (ret);
 899             }
 900           else
 901             {
 902               emacs_gnutls_deinit (proc);
 903               error (STRINGP (keyfile) ? "Invalid client cert file"
 904                      : "Invalid client key file");
 905             }
 906         }
 907     }
 908
 909   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 910   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
 911   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
 912
 913   /* Call gnutls_init here: */
 914
 915   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 916   ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
 917   XPROCESS (proc)->gnutls_state = state;
 918   if (ret < GNUTLS_E_SUCCESS)
 919     return gnutls_make_error (ret);
 920   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
 921
 922   if (STRINGP (priority_string))
 923     {
 924       priority_string_ptr = SSDATA (priority_string);
 925       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
 926                    priority_string_ptr);
 927     }
 928   else
 929     {
 930       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
 931                    priority_string_ptr);
 932     }
 933
 934   GNUTLS_LOG (1, max_log_level, "setting the priority string");
 935   ret = fn_gnutls_priority_set_direct (state,
 936                                        priority_string_ptr,
 937                                        NULL);
 938   if (ret < GNUTLS_E_SUCCESS)
 939     return gnutls_make_error (ret);
 940
 941   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
 942
 943   if (INTEGERP (prime_bits))
 944     fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
 945
 946   ret = EQ (type, Qgnutls_x509pki)
 947     ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
 948     : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
 949   if (ret < GNUTLS_E_SUCCESS)
 950     return gnutls_make_error (ret);
 951
 952   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
 953   ret = emacs_gnutls_handshake (XPROCESS (proc));
 954   if (ret < GNUTLS_E_SUCCESS)
 955     return gnutls_make_error (ret);
 956
 957   /* Now verify the peer, following
 958      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
 959      The peer should present at least one certificate in the chain; do a
 960      check of the certificate's hostname with
 961      gnutls_x509_crt_check_hostname() against :hostname.  */
 962
 963   ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
 964   if (ret < GNUTLS_E_SUCCESS)
 965     return gnutls_make_error (ret);
 966
 967   if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
 968     message ("%s certificate could not be verified.", c_hostname);
 969
 970   if (peer_verification & GNUTLS_CERT_REVOKED)
 971     GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
 972                  c_hostname);
 973
 974   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
 975     GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
 976                  c_hostname);
 977
 978   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
 979     GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
 980                  c_hostname);
 981
 982   if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
 983     GNUTLS_LOG2 (1, max_log_level,
 984                  "certificate was signed with an insecure algorithm:",
 985                  c_hostname);
 986
 987   if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
 988     GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
 989                  c_hostname);
 990
 991   if (peer_verification & GNUTLS_CERT_EXPIRED)
 992     GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
 993                  c_hostname);
 994
 995   if (peer_verification != 0)
 996     {
 997       if (NILP (verify_hostname_error))
 998         GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
 999                      c_hostname);
1000       else
1001         {
1002           emacs_gnutls_deinit (proc);
1003           error ("Certificate validation failed %s, verification code %d",
1004                  c_hostname, peer_verification);
1005         }
1006     }
1007
1008   /* Up to here the process is the same for X.509 certificates and
1009      OpenPGP keys.  From now on X.509 certificates are assumed.  This
1010      can be easily extended to work with openpgp keys as well.  */
1011   if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1012     {
1013       gnutls_x509_crt_t gnutls_verify_cert;
1014       const gnutls_datum_t *gnutls_verify_cert_list;
1015       unsigned int gnutls_verify_cert_list_size;
1016
1017       ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
1018       if (ret < GNUTLS_E_SUCCESS)
1019         return gnutls_make_error (ret);
1020
1021       gnutls_verify_cert_list =
1022         fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1023
1024       if (gnutls_verify_cert_list == NULL)
1025         {
1026           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1027           emacs_gnutls_deinit (proc);
1028           error ("No x509 certificate was found\n");
1029         }
1030
1031       /* We only check the first certificate in the given chain.  */
1032       ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1033                                        &gnutls_verify_cert_list[0],
1034                                        GNUTLS_X509_FMT_DER);
1035
1036       if (ret < GNUTLS_E_SUCCESS)
1037         {
1038           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1039           return gnutls_make_error (ret);
1040         }
1041
1042       if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1043         {
1044           if (NILP (verify_hostname_error))
1045             GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1046                          c_hostname);
1047           else
1048             {
1049               fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1050               emacs_gnutls_deinit (proc);
1051               error ("The x509 certificate does not match \"%s\"", c_hostname);
1052             }
1053         }
1054       fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1055     }
1056
1057   return gnutls_make_error (ret);
1058 }
1059
1060 DEFUN ("gnutls-bye", Fgnutls_bye,
1061        Sgnutls_bye, 2, 2, 0,
1062        doc: /* Terminate current GnuTLS connection for process PROC.
1063 The connection should have been initiated using `gnutls-handshake'.
1064
1065 If CONT is not nil the TLS connection gets terminated and further
1066 receives and sends will be disallowed.  If the return value is zero you
1067 may continue using the connection.  If CONT is nil, GnuTLS actually
1068 sends an alert containing a close request and waits for the peer to
1069 reply with the same message.  In order to reuse the connection you
1070 should wait for an EOF from the peer.
1071
1072 This function may also return `gnutls-e-again', or
1073 `gnutls-e-interrupted'.  */)
1074     (Lisp_Object proc, Lisp_Object cont)
1075 {
1076   gnutls_session_t state;
1077   int ret;
1078
1079   CHECK_PROCESS (proc);
1080
1081   state = XPROCESS (proc)->gnutls_state;
1082
1083   ret = fn_gnutls_bye (state,
1084                        NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1085
1086   return gnutls_make_error (ret);
1087 }
1088
1089 void
1090 syms_of_gnutls (void)
1091 {
1092   gnutls_global_initialized = 0;
1093
1094   DEFSYM (Qgnutls_dll, "gnutls");
1095   DEFSYM (Qgnutls_code, "gnutls-code");
1096   DEFSYM (Qgnutls_anon, "gnutls-anon");
1097   DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1098   DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1099   DEFSYM (QCgnutls_bootprop_priority, ":priority");
1100   DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1101   DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1102   DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1103   DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1104   DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1105   DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1106   DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1107   DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1108   DEFSYM (QCgnutls_bootprop_verify_hostname_error, ":verify-hostname-error");
1109
1110   DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1111   Fput (Qgnutls_e_interrupted, Qgnutls_code,
1112         make_number (GNUTLS_E_INTERRUPTED));
1113
1114   DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1115   Fput (Qgnutls_e_again, Qgnutls_code,
1116         make_number (GNUTLS_E_AGAIN));
1117
1118   DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1119   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1120         make_number (GNUTLS_E_INVALID_SESSION));
1121
1122   DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1123   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1124         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1125
1126   defsubr (&Sgnutls_get_initstage);
1127   defsubr (&Sgnutls_errorp);
1128   defsubr (&Sgnutls_error_fatalp);
1129   defsubr (&Sgnutls_error_string);
1130   defsubr (&Sgnutls_boot);
1131   defsubr (&Sgnutls_deinit);
1132   defsubr (&Sgnutls_bye);
1133   defsubr (&Sgnutls_available_p);
1134
1135   DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1136               doc: /* Logging level used by the GnuTLS functions.
1137 Set this larger than 0 to get debug output in the *Messages* buffer.
1138 1 is for important messages, 2 is for debug data, and higher numbers
1139 are as per the GnuTLS logging conventions.  */);
1140   global_gnutls_log_level = 0;
1141 }
1142
1143 #endif /* HAVE_GNUTLS */