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 #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                                     (gnutls_transport_ptr_t) (long) proc->infd,
 340                                     (gnutls_transport_ptr_t) (long) 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
 790   gnutls_session_t state;
 791   gnutls_certificate_credentials_t x509_cred = NULL;
 792   gnutls_anon_client_credentials_t anon_cred = NULL;
 793   Lisp_Object global_init;
 794   char const *priority_string_ptr = "NORMAL"; /* default priority string.  */
 795   unsigned int peer_verification;
 796   char* c_hostname;
 797
 798   /* Placeholders for the property list elements.  */
 799   Lisp_Object priority_string;
 800   Lisp_Object trustfiles;
 801   Lisp_Object crlfiles;
 802   Lisp_Object keylist;
 803   /* Lisp_Object callbacks; */
 804   Lisp_Object loglevel;
 805   Lisp_Object hostname;
 806   Lisp_Object verify_error;
 807   Lisp_Object prime_bits;
 808
 809   CHECK_PROCESS (proc);
 810   CHECK_SYMBOL (type);
 811   CHECK_LIST (proplist);
 812
 813   if (NILP (Fgnutls_available_p ()))
 814     error ("GnuTLS not available");
 815
 816   if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
 817     error ("Invalid GnuTLS credential type");
 818
 819   hostname              = Fplist_get (proplist, QCgnutls_bootprop_hostname);
 820   priority_string       = Fplist_get (proplist, QCgnutls_bootprop_priority);
 821   trustfiles            = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
 822   keylist               = Fplist_get (proplist, QCgnutls_bootprop_keylist);
 823   crlfiles              = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
 824   loglevel              = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
 825   verify_error          = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
 826   prime_bits            = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
 827
 828   if (NILP (Flistp (verify_error)))
 829     error ("gnutls-boot: invalid :verify_error parameter (not a list)");
 830
 831   if (!STRINGP (hostname))
 832     error ("gnutls-boot: invalid :hostname parameter (not a string)");
 833   c_hostname = SSDATA (hostname);
 834
 835   state = XPROCESS (proc)->gnutls_state;
 836
 837   if (TYPE_RANGED_INTEGERP (int, loglevel))
 838     {
 839       fn_gnutls_global_set_log_function (gnutls_log_function);
 840 #ifdef HAVE_GNUTLS3
 841       fn_gnutls_global_set_audit_log_function (gnutls_audit_log_function);
 842 #endif
 843       fn_gnutls_global_set_log_level (XINT (loglevel));
 844       max_log_level = XINT (loglevel);
 845       XPROCESS (proc)->gnutls_log_level = max_log_level;
 846     }
 847
 848   /* always initialize globals.  */
 849   global_init = emacs_gnutls_global_init ();
 850   if (! NILP (Fgnutls_errorp (global_init)))
 851     return global_init;
 852
 853   /* Before allocating new credentials, deallocate any credentials
 854      that PROC might already have.  */
 855   emacs_gnutls_deinit (proc);
 856
 857   /* Mark PROC as a GnuTLS process.  */
 858   XPROCESS (proc)->gnutls_state = NULL;
 859   XPROCESS (proc)->gnutls_x509_cred = NULL;
 860   XPROCESS (proc)->gnutls_anon_cred = NULL;
 861   pset_gnutls_cred_type (XPROCESS (proc), type);
 862   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
 863
 864   GNUTLS_LOG (1, max_log_level, "allocating credentials");
 865   if (EQ (type, Qgnutls_x509pki))
 866     {
 867       Lisp_Object verify_flags;
 868       unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
 869
 870       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
 871       fn_gnutls_certificate_allocate_credentials (&x509_cred);
 872       XPROCESS (proc)->gnutls_x509_cred = x509_cred;
 873
 874       verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
 875       if (NUMBERP (verify_flags))
 876         {
 877           gnutls_verify_flags = XINT (verify_flags);
 878           GNUTLS_LOG (2, max_log_level, "setting verification flags");
 879         }
 880       else if (NILP (verify_flags))
 881         GNUTLS_LOG (2, max_log_level, "using default verification flags");
 882       else
 883         GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
 884
 885       fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
 886     }
 887   else /* Qgnutls_anon: */
 888     {
 889       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
 890       fn_gnutls_anon_allocate_client_credentials (&anon_cred);
 891       XPROCESS (proc)->gnutls_anon_cred = anon_cred;
 892     }
 893
 894   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
 895
 896   if (EQ (type, Qgnutls_x509pki))
 897     {
 898       /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
 899       int file_format = GNUTLS_X509_FMT_PEM;
 900       Lisp_Object tail;
 901
 902       for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
 903         {
 904           Lisp_Object trustfile = XCAR (tail);
 905           if (STRINGP (trustfile))
 906             {
 907               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
 908                            SSDATA (trustfile));
 909               trustfile = ENCODE_FILE (trustfile);
 910 #ifdef WINDOWSNT
 911               /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
 912                  file names on Windows, we need to re-encode the file
 913                  name using the current ANSI codepage.  */
 914               trustfile = ansi_encode_filename (trustfile);
 915 #endif
 916               ret = fn_gnutls_certificate_set_x509_trust_file
 917                 (x509_cred,
 918                  SSDATA (trustfile),
 919                  file_format);
 920
 921               if (ret < GNUTLS_E_SUCCESS)
 922                 return gnutls_make_error (ret);
 923             }
 924           else
 925             {
 926               emacs_gnutls_deinit (proc);
 927               error ("Invalid trustfile");
 928             }
 929         }
 930
 931       for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
 932         {
 933           Lisp_Object crlfile = XCAR (tail);
 934           if (STRINGP (crlfile))
 935             {
 936               GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
 937                            SSDATA (crlfile));
 938               crlfile = ENCODE_FILE (crlfile);
 939 #ifdef WINDOWSNT
 940               crlfile = ansi_encode_filename (crlfile);
 941 #endif
 942               ret = fn_gnutls_certificate_set_x509_crl_file
 943                 (x509_cred, SSDATA (crlfile), file_format);
 944
 945               if (ret < GNUTLS_E_SUCCESS)
 946                 return gnutls_make_error (ret);
 947             }
 948           else
 949             {
 950               emacs_gnutls_deinit (proc);
 951               error ("Invalid CRL file");
 952             }
 953         }
 954
 955       for (tail = keylist; CONSP (tail); tail = XCDR (tail))
 956         {
 957           Lisp_Object keyfile = Fcar (XCAR (tail));
 958           Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
 959           if (STRINGP (keyfile) && STRINGP (certfile))
 960             {
 961               GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
 962                            SSDATA (keyfile));
 963               GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
 964                            SSDATA (certfile));
 965               keyfile = ENCODE_FILE (keyfile);
 966               certfile = ENCODE_FILE (certfile);
 967 #ifdef WINDOWSNT
 968               keyfile = ansi_encode_filename (keyfile);
 969               certfile = ansi_encode_filename (certfile);
 970 #endif
 971               ret = fn_gnutls_certificate_set_x509_key_file
 972                 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
 973
 974               if (ret < GNUTLS_E_SUCCESS)
 975                 return gnutls_make_error (ret);
 976             }
 977           else
 978             {
 979               emacs_gnutls_deinit (proc);
 980               error (STRINGP (keyfile) ? "Invalid client cert file"
 981                      : "Invalid client key file");
 982             }
 983         }
 984     }
 985
 986   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 987   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
 988   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
 989
 990   /* Call gnutls_init here: */
 991
 992   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 993   ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
 994   XPROCESS (proc)->gnutls_state = state;
 995   if (ret < GNUTLS_E_SUCCESS)
 996     return gnutls_make_error (ret);
 997   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
 998
 999   if (STRINGP (priority_string))
