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
 492       switch (err)
 493         {
 494         case GNUTLS_E_AGAIN:
 495           GNUTLS_LOG2 (3,
 496                        max_log_level,
 497                        "retry:",
 498                        str);
 499         default:
 500           GNUTLS_LOG2 (1,
 501                        max_log_level,
 502                        "non-fatal error:",
 503                        str);
 504         }
 505     }
 506
 507   if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
 508       || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
 509     {
 510       int alert = fn_gnutls_alert_get (session);
 511       int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
 512       str = fn_gnutls_alert_get_name (alert);
 513       if (!str)
 514         str = "unknown";
 515
 516       GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
 517     }
 518   return ret;
 519 }
 520
 521 /* convert an integer error to a Lisp_Object; it will be either a
 522    known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
 523    simply the integer value of the error.  GNUTLS_E_SUCCESS is mapped
 524    to Qt.  */
 525 static Lisp_Object
 526 gnutls_make_error (int err)
 527 {
 528   switch (err)
 529     {
 530     case GNUTLS_E_SUCCESS:
 531       return Qt;
 532     case GNUTLS_E_AGAIN:
 533       return Qgnutls_e_again;
 534     case GNUTLS_E_INTERRUPTED:
 535       return Qgnutls_e_interrupted;
 536     case GNUTLS_E_INVALID_SESSION:
 537       return Qgnutls_e_invalid_session;
 538     }
 539
 540   return make_number (err);
 541 }
 542
 543 Lisp_Object
 544 emacs_gnutls_deinit (Lisp_Object proc)
 545 {
 546   int log_level;
 547
 548   CHECK_PROCESS (proc);
 549
 550   if (XPROCESS (proc)->gnutls_p == 0)
 551     return Qnil;
 552
 553   log_level = XPROCESS (proc)->gnutls_log_level;
 554
 555   if (XPROCESS (proc)->gnutls_x509_cred)
 556     {
 557       GNUTLS_LOG (2, log_level, "Deallocating x509 credentials");
 558       fn_gnutls_certificate_free_credentials (XPROCESS (proc)->gnutls_x509_cred);
 559       XPROCESS (proc)->gnutls_x509_cred = NULL;
 560     }
 561
 562   if (XPROCESS (proc)->gnutls_anon_cred)
 563     {
 564       GNUTLS_LOG (2, log_level, "Deallocating anon credentials");
 565       fn_gnutls_anon_free_client_credentials (XPROCESS (proc)->gnutls_anon_cred);
 566       XPROCESS (proc)->gnutls_anon_cred = NULL;
 567     }
 568
 569   if (XPROCESS (proc)->gnutls_state)
 570     {
 571       fn_gnutls_deinit (XPROCESS (proc)->gnutls_state);
 572       XPROCESS (proc)->gnutls_state = NULL;
 573       if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 574         GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
 575     }
 576
 577   XPROCESS (proc)->gnutls_p = 0;
 578   return Qt;
 579 }
 580
 581 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
 582        doc: /* Return the GnuTLS init stage of process PROC.
 583 See also `gnutls-boot'.  */)
 584   (Lisp_Object proc)
 585 {
 586   CHECK_PROCESS (proc);
 587
 588   return make_number (GNUTLS_INITSTAGE (proc));
 589 }
 590
 591 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
 592        doc: /* Return t if ERROR indicates a GnuTLS problem.
 593 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 594 usage: (gnutls-errorp ERROR)  */)
 595   (Lisp_Object err)
 596 {
 597   if (EQ (err, Qt)) return Qnil;
 598
 599   return Qt;
 600 }
 601
 602 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
 603        doc: /* Check if ERROR is fatal.
 604 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 605 usage: (gnutls-error-fatalp ERROR)  */)
 606   (Lisp_Object err)
 607 {
 608   Lisp_Object code;
 609
 610   if (EQ (err, Qt)) return Qnil;
 611
 612   if (SYMBOLP (err))
 613     {
 614       code = Fget (err, Qgnutls_code);
 615       if (NUMBERP (code))
 616         {
 617           err = code;
 618         }
 619       else
 620         {
 621           error ("Symbol has no numeric gnutls-code property");
 622         }
 623     }
 624
 625   if (! TYPE_RANGED_INTEGERP (int, err))
 626     error ("Not an error symbol or code");
 627
 628   if (0 == fn_gnutls_error_is_fatal (XINT (err)))
 629     return Qnil;
 630
 631   return Qt;
 632 }
 633
 634 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
 635        doc: /* Return a description of ERROR.
 636 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 637 usage: (gnutls-error-string ERROR)  */)
 638   (Lisp_Object err)
 639 {
 640   Lisp_Object code;
 641
 642   if (EQ (err, Qt)) return build_string ("Not an error");
 643
 644   if (SYMBOLP (err))
 645     {
 646       code = Fget (err, Qgnutls_code);
 647       if (NUMBERP (code))
 648         {
 649           err = code;
 650         }
 651       else
 652         {
 653           return build_string ("Symbol has no numeric gnutls-code property");
 654         }
 655     }
 656
 657   if (! TYPE_RANGED_INTEGERP (int, err))
 658     return build_string ("Not an error symbol or code");
 659
 660   return build_string (fn_gnutls_strerror (XINT (err)));
 661 }
 662
 663 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
 664        doc: /* Deallocate GnuTLS resources associated with process PROC.
 665 See also `gnutls-init'.  */)
 666   (Lisp_Object proc)
 667 {
 668   return emacs_gnutls_deinit (proc);
 669 }
 670
 671 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
 672        doc: /* Return t if GnuTLS is available in this instance of Emacs.  */)
 673      (void)
 674 {
 675 #ifdef WINDOWSNT
 676   Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
 677   if (CONSP (found))
 678     return XCDR (found);
 679   else
 680     {
 681       Lisp_Object status;
 682       status = init_gnutls_functions () ? Qt : Qnil;
 683       Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
 684       return status;
 685     }
 686 #else
 687   return Qt;
 688 #endif
 689 }
 690
 691
 692 /* Initializes global GnuTLS state to defaults.
 693 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
 694 Returns zero on success.  */
 695 static Lisp_Object
 696 emacs_gnutls_global_init (void)
 697 {
 698   int ret = GNUTLS_E_SUCCESS;
 699
 700   if (!gnutls_global_initialized)
 701     {
 702       fn_gnutls_global_set_mem_functions (xmalloc, xmalloc, NULL,
 703                                           xrealloc, xfree);
 704       ret = fn_gnutls_global_init ();
 705     }
 706   gnutls_global_initialized = 1;
 707
 708   return gnutls_make_error (ret);
 709 }
 710
 711 #if 0
 712 /* Deinitializes global GnuTLS state.
 713 See also `gnutls-global-init'.  */
 714 static Lisp_Object
 715 emacs_gnutls_global_deinit (void)
 716 {
 717   if (gnutls_global_initialized)
 718     gnutls_global_deinit ();
 719
 720   gnutls_global_initialized = 0;
 721
 722   return gnutls_make_error (GNUTLS_E_SUCCESS);
 723 }
 724 #endif
 725
 726 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 727        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
 728 Currently only client mode is supported.  Return a success/failure
 729 value you can check with `gnutls-errorp'.
 730
 731 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
 732 PROPLIST is a property list with the following keys:
 733
 734 :hostname is a string naming the remote host.
 735
 736 :priority is a GnuTLS priority string, defaults to "NORMAL".
 737
 738 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
 739
 740 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
 741
 742 :keylist is an alist of PEM-encoded key files and PEM-encoded
 743 certificates for `gnutls-x509pki'.
 744
 745 :callbacks is an alist of callback functions, see below.
 746
 747 :loglevel is the debug level requested from GnuTLS, try 4.
 748
 749 :verify-flags is a bitset as per GnuTLS'
 750 gnutls_certificate_set_verify_flags.
 751
 752 :verify-hostname-error, if non-nil, makes a hostname mismatch an
 753 error.  Otherwise it will be just a warning.
 754
 755 :min-prime-bits is the minimum accepted number of bits the client will
 756 accept in Diffie-Hellman key exchange.
 757
 758 The debug level will be set for this process AND globally for GnuTLS.
 759 So if you set it higher or lower at any point, it affects global
 760 debugging.
 761
 762 Note that the priority is set on the client.  The server does not use
 763 the protocols's priority except for disabling protocols that were not
 764 specified.
 765
 766 Processes must be initialized with this function before other GnuTLS
 767 functions are used.  This function allocates resources which can only
 768 be deallocated by calling `gnutls-deinit' or by calling it again.
 769
 770 The callbacks alist can have a `verify' key, associated with a
 771 verification function (UNUSED).
 772
 773 Each authentication type may need additional information in order to
 774 work.  For X.509 PKI (`gnutls-x509pki'), you probably need at least
 775 one trustfile (usually a CA bundle).  */)
 776   (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
 777 {
 778   int ret = GNUTLS_E_SUCCESS;
 779   int max_log_level = 0;
 780
 781   gnutls_session_t state;
 782   gnutls_certificate_credentials_t x509_cred = NULL;
 783   gnutls_anon_client_credentials_t anon_cred = NULL;
 784   Lisp_Object global_init;
 785   char const *priority_string_ptr = "NORMAL"; /* default priority string.  */
 786   unsigned int peer_verification;
 787   char* c_hostname;
 788
 789   /* Placeholders for the property list elements.  */
 790   Lisp_Object priority_string;
 791   Lisp_Object trustfiles;
 792   Lisp_Object crlfiles;
 793   Lisp_Object keylist;
 794   /* Lisp_Object callbacks; */
 795   Lisp_Object loglevel;
 796   Lisp_Object hostname;
 797   /* Lisp_Object verify_error; */
 798   Lisp_Object verify_hostname_error;
 799   Lisp_Object prime_bits;
 800
 801   CHECK_PROCESS (proc);
 802   CHECK_SYMBOL (type);
 803   CHECK_LIST (proplist);
 804
 805   if (NILP (Fgnutls_available_p ()))
 806     error ("GnuTLS not available");
 807
 808   if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
 809     error ("Invalid GnuTLS credential type");
 810
 811   hostname              = Fplist_get (proplist, QCgnutls_bootprop_hostname);
 812   priority_string       = Fplist_get (proplist, QCgnutls_bootprop_priority);
 813   trustfiles            = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
 814   keylist               = Fplist_get (proplist, QCgnutls_bootprop_keylist);
 815   crlfiles              = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
 816   loglevel              = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
 817   verify_hostname_error = Fplist_get (proplist, QCgnutls_bootprop_verify_hostname_error);
 818   prime_bits            = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
 819
 820   if (!STRINGP (hostname))
 821     error ("gnutls-boot: invalid :hostname parameter");
 822   c_hostname = SSDATA (hostname);
 823
 824   state = XPROCESS (proc)->gnutls_state;
 825
 826   if (TYPE_RANGED_INTEGERP (int, loglevel))
 827     {
 828       fn_gnutls_global_set_log_function (gnutls_log_function);
 829 #ifdef HAVE_GNUTLS3
 830       fn_gnutls_global_set_audit_log_function (gnutls_audit_log_function);
 831 #endif
 832       fn_gnutls_global_set_log_level (XINT (loglevel));
 833       max_log_level = XINT (loglevel);
 834       XPROCESS (proc)->gnutls_log_level = max_log_level;
 835     }
 836
 837   /* always initialize globals.  */
 838   global_init = emacs_gnutls_global_init ();
 839   if (! NILP (Fgnutls_errorp (global_init)))
 840     return global_init;
 841
 842   /* Before allocating new credentials, deallocate any credentials
 843      that PROC might already have.  */
 844   emacs_gnutls_deinit (proc);
 845
 846   /* Mark PROC as a GnuTLS process.  */
 847   XPROCESS (proc)->gnutls_state = NULL;
 848   XPROCESS (proc)->gnutls_x509_cred = NULL;
 849   XPROCESS (proc)->gnutls_anon_cred = NULL;
 850   pset_gnutls_cred_type (XPROCESS (proc), type);
 851   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
 852
 853   GNUTLS_LOG (1, max_log_level, "allocating credentials");
 854   if (EQ (type, Qgnutls_x509pki))
 855     {
 856       Lisp_Object verify_flags;
 857       unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
 858
 859       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
 860       fn_gnutls_certificate_allocate_credentials (&x509_cred);
 861       XPROCESS (proc)->gnutls_x509_cred = x509_cred;
 862
 863       verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
 864       if (NUMBERP (verify_flags))
 865         {
 866           gnutls_verify_flags = XINT (verify_flags);
 867           GNUTLS_LOG (2, max_log_level, "setting verification flags");
 868         }
 869       else if (NILP (verify_flags))
 870         GNUTLS_LOG (2, max_log_level, "using default verification flags");
 871       else
 872         GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
 873
 874       fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
 875     }
 876   else /* Qgnutls_anon: */
 877     {
 878       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
 879       fn_gnutls_anon_allocate_client_credentials (&anon_cred);
 880       XPROCESS (proc)->gnutls_anon_cred = anon_cred;
 881     }
 882
 883   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
 884
 885   if (EQ (type, Qgnutls_x509pki))
 886     {
 887       /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
 888       int file_format = GNUTLS_X509_FMT_PEM;
 889       Lisp_Object tail;
 890
 891       for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
 892         {
 893           Lisp_Object trustfile = XCAR (tail);
 894           if (STRINGP (trustfile))
 895             {
 896               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
 897                            SSDATA (trustfile));
 898               ret = fn_gnutls_certificate_set_x509_trust_file
 899                 (x509_cred,
 900                  SSDATA (trustfile),
 901                  file_format);
 902
 903               if (ret < GNUTLS_E_SUCCESS)
 904                 return gnutls_make_error (ret);
 905             }
 906           else
 907             {
 908               emacs_gnutls_deinit (proc);
 909               error ("Invalid trustfile");
 910             }
 911         }
 912
 913       for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
 914         {
 915           Lisp_Object crlfile = XCAR (tail);
 916           if (STRINGP (crlfile))
 917             {
 918               GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
 919                            SSDATA (crlfile));
 920               ret = fn_gnutls_certificate_set_x509_crl_file
 921                 (x509_cred, SSDATA (crlfile), file_format);
 922
 923               if (ret < GNUTLS_E_SUCCESS)
 924                 return gnutls_make_error (ret);
 925             }
 926           else
 927             {
 928               emacs_gnutls_deinit (proc);
 929               error ("Invalid CRL file");
 930             }
 931         }
 932
 933       for (tail = keylist; CONSP (tail); tail = XCDR (tail))
 934         {
 935           Lisp_Object keyfile = Fcar (XCAR (tail));
 936           Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
 937           if (STRINGP (keyfile) && STRINGP (certfile))
 938             {
 939               GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
 940                            SSDATA (keyfile));
 941               GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
 942                            SSDATA (certfile));
 943               ret = fn_gnutls_certificate_set_x509_key_file
 944                 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
 945
 946               if (ret < GNUTLS_E_SUCCESS)
 947                 return gnutls_make_error (ret);
 948             }
 949           else
 950             {
 951               emacs_gnutls_deinit (proc);
 952               error (STRINGP (keyfile) ? "Invalid client cert file"
 953                      : "Invalid client key file");
 954             }
 955         }
 956     }
 957
 958   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 959   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
 960   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
 961
 962   /* Call gnutls_init here: */
 963
 964   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 965   ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
 966   XPROCESS (proc)->gnutls_state = state;
 967   if (ret < GNUTLS_E_SUCCESS)
 968     return gnutls_make_error (ret);
 969   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
 970
 971   if (STRINGP (priority_string))
 972     {
 973       priority_string_ptr = SSDATA (priority_string);
 974       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
 975                    priority_string_ptr);
 976     }
 977   else
 978     {
 979       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
 980                    priority_string_ptr);
 981     }
 982
 983   GNUTLS_LOG (1, max_log_level, "setting the priority string");
 984   ret = fn_gnutls_priority_set_direct (state,
 985                                        priority_string_ptr,
 986                                        NULL);
 987   if (ret < GNUTLS_E_SUCCESS)
 988     return gnutls_make_error (ret);
 989
 990   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
 991
 992   if (INTEGERP (prime_bits))
 993     fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
 994
 995   ret = EQ (type, Qgnutls_x509pki)
 996     ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
 997     : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
 998   if (ret < GNUTLS_E_SUCCESS)
 999     return gnutls_make_error (ret);
1000
1001   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
1002   ret = emacs_gnutls_handshake (XPROCESS (proc));
1003   if (ret < GNUTLS_E_SUCCESS)
1004     return gnutls_make_error (ret);
1005
1006   /* Now verify the peer, following
1007      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1008      The peer should present at least one certificate in the chain; do a
1009      check of the certificate's hostname with
1010      gnutls_x509_crt_check_hostname() against :hostname.  */
1011
1012   ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
1013   if (ret < GNUTLS_E_SUCCESS)
1014     return gnutls_make_error (ret);
1015
1016   if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
1017     message ("%s certificate could not be verified.", c_hostname);
1018
1019   if (peer_verification & GNUTLS_CERT_REVOKED)
1020     GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
1021                  c_hostname);
1022
1023   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
1024     GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
1025                  c_hostname);
1026
1027   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
1028     GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
1029                  c_hostname);
1030
1031   if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1032     GNUTLS_LOG2 (1, max_log_level,
1033                  "certificate was signed with an insecure algorithm:",
1034                  c_hostname);
1035
1036   if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
1037     GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
1038                  c_hostname);
1039
1040   if (peer_verification & GNUTLS_CERT_EXPIRED)
1041     GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
1042                  c_hostname);
1043
1044   if (peer_verification != 0)
1045     {
1046       if (NILP (verify_hostname_error))
1047         GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1048                      c_hostname);
1049       else
1050         {
1051           emacs_gnutls_deinit (proc);
1052           error ("Certificate validation failed %s, verification code %d",
1053                  c_hostname, peer_verification);
1054         }
1055     }
1056
1057   /* Up to here the process is the same for X.509 certificates and
1058      OpenPGP keys.  From now on X.509 certificates are assumed.  This
1059      can be easily extended to work with openpgp keys as well.  */
1060   if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1061     {
1062       gnutls_x509_crt_t gnutls_verify_cert;
1063       const gnutls_datum_t *gnutls_verify_cert_list;
1064       unsigned int gnutls_verify_cert_list_size;
1065
1066       ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
1067       if (ret < GNUTLS_E_SUCCESS)
1068         return gnutls_make_error (ret);
1069
1070       gnutls_verify_cert_list =
1071         fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1072
1073       if (gnutls_verify_cert_list == NULL)
1074         {
1075           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1076           emacs_gnutls_deinit (proc);
1077           error ("No x509 certificate was found\n");
1078         }
1079
1080       /* We only check the first certificate in the given chain.  */
1081       ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1082                                        &gnutls_verify_cert_list[0],
1083                                        GNUTLS_X509_FMT_DER);
1084
1085       if (ret < GNUTLS_E_SUCCESS)
1086         {
1087           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1088           return gnutls_make_error (ret);
1089         }
1090
1091       if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1092         {
1093           if (NILP (verify_hostname_error))
1094             GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1095                          c_hostname);
1096           else
1097             {
1098               fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1099               emacs_gnutls_deinit (proc);
1100               error ("The x509 certificate does not match \"%s\"", c_hostname);
1101             }
1102         }
1103       fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1104     }
1105
1106   /* Set this flag only if the whole initialization succeeded.  */
1107   XPROCESS (proc)->gnutls_p = 1;
1108
1109   return gnutls_make_error (ret);
1110 }
1111
1112 DEFUN ("gnutls-bye", Fgnutls_bye,
1113        Sgnutls_bye, 2, 2, 0,
1114        doc: /* Terminate current GnuTLS connection for process PROC.
1115 The connection should have been initiated using `gnutls-handshake'.
1116
1117 If CONT is not nil the TLS connection gets terminated and further
1118 receives and sends will be disallowed.  If the return value is zero you
1119 may continue using the connection.  If CONT is nil, GnuTLS actually
1120 sends an alert containing a close request and waits for the peer to
1121 reply with the same message.  In order to reuse the connection you
1122 should wait for an EOF from the peer.
1123
1124 This function may also return `gnutls-e-again', or
1125 `gnutls-e-interrupted'.  */)
1126     (Lisp_Object proc, Lisp_Object cont)
1127 {
1128   gnutls_session_t state;
1129   int ret;
1130
1131   CHECK_PROCESS (proc);
1132
1133   state = XPROCESS (proc)->gnutls_state;
1134
1135   ret = fn_gnutls_bye (state,
1136                        NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1137
1138   return gnutls_make_error (ret);
1139 }
1140
1141 void
1142 syms_of_gnutls (void)
1143 {
1144   gnutls_global_initialized = 0;
1145
1146   DEFSYM (Qgnutls_dll, "gnutls");
1147   DEFSYM (Qgnutls_code, "gnutls-code");
1148   DEFSYM (Qgnutls_anon, "gnutls-anon");
1149   DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1150   DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1151   DEFSYM (QCgnutls_bootprop_priority, ":priority");
1152   DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1153   DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1154   DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1155   DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1156   DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1157   DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1158   DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1159   DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1160   DEFSYM (QCgnutls_bootprop_verify_hostname_error, ":verify-hostname-error");
1161
1162   DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1163   Fput (Qgnutls_e_interrupted, Qgnutls_code,
1164         make_number (GNUTLS_E_INTERRUPTED));
1165
1166   DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1167   Fput (Qgnutls_e_again, Qgnutls_code,
1168         make_number (GNUTLS_E_AGAIN));
1169
1170   DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1171   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1172         make_number (GNUTLS_E_INVALID_SESSION));
1173
1174   DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1175   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1176         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1177
1178   defsubr (&Sgnutls_get_initstage);
1179   defsubr (&Sgnutls_errorp);
1180   defsubr (&Sgnutls_error_fatalp);
1181   defsubr (&Sgnutls_error_string);
1182   defsubr (&Sgnutls_boot);
1183   defsubr (&Sgnutls_deinit);
1184   defsubr (&Sgnutls_bye);
1185   defsubr (&Sgnutls_available_p);
1186
1187   DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1188               doc: /* Logging level used by the GnuTLS functions.
1189 Set this larger than 0 to get debug output in the *Messages* buffer.
1190 1 is for important messages, 2 is for debug data, and higher numbers
1191 are as per the GnuTLS logging conventions.  */);
1192   global_gnutls_log_level = 0;
1193 }
1194
1195 #endif /* HAVE_GNUTLS */