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