1000     {
1001       priority_string_ptr = SSDATA (priority_string);
1002       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
1003                    priority_string_ptr);
1004     }
1005   else
1006     {
1007       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
1008                    priority_string_ptr);
1009     }
1010
1011   GNUTLS_LOG (1, max_log_level, "setting the priority string");
1012   ret = fn_gnutls_priority_set_direct (state,
1013                                        priority_string_ptr,
1014                                        NULL);
1015   if (ret < GNUTLS_E_SUCCESS)
1016     return gnutls_make_error (ret);
1017
1018   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
1019
1020   if (INTEGERP (prime_bits))
1021     fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
1022
1023   ret = EQ (type, Qgnutls_x509pki)
1024     ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
1025     : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
1026   if (ret < GNUTLS_E_SUCCESS)
1027     return gnutls_make_error (ret);
1028
1029   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
1030   ret = emacs_gnutls_handshake (XPROCESS (proc));
1031   if (ret < GNUTLS_E_SUCCESS)
1032     return gnutls_make_error (ret);
1033
1034   /* Now verify the peer, following
1035      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1036      The peer should present at least one certificate in the chain; do a
1037      check of the certificate's hostname with
1038      gnutls_x509_crt_check_hostname() against :hostname.  */
1039
1040   ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
1041   if (ret < GNUTLS_E_SUCCESS)
1042     return gnutls_make_error (ret);
1043
1044   if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
1045     message ("%s certificate could not be verified.", c_hostname);
1046
1047   if (peer_verification & GNUTLS_CERT_REVOKED)
1048     GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
1049                  c_hostname);
1050
1051   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
1052     GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
1053                  c_hostname);
1054
1055   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
1056     GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
1057                  c_hostname);
1058
1059   if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1060     GNUTLS_LOG2 (1, max_log_level,
1061                  "certificate was signed with an insecure algorithm:",
1062                  c_hostname);
1063
1064   if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
1065     GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
1066                  c_hostname);
1067
1068   if (peer_verification & GNUTLS_CERT_EXPIRED)
1069     GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
1070                  c_hostname);
1071
1072   if (peer_verification != 0)
1073     {
1074       if (!NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
1075         {
1076           emacs_gnutls_deinit (proc);
1077           error ("Certificate validation failed %s, verification code %d",
1078                  c_hostname, peer_verification);
1079         }
1080       else
1081         {
1082           GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1083                        c_hostname);
1084         }
1085     }
1086
1087   /* Up to here the process is the same for X.509 certificates and
1088      OpenPGP keys.  From now on X.509 certificates are assumed.  This
1089      can be easily extended to work with openpgp keys as well.  */
1090   if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1091     {
1092       gnutls_x509_crt_t gnutls_verify_cert;
1093       const gnutls_datum_t *gnutls_verify_cert_list;
1094       unsigned int gnutls_verify_cert_list_size;
1095
1096       ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
1097       if (ret < GNUTLS_E_SUCCESS)
1098         return gnutls_make_error (ret);
1099
1100       gnutls_verify_cert_list =
1101         fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1102
1103       if (gnutls_verify_cert_list == NULL)
1104         {
1105           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1106           emacs_gnutls_deinit (proc);
1107           error ("No x509 certificate was found\n");
1108         }
1109
1110       /* We only check the first certificate in the given chain.  */
1111       ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1112                                        &gnutls_verify_cert_list[0],
1113                                        GNUTLS_X509_FMT_DER);
1114
1115       if (ret < GNUTLS_E_SUCCESS)
1116         {
1117           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1118           return gnutls_make_error (ret);
1119         }
1120
1121       if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1122         {
1123           if (!NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
1124             {
1125               fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1126               emacs_gnutls_deinit (proc);
1127               error ("The x509 certificate does not match \"%s\"", c_hostname);
1128             }
1129           else
1130             {
1131               GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1132                            c_hostname);
1133             }
1134         }
1135       fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1136     }
1137
1138   /* Set this flag only if the whole initialization succeeded.  */
1139   XPROCESS (proc)->gnutls_p = 1;
1140
1141   return gnutls_make_error (ret);
1142 }
1143
1144 DEFUN ("gnutls-bye", Fgnutls_bye,
1145        Sgnutls_bye, 2, 2, 0,
1146        doc: /* Terminate current GnuTLS connection for process PROC.
1147 The connection should have been initiated using `gnutls-handshake'.
1148
1149 If CONT is not nil the TLS connection gets terminated and further
1150 receives and sends will be disallowed.  If the return value is zero you
1151 may continue using the connection.  If CONT is nil, GnuTLS actually
1152 sends an alert containing a close request and waits for the peer to
1153 reply with the same message.  In order to reuse the connection you
1154 should wait for an EOF from the peer.
1155
1156 This function may also return `gnutls-e-again', or
1157 `gnutls-e-interrupted'.  */)
1158     (Lisp_Object proc, Lisp_Object cont)
1159 {
1160   gnutls_session_t state;
1161   int ret;
1162
1163   CHECK_PROCESS (proc);
1164
1165   state = XPROCESS (proc)->gnutls_state;
1166
1167   ret = fn_gnutls_bye (state,
1168                        NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1169
1170   return gnutls_make_error (ret);
1171 }
1172
1173 void
1174 syms_of_gnutls (void)
1175 {
1176   gnutls_global_initialized = 0;
1177
1178   DEFSYM (Qgnutls_dll, "gnutls");
1179   DEFSYM (Qgnutls_code, "gnutls-code");
1180   DEFSYM (Qgnutls_anon, "gnutls-anon");
1181   DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1182   DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1183   DEFSYM (QCgnutls_bootprop_priority, ":priority");
1184   DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1185   DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1186   DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1187   DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1188   DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1189   DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1190   DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1191   DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1192   DEFSYM (QCgnutls_bootprop_verify_error, ":verify-error");
1193
1194   DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1195   Fput (Qgnutls_e_interrupted, Qgnutls_code,
1196         make_number (GNUTLS_E_INTERRUPTED));
1197
1198   DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1199   Fput (Qgnutls_e_again, Qgnutls_code,
1200         make_number (GNUTLS_E_AGAIN));
1201
1202   DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1203   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1204         make_number (GNUTLS_E_INVALID_SESSION));
1205
1206   DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1207   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1208         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1209
1210   defsubr (&Sgnutls_get_initstage);
1211   defsubr (&Sgnutls_errorp);
1212   defsubr (&Sgnutls_error_fatalp);
1213   defsubr (&Sgnutls_error_string);
1214   defsubr (&Sgnutls_boot);
1215   defsubr (&Sgnutls_deinit);
1216   defsubr (&Sgnutls_bye);
1217   defsubr (&Sgnutls_available_p);
1218
1219   DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1220               doc: /* Logging level used by the GnuTLS functions.
1221 Set this larger than 0 to get debug output in the *Messages* buffer.
1222 1 is for important messages, 2 is for debug data, and higher numbers
1223 are as per the GnuTLS logging conventions.  */);
1224   global_gnutls_log_level = 0;
1225 }
1226
1227 #endif /* HAVE_GNUTLS */