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 *, unsigned int));
 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 /* Initializes global GnuTLS state to defaults.
 677 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
 678 Returns zero on success.  */
 679 static Lisp_Object
 680 emacs_gnutls_global_init (void)
 681 {
 682   int ret = GNUTLS_E_SUCCESS;
 683
 684   if (!gnutls_global_initialized)
 685     {
 686       fn_gnutls_global_set_mem_functions (xmalloc, xmalloc, NULL,
 687                                           xrealloc, xfree);
 688       ret = fn_gnutls_global_init ();
 689     }
 690   gnutls_global_initialized = 1;
 691
 692   return gnutls_make_error (ret);
 693 }
 694
 695 #if 0
 696 /* Deinitializes global GnuTLS state.
 697 See also `gnutls-global-init'.  */
 698 static Lisp_Object
 699 emacs_gnutls_global_deinit (void)
 700 {
 701   if (gnutls_global_initialized)
 702     gnutls_global_deinit ();
 703
 704   gnutls_global_initialized = 0;
 705
 706   return gnutls_make_error (GNUTLS_E_SUCCESS);
 707 }
 708 #endif
 709
 710 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 711        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
 712 Currently only client mode is supported.  Return a success/failure
 713 value you can check with `gnutls-errorp'.
 714
 715 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
 716 PROPLIST is a property list with the following keys:
 717
 718 :hostname is a string naming the remote host.
 719
 720 :priority is a GnuTLS priority string, defaults to "NORMAL".
 721
 722 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
 723
 724 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
 725
 726 :keylist is an alist of PEM-encoded key files and PEM-encoded
 727 certificates for `gnutls-x509pki'.
 728
 729 :callbacks is an alist of callback functions, see below.
 730
 731 :loglevel is the debug level requested from GnuTLS, try 4.
 732
 733 :verify-flags is a bitset as per GnuTLS'
 734 gnutls_certificate_set_verify_flags.
 735
 736 :verify-hostname-error is ignored.  Pass :hostname in :verify-error
 737 instead.
 738
 739 :verify-error is a list of symbols to express verification checks or
 740 `t' to do all checks.  Currently it can contain `:trustfiles' and
 741 `:hostname' to verify the certificate or the hostname respectively.
 742
 743 :min-prime-bits is the minimum accepted number of bits the client will
 744 accept in Diffie-Hellman key exchange.
 745
 746 The debug level will be set for this process AND globally for GnuTLS.
 747 So if you set it higher or lower at any point, it affects global
 748 debugging.
 749
 750 Note that the priority is set on the client.  The server does not use
 751 the protocols's priority except for disabling protocols that were not
 752 specified.
 753
 754 Processes must be initialized with this function before other GnuTLS
 755 functions are used.  This function allocates resources which can only
 756 be deallocated by calling `gnutls-deinit' or by calling it again.
 757
 758 The callbacks alist can have a `verify' key, associated with a
 759 verification function (UNUSED).
 760
 761 Each authentication type may need additional information in order to
 762 work.  For X.509 PKI (`gnutls-x509pki'), you probably need at least
 763 one trustfile (usually a CA bundle).  */)
 764   (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
 765 {
 766   int ret = GNUTLS_E_SUCCESS;
 767   int max_log_level = 0;
 768   bool verify_error_all = 0;
 769
 770   gnutls_session_t state;
 771   gnutls_certificate_credentials_t x509_cred = NULL;
 772   gnutls_anon_client_credentials_t anon_cred = NULL;
 773   Lisp_Object global_init;
 774   char const *priority_string_ptr = "NORMAL"; /* default priority string.  */
 775   unsigned int peer_verification;
 776   char* c_hostname;
 777
 778   /* Placeholders for the property list elements.  */
 779   Lisp_Object priority_string;
 780   Lisp_Object trustfiles;
 781   Lisp_Object crlfiles;
 782   Lisp_Object keylist;
 783   /* Lisp_Object callbacks; */
 784   Lisp_Object loglevel;
 785   Lisp_Object hostname;
 786   Lisp_Object verify_error;
 787   Lisp_Object prime_bits;
 788
 789   CHECK_PROCESS (proc);
 790   CHECK_SYMBOL (type);
 791   CHECK_LIST (proplist);
 792
 793   if (NILP (Fgnutls_available_p ()))
 794     error ("GnuTLS not available");
 795
 796   if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
 797     error ("Invalid GnuTLS credential type");
 798
 799   hostname              = Fplist_get (proplist, QCgnutls_bootprop_hostname);
 800   priority_string       = Fplist_get (proplist, QCgnutls_bootprop_priority);
 801   trustfiles            = Fplist_get (proplist, QCgnutls_bootprop_trustfiles);
 802   keylist               = Fplist_get (proplist, QCgnutls_bootprop_keylist);
 803   crlfiles              = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
 804   loglevel              = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
 805   verify_error          = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
 806   prime_bits            = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
 807
 808   if (EQ (verify_error, Qt))
 809     {
 810       verify_error_all = 1;
 811     }
 812   else if (NILP (Flistp (verify_error)))
 813     {
 814       error ("gnutls-boot: invalid :verify_error parameter (not a list)");
 815     }
 816
 817   if (!STRINGP (hostname))
 818     error ("gnutls-boot: invalid :hostname parameter (not a string)");
 819   c_hostname = SSDATA (hostname);
 820
 821   state = XPROCESS (proc)->gnutls_state;
 822
 823   if (TYPE_RANGED_INTEGERP (int, loglevel))
 824     {
 825       fn_gnutls_global_set_log_function (gnutls_log_function);
 826 #ifdef HAVE_GNUTLS3
 827       fn_gnutls_global_set_audit_log_function (gnutls_audit_log_function);
 828 #endif
 829       fn_gnutls_global_set_log_level (XINT (loglevel));
 830       max_log_level = XINT (loglevel);
 831       XPROCESS (proc)->gnutls_log_level = max_log_level;
 832     }
 833
 834   /* always initialize globals.  */
 835   global_init = emacs_gnutls_global_init ();
 836   if (! NILP (Fgnutls_errorp (global_init)))
 837     return global_init;
 838
 839   /* Before allocating new credentials, deallocate any credentials
 840      that PROC might already have.  */
 841   emacs_gnutls_deinit (proc);
 842
 843   /* Mark PROC as a GnuTLS process.  */
 844   XPROCESS (proc)->gnutls_state = NULL;
 845   XPROCESS (proc)->gnutls_x509_cred = NULL;
 846   XPROCESS (proc)->gnutls_anon_cred = NULL;
 847   pset_gnutls_cred_type (XPROCESS (proc), type);
 848   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
 849
 850   GNUTLS_LOG (1, max_log_level, "allocating credentials");
 851   if (EQ (type, Qgnutls_x509pki))
 852     {
 853       Lisp_Object verify_flags;
 854       unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
 855
 856       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
 857       fn_gnutls_certificate_allocate_credentials (&x509_cred);
 858       XPROCESS (proc)->gnutls_x509_cred = x509_cred;
 859
 860       verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags);
 861       if (NUMBERP (verify_flags))
 862         {
 863           gnutls_verify_flags = XINT (verify_flags);
 864           GNUTLS_LOG (2, max_log_level, "setting verification flags");
 865         }
 866       else if (NILP (verify_flags))
 867         GNUTLS_LOG (2, max_log_level, "using default verification flags");
 868       else
 869         GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
 870
 871       fn_gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
 872     }
 873   else /* Qgnutls_anon: */
 874     {
 875       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
 876       fn_gnutls_anon_allocate_client_credentials (&anon_cred);
 877       XPROCESS (proc)->gnutls_anon_cred = anon_cred;
 878     }
 879
 880   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
 881
 882   if (EQ (type, Qgnutls_x509pki))
 883     {
 884       /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
 885       int file_format = GNUTLS_X509_FMT_PEM;
 886       Lisp_Object tail;
 887
 888       for (tail = trustfiles; CONSP (tail); tail = XCDR (tail))
 889         {
 890           Lisp_Object trustfile = XCAR (tail);
 891           if (STRINGP (trustfile))
 892             {
 893               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
 894                            SSDATA (trustfile));
 895               trustfile = ENCODE_FILE (trustfile);
 896 #ifdef WINDOWSNT
 897               /* Since GnuTLS doesn't support UTF-8 or UTF-16 encoded
 898                  file names on Windows, we need to re-encode the file
 899                  name using the current ANSI codepage.  */
 900               trustfile = ansi_encode_filename (trustfile);
 901 #endif
 902               ret = fn_gnutls_certificate_set_x509_trust_file
 903                 (x509_cred,
 904                  SSDATA (trustfile),
 905                  file_format);
 906
 907               if (ret < GNUTLS_E_SUCCESS)
 908                 return gnutls_make_error (ret);
 909             }
 910           else
 911             {
 912               emacs_gnutls_deinit (proc);
 913               error ("Invalid trustfile");
 914             }
 915         }
 916
 917       for (tail = crlfiles; CONSP (tail); tail = XCDR (tail))
 918         {
 919           Lisp_Object crlfile = XCAR (tail);
 920           if (STRINGP (crlfile))
 921             {
 922               GNUTLS_LOG2 (1, max_log_level, "setting the CRL file: ",
 923                            SSDATA (crlfile));
 924               crlfile = ENCODE_FILE (crlfile);
 925 #ifdef WINDOWSNT
 926               crlfile = ansi_encode_filename (crlfile);
 927 #endif
 928               ret = fn_gnutls_certificate_set_x509_crl_file
 929                 (x509_cred, SSDATA (crlfile), file_format);
 930
 931               if (ret < GNUTLS_E_SUCCESS)
 932                 return gnutls_make_error (ret);
 933             }
 934           else
 935             {
 936               emacs_gnutls_deinit (proc);
 937               error ("Invalid CRL file");
 938             }
 939         }
 940
 941       for (tail = keylist; CONSP (tail); tail = XCDR (tail))
 942         {
 943           Lisp_Object keyfile = Fcar (XCAR (tail));
 944           Lisp_Object certfile = Fcar (Fcdr (XCAR (tail)));
 945           if (STRINGP (keyfile) && STRINGP (certfile))
 946             {
 947               GNUTLS_LOG2 (1, max_log_level, "setting the client key file: ",
 948                            SSDATA (keyfile));
 949               GNUTLS_LOG2 (1, max_log_level, "setting the client cert file: ",
 950                            SSDATA (certfile));
 951               keyfile = ENCODE_FILE (keyfile);
 952               certfile = ENCODE_FILE (certfile);
 953 #ifdef WINDOWSNT
 954               keyfile = ansi_encode_filename (keyfile);
 955               certfile = ansi_encode_filename (certfile);
 956 #endif
 957               ret = fn_gnutls_certificate_set_x509_key_file
 958                 (x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
 959
 960               if (ret < GNUTLS_E_SUCCESS)
 961                 return gnutls_make_error (ret);
 962             }
 963           else
 964             {
 965               emacs_gnutls_deinit (proc);
 966               error (STRINGP (keyfile) ? "Invalid client cert file"
 967                      : "Invalid client key file");
 968             }
 969         }
 970     }
 971
 972   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 973   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
 974   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
 975
 976   /* Call gnutls_init here: */
 977
 978   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 979   ret = fn_gnutls_init (&state, GNUTLS_CLIENT);
 980   XPROCESS (proc)->gnutls_state = state;
 981   if (ret < GNUTLS_E_SUCCESS)
 982     return gnutls_make_error (ret);
 983   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
 984
 985   if (STRINGP (priority_string))
 986     {
 987       priority_string_ptr = SSDATA (priority_string);
 988       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
 989                    priority_string_ptr);
 990     }
 991   else
 992     {
 993       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
 994                    priority_string_ptr);
 995     }
 996
 997   GNUTLS_LOG (1, max_log_level, "setting the priority string");
 998   ret = fn_gnutls_priority_set_direct (state,
 999                                        priority_string_ptr,
1000                                        NULL);
1001   if (ret < GNUTLS_E_SUCCESS)
1002     return gnutls_make_error (ret);
1003
1004   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
1005
1006   if (INTEGERP (prime_bits))
1007     fn_gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
1008
1009   ret = EQ (type, Qgnutls_x509pki)
1010     ? fn_gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
1011     : fn_gnutls_credentials_set (state, GNUTLS_CRD_ANON, anon_cred);
1012   if (ret < GNUTLS_E_SUCCESS)
1013     return gnutls_make_error (ret);
1014
1015   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
1016   ret = emacs_gnutls_handshake (XPROCESS (proc));
1017   if (ret < GNUTLS_E_SUCCESS)
1018     return gnutls_make_error (ret);
1019
1020   /* Now verify the peer, following
1021      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1022      The peer should present at least one certificate in the chain; do a
1023      check of the certificate's hostname with
1024      gnutls_x509_crt_check_hostname() against :hostname.  */
1025
1026   ret = fn_gnutls_certificate_verify_peers2 (state, &peer_verification);
1027   if (ret < GNUTLS_E_SUCCESS)
1028     return gnutls_make_error (ret);
1029
1030   if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
1031     message ("%s certificate could not be verified.", c_hostname);
1032
1033   if (peer_verification & GNUTLS_CERT_REVOKED)
1034     GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
1035                  c_hostname);
1036
1037   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
1038     GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
1039                  c_hostname);
1040
1041   if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
1042     GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
1043                  c_hostname);
1044
1045   if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
1046     GNUTLS_LOG2 (1, max_log_level,
1047                  "certificate was signed with an insecure algorithm:",
1048                  c_hostname);
1049
1050   if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
1051     GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
1052                  c_hostname);
1053
1054   if (peer_verification & GNUTLS_CERT_EXPIRED)
1055     GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
1056                  c_hostname);
1057
1058   if (peer_verification != 0)
1059     {
1060       if (verify_error_all
1061           || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
1062         {
1063           emacs_gnutls_deinit (proc);
1064           error ("Certificate validation failed %s, verification code %d",
1065                  c_hostname, peer_verification);
1066         }
1067       else
1068         {
1069           GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1070                        c_hostname);
1071         }
1072     }
1073
1074   /* Up to here the process is the same for X.509 certificates and
1075      OpenPGP keys.  From now on X.509 certificates are assumed.  This
1076      can be easily extended to work with openpgp keys as well.  */
1077   if (fn_gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1078     {
1079       gnutls_x509_crt_t gnutls_verify_cert;
1080       const gnutls_datum_t *gnutls_verify_cert_list;
1081       unsigned int gnutls_verify_cert_list_size;
1082
1083       ret = fn_gnutls_x509_crt_init (&gnutls_verify_cert);
1084       if (ret < GNUTLS_E_SUCCESS)
1085         return gnutls_make_error (ret);
1086
1087       gnutls_verify_cert_list =
1088         fn_gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1089
1090       if (gnutls_verify_cert_list == NULL)
1091         {
1092           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1093           emacs_gnutls_deinit (proc);
1094           error ("No x509 certificate was found\n");
1095         }
1096
1097       /* We only check the first certificate in the given chain.  */
1098       ret = fn_gnutls_x509_crt_import (gnutls_verify_cert,
1099                                        &gnutls_verify_cert_list[0],
1100                                        GNUTLS_X509_FMT_DER);
1101
1102       if (ret < GNUTLS_E_SUCCESS)
1103         {
1104           fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1105           return gnutls_make_error (ret);
1106         }
1107
1108       if (!fn_gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
1109         {
1110           if (verify_error_all
1111               || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
1112             {
1113               fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1114               emacs_gnutls_deinit (proc);
1115               error ("The x509 certificate does not match \"%s\"", c_hostname);
1116             }
1117           else
1118             {
1119               GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1120                            c_hostname);
1121             }
1122         }
1123       fn_gnutls_x509_crt_deinit (gnutls_verify_cert);
1124     }
1125
1126   /* Set this flag only if the whole initialization succeeded.  */
1127   XPROCESS (proc)->gnutls_p = 1;
1128
1129   return gnutls_make_error (ret);
1130 }
1131
1132 DEFUN ("gnutls-bye", Fgnutls_bye,
1133        Sgnutls_bye, 2, 2, 0,
1134        doc: /* Terminate current GnuTLS connection for process PROC.
1135 The connection should have been initiated using `gnutls-handshake'.
1136
1137 If CONT is not nil the TLS connection gets terminated and further
1138 receives and sends will be disallowed.  If the return value is zero you
1139 may continue using the connection.  If CONT is nil, GnuTLS actually
1140 sends an alert containing a close request and waits for the peer to
1141 reply with the same message.  In order to reuse the connection you
1142 should wait for an EOF from the peer.
1143
1144 This function may also return `gnutls-e-again', or
1145 `gnutls-e-interrupted'.  */)
1146     (Lisp_Object proc, Lisp_Object cont)
1147 {
1148   gnutls_session_t state;
1149   int ret;
1150
1151   CHECK_PROCESS (proc);
1152
1153   state = XPROCESS (proc)->gnutls_state;
1154
1155   ret = fn_gnutls_bye (state,
1156                        NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
1157
1158   return gnutls_make_error (ret);
1159 }
1160
1161 #endif  /* HAVE_GNUTLS */
1162
1163 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
1164        doc: /* Return t if GnuTLS is available in this instance of Emacs.  */)
1165      (void)
1166 {
1167 #ifdef HAVE_GNUTLS
1168 # ifdef WINDOWSNT
1169   Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache);
1170   if (CONSP (found))
1171     return XCDR (found);
1172   else
1173     {
1174       Lisp_Object status;
1175       status = init_gnutls_functions () ? Qt : Qnil;
1176       Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache);
1177       return status;
1178     }
1179 # else  /* !WINDOWSNT */
1180   return Qt;
1181 # endif  /* !WINDOWSNT */
1182 #else  /* !HAVE_GNUTLS */
1183   return Qnil;
1184 #endif  /* !HAVE_GNUTLS */
1185 }
1186
1187 void
1188 syms_of_gnutls (void)
1189 {
1190 #ifdef HAVE_GNUTLS
1191   gnutls_global_initialized = 0;
1192
1193   DEFSYM (Qgnutls_dll, "gnutls");
1194   DEFSYM (Qgnutls_code, "gnutls-code");
1195   DEFSYM (Qgnutls_anon, "gnutls-anon");
1196   DEFSYM (Qgnutls_x509pki, "gnutls-x509pki");
1197   DEFSYM (QCgnutls_bootprop_hostname, ":hostname");
1198   DEFSYM (QCgnutls_bootprop_priority, ":priority");
1199   DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles");
1200   DEFSYM (QCgnutls_bootprop_keylist, ":keylist");
1201   DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles");
1202   DEFSYM (QCgnutls_bootprop_callbacks, ":callbacks");
1203   DEFSYM (QCgnutls_bootprop_callbacks_verify, "verify");
1204   DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits");
1205   DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel");
1206   DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags");
1207   DEFSYM (QCgnutls_bootprop_verify_error, ":verify-error");
1208
1209   DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
1210   Fput (Qgnutls_e_interrupted, Qgnutls_code,
1211         make_number (GNUTLS_E_INTERRUPTED));
1212
1213   DEFSYM (Qgnutls_e_again, "gnutls-e-again");
1214   Fput (Qgnutls_e_again, Qgnutls_code,
1215         make_number (GNUTLS_E_AGAIN));
1216
1217   DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
1218   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
1219         make_number (GNUTLS_E_INVALID_SESSION));
1220
1221   DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
1222   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
1223         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1224
1225   defsubr (&Sgnutls_get_initstage);
1226   defsubr (&Sgnutls_errorp);
1227   defsubr (&Sgnutls_error_fatalp);
1228   defsubr (&Sgnutls_error_string);
1229   defsubr (&Sgnutls_boot);
1230   defsubr (&Sgnutls_deinit);
1231   defsubr (&Sgnutls_bye);
1232
1233   DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level,
1234               doc: /* Logging level used by the GnuTLS functions.
1235 Set this larger than 0 to get debug output in the *Messages* buffer.
1236 1 is for important messages, 2 is for debug data, and higher numbers
1237 are as per the GnuTLS logging conventions.  */);
1238   global_gnutls_log_level = 0;
1239
1240 #endif  /* HAVE_GNUTLS */
1241
1242   defsubr (&Sgnutls_available_p);
1243 }