src/gnutls.c

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