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