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;
 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 alert, 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 error)
 253 {
 254   switch (error)
 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 (error);
 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 /* Deinitializes global GnuTLS state.
 387 See also `gnutls-global-init'.  */
 388 static Lisp_Object
 389 emacs_gnutls_global_deinit (void)
 390 {
 391   if (gnutls_global_initialized)
 392     gnutls_global_deinit ();
 393
 394   gnutls_global_initialized = 0;
 395
 396   return gnutls_make_error (GNUTLS_E_SUCCESS);
 397 }
 398
 399 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 400        doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
 401 Currently only client mode is supported.  Returns a success/failure
 402 value you can check with `gnutls-errorp'.
 403
 404 TYPE is a symbol, either `gnutls-anon' or `gnutls-x509pki'.
 405 PROPLIST is a property list with the following keys:
 406
 407 :hostname is a string naming the remote host.
 408
 409 :priority is a GnuTLS priority string, defaults to "NORMAL".
 410
 411 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
 412
 413 :keyfiles is a list of PEM-encoded key files for `gnutls-x509pki'.
 414
 415 :callbacks is an alist of callback functions, see below.
 416
 417 :loglevel is the debug level requested from GnuTLS, try 4.
 418
 419 :verify-flags is a bitset as per GnuTLS'
 420 gnutls_certificate_set_verify_flags.
 421
 422 :verify-error, if non-nil, makes failure of the certificate validation
 423 an error.  Otherwise it will be just a series of warnings.
 424
 425 :verify-hostname-error, if non-nil, makes a hostname mismatch an
 426 error.  Otherwise it will be just a warning.
 427
 428 The debug level will be set for this process AND globally for GnuTLS.
 429 So if you set it higher or lower at any point, it affects global
 430 debugging.
 431
 432 Note that the priority is set on the client.  The server does not use
 433 the protocols's priority except for disabling protocols that were not
 434 specified.
 435
 436 Processes must be initialized with this function before other GnuTLS
 437 functions are used.  This function allocates resources which can only
 438 be deallocated by calling `gnutls-deinit' or by calling it again.
 439
 440 The callbacks alist can have a `verify' key, associated with a
 441 verification function (UNUSED).
 442
 443 Each authentication type may need additional information in order to
 444 work.  For X.509 PKI (`gnutls-x509pki'), you probably need at least
 445 one trustfile (usually a CA bundle).  */)
 446   (Lisp_Object proc, Lisp_Object type, Lisp_Object proplist)
 447 {
 448   int ret = GNUTLS_E_SUCCESS;
 449
 450   int max_log_level = 0;
 451
 452   /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
 453   int file_format = GNUTLS_X509_FMT_PEM;
 454
 455   unsigned int gnutls_verify_flags = GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT;
 456   gnutls_x509_crt_t gnutls_verify_cert;
 457   unsigned int gnutls_verify_cert_list_size;
 458   const gnutls_datum_t *gnutls_verify_cert_list;
 459
 460   gnutls_session_t state;
 461   gnutls_certificate_credentials_t x509_cred;
 462   gnutls_anon_client_credentials_t anon_cred;
 463   Lisp_Object global_init;
 464   char* priority_string_ptr = "NORMAL"; /* default priority string.  */
 465   Lisp_Object tail;
 466   int peer_verification;
 467   char* c_hostname;
 468
 469   /* Placeholders for the property list elements.  */
 470   Lisp_Object priority_string;
 471   Lisp_Object trustfiles;
 472   Lisp_Object keyfiles;
 473   Lisp_Object callbacks;
 474   Lisp_Object loglevel;
 475   Lisp_Object hostname;
 476   Lisp_Object verify_flags;
 477   Lisp_Object verify_error;
 478   Lisp_Object verify_hostname_error;
 479
 480   CHECK_PROCESS (proc);
 481   CHECK_SYMBOL (type);
 482   CHECK_LIST (proplist);
 483
 484   hostname              = Fplist_get (proplist, Qgnutls_bootprop_hostname);
 485   priority_string       = Fplist_get (proplist, Qgnutls_bootprop_priority);
 486   trustfiles            = Fplist_get (proplist, Qgnutls_bootprop_trustfiles);
 487   keyfiles              = Fplist_get (proplist, Qgnutls_bootprop_keyfiles);
 488   callbacks             = Fplist_get (proplist, Qgnutls_bootprop_callbacks);
 489   loglevel              = Fplist_get (proplist, Qgnutls_bootprop_loglevel);
 490   verify_flags          = Fplist_get (proplist, Qgnutls_bootprop_verify_flags);
 491   verify_error          = Fplist_get (proplist, Qgnutls_bootprop_verify_error);
 492   verify_hostname_error = Fplist_get (proplist, Qgnutls_bootprop_verify_hostname_error);
 493
 494   if (!STRINGP (hostname))
 495     error ("gnutls-boot: invalid :hostname parameter");
 496
 497   c_hostname = SSDATA (hostname);
 498
 499   state = XPROCESS (proc)->gnutls_state;
 500   XPROCESS (proc)->gnutls_p = 1;
 501
 502   if (NUMBERP (loglevel))
 503     {
 504       gnutls_global_set_log_function (gnutls_log_function);
 505       gnutls_global_set_log_level (XINT (loglevel));
 506       max_log_level = XINT (loglevel);
 507       XPROCESS (proc)->gnutls_log_level = max_log_level;
 508     }
 509
 510   /* always initialize globals.  */
 511   global_init = emacs_gnutls_global_init ();
 512   if (! NILP (Fgnutls_errorp (global_init)))
 513     return global_init;
 514
 515   /* deinit and free resources.  */
 516   if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_CRED_ALLOC)
 517     {
 518       GNUTLS_LOG (1, max_log_level, "deallocating credentials");
 519
 520       if (EQ (type, Qgnutls_x509pki))
 521         {
 522           GNUTLS_LOG (2, max_log_level, "deallocating x509 credentials");
 523           x509_cred = XPROCESS (proc)->gnutls_x509_cred;
 524           gnutls_certificate_free_credentials (x509_cred);
 525         }
 526       else if (EQ (type, Qgnutls_anon))
 527         {
 528           GNUTLS_LOG (2, max_log_level, "deallocating anon credentials");
 529           anon_cred = XPROCESS (proc)->gnutls_anon_cred;
 530           gnutls_anon_free_client_credentials (anon_cred);
 531         }
 532       else
 533         {
 534           error ("unknown credential type");
 535           ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
 536         }
 537
 538       if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 539         {
 540           GNUTLS_LOG (1, max_log_level, "deallocating x509 credentials");
 541           Fgnutls_deinit (proc);
 542         }
 543     }
 544
 545   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
 546
 547   GNUTLS_LOG (1, max_log_level, "allocating credentials");
 548
 549   if (EQ (type, Qgnutls_x509pki))
 550     {
 551       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
 552       x509_cred = XPROCESS (proc)->gnutls_x509_cred;
 553       if (gnutls_certificate_allocate_credentials (&x509_cred) < 0)
 554         memory_full ();
 555
 556       if (NUMBERP (verify_flags))
 557         {
 558           gnutls_verify_flags = XINT (verify_flags);
 559           GNUTLS_LOG (2, max_log_level, "setting verification flags");
 560         }
 561       else if (NILP (verify_flags))
 562         {
 563           /* The default is already GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT.  */
 564           GNUTLS_LOG (2, max_log_level, "using default verification flags");
 565         }
 566       else
 567         {
 568           /* The default is already GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT.  */
 569           GNUTLS_LOG (2, max_log_level, "ignoring invalid verify-flags");
 570         }
 571       gnutls_certificate_set_verify_flags (x509_cred, gnutls_verify_flags);
 572     }
 573   else if (EQ (type, Qgnutls_anon))
 574     {
 575       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
 576       anon_cred = XPROCESS (proc)->gnutls_anon_cred;
 577       if (gnutls_anon_allocate_client_credentials (&anon_cred) < 0)
 578         memory_full ();
 579     }
 580   else
 581     {
 582       error ("unknown credential type");
 583       ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
 584     }
 585
 586   if (ret < GNUTLS_E_SUCCESS)
 587     return gnutls_make_error (ret);
 588
 589   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
 590
 591   if (EQ (type, Qgnutls_x509pki))
 592     {
 593       for (tail = trustfiles; !NILP (tail); tail = Fcdr (tail))
 594         {
 595           Lisp_Object trustfile = Fcar (tail);
 596           if (STRINGP (trustfile))
 597             {
 598               GNUTLS_LOG2 (1, max_log_level, "setting the trustfile: ",
 599                            SDATA (trustfile));
 600               ret = gnutls_certificate_set_x509_trust_file
 601                 (x509_cred,
 602                  SDATA (trustfile),
 603                  file_format);
 604
 605               if (ret < GNUTLS_E_SUCCESS)
 606                 return gnutls_make_error (ret);
 607             }
 608           else
 609             {
 610               error ("Sorry, GnuTLS can't use non-string trustfile %s",
 611                      SDATA (trustfile));
 612             }
 613         }
 614
 615       for (tail = keyfiles; !NILP (tail); tail = Fcdr (tail))
 616         {
 617           Lisp_Object keyfile = Fcar (tail);
 618           if (STRINGP (keyfile))
 619             {
 620               GNUTLS_LOG2 (1, max_log_level, "setting the keyfile: ",
 621                            SDATA (keyfile));
 622               ret = gnutls_certificate_set_x509_crl_file
 623                 (x509_cred,
 624                  SDATA (keyfile),
 625                  file_format);
 626
 627               if (ret < GNUTLS_E_SUCCESS)
 628                 return gnutls_make_error (ret);
 629             }
 630           else
 631             {
 632               error ("Sorry, GnuTLS can't use non-string keyfile %s",
 633                      SDATA (keyfile));
 634             }
 635         }
 636     }
 637
 638   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 639
 640   GNUTLS_LOG (1, max_log_level, "gnutls callbacks");
 641
 642   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CALLBACKS;
 643
 644 #ifdef HAVE_GNUTLS_CALLBACK_CERTIFICATE_VERIFY
 645 #else
 646 #endif
 647
 648   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 649
 650   ret = gnutls_init (&state, GNUTLS_CLIENT);
 651
 652   if (ret < GNUTLS_E_SUCCESS)
 653     return gnutls_make_error (ret);
 654
 655   XPROCESS (proc)->gnutls_state = state;
 656
 657   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
 658
 659   if (STRINGP (priority_string))
 660     {
 661       priority_string_ptr = SSDATA (priority_string);
 662       GNUTLS_LOG2 (1, max_log_level, "got non-default priority string:",
 663                    priority_string_ptr);
 664     }
 665   else
 666     {
 667       GNUTLS_LOG2 (1, max_log_level, "using default priority string:",
 668                    priority_string_ptr);
 669     }
 670
 671   GNUTLS_LOG (1, max_log_level, "setting the priority string");
 672
 673   ret = gnutls_priority_set_direct (state,
 674                                     priority_string_ptr,
 675                                     NULL);
 676
 677   if (ret < GNUTLS_E_SUCCESS)
 678     return gnutls_make_error (ret);
 679
 680   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
 681
 682   if (EQ (type, Qgnutls_x509pki))
 683     {
 684       ret = gnutls_cred_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred);
 685     }
 686   else if (EQ (type, Qgnutls_anon))
 687     {
 688       ret = gnutls_cred_set (state, GNUTLS_CRD_ANON, anon_cred);
 689     }
 690   else
 691     {
 692       error ("unknown credential type");
 693       ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
 694     }
 695
 696   if (ret < GNUTLS_E_SUCCESS)
 697     return gnutls_make_error (ret);
 698
 699   XPROCESS (proc)->gnutls_anon_cred = anon_cred;
 700   XPROCESS (proc)->gnutls_x509_cred = x509_cred;
 701   XPROCESS (proc)->gnutls_cred_type = type;
 702
 703   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
 704
 705   ret = emacs_gnutls_handshake (XPROCESS (proc));
 706
 707   if (ret < GNUTLS_E_SUCCESS)
 708     return gnutls_make_error (ret);
 709
 710   /* Now verify the peer, following
 711      http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
 712      The peer should present at least one certificate in the chain; do a
 713      check of the certificate's hostname with
 714      gnutls_x509_crt_check_hostname() against :hostname.  */
 715
 716   ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
 717
 718   if (ret < GNUTLS_E_SUCCESS)
 719     return gnutls_make_error (ret);
 720
 721   if (XINT (loglevel) > 0 && peer_verification & GNUTLS_CERT_INVALID)
 722     message ("%s certificate could not be verified.",
 723              c_hostname);
 724
 725  if (peer_verification & GNUTLS_CERT_REVOKED)
 726    GNUTLS_LOG2 (1, max_log_level, "certificate was revoked (CRL):",
 727                 c_hostname);
 728
 729  if (peer_verification & GNUTLS_CERT_SIGNER_NOT_FOUND)
 730    GNUTLS_LOG2 (1, max_log_level, "certificate signer was not found:",
 731                 c_hostname);
 732
 733  if (peer_verification & GNUTLS_CERT_SIGNER_NOT_CA)
 734    GNUTLS_LOG2 (1, max_log_level, "certificate signer is not a CA:",
 735                 c_hostname);
 736
 737  if (peer_verification & GNUTLS_CERT_INSECURE_ALGORITHM)
 738    GNUTLS_LOG2 (1, max_log_level,
 739                 "certificate was signed with an insecure algorithm:",
 740                 c_hostname);
 741
 742  if (peer_verification & GNUTLS_CERT_NOT_ACTIVATED)
 743    GNUTLS_LOG2 (1, max_log_level, "certificate is not yet activated:",
 744                 c_hostname);
 745
 746  if (peer_verification & GNUTLS_CERT_EXPIRED)
 747    GNUTLS_LOG2 (1, max_log_level, "certificate has expired:",
 748                 c_hostname);
 749
 750  if (peer_verification != 0)
 751    {
 752      if (NILP (verify_hostname_error))
 753        {
 754          GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
 755                       c_hostname);
 756        }
 757      else
 758        {
 759          error ("Certificate validation failed %s, verification code %d",
 760                 c_hostname, peer_verification);
 761        }
 762    }
 763
 764   /* Up to here the process is the same for X.509 certificates and
 765      OpenPGP keys.  From now on X.509 certificates are assumed.  This
 766      can be easily extended to work with openpgp keys as well.  */
 767   if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
 768     {
 769       ret = gnutls_x509_crt_init (&gnutls_verify_cert);
 770
 771       if (ret < GNUTLS_E_SUCCESS)
 772         return gnutls_make_error (ret);
 773
 774       gnutls_verify_cert_list =
 775         gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
 776
 777       if (NULL == gnutls_verify_cert_list)
 778         {
 779           error ("No x509 certificate was found!\n");
 780         }
 781
 782       /* We only check the first certificate in the given chain.  */
 783       ret = gnutls_x509_crt_import (gnutls_verify_cert,
 784                                     &gnutls_verify_cert_list[0],
 785                                     GNUTLS_X509_FMT_DER);
 786
 787       if (ret < GNUTLS_E_SUCCESS)
 788         {
 789           gnutls_x509_crt_deinit (gnutls_verify_cert);
 790           return gnutls_make_error (ret);
 791         }
 792
 793       if (!gnutls_x509_crt_check_hostname (gnutls_verify_cert, c_hostname))
 794         {
 795           if (NILP (verify_hostname_error))
 796             {
 797               GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
 798                            c_hostname);
 799             }
 800           else
 801             {
 802               gnutls_x509_crt_deinit (gnutls_verify_cert);
 803               error ("The x509 certificate does not match \"%s\"",
 804                      c_hostname);
 805             }
 806         }
 807
 808       gnutls_x509_crt_deinit (gnutls_verify_cert);
 809     }
 810
 811   return gnutls_make_error (ret);
 812 }
 813
 814 DEFUN ("gnutls-bye", Fgnutls_bye,
 815        Sgnutls_bye, 2, 2, 0,
 816        doc: /* Terminate current GnuTLS connection for process PROC.
 817 The connection should have been initiated using `gnutls-handshake'.
 818
 819 If CONT is not nil the TLS connection gets terminated and further
 820 receives and sends will be disallowed.  If the return value is zero you
 821 may continue using the connection.  If CONT is nil, GnuTLS actually
 822 sends an alert containing a close request and waits for the peer to
 823 reply with the same message.  In order to reuse the connection you
 824 should wait for an EOF from the peer.
 825
 826 This function may also return `gnutls-e-again', or
 827 `gnutls-e-interrupted'.  */)
 828     (Lisp_Object proc, Lisp_Object cont)
 829 {
 830   gnutls_session_t state;
 831   int ret;
 832
 833   CHECK_PROCESS (proc);
 834
 835   state = XPROCESS (proc)->gnutls_state;
 836
 837   ret = gnutls_bye (state,
 838                     NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
 839
 840   return gnutls_make_error (ret);
 841 }
 842
 843 void
 844 syms_of_gnutls (void)
 845 {
 846   gnutls_global_initialized = 0;
 847
 848   Qgnutls_log_level = intern_c_string ("gnutls-log-level");
 849   staticpro (&Qgnutls_log_level);
 850
 851   Qgnutls_code = intern_c_string ("gnutls-code");
 852   staticpro (&Qgnutls_code);
 853
 854   Qgnutls_anon = intern_c_string ("gnutls-anon");
 855   staticpro (&Qgnutls_anon);
 856
 857   Qgnutls_x509pki = intern_c_string ("gnutls-x509pki");
 858   staticpro (&Qgnutls_x509pki);
 859
 860   Qgnutls_bootprop_hostname = intern_c_string (":hostname");
 861   staticpro (&Qgnutls_bootprop_hostname);
 862
 863   Qgnutls_bootprop_priority = intern_c_string (":priority");
 864   staticpro (&Qgnutls_bootprop_priority);
 865
 866   Qgnutls_bootprop_trustfiles = intern_c_string (":trustfiles");
 867   staticpro (&Qgnutls_bootprop_trustfiles);
 868
 869   Qgnutls_bootprop_keyfiles = intern_c_string (":keyfiles");
 870   staticpro (&Qgnutls_bootprop_keyfiles);
 871
 872   Qgnutls_bootprop_callbacks = intern_c_string (":callbacks");
 873   staticpro (&Qgnutls_bootprop_callbacks);
 874
 875   Qgnutls_bootprop_callbacks_verify = intern_c_string ("verify");
 876   staticpro (&Qgnutls_bootprop_callbacks_verify);
 877
 878   Qgnutls_bootprop_loglevel = intern_c_string (":loglevel");
 879   staticpro (&Qgnutls_bootprop_loglevel);
 880
 881   Qgnutls_bootprop_verify_flags = intern_c_string (":verify-flags");
 882   staticpro (&Qgnutls_bootprop_verify_flags);
 883
 884   Qgnutls_bootprop_verify_hostname_error = intern_c_string (":verify-error");
 885   staticpro (&Qgnutls_bootprop_verify_error);
 886
 887   Qgnutls_bootprop_verify_hostname_error = intern_c_string (":verify-hostname-error");
 888   staticpro (&Qgnutls_bootprop_verify_hostname_error);
 889
 890   Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted");
 891   staticpro (&Qgnutls_e_interrupted);
 892   Fput (Qgnutls_e_interrupted, Qgnutls_code,
 893         make_number (GNUTLS_E_INTERRUPTED));
 894
 895   Qgnutls_e_again = intern_c_string ("gnutls-e-again");
 896   staticpro (&Qgnutls_e_again);
 897   Fput (Qgnutls_e_again, Qgnutls_code,
 898         make_number (GNUTLS_E_AGAIN));
 899
 900   Qgnutls_e_invalid_session = intern_c_string ("gnutls-e-invalid-session");
 901   staticpro (&Qgnutls_e_invalid_session);
 902   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
 903         make_number (GNUTLS_E_INVALID_SESSION));
 904
 905   Qgnutls_e_not_ready_for_handshake =
 906     intern_c_string ("gnutls-e-not-ready-for-handshake");
 907   staticpro (&Qgnutls_e_not_ready_for_handshake);
 908   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
 909         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
 910
 911   defsubr (&Sgnutls_get_initstage);
 912   defsubr (&Sgnutls_errorp);
 913   defsubr (&Sgnutls_error_fatalp);
 914   defsubr (&Sgnutls_error_string);
 915   defsubr (&Sgnutls_boot);
 916   defsubr (&Sgnutls_deinit);
 917   defsubr (&Sgnutls_bye);
 918 }
 919 #endif