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