src/gnutls.c

   1 /* GnuTLS glue for GNU Emacs.
   2    Copyright (C) 2010  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 Lisp_Object Qgnutls_code;
  30 Lisp_Object Qgnutls_anon, Qgnutls_x509pki;
  31 Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again,
  32   Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake;
  33 int global_initialized;
  34
  35 static void
  36 emacs_gnutls_handshake (struct Lisp_Process *proc)
  37 {
  38   gnutls_session_t state = proc->gnutls_state;
  39   int ret;
  40
  41   if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
  42     return;
  43
  44   if (proc->gnutls_initstage < GNUTLS_STAGE_TRANSPORT_POINTERS_SET)
  45     {
  46       gnutls_transport_set_ptr2 (state,
  47                                  (gnutls_transport_ptr_t) (long) proc->infd,
  48                                  (gnutls_transport_ptr_t) (long) proc->outfd);
  49
  50       proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
  51     }
  52
  53   ret = gnutls_handshake (state);
  54   proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
  55
  56   if (ret == GNUTLS_E_SUCCESS)
  57     {
  58       /* here we're finally done.  */
  59       proc->gnutls_initstage = GNUTLS_STAGE_READY;
  60     }
  61 }
  62
  63 int
  64 emacs_gnutls_write (int fildes, struct Lisp_Process *proc, char *buf,
  65                     unsigned int nbyte)
  66 {
  67   register int rtnval, bytes_written;
  68   gnutls_session_t state = proc->gnutls_state;
  69
  70   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
  71     return -1;
  72
  73   bytes_written = 0;
  74
  75   while (nbyte > 0)
  76     {
  77       rtnval = gnutls_write (state, buf, nbyte);
  78
  79       if (rtnval == -1)
  80         {
  81           if (errno == EINTR)
  82             continue;
  83           else
  84             return (bytes_written ? bytes_written : -1);
  85         }
  86
  87       buf += rtnval;
  88       nbyte -= rtnval;
  89       bytes_written += rtnval;
  90     }
  91   fsync (STDOUT_FILENO);
  92
  93   return (bytes_written);
  94 }
  95
  96 int
  97 emacs_gnutls_read (int fildes, struct Lisp_Process *proc, char *buf,
  98                    unsigned int nbyte)
  99 {
 100   register int rtnval;
 101   gnutls_session_t state = proc->gnutls_state;
 102
 103   if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
 104     {
 105       emacs_gnutls_handshake (proc);
 106       return -1;
 107     }
 108
 109   rtnval = gnutls_read (state, buf, nbyte);
 110   if (rtnval >= 0)
 111     return rtnval;
 112   else
 113     return 0;
 114 }
 115
 116 /* convert an integer error to a Lisp_Object; it will be either a
 117    known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or
 118    simply the integer value of the error.  GNUTLS_E_SUCCESS is mapped
 119    to Qt.  */
 120 static Lisp_Object
 121 gnutls_make_error (int error)
 122 {
 123   switch (error)
 124     {
 125     case GNUTLS_E_SUCCESS:
 126       return Qt;
 127     case GNUTLS_E_AGAIN:
 128       return Qgnutls_e_again;
 129     case GNUTLS_E_INTERRUPTED:
 130       return Qgnutls_e_interrupted;
 131     case GNUTLS_E_INVALID_SESSION:
 132       return Qgnutls_e_invalid_session;
 133     }
 134
 135   return make_number (error);
 136 }
 137
 138 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
 139        doc: /* Return the GnuTLS init stage of process PROC.
 140 See also `gnutls-boot'.  */)
 141   (Lisp_Object proc)
 142 {
 143   CHECK_PROCESS (proc);
 144
 145   return make_number (GNUTLS_INITSTAGE (proc));
 146 }
 147
 148 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
 149        doc: /* Return t if ERROR indicates a GnuTLS problem.
 150 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 151 usage: (gnutls-errorp ERROR)  */)
 152   (Lisp_Object err)
 153 {
 154   if (EQ (err, Qt)) return Qnil;
 155
 156   return Qt;
 157 }
 158
 159 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0,
 160        doc: /* Check if ERROR is fatal.
 161 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 162 usage: (gnutls-error-fatalp ERROR)  */)
 163   (Lisp_Object err)
 164 {
 165   Lisp_Object code;
 166
 167   if (EQ (err, Qt)) return Qnil;
 168
 169   if (SYMBOLP (err))
 170     {
 171       code = Fget (err, Qgnutls_code);
 172       if (NUMBERP (code))
 173         {
 174           err = code;
 175         }
 176       else
 177         {
 178           error ("Symbol has no numeric gnutls-code property");
 179         }
 180     }
 181
 182   if (!NUMBERP (err))
 183     error ("Not an error symbol or code");
 184
 185   if (0 == gnutls_error_is_fatal (XINT (err)))
 186     return Qnil;
 187
 188   return Qt;
 189 }
 190
 191 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0,
 192        doc: /* Return a description of ERROR.
 193 ERROR is an integer or a symbol with an integer `gnutls-code' property.
 194 usage: (gnutls-error-string ERROR)  */)
 195   (Lisp_Object err)
 196 {
 197   Lisp_Object code;
 198
 199   if (EQ (err, Qt)) return build_string ("Not an error");
 200
 201   if (SYMBOLP (err))
 202     {
 203       code = Fget (err, Qgnutls_code);
 204       if (NUMBERP (code))
 205         {
 206           err = code;
 207         }
 208       else
 209         {
 210           return build_string ("Symbol has no numeric gnutls-code property");
 211         }
 212     }
 213
 214   if (!NUMBERP (err))
 215     return build_string ("Not an error symbol or code");
 216
 217   return build_string (gnutls_strerror (XINT (err)));
 218 }
 219
 220 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
 221        doc: /* Deallocate GNU TLS resources associated with process PROC.
 222 See also `gnutls-init'.  */)
 223   (Lisp_Object proc)
 224 {
 225   gnutls_session_t state;
 226
 227   CHECK_PROCESS (proc);
 228   state = XPROCESS (proc)->gnutls_state;
 229
 230   if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 231     {
 232       gnutls_deinit (state);
 233       GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
 234     }
 235
 236   return Qt;
 237 }
 238
 239 /* Initializes global GNU TLS state to defaults.
 240 Call `gnutls-global-deinit' when GNU TLS usage is no longer needed.
 241 Returns zero on success.  */
 242 static Lisp_Object
 243 gnutls_emacs_global_init (void)
 244 {
 245   int ret = GNUTLS_E_SUCCESS;
 246
 247   if (!global_initialized)
 248     ret = gnutls_global_init ();
 249
 250   global_initialized = 1;
 251
 252   return gnutls_make_error (ret);
 253 }
 254
 255 /* Deinitializes global GNU TLS state.
 256 See also `gnutls-global-init'.  */
 257 static Lisp_Object
 258 gnutls_emacs_global_deinit (void)
 259 {
 260   if (global_initialized)
 261     gnutls_global_deinit ();
 262
 263   global_initialized = 0;
 264
 265   return gnutls_make_error (GNUTLS_E_SUCCESS);
 266 }
 267
 268 static void
 269 gnutls_log_function (int level, const char* string)
 270 {
 271   message ("gnutls.c: [%d] %s", level, string);
 272 }
 273
 274 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 7, 0,
 275        doc: /* Initialize client-mode GnuTLS for process PROC.
 276 Currently only client mode is supported.  Returns a success/failure
 277 value you can check with `gnutls-errorp'.
 278
 279 PRIORITY-STRING is a string describing the priority.
 280 TYPE is either `gnutls-anon' or `gnutls-x509pki'.
 281 TRUSTFILE is a PEM encoded trust file for `gnutls-x509pki'.
 282 KEYFILE is ... for `gnutls-x509pki' (TODO).
 283 CALLBACK is ... for `gnutls-x509pki' (TODO).
 284 LOGLEVEL is the debug level requested from GnuTLS, try 4.
 285
 286 LOGLEVEL will be set for this process AND globally for GnuTLS.  So if
 287 you set it higher or lower at any point, it affects global debugging.
 288
 289 Note that the priority is set on the client.  The server does not use
 290 the protocols's priority except for disabling protocols that were not
 291 specified.
 292
 293 Processes must be initialized with this function before other GnuTLS
 294 functions are used.  This function allocates resources which can only
 295 be deallocated by calling `gnutls-deinit' or by calling it again.
 296
 297 Each authentication type may need additional information in order to
 298 work.  For X.509 PKI (`gnutls-x509pki'), you need TRUSTFILE and
 299 KEYFILE and optionally CALLBACK.  */)
 300   (Lisp_Object proc, Lisp_Object priority_string, Lisp_Object type,
 301    Lisp_Object trustfile, Lisp_Object keyfile, Lisp_Object callback,
 302    Lisp_Object loglevel)
 303 {
 304   int ret = GNUTLS_E_SUCCESS;
 305
 306   int max_log_level = 0;
 307
 308   /* TODO: GNUTLS_X509_FMT_DER is also an option.  */
 309   int file_format = GNUTLS_X509_FMT_PEM;
 310
 311   gnutls_session_t state;
 312   gnutls_certificate_credentials_t x509_cred;
 313   gnutls_anon_client_credentials_t anon_cred;
 314   Lisp_Object global_init;
 315
 316   CHECK_PROCESS (proc);
 317   CHECK_SYMBOL (type);
 318   CHECK_STRING (priority_string);
 319
 320   state = XPROCESS (proc)->gnutls_state;
 321   XPROCESS (proc)->gnutls_p = 1;
 322
 323   if (NUMBERP (loglevel))
 324     {
 325       gnutls_global_set_log_function (gnutls_log_function);
 326       gnutls_global_set_log_level (XINT (loglevel));
 327       max_log_level = XINT (loglevel);
 328       XPROCESS (proc)->gnutls_log_level = max_log_level;
 329     }
 330
 331   /* always initialize globals.  */
 332   global_init = gnutls_emacs_global_init ();
 333   if (! NILP (Fgnutls_errorp (global_init)))
 334     return global_init;
 335
 336   /* deinit and free resources.  */
 337   if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_CRED_ALLOC)
 338     {
 339       GNUTLS_LOG (1, max_log_level, "deallocating credentials");
 340
 341       if (EQ (type, Qgnutls_x509pki))
 342         {
 343           GNUTLS_LOG (2, max_log_level, "deallocating x509 credentials");
 344           x509_cred = XPROCESS (proc)->gnutls_x509_cred;
 345           gnutls_certificate_free_credentials (x509_cred);
 346         }
 347       else if (EQ (type, Qgnutls_anon))
 348         {
 349           GNUTLS_LOG (2, max_log_level, "deallocating anon credentials");
 350           anon_cred = XPROCESS (proc)->gnutls_anon_cred;
 351           gnutls_anon_free_client_credentials (anon_cred);
 352         }
 353       else
 354         {
 355           error ("unknown credential type");
 356           ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
 357         }
 358
 359       if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT)
 360         {
 361           GNUTLS_LOG (1, max_log_level, "deallocating x509 credentials");
 362           Fgnutls_deinit (proc);
 363         }
 364     }
 365
 366   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY;
 367
 368   GNUTLS_LOG (1, max_log_level, "allocating credentials");
 369
 370   if (EQ (type, Qgnutls_x509pki))
 371     {
 372       GNUTLS_LOG (2, max_log_level, "allocating x509 credentials");
 373       x509_cred = XPROCESS (proc)->gnutls_x509_cred;
 374       if (gnutls_certificate_allocate_credentials (&x509_cred) < 0)
 375         memory_full ();
 376     }
 377   else if (EQ (type, Qgnutls_anon))
 378     {
 379       GNUTLS_LOG (2, max_log_level, "allocating anon credentials");
 380       anon_cred = XPROCESS (proc)->gnutls_anon_cred;
 381       if (gnutls_anon_allocate_client_credentials (&anon_cred) < 0)
 382         memory_full ();
 383     }
 384   else
 385     {
 386       error ("unknown credential type");
 387       ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
 388     }
 389
 390   if (ret < GNUTLS_E_SUCCESS)
 391     return gnutls_make_error (ret);
 392
 393   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC;
 394
 395   if (EQ (type, Qgnutls_x509pki))
 396     {
 397       if (STRINGP (trustfile))
 398         {
 399           GNUTLS_LOG (1, max_log_level, "setting the trustfile");
 400           ret = gnutls_certificate_set_x509_trust_file
 401             (x509_cred,
 402              SDATA (trustfile),
 403              file_format);
 404
 405           if (ret < GNUTLS_E_SUCCESS)
 406             return gnutls_make_error (ret);
 407         }
 408
 409       if (STRINGP (keyfile))
 410         {
 411           GNUTLS_LOG (1, max_log_level, "setting the keyfile");
 412           ret = gnutls_certificate_set_x509_crl_file
 413             (x509_cred,
 414              SDATA (keyfile),
 415              file_format);
 416
 417           if (ret < GNUTLS_E_SUCCESS)
 418             return gnutls_make_error (ret);
 419         }
 420     }
 421
 422   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES;
 423
 424   GNUTLS_LOG (1, max_log_level, "gnutls_init");
 425
 426   ret = gnutls_init (&state, GNUTLS_CLIENT);
 427
 428   if (ret < GNUTLS_E_SUCCESS)
 429     return gnutls_make_error (ret);
 430
 431   XPROCESS (proc)->gnutls_state = state;
 432
 433   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT;
 434
 435   GNUTLS_LOG (1, max_log_level, "setting the priority string");
 436
 437   ret = gnutls_priority_set_direct (state,
 438                                     (char*) SDATA (priority_string),
 439                                     NULL);
 440
 441   if (ret < GNUTLS_E_SUCCESS)
 442     return gnutls_make_error (ret);
 443
 444   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
 445
 446   if (EQ (type, Qgnutls_x509pki))
 447     {
 448       ret = gnutls_cred_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred);
 449     }
 450   else if (EQ (type, Qgnutls_anon))
 451     {
 452       ret = gnutls_cred_set (state, GNUTLS_CRD_ANON, anon_cred);
 453     }
 454   else
 455     {
 456       error ("unknown credential type");
 457       ret = GNUTLS_EMACS_ERROR_INVALID_TYPE;
 458     }
 459
 460   if (ret < GNUTLS_E_SUCCESS)
 461     return gnutls_make_error (ret);
 462
 463   XPROCESS (proc)->gnutls_anon_cred = anon_cred;
 464   XPROCESS (proc)->gnutls_x509_cred = x509_cred;
 465   XPROCESS (proc)->gnutls_cred_type = type;
 466
 467   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET;
 468
 469   emacs_gnutls_handshake (XPROCESS (proc));
 470
 471   return gnutls_make_error (GNUTLS_E_SUCCESS);
 472 }
 473
 474 DEFUN ("gnutls-bye", Fgnutls_bye,
 475        Sgnutls_bye, 2, 2, 0,
 476        doc: /* Terminate current GnuTLS connection for process PROC.
 477 The connection should have been initiated using `gnutls-handshake'.
 478
 479 If CONT is not nil the TLS connection gets terminated and further
 480 receives and sends will be disallowed.  If the return value is zero you
 481 may continue using the connection.  If CONT is nil, GnuTLS actually
 482 sends an alert containing a close request and waits for the peer to
 483 reply with the same message.  In order to reuse the connection you
 484 should wait for an EOF from the peer.
 485
 486 This function may also return `gnutls-e-again', or
 487 `gnutls-e-interrupted'.  */)
 488     (Lisp_Object proc, Lisp_Object cont)
 489 {
 490   gnutls_session_t state;
 491   int ret;
 492
 493   CHECK_PROCESS (proc);
 494
 495   state = XPROCESS (proc)->gnutls_state;
 496
 497   ret = gnutls_bye (state,
 498                     NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
 499
 500   return gnutls_make_error (ret);
 501 }
 502
 503 void
 504 syms_of_gnutls (void)
 505 {
 506   global_initialized = 0;
 507
 508   Qgnutls_code = intern_c_string ("gnutls-code");
 509   staticpro (&Qgnutls_code);
 510
 511   Qgnutls_anon = intern_c_string ("gnutls-anon");
 512   staticpro (&Qgnutls_anon);
 513
 514   Qgnutls_x509pki = intern_c_string ("gnutls-x509pki");
 515   staticpro (&Qgnutls_x509pki);
 516
 517   Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted");
 518   staticpro (&Qgnutls_e_interrupted);
 519   Fput (Qgnutls_e_interrupted, Qgnutls_code,
 520         make_number (GNUTLS_E_INTERRUPTED));
 521
 522   Qgnutls_e_again = intern_c_string ("gnutls-e-again");
 523   staticpro (&Qgnutls_e_again);
 524   Fput (Qgnutls_e_again, Qgnutls_code,
 525         make_number (GNUTLS_E_AGAIN));
 526
 527   Qgnutls_e_invalid_session = intern_c_string ("gnutls-e-invalid-session");
 528   staticpro (&Qgnutls_e_invalid_session);
 529   Fput (Qgnutls_e_invalid_session, Qgnutls_code,
 530         make_number (GNUTLS_E_INVALID_SESSION));
 531
 532   Qgnutls_e_not_ready_for_handshake =
 533     intern_c_string ("gnutls-e-not-ready-for-handshake");
 534   staticpro (&Qgnutls_e_not_ready_for_handshake);
 535   Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
 536         make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
 537
 538   defsubr (&Sgnutls_get_initstage);
 539   defsubr (&Sgnutls_errorp);
 540   defsubr (&Sgnutls_error_fatalp);
 541   defsubr (&Sgnutls_error_string);
 542   defsubr (&Sgnutls_boot);
 543   defsubr (&Sgnutls_deinit);
 544   defsubr (&Sgnutls_bye);
 545 }
 546 #endif