src/gnutls.c

   1 /* GnuTLS glue for GNU Emacs.
   2    Copyright (C) 2010-2011  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 #include <setjmp.h>
  22
  23 #include "lisp.h"
  24 #include "process.h"
  25
  26 #ifdef HAVE_GNUTLS
  27 #include <gnutls/gnutls.h>
  28
  29 #ifdef WINDOWSNT
  30 #include <windows.h>
  31 #include "w32.h"
  32 #endif
  33
  34 static int
  35 emacs_gnutls_handle_error (gnutls_session_t, int err);
  36
  37 Lisp_Object Qgnutls_log_level;
  38 Lisp_Object Qgnutls_code;
  39 Lisp_Object Qgnutls_anon, Qgnutls_x509pki;
  40 Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again,
  41   Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake;
  42 int gnutls_global_initialized;
  43
  44 /* The following are for the property list of `gnutls-boot'.  */
  45 Lisp_Object Qgnutls_bootprop_priority;
  46 Lisp_Object Qgnutls_bootprop_trustfiles;
  47 Lisp_Object Qgnutls_bootprop_keyfiles;
  48 Lisp_Object Qgnutls_bootprop_callbacks;
  49 Lisp_Object Qgnutls_bootprop_loglevel;
  50 Lisp_Object Qgnutls_bootprop_hostname;
  51 Lisp_Object Qgnutls_bootprop_verify_flags;
  52 Lisp_Object Qgnutls_bootprop_verify_error;
  53 Lisp_Object Qgnutls_bootprop_verify_hostname_error;
  54
  55 /* Callback keys for `gnutls-boot'.  Unused currently.  */
  56 Lisp_Object Qgnutls_bootprop_callbacks_verify;
  57
  58 static void
  59 gnutls_log_function (int level, const char* string)
  60 {
  61   message ("gnutls.c: [%d] %s", level, string);
  62 }
  63
  64 static void
  65 gnutls_log_function2 (int level, const char* string, const char* extra)
  66 {
  67   message ("gnutls.c: [%d] %s %s", level, string, extra);
  68 }
  69
  70 static int
  71 emacs_gnutls_handshake (struct Lisp_Process *proc)
  72 {
  73   gnutls_session_t state = proc->gnutls_state;
  74   int ret;
  75
  76   if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
  77     return -1;
  78
  79   if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
  80     {
  81 #ifdef WINDOWSNT
  82       /* On W32 we cannot transfer socket handles between different runtime
  83          libraries, so we tell GnuTLS to use our special push/pull
  84          functions.  */
  85       gnutls_transport_set_ptr2 (state,
  86                                  (gnutls_transport_ptr_t) proc,
  87                                  (gnutls_transport_ptr_t) proc);
  88       gnutls_transport_set_push_function (state, &emacs_gnutls_push);
  89       gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
  90
  91       /* For non blocking sockets or other custom made pull/push
  92          functions the gnutls_transport_set_lowat must be called, with
  93          a zero low water mark value. (GnuTLS 2.10.4 documentation)
  94
  95          (Note: this is probably not strictly necessary as the lowat
  96           value is only used when no custom pull/push functions are
  97           set.)  */
  98       gnutls_transport_set_lowat (state, 0);
  99 #else
 100       /* This is how GnuTLS takes sockets: as file descriptors passed
 101          in.  For an Emacs process socket, infd and outfd are the
 102          same but we use this two-argument version for clarity.  */
 103       gnutls_transport_set_ptr2 (state,
 104                                  (gnutls_transport_ptr_t) (long) proc->infd,
 105                                  (gnutls_transport_ptr_t) (long) proc->outfd);
 106 #endif
 107
 108       proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
 109     }
 110
 111   do
 112     {
 113       ret = gnutls_handshake (state);
 114       emacs_gnutls_handle_error (state, ret);
 115     }
 116   while (ret < 0 && gnutls_error_is_fatal (ret) == 0);
 117
 118   proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
 119
 120   if (ret == GNUTLS_E_SUCCESS)
 121     {
 122       /* Here we're finally done.  */
 123       proc->gnutls_initstage = GNUTLS_STAGE_READY;
 124     }
 125   else
 126     {
 127         gnutls_alert_send_appropriate (state, ret);
 128     }
 129   return ret;
 130 }
 131
 132 EMACS_INT
 133 emacs_gnutls_write (int fildes, struct Lisp_Process *proc, const char *buf,
 134                     EMACS_INT nbyte)
 135 {
 136   ssize_t rtnval = 0;
 137   EMACS_INT bytes_written;
 138   gnutls_session_t state = proc->gnutls_state;
 139
 140   if (proc->gnutls_initstage != GNUTLS_STAGE_READY) {
 141 #ifdef EWOULDBLOCK
 142     errno = EWOULDBLOCK;
 143 #endif
 144 #ifdef EAGAIN
 145     errno = EAGAIN;
 146 #endif
 147     return 0;
 148   }
 149
 150   bytes_written = 0;
 151
 152   while (nbyte > 0)
 153     {
 154       rtnval = gnutls_write (state, buf, nbyte);
 155
 156       if (rtnval < 0)
 157         {
 158           if (rtnval == GNUTLS_E_AGAIN || rtnval == GNUTLS_E_INTERRUPTED)
 159             continue;
 160           else
 161             break;
 162         }
 163
 164       buf += rtnval;
 165       nbyte -= rtnval;
 166       bytes_written += rtnval;
 167     }
 168
 169   emacs_gnutls_handle_error (state, rtnval);
 170   return (bytes_written);
 171 }
 172
 173 EMACS_INT
 174 emacs_gnutls_read (int fildes, struct Lisp_Process *proc, char *buf,
 175                    EMACS_INT nbyte)
 176 {
 177   ssize_t rtnval;
 178   gnutls_session_t state = proc->gnutls_state;
 179
 180   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
 181     {
 182       emacs_gnutls_handshake (proc);
 183       return -1;
 184     }
 185   rtnval = gnutls_read (state, buf, nbyte);
 186   if (rtnval >= 0)
 187     return rtnval;
 188   else if (emacs_gnutls_handle_error (state, rtnval) == 0)
 189     /* non-fatal error */
 190     return -1;
 191   else {
 192     /* a fatal error occured */
 193     return 0;
 194   }
 195 }
 196
 197 /* report a GnuTLS error to the user.
 198    Returns zero if the error code was successfully handled. */
 199 static int
 200 emacs_gnutls_handle_error (gnutls_session_t session, int err)
 201 {
 202   Lisp_Object gnutls_log_level = Fsymbol_value (Qgnutls_log_level);
 203   int max_log_level = 0;
 204
 205   int ret;
 206   const char *str;
 207
 208   /* TODO: use a Lisp_Object generated by gnutls_make_error?  */
 209   if (err >= 0)
 210     return 0;
 211
 212   if (NUMBERP (gnutls_log_level))
 213     max_log_level = XINT (gnutls_log_level);
 214
 215   /* TODO: use gnutls-error-fatalp and gnutls-error-string.  */
 216
 217   str = gnutls_strerror (err);
 218   if (!str)
 219     str = "unknown";
 220
 221   if (gnutls_error_is_fatal (err))
 222     {
 223       ret = err;
 224       GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
 225     }
 226   else
 227     {
 228       ret = 0;
 229       GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str);
 230       /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2.  */
 231     }
 232
 233   if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
 234       || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
 235     {
 236       int alert = gnutls_alert_get (session);
 237       int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
 238       str = gnutls_alert_get_name (alert);
 239       if (!str)
 240         str = "unknown";
 241
 242       GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
 243     }
 244   return ret;
 245 }
 246
 247 /* convert an integer error to a Lisp_Object; it will be either a
 248    known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
 249    simply the integer value of the error.  GNUTLS_E_SUCCESS is mapped
 250    to Qt.  */
 251 static Lisp_Object
 252 gnutls_make_error (int err)
 253 {
 254   switch (err)
 255     {
 256     case GNUTLS_E_SUCCESS:
 257       return Qt;
 258     case GNUTLS_E_AGAIN:
 259       return Qgnutls_e_again;
 260     case GNUTLS_E_INTERRUPTED:
 261       return Qgnutls_e_interrupted;
 262     case GNUTLS_E_INVALID_SESSION:
 263       return Qgnutls_e_invalid_session;
 264     }
 265
 266   return make_number (err);
 267 }
 268
 269 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
 270        doc: /* Return the GnuTLS init stage of process PROC.
 271 See also `gnutls-boot'.  */)
 272   (Lisp_Object proc)
 273 {
 274   CHECK_PROCESS (proc);
 275
 276   return make_number (GNUTLS_INITSTAGE (proc));
 277 }
 278
 279 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
 280        doc: /* Return t if ERROR indicates a GnuTLS problem.
 281 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 282 usage: (gnutls-errorp ERROR)  */)
 283   (Lisp_Object err)
 284 {
 285   if (EQ (err, Qt)) return Qnil;
 286
 287   return Qt;
 288 }
 289
 290 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
 291        doc: /* Check if ERROR is fatal.
 292 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 293 usage: (gnutls-error-fatalp ERROR)  */)
 294   (Lisp_Object err)
 295 {
 296   Lisp_Object code;
 297
 298   if (EQ (err, Qt)) return Qnil;
 299
 300   if (SYMBOLP (err))
 301     {
 302       code = Fget (err, Qgnutls_code);
 303       if (NUMBERP (code))
 304         {
 305           err = code;
 306         }
 307       else
 308         {
 309           error ("Symbol has no numeric gnutls-code property");
 310         }
 311     }
 312
 313   if (!NUMBERP (err))
 314     error ("Not an error symbol or code");
 315
 316   if (0 == gnutls_error_is_fatal (XINT (err)))
 317     return Qnil;
 318
 319   return Qt;
 320 }
 321
 322 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
 323        doc: /* Return a description of ERROR.
 324 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 325 usage: (gnutls-error-string ERROR)  */)
 326   (Lisp_Object err)
 327 {
 328   Lisp_Object code;
 329
 330   if (EQ (err, Qt)) return build_string ("Not an error");
 331
 332   if (SYMBOLP (err))
 333     {
 334       code = Fget (err, Qgnutls_code);
 335       if (NUMBERP (code))
 336         {
 337           err = code;
 338         }
 339       else
 340         {
 341           return build_string ("Symbol has no numeric gnutls-code property");
 342         }
 343     }
 344
 345   if (!NUMBERP (err))
 346     return build_string ("Not an error symbol or code");
 347
 348   return build_string (gnutls_strerror (XINT (err)));
 349 }
 350
 351 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
 352        doc: /* Deallocate GnuTLS resources associated with process PROC.
 353 See also `gnutls-init'.  */)
 354   (Lisp_Object proc)
 355 {
 356   gnutls_session_t state;
 357
 358   CHECK_PROCESS (proc);
 359   state = XPROCESS (proc)->gnutls_state;
 360
 361   if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 362     {
 363       gnutls_deinit (state);
 364       GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
 365     }
 366
 367   return Qt;
 368 }
 369
 370 /* Initializes global GnuTLS state to defaults.
 371 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
 372 Returns zero on success.  */
 373 static Lisp_Object
 374 emacs_gnutls_global_init (void)
 375 {
 376   int ret = GNUTLS_E_SUCCESS;
 377
 378   if (!gnutls_global_initialized)
 379     ret = gnutls_global_init ();
 380
 381   gnutls_global_initialized = 1;
 382
 383   return gnutls_make_error (ret);
 384 }
 385
 386 #if 0
 387 /* Deinitializes global GnuTLS state.
 388 See also `gnutls-global-init'.  */
 389 static Lisp_Object
 390 emacs_gnutls_global_deinit (void)
 391 {
 392   if (gnutls_global_initialized)
 393     gnutls_global_deinit ();
 394
 395   gnutls_global_initialized = 0;
 396
 397   return gnutls_make_error (GNUTLS_E_SUCCESS);
 398 }
 399 #endif
 400
 401 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 402        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
 403 Currently only client mode is supported.  Returns a success/failure
 404 value you can check with `gnutls-errorp'.
 405
 406 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
 407 PROPLIST is a property list with the following keys:
 408
 409 :hostname is a string naming the remote host.
 410
 411 :priority is a GnuTLS priority string, defaults to "NORMAL".
 412
 413 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
 414
 415 :keyfiles is a list of PEM-encoded key files for `gnutls-x509pki'.
 416
 417 :callbacks is an alist of callback functions, see below.
 418
 419 :loglevel is the debug level requested from GnuTLS, try 4.
 420
 421 :verify-flags is a bitset as per GnuTLS'
 422 gnutls_certificate_set_verify_flags.
 423
 424 :verify-error, if non-nil, makes failure of the certificate validation
 425 an error.  Otherwise it will be just a series of warnings.
 426
 427 :verify-hostname-error, if non-nil, makes a hostname mismatch an
 428 error.  Otherwise it will be just a warning.
 429
 430 The debug level will be set for this process AND globally for GnuTLS.
 431 So if you set it higher or lower at any point, it affects global
 432 debugging.
 433
 434 Note that the priority is set on the client.  The server does not use
 435 the protocols's priority except for disabling protocols that were not
 436 specified.
 437
 438 Processes must be initialized with this function before other GnuTLS
 439 functions are used.  This function allocates resources which can only
 440 be deallocated by calling `gnutls-deinit' or by calling it again.
 441
 442 The callbacks alist can have a `verify' key, associated with a
 443 verification function (UNUSED).
 444
 445 Each authentication type may need additional information in order to
 446 work.  For X.509 PKI (`gnutls-x509pki'), you probably need at least
 447 one trustfile (usually a CA bundle).  */)
 448   (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
 449 {
 450   int ret = GNUTLS_E_SUCCESS;
 451
 452   int max_log_level = 0;
 453
 454   /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
 455   int file_format = GNUTLS_X509_FMT_PEM;
 456
 457   unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
 458   gnutls_x509_crt_t gnutls_verify_cert;
 459   unsigned int gnutls_verify_cert_list_size;
 460   const gnutls_datum_t *gnutls_verify_cert_list;
 461
 462   gnutls_session_t state;
 463   gnutls_certificate_credentials_t x509_cred;
 464   gnutls_anon_client_credentials_t anon_cred;
 465   Lisp_Object global_init;
 466   char const *priority_string_ptr = "NORMAL"; /* default priority string.  */
 467   Lisp_Object tail;
 468   unsigned int peer_verification;
 469   char* c_hostname;
 470
 471   /* Placeholders for the property list elements.  */
 472   Lisp_Object priority_string;
 473   Lisp_Object trustfiles;
 474   Lisp_Object keyfiles;
 475   /* Lisp_Object callbacks; */
 476   Lisp_Object loglevel;
 477   Lisp_Object hostname;
 478   Lisp_Object verify_flags;
 479   /* Lisp_Object verify_error; */
 480   Lisp_Object verify_hostname_error;
 481
 482   CHECK_PROCESS (proc);
 483   CHECK_SYMBOL (type);
 484   CHECK_LIST (proplist);
 485
 486   hostname              = Fplist_get (proplist, Qgnutls_bootprop_hostname);
 487   priority_string       = Fplist_get (proplist, Qgnutls_bootprop_priority);
 488   trustfiles            = Fplist_get (proplist, Qgnutls_bootprop_trustfiles);
 489   keyfiles              = Fplist_get (proplist, Qgnutls_bootprop_keyfiles);
 490   /* callbacks          = Fplist_get (proplist, Qgnutls_bootprop_callbacks); */
 491   loglevel              = Fplist_get (proplist, Qgnutls_bootprop_loglevel);
 492   verify_flags          = Fplist_get (proplist, Qgnutls_bootprop_verify_flags);
 493   /* verify_error    = Fplist_get (proplist, Qgnutls_bootprop_verify_error); */
 494   verify_hostname_error = Fplist_get (proplist, Qgnutls_bootprop_verify_hostname_error);
 495
 496   if (!STRINGP (hostname))
 497     error ("gnutls-boot: invalid :hostname parameter");
 498
 499   c_hostname = SSDATA (hostname);
 500
 501   state = XPROCESS (proc)->gnutls_state;
 502   XPROCESS (proc)->gnutls_p = 1;
 503
 504   if (NUMBERP (loglevel))
 505     {
 506       gnutls_global_set_log_function (gnutls_log_function);
 507       gnutls_global_set_log_level (XINT (loglevel));
 508       max_log_level = XINT (loglevel);
 509       XPROCESS (proc)->gnutls_log_level = max_log_level;
 510     }
 511
 512   /* always initialize globals.  */
 513   global_init = emacs_gnutls_global_init ();
 514   if (! NILP (Fgnutls_errorp (global_init)))
 515     return global_init;
 516
 517   /* deinit and free resources.  */
 518   if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_CRED_ALLOC)
 519     {
 520       GNUTLS_LOG (1, max_log_level, "deallocating credentials");
 521
 522       if (EQ (type, Qgnutls_x509pki))
 523         {
 524           GNUTLS_LOG (2, max_log_level, "deallocating x509 credentials");
 525           x509_cred = XPROCESS (proc)->gnutls_x509_cred;
 526           gnutls_certificate_free_credentials (x509_cred);
 527         }
 528       else if (EQ (type, Qgnutls_anon))
 529         {
 530           GNUTLS_LOG (2, max_log_level, "deallocating anon credentials");
 531           anon_cred = XPROCESS (proc)->gnutls_anon_cred;
 532           gnutls_anon_free_client_credentials (anon_cred);
 533         }
 534       else
 535         {
 536           error ("unknown credential type");
 537           ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
 538         }
 539
 540       if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 541         {
 542           GNUTLS_LOG (1, max_log_level, "deallocating x509 credentials");
 543           Fgnutls_deinit (proc);
 544         }
 545     }
 546
 547   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
 548
 549   GNUTLS_LOG (1, max_log_level, "allocating credentials");
 550
 551   if (EQ (type, Qgnutls_x509pki))
 552     {
 553       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
 554       x509_cred = XPROCESS (proc)->gnutls_x509_cred;
 555       if (gnutls_certificate_allocate_credentials (&x509_cred) < 0)
 556         memory_full ();
 557
 558       if (NUMBERP (verify_flags))
 559         {
 560           gnutls_verify_flags = XINT (verify_flags);
 561           GNUTLS_LOG (2, max_log_level, "setting verification flags");
 562         }
 563       else if (NILP (verify_flags))
 564         {
 565           /* The default is already GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT.  */
 566           GNUTLS_LOG (2, max_log_level, "using default verification flags");
 567         }
 568       else
 569         {
 570           /* The default is already GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT.  */
 571           GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
 572         }
 573       gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
 574     }
 575   else if (EQ (type, Qgnutls_anon))
 576     {
 577       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
 578       anon_cred = XPROCESS (proc)->gnutls_anon_cred;
 579       if (gnutls_anon_allocate_client_credentials (&anon_cred) < 0)
 580         memory_full ();
 581     }
 582   else
 583     {
 584       error ("unknown credential type");
 585       ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
 586     }
 587
 588   if (ret < GNUTLS_E_SUCCESS)
 589     return gnutls_make_error (ret);
 590
 591   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
 592
 593   if (EQ (type, Qgnutls_x509pki))
 594     {
 595       for (tail = trustfiles; !NILP (tail); tail = Fcdr (tail))
 596         {
 597           Lisp_Object trustfile = Fcar (tail);
 598           if (STRINGP (trustfile))
 599             {
 600               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
 601                            SSDATA (trustfile));
 602               ret = gnutls_certificate_set_x509_trust_file
 603                 (x509_cred,
 604                  SSDATA (trustfile),
 605                  file_format);
 606
 607               if (ret < GNUTLS_E_SUCCESS)
 608                 return gnutls_make_error (ret);
 609             }
 610           else
 611             {
 612               error ("Sorry, GnuTLS can't use non-string trustfile %s",
 613                      SDATA (trustfile));
 614             }
 615         }
 616
 617       for (tail = keyfiles; !NILP (tail); tail = Fcdr (tail))
 618         {
 619           Lisp_Object keyfile = Fcar (tail);
 620           if (STRINGP (keyfile))
 621             {
 622               GNUTLS_LOG2 (1, max_log_level, "setting the keyfile: ",
 623                            SSDATA (keyfile));
 624               ret = gnutls_certificate_set_x509_crl_file
 625                 (x509_cred,
 626                  SSDATA (keyfile),
 627                  file_format);
 628
 629               if (ret < GNUTLS_E_SUCCESS)
 630                 return gnutls_make_error (ret);
 631             }
 632           else
 633             {
 634               error ("Sorry, GnuTLS can't use non-string keyfile %s",
 635                      SDATA (keyfile));
 636             }
 637         }
 638     }
 639
 640   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 641
 642   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
 643
 644   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
 645
 646 #ifdef HAVE_GNUTLS_CALLBACK_CERTIFICATE_VERIFY
 647 #else
 648 #endif
 649
 650   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 651
 652   ret = gnutls_init (&state, GNUTLS_CLIENT);
 653
 654   if (ret < GNUTLS_E_SUCCESS)
 655     return gnutls_make_error (ret);
 656
 657   XPROCESS (proc)->gnutls_state = state;
 658
 659   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
 660
 661   if (STRINGP (priority_string))
 662     {
 663       priority_string_ptr = SSDATA (priority_string);
 664       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
 665                    priority_string_ptr);
 666     }
 667   else
 668     {
 669       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
 670                    priority_string_ptr);
 671     }
 672
 673   GNUTLS_LOG (1, max_log_level, "setting the priority string");
 674
 675   ret = gnutls_priority_set_direct (state,
 676                                     priority_string_ptr,
 677                                     NULL);
 678
 679   if (ret < GNUTLS_E_SUCCESS)
 680     return gnutls_make_error (ret);
 681
 682   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
 683
 684   if (EQ (type, Qgnutls_x509pki))
 685     {
 686       ret = gnutls_cred_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred);
 687     }
 688   else if (EQ (type, Qgnutls_anon))
 689     {
 690       ret = gnutls_cred_set (state, GNUTLS_CRD_ANON, anon_cred);
 691     }
 692   else
 693     {
 694       error ("unknown credential type");
 695       ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
 696     }
 697
 698   if (ret < GNUTLS_E_SUCCESS)
 699     return gnutls_make_error (ret);
 700
 701   XPROCESS (proc)->gnutls_anon_cred = anon_cred;
 702   XPROCESS (proc)->gnutls_x509_cred = x509_cred;
 703   XPROCESS (proc)->gnutls_cred_type = type;
 704
 705   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
 706
 707   ret = emacs_gnutls_handshake (XPROCESS (proc));
 708
 709   if (ret < GNUTLS_E_SUCCESS)
 710     return gnutls_make_error (ret);
 711
 712   /* Now verify the peer, following
 713      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
 714      The peer should present at least one certificate in the chain; do a
 715      check of the certificate's hostname with
 716      gnutls_x509_crt_check_hostname() against :hostname.  */
 717
 718   ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
 719
 720   if (ret < GNUTLS_E_SUCCESS)
 721     return gnutls_make_error (ret);
 722
 723   if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
 724     message ("%s certificate could not be verified.",
 725              c_hostname);
 726
 727  if (peer_verification & GNUTLS_CERT_REVOKED)
 728    GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
 729                 c_hostname);
 730
 731  if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
 732    GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
 733                 c_hostname);
 734
 735  if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
 736    GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
 737                 c_hostname);
 738
 739  if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
 740    GNUTLS_LOG2 (1, max_log_level,
 741                 "certificate was signed with an insecure algorithm:",
 742                 c_hostname);
 743
 744  if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
 745    GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
 746                 c_hostname);
 747
 748  if (peer_verification & GNUTLS_CERT_EXPIRED)
 749    GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
 750                 c_hostname);
 751
 752  if (peer_verification != 0)
 753    {
 754      if (NILP (verify_hostname_error))
 755        {
 756          GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
 757                       c_hostname);
 758        }
 759      else
 760        {
 761          error ("Certificate validation failed %s, verification code %d",
 762                 c_hostname, peer_verification);
 763        }
 764    }
 765
 766   /* Up to here the process is the same for X.509 certificates and
 767      OpenPGP keys.  From now on X.509 certificates are assumed.  This
 768      can be easily extended to work with openpgp keys as well.  */
 769   if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
 770     {
 771       ret = gnutls_x509_crt_init (&gnutls_verify_cert);
 772
 773       if (ret < GNUTLS_E_SUCCESS)
 774         return gnutls_make_error (ret);
 775
 776       gnutls_verify_cert_list =
 777         gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
 778
 779       if (NULL == gnutls_verify_cert_list)
 780         {
 781           error ("No x509 certificate was found!\n");
 782         }
 783
 784       /* We only check the first certificate in the given chain.  */
 785       ret = gnutls_x509_crt_import (gnutls_verify_cert,
 786                                     &gnutls_verify_cert_list[0],
 787                                     GNUTLS_X509_FMT_DER);
 788
 789       if (ret < GNUTLS_E_SUCCESS)
 790         {
 791           gnutls_x509_crt_deinit (gnutls_verify_cert);
 792           return gnutls_make_error (ret);
 793         }
 794
 795       if (!gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
 796         {
 797           if (NILP (verify_hostname_error))
 798             {
 799               GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
 800                            c_hostname);
 801             }
 802           else
 803             {
 804               gnutls_x509_crt_deinit (gnutls_verify_cert);
 805               error ("The x509 certificate does not match \"%s\"",
 806                      c_hostname);
 807             }
 808         }
 809
 810       gnutls_x509_crt_deinit (gnutls_verify_cert);
 811     }
 812
 813   return gnutls_make_error (ret);
 814 }
 815
 816 DEFUN ("gnutls-bye", Fgnutls_bye,
 817        Sgnutls_bye, 2, 2, 0,
 818        doc: /* Terminate current GnuTLS connection for process PROC.
 819 The connection should have been initiated using `gnutls-handshake'.
 820
 821 If CONT is not nil the TLS connection gets terminated and further
 822 receives and sends will be disallowed.  If the return value is zero you
 823 may continue using the connection.  If CONT is nil, GnuTLS actually
 824 sends an alert containing a close request and waits for the peer to
 825 reply with the same message.  In order to reuse the connection you
 826 should wait for an EOF from the peer.
 827
 828 This function may also return `gnutls-e-again', or
 829 `gnutls-e-interrupted'.  */)
 830     (Lisp_Object proc, Lisp_Object cont)
 831 {
 832   gnutls_session_t state;
 833   int ret;
 834
 835   CHECK_PROCESS (proc);
 836
 837   state = XPROCESS (proc)->gnutls_state;
 838
 839   ret = gnutls_bye (state,
 840                     NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
 841
 842   return gnutls_make_error (ret);
 843 }
 844
 845 void
 846 syms_of_gnutls (void)
 847 {
 848   gnutls_global_initialized = 0;
 849
 850   Qgnutls_log_level = intern_c_string ("gnutls-log-level");
 851   staticpro (&Qgnutls_log_level);
 852
 853   Qgnutls_code = intern_c_string ("gnutls-code");
 854   staticpro (&Qgnutls_code);
 855
 856   Qgnutls_anon = intern_c_string ("gnutls-anon");
 857   staticpro (&Qgnutls_anon);
 858
 859   Qgnutls_x509pki = intern_c_string ("gnutls-x509pki");
 860   staticpro (&Qgnutls_x509pki);
 861
 862   Qgnutls_bootprop_hostname = intern_c_string (":hostname");
 863   staticpro (&Qgnutls_bootprop_hostname);
 864
 865   Qgnutls_bootprop_priority = intern_c_string (":priority");
 866   staticpro (&Qgnutls_bootprop_priority);
 867
 868   Qgnutls_bootprop_trustfiles = intern_c_string (":trustfiles");
 869   staticpro (&Qgnutls_bootprop_trustfiles);
 870
 871   Qgnutls_bootprop_keyfiles = intern_c_string (":keyfiles");
 872   staticpro (&Qgnutls_bootprop_keyfiles);
 873
 874   Qgnutls_bootprop_callbacks = intern_c_string (":callbacks");
 875   staticpro (&Qgnutls_bootprop_callbacks);
 876
 877   Qgnutls_bootprop_callbacks_verify = intern_c_string ("verify");
 878   staticpro (&Qgnutls_bootprop_callbacks_verify);
 879
 880   Qgnutls_bootprop_loglevel = intern_c_string (":loglevel");
 881   staticpro (&Qgnutls_bootprop_loglevel);
 882
 883   Qgnutls_bootprop_verify_flags = intern_c_string (":verify-flags");
 884   staticpro (&Qgnutls_bootprop_verify_flags);
 885
 886   Qgnutls_bootprop_verify_hostname_error = intern_c_string (":verify-error");
 887   staticpro (&Qgnutls_bootprop_verify_error);
 888
 889   Qgnutls_bootprop_verify_hostname_error = intern_c_string (":verify-hostname-error");
 890   staticpro (&Qgnutls_bootprop_verify_hostname_error);
 891
 892   Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted");
 893   staticpro (&Qgnutls_e_interrupted);
 894   Fput (Qgnutls_e_interrupted, Qgnutls_code,
 895         make_number (GNUTLS_E_INTERRUPTED));
 896
 897   Qgnutls_e_again = intern_c_string ("gnutls-e-again");
 898   staticpro (&Qgnutls_e_again);
 899   Fput (Qgnutls_e_again, Qgnutls_code,
 900         make_number (GNUTLS_E_AGAIN));
 901
 902   Qgnutls_e_invalid_session = intern_c_string ("gnutls-e-invalid-session");
 903   staticpro (&Qgnutls_e_invalid_session);
 904   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
 905         make_number (GNUTLS_E_INVALID_SESSION));
 906
 907   Qgnutls_e_not_ready_for_handshake =
 908     intern_c_string ("gnutls-e-not-ready-for-handshake");
 909   staticpro (&Qgnutls_e_not_ready_for_handshake);
 910   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
 911         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
 912
 913   defsubr (&Sgnutls_get_initstage);
 914   defsubr (&Sgnutls_errorp);
 915   defsubr (&Sgnutls_error_fatalp);
 916   defsubr (&Sgnutls_error_string);
 917   defsubr (&Sgnutls_boot);
 918   defsubr (&Sgnutls_deinit);
 919   defsubr (&Sgnutls_bye);
 920 }
 921 #endif