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