src/gnutls.c

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