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_TRANSPORT_POINTERS_SET)
  77     {
  78 #ifdef WINDOWSNT
  79       /* On W32 we cannot transfer socket handles between different runtime
  80          libraries, so we tell GnuTLS to use our special push/pull
  81          functions.  */
  82       gnutls_transport_set_ptr2 (state,
  83                                  (gnutls_transport_ptr_t) proc,
  84                                  (gnutls_transport_ptr_t) proc);
  85       gnutls_transport_set_push_function (state, &emacs_gnutls_push);
  86       gnutls_transport_set_pull_function (state, &emacs_gnutls_pull);
  87
  88       /* For non blocking sockets or other custom made pull/push
  89          functions the gnutls_transport_set_lowat must be called, with
  90          a zero low water mark value. (GnuTLS 2.10.4 documentation)
  91
  92          (Note: this is probably not strictly necessary as the lowat
  93           value is only used when no custom pull/push functions are
  94           set.)  */
  95       gnutls_transport_set_lowat (state, 0);
  96 #else
  97       /* This is how GnuTLS takes sockets: as file descriptors passed
  98          in.  For an Emacs process socket, infd and outfd are the
  99          same but we use this two-argument version for clarity.  */
 100       gnutls_transport_set_ptr2 (state,
 101                                  (gnutls_transport_ptr_t) (long) proc->infd,
 102                                  (gnutls_transport_ptr_t) (long) proc->outfd);
 103 #endif
 104
 105       proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
 106     }
 107
 108   do
 109     {
 110       ret = gnutls_handshake (state);
 111       emacs_gnutls_handle_error (state, ret);
 112     }
 113   while (ret < 0 && gnutls_error_is_fatal (ret) == 0);
 114
 115   proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
 116
 117   if (ret == GNUTLS_E_SUCCESS)
 118     {
 119       /* Here we're finally done.  */
 120       proc->gnutls_initstage = GNUTLS_STAGE_READY;
 121     }
 122   else
 123     {
 124         gnutls_alert_send_appropriate (state, ret);
 125     }
 126   return ret;
 127 }
 128
 129 EMACS_INT
 130 emacs_gnutls_write (int fildes, struct Lisp_Process *proc, const char *buf,
 131                     EMACS_INT nbyte)
 132 {
 133   ssize_t rtnval;
 134   EMACS_INT bytes_written;
 135   gnutls_session_t state = proc->gnutls_state;
 136
 137   if (proc->gnutls_initstage != GNUTLS_STAGE_READY) {
 138 #ifdef EWOULDBLOCK
 139     errno = EWOULDBLOCK;
 140 #endif
 141 #ifdef EAGAIN
 142     errno = EAGAIN;
 143 #endif
 144     return 0;
 145   }
 146
 147   bytes_written = 0;
 148
 149   while (nbyte > 0)
 150     {
 151       rtnval = gnutls_write (state, buf, nbyte);
 152
 153       if (rtnval < 0)
 154         {
 155           if (rtnval == GNUTLS_E_AGAIN || rtnval == GNUTLS_E_INTERRUPTED)
 156             continue;
 157           else
 158             break;
 159         }
 160
 161       buf += rtnval;
 162       nbyte -= rtnval;
 163       bytes_written += rtnval;
 164     }
 165
 166   emacs_gnutls_handle_error (state, rtnval);
 167   return (bytes_written);
 168 }
 169
 170 EMACS_INT
 171 emacs_gnutls_read (int fildes, struct Lisp_Process *proc, char *buf,
 172                    EMACS_INT nbyte)
 173 {
 174   ssize_t rtnval;
 175   gnutls_session_t state = proc->gnutls_state;
 176
 177   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
 178     {
 179       if (GNUTLS_STAGE_HANDSHAKE_CANDO <= proc->gnutls_initstage)
 180         emacs_gnutls_handshake (proc);
 181       return -1;
 182     }
 183   rtnval = gnutls_read (state, buf, nbyte);
 184   if (rtnval >= 0)
 185     return rtnval;
 186   else if (emacs_gnutls_handle_error (state, rtnval) == 0)
 187     /* non-fatal error */
 188     return -1;
 189   else {
 190     /* a fatal error occured */
 191     return 0;
 192   }
 193 }
 194
 195 /* report a GnuTLS error to the user.
 196    Returns zero if the error code was successfully handled. */
 197 static int
 198 emacs_gnutls_handle_error (gnutls_session_t session, int err)
 199 {
 200   Lisp_Object gnutls_log_level = Fsymbol_value (Qgnutls_log_level);
 201   int max_log_level = 0;
 202
 203   int ret;
 204   const char *str;
 205
 206   /* TODO: use a Lisp_Object generated by gnutls_make_error?  */
 207   if (err >= 0)
 208     return 0;
 209
 210   if (NUMBERP (gnutls_log_level))
 211     max_log_level = XINT (gnutls_log_level);
 212
 213   /* TODO: use gnutls-error-fatalp and gnutls-error-string.  */
 214
 215   str = gnutls_strerror (err);
 216   if (!str)
 217     str = "unknown";
 218
 219   if (gnutls_error_is_fatal (err))
 220     {
 221       ret = err;
 222       GNUTLS_LOG2 (0, max_log_level, "fatal error:", str);
 223     }
 224   else
 225     {
 226       ret = 0;
 227       GNUTLS_LOG2 (1, max_log_level, "non-fatal error:", str);
 228       /* TODO: EAGAIN AKA Qgnutls_e_again should be level 2.  */
 229     }
 230
 231   if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
 232       || err == GNUTLS_E_FATAL_ALERT_RECEIVED)
 233     {
 234       int alert = gnutls_alert_get (session);
 235       int level = (err == GNUTLS_E_FATAL_ALERT_RECEIVED) ? 0 : 1;
 236       str = gnutls_alert_get_name (alert);
 237       if (!str)
 238         str = "unknown";
 239
 240       GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
 241     }
 242   return ret;
 243 }
 244
 245 /* convert an integer error to a Lisp_Object; it will be either a
 246    known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
 247    simply the integer value of the error.  GNUTLS_E_SUCCESS is mapped
 248    to Qt.  */
 249 static Lisp_Object
 250 gnutls_make_error (int err)
 251 {
 252   switch (err)
 253     {
 254     case GNUTLS_E_SUCCESS:
 255       return Qt;
 256     case GNUTLS_E_AGAIN:
 257       return Qgnutls_e_again;
 258     case GNUTLS_E_INTERRUPTED:
 259       return Qgnutls_e_interrupted;
 260     case GNUTLS_E_INVALID_SESSION:
 261       return Qgnutls_e_invalid_session;
 262     }
 263
 264   return make_number (err);
 265 }
 266
 267 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
 268        doc: /* Return the GnuTLS init stage of process PROC.
 269 See also `gnutls-boot'.  */)
 270   (Lisp_Object proc)
 271 {
 272   CHECK_PROCESS (proc);
 273
 274   return make_number (GNUTLS_INITSTAGE (proc));
 275 }
 276
 277 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
 278        doc: /* Return t if ERROR indicates a GnuTLS problem.
 279 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 280 usage: (gnutls-errorp ERROR)  */)
 281   (Lisp_Object err)
 282 {
 283   if (EQ (err, Qt)) return Qnil;
 284
 285   return Qt;
 286 }
 287
 288 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
 289        doc: /* Check if ERROR is fatal.
 290 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 291 usage: (gnutls-error-fatalp ERROR)  */)
 292   (Lisp_Object err)
 293 {
 294   Lisp_Object code;
 295
 296   if (EQ (err, Qt)) return Qnil;
 297
 298   if (SYMBOLP (err))
 299     {
 300       code = Fget (err, Qgnutls_code);
 301       if (NUMBERP (code))
 302         {
 303           err = code;
 304         }
 305       else
 306         {
 307           error ("Symbol has no numeric gnutls-code property");
 308         }
 309     }
 310
 311   if (!NUMBERP (err))
 312     error ("Not an error symbol or code");
 313
 314   if (0 == gnutls_error_is_fatal (XINT (err)))
 315     return Qnil;
 316
 317   return Qt;
 318 }
 319
 320 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
 321        doc: /* Return a description of ERROR.
 322 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 323 usage: (gnutls-error-string ERROR)  */)
 324   (Lisp_Object err)
 325 {
 326   Lisp_Object code;
 327
 328   if (EQ (err, Qt)) return build_string ("Not an error");
 329
 330   if (SYMBOLP (err))
 331     {
 332       code = Fget (err, Qgnutls_code);
 333       if (NUMBERP (code))
 334         {
 335           err = code;
 336         }
 337       else
 338         {
 339           return build_string ("Symbol has no numeric gnutls-code property");
 340         }
 341     }
 342
 343   if (!NUMBERP (err))
 344     return build_string ("Not an error symbol or code");
 345
 346   return build_string (gnutls_strerror (XINT (err)));
 347 }
 348
 349 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
 350        doc: /* Deallocate GnuTLS resources associated with process PROC.
 351 See also `gnutls-init'.  */)
 352   (Lisp_Object proc)
 353 {
 354   gnutls_session_t state;
 355
 356   CHECK_PROCESS (proc);
 357   state = XPROCESS (proc)->gnutls_state;
 358
 359   if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 360     {
 361       gnutls_deinit (state);
 362       GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
 363     }
 364
 365   return Qt;
 366 }
 367
 368 /* Initializes global GnuTLS state to defaults.
 369 Call `gnutls-global-deinit' when GnuTLS usage is no longer needed.
 370 Returns zero on success.  */
 371 static Lisp_Object
 372 emacs_gnutls_global_init (void)
 373 {
 374   int ret = GNUTLS_E_SUCCESS;
 375
 376   if (!gnutls_global_initialized)
 377     ret = gnutls_global_init ();
 378
 379   gnutls_global_initialized = 1;
 380
 381   return gnutls_make_error (ret);
 382 }
 383
 384 #if 0
 385 /* Deinitializes global GnuTLS state.
 386 See also `gnutls-global-init'.  */
 387 static Lisp_Object
 388 emacs_gnutls_global_deinit (void)
 389 {
 390   if (gnutls_global_initialized)
 391     gnutls_global_deinit ();
 392
 393   gnutls_global_initialized = 0;
 394
 395   return gnutls_make_error (GNUTLS_E_SUCCESS);
 396 }
 397 #endif
 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 const *priority_string_ptr = "NORMAL"; /* default priority string.  */
 465   Lisp_Object tail;
 466   unsigned 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                            SSDATA (trustfile));
 600               ret = gnutls_certificate_set_x509_trust_file
 601                 (x509_cred,
 602                  SSDATA (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                            SSDATA (keyfile));
 622               ret = gnutls_certificate_set_x509_crl_file
 623                 (x509_cred,
 624                  SSDATA (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