src/gnutls.c

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