src/gnutls.c

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