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