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