guile/src/extra.c

   1 /* GNUTLS-EXTRA --- Guile bindings for GNUTLS-EXTRA.
   2    Copyright (C) 2007  Free Software Foundation
   3
   4    GNUTLS-EXTRA is free software; you can redistribute it and/or modify
   5    it under the terms of the GNU General Public License as published by
   6    the Free Software Foundation; either version 3 of the License, or
   7    (at your option) any later version.
   8
   9    GNUTLS-EXTRA is distributed in the hope that it will be useful,
  10    but WITHOUT ANY WARRANTY; without even the implied warranty of
  11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12    GNU General Public License for more details.
  13
  14    You should have received a copy of the GNU General Public License
  15    along with GNUTLS-EXTRA; if not, write to the Free Software
  16    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.  */
  17
  18 /* Important note: As written above, this part of the code is ditributed
  19    under the GPL, not the LGPL.  */
  20
  21 /* Written by Ludovic Courtès <ludo@chbouib.org>.  */
  22
  23
  24 #include <stdio.h>
  25 #include <gnutls/gnutls.h>
  26 #include <gnutls/extra.h>
  27 #include <gnutls/openpgp.h>
  28 #include <libguile.h>
  29
  30 #include <alloca.h>
  31
  32 #include "errors.h"
  33 #include "utils.h"
  34 #include "smobs.h"
  35 #include "enums.h"
  36 #include "extra-enums.h"
  37 #include "extra-smobs.h"
  38
  39
  40 \f
  41 /* SMOB and enums type definitions.  */
  42
  43 #include "extra-smob-types.i.c"
  44 #include "extra-enum-map.i.c"
  45
  46 \f
  47 /* OpenPGP keys.  */
  48
  49
  50 /* Maximum size we support for the name of OpenPGP keys.  */
  51 #define GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH  2048
  52
  53 SCM_DEFINE (scm_gnutls_import_openpgp_certificate, "import-openpgp-certificate",
  54             2, 0, 0,
  55             (SCM data, SCM format),
  56             "Return a new OpenPGP certificate object resulting from the "
  57             "import of @var{data} (a uniform array) according to "
  58             "@var{format}.")
  59 #define FUNC_NAME s_scm_gnutls_import_openpgp_certificate
  60 {
  61   int err;
  62   gnutls_openpgp_crt_t c_key;
  63   gnutls_openpgp_crt_fmt_t c_format;
  64   gnutls_datum_t c_data_d;
  65   scm_t_array_handle c_data_handle;
  66   const char *c_data;
  67   size_t c_data_len;
  68
  69   SCM_VALIDATE_ARRAY (1, data);
  70   c_format = scm_to_gnutls_openpgp_certificate_format (format, 2, FUNC_NAME);
  71
  72   c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
  73                                  FUNC_NAME);
  74   c_data_d.data = (unsigned char *) c_data;
  75   c_data_d.size = c_data_len;
  76
  77   err = gnutls_openpgp_crt_init (&c_key);
  78   if (EXPECT_FALSE (err))
  79     {
  80       scm_gnutls_release_array (&c_data_handle);
  81       scm_gnutls_error (err, FUNC_NAME);
  82     }
  83
  84   err = gnutls_openpgp_crt_import (c_key, &c_data_d, c_format);
  85   scm_gnutls_release_array (&c_data_handle);
  86
  87   if (EXPECT_FALSE (err))
  88     {
  89       gnutls_openpgp_crt_deinit (c_key);
  90       scm_gnutls_error (err, FUNC_NAME);
  91     }
  92
  93   return (scm_from_gnutls_openpgp_certificate (c_key));
  94 }
  95 #undef FUNC_NAME
  96
  97 SCM_DEFINE (scm_gnutls_import_openpgp_private_key, "import-openpgp-private-key",
  98             2, 1, 0,
  99             (SCM data, SCM format, SCM pass),
 100             "Return a new OpenPGP private key object resulting from the "
 101             "import of @var{data} (a uniform array) according to "
 102             "@var{format}.  Optionally, a passphrase may be provided.")
 103 #define FUNC_NAME s_scm_gnutls_import_openpgp_private_key
 104 {
 105   int err;
 106   gnutls_openpgp_privkey_t c_key;
 107   gnutls_openpgp_crt_fmt_t c_format;
 108   gnutls_datum_t c_data_d;
 109   scm_t_array_handle c_data_handle;
 110   const char *c_data;
 111   char *c_pass;
 112   size_t c_data_len, c_pass_len;
 113
 114   SCM_VALIDATE_ARRAY (1, data);
 115   c_format = scm_to_gnutls_openpgp_certificate_format (format, 2, FUNC_NAME);
 116   if ((pass == SCM_UNDEFINED) || (scm_is_false (pass)))
 117     c_pass = NULL;
 118   else
 119     {
 120       c_pass_len = scm_c_string_length (pass);
 121       c_pass = (char *) alloca (c_pass_len + 1);
 122       (void) scm_to_locale_stringbuf (pass, c_pass, c_pass_len + 1);
 123       c_pass[c_pass_len] = '\0';
 124     }
 125
 126   c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
 127                                  FUNC_NAME);
 128   c_data_d.data = (unsigned char *) c_data;
 129   c_data_d.size = c_data_len;
 130
 131   err = gnutls_openpgp_privkey_init (&c_key);
 132   if (EXPECT_FALSE (err))
 133     {
 134       scm_gnutls_release_array (&c_data_handle);
 135       scm_gnutls_error (err, FUNC_NAME);
 136     }
 137
 138   err = gnutls_openpgp_privkey_import (c_key, &c_data_d, c_format, c_pass,
 139                                        0 /* currently unused */);
 140   scm_gnutls_release_array (&c_data_handle);
 141
 142   if (EXPECT_FALSE (err))
 143     {
 144       gnutls_openpgp_privkey_deinit (c_key);
 145       scm_gnutls_error (err, FUNC_NAME);
 146     }
 147
 148   return (scm_from_gnutls_openpgp_private_key (c_key));
 149 }
 150 #undef FUNC_NAME
 151
 152 SCM_DEFINE (scm_gnutls_openpgp_certificate_id, "openpgp-certificate-id",
 153             1, 0, 0,
 154             (SCM key),
 155             "Return the ID (an 8-element u8vector) of certificate "
 156             "@var{key}.")
 157 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_id
 158 {
 159   int err;
 160   unsigned char *c_id;
 161   gnutls_openpgp_crt_t c_key;
 162
 163   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
 164
 165   c_id = (unsigned char * ) malloc (8);
 166   if (c_id == NULL)
 167     scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
 168
 169   err = gnutls_openpgp_crt_get_id (c_key, c_id);
 170   if (EXPECT_FALSE (err))
 171     scm_gnutls_error (err, FUNC_NAME);
 172
 173   return (scm_take_u8vector (c_id, 8));
 174 }
 175 #undef FUNC_NAME
 176
 177 SCM_DEFINE (scm_gnutls_openpgp_certificate_id_x, "openpgp-certificate-id!",
 178             2, 0, 0,
 179             (SCM key, SCM id),
 180             "Store the ID (an 8 byte sequence) of certificate "
 181             "@var{key} in @var{id} (a u8vector).")
 182 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_id_x
 183 {
 184   int err;
 185   char *c_id;
 186   scm_t_array_handle c_id_handle;
 187   size_t c_id_size;
 188   gnutls_openpgp_crt_t c_key;
 189
 190   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
 191   c_id = scm_gnutls_get_writable_array (id, &c_id_handle, &c_id_size,
 192                                         FUNC_NAME);
 193
 194   if (EXPECT_FALSE (c_id_size < 8))
 195     {
 196       scm_gnutls_release_array (&c_id_handle);
 197       scm_misc_error (FUNC_NAME, "ID vector too small: ~A",
 198                       scm_list_1 (id));
 199     }
 200
 201   err = gnutls_openpgp_crt_get_id (c_key, (unsigned char *) c_id);
 202   scm_gnutls_release_array (&c_id_handle);
 203
 204   if (EXPECT_FALSE (err))
 205     scm_gnutls_error (err, FUNC_NAME);
 206
 207   return SCM_UNSPECIFIED;
 208 }
 209 #undef FUNC_NAME
 210
 211 SCM_DEFINE (scm_gnutls_openpgp_certificate_fingerpint_x,
 212             "openpgp-certificate-fingerprint!",
 213             2, 0, 0,
 214             (SCM key, SCM fpr),
 215             "Store in @var{fpr} (a u8vector) the fingerprint of @var{key}.  "
 216             "Return the number of bytes stored in @var{fpr}.")
 217 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_fingerpint_x
 218 {
 219   int err;
 220   gnutls_openpgp_crt_t c_key;
 221   char *c_fpr;
 222   scm_t_array_handle c_fpr_handle;
 223   size_t c_fpr_len, c_actual_len = 0;
 224
 225   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
 226   SCM_VALIDATE_ARRAY (2, fpr);
 227
 228   c_fpr = scm_gnutls_get_writable_array (fpr, &c_fpr_handle, &c_fpr_len,
 229                                          FUNC_NAME);
 230
 231   err = gnutls_openpgp_crt_get_fingerprint (c_key, c_fpr, &c_actual_len);
 232   scm_gnutls_release_array (&c_fpr_handle);
 233
 234   if (EXPECT_FALSE (err))
 235     scm_gnutls_error (err, FUNC_NAME);
 236
 237   return (scm_from_size_t (c_actual_len));
 238 }
 239 #undef FUNC_NAME
 240
 241 SCM_DEFINE (scm_gnutls_openpgp_certificate_fingerprint,
 242             "openpgp-certificate-fingerprint",
 243             1, 0, 0,
 244             (SCM key),
 245             "Return a new u8vector denoting the fingerprint of "
 246             "@var{key}.")
 247 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_fingerprint
 248 {
 249   int err;
 250   gnutls_openpgp_crt_t c_key;
 251   unsigned char *c_fpr;
 252   size_t c_fpr_len, c_actual_len;
 253
 254   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
 255
 256   /* V4 fingerprints are 160-bit SHA-1 hashes (see RFC2440).  */
 257   c_fpr_len = 20;
 258   c_fpr = (unsigned char *) malloc (c_fpr_len);
 259   if (EXPECT_FALSE (c_fpr == NULL))
 260     scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
 261
 262   do
 263     {
 264       c_actual_len = 0;
 265       err = gnutls_openpgp_crt_get_fingerprint (c_key, c_fpr,
 266                                                 &c_actual_len);
 267       if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
 268         {
 269           /* Grow C_FPR.  */
 270           unsigned char *c_new;
 271
 272           c_new = (unsigned char *) realloc (c_fpr, c_fpr_len * 2);
 273           if (EXPECT_FALSE (c_new == NULL))
 274             {
 275               free (c_fpr);
 276               scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
 277             }
 278           else
 279             {
 280               c_fpr_len *= 2;
 281               c_fpr = c_new;
 282             }
 283         }
 284     }
 285   while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
 286
 287   if (EXPECT_FALSE (err))
 288     {
 289       free (c_fpr);
 290       scm_gnutls_error (err, FUNC_NAME);
 291     }
 292
 293   if (c_actual_len < c_fpr_len)
 294     /* Shrink C_FPR.  */
 295     c_fpr = realloc (c_fpr, c_actual_len);
 296
 297   return (scm_take_u8vector (c_fpr, c_actual_len));
 298 }
 299 #undef FUNC_NAME
 300
 301 SCM_DEFINE (scm_gnutls_openpgp_certificate_name, "openpgp-certificate-name",
 302             2, 0, 0,
 303             (SCM key, SCM index),
 304             "Return the @var{index}th name of @var{key}.")
 305 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_name
 306 {
 307   int err;
 308   gnutls_openpgp_crt_t c_key;
 309   int c_index;
 310   char c_name[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH];
 311   size_t c_name_len = sizeof (c_name);
 312
 313   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
 314   c_index = scm_to_int (index);
 315
 316   err = gnutls_openpgp_crt_get_name (c_key, c_index, c_name,
 317                                      &c_name_len);
 318   if (EXPECT_FALSE (err))
 319     scm_gnutls_error (err, FUNC_NAME);
 320
 321   /* XXX: The name is really UTF-8.  */
 322   return (scm_from_locale_string (c_name));
 323 }
 324 #undef FUNC_NAME
 325
 326 SCM_DEFINE (scm_gnutls_openpgp_certificate_names, "openpgp-certificate-names",
 327             1, 0, 0,
 328             (SCM key),
 329             "Return the list of names for @var{key}.")
 330 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_names
 331 {
 332   int err;
 333   SCM result = SCM_EOL;
 334   gnutls_openpgp_crt_t c_key;
 335   int c_index = 0;
 336   char c_name[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH];
 337   size_t c_name_len = sizeof (c_name);
 338
 339   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
 340
 341   do
 342     {
 343       err = gnutls_openpgp_crt_get_name (c_key, c_index, c_name,
 344                                          &c_name_len);
 345       if (!err)
 346         {
 347           result = scm_cons (scm_from_locale_string (c_name),
 348                              result);
 349           c_index++;
 350         }
 351     }
 352   while (!err);
 353
 354   if (EXPECT_FALSE (err != GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE))
 355     scm_gnutls_error (err, FUNC_NAME);
 356
 357   return (scm_reverse_x (result, SCM_EOL));
 358 }
 359 #undef FUNC_NAME
 360
 361 SCM_DEFINE (scm_gnutls_openpgp_certificate_algorithm,
 362             "openpgp-certificate-algorithm",
 363             1, 0, 0,
 364             (SCM key),
 365             "Return two values: the certificate algorithm used by "
 366             "@var{key} and the number of bits used.")
 367 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_algorithm
 368 {
 369   gnutls_openpgp_crt_t c_key;
 370   unsigned int c_bits;
 371   gnutls_pk_algorithm_t c_algo;
 372
 373   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
 374   c_algo = gnutls_openpgp_crt_get_pk_algorithm (c_key, &c_bits);
 375
 376   return (scm_values (scm_list_2 (scm_from_gnutls_pk_algorithm (c_algo),
 377                                   scm_from_uint (c_bits))));
 378 }
 379 #undef FUNC_NAME
 380
 381 SCM_DEFINE (scm_gnutls_openpgp_certificate_version,
 382             "openpgp-certificate-version",
 383             1, 0, 0,
 384             (SCM key),
 385             "Return the version of the OpenPGP message format (RFC2440) "
 386             "honored by @var{key}.")
 387 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_version
 388 {
 389   int c_version;
 390   gnutls_openpgp_crt_t c_key;
 391
 392   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
 393   c_version = gnutls_openpgp_crt_get_version (c_key);
 394
 395   return (scm_from_int (c_version));
 396 }
 397 #undef FUNC_NAME
 398
 399 SCM_DEFINE (scm_gnutls_openpgp_certificate_usage, "openpgp-certificate-usage",
 400             1, 0, 0,
 401             (SCM key),
 402             "Return a list of values denoting the key usage of @var{key}.")
 403 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_usage
 404 {
 405   int err;
 406   unsigned int c_usage = 0;
 407   gnutls_openpgp_crt_t c_key;
 408
 409   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
 410
 411   err = gnutls_openpgp_crt_get_key_usage (c_key, &c_usage);
 412   if (EXPECT_FALSE (err))
 413     scm_gnutls_error (err, FUNC_NAME);
 414
 415   return (scm_from_gnutls_key_usage_flags (c_usage));
 416 }
 417 #undef FUNC_NAME
 418
 419
 420 \f
 421 /* OpenPGP keyrings.  */
 422
 423 SCM_DEFINE (scm_gnutls_import_openpgp_keyring, "import-openpgp-keyring",
 424             2, 0, 0,
 425             (SCM data, SCM format),
 426             "Import @var{data} (a u8vector) according to @var{format} "
 427             "and return the imported keyring.")
 428 #define FUNC_NAME s_scm_gnutls_import_openpgp_keyring
 429 {
 430   int err;
 431   gnutls_openpgp_keyring_t c_keyring;
 432   gnutls_openpgp_crt_fmt_t c_format;
 433   gnutls_datum_t c_data_d;
 434   scm_t_array_handle c_data_handle;
 435   const char *c_data;
 436   size_t c_data_len;
 437
 438   SCM_VALIDATE_ARRAY (1, data);
 439   c_format = scm_to_gnutls_openpgp_certificate_format (format, 2, FUNC_NAME);
 440
 441   c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
 442                                  FUNC_NAME);
 443
 444   c_data_d.data = (unsigned char *) c_data;
 445   c_data_d.size = c_data_len;
 446
 447   err = gnutls_openpgp_keyring_init (&c_keyring);
 448   if (EXPECT_FALSE (err))
 449     {
 450       scm_gnutls_release_array (&c_data_handle);
 451       scm_gnutls_error (err, FUNC_NAME);
 452     }
 453
 454   err = gnutls_openpgp_keyring_import (c_keyring, &c_data_d, c_format);
 455   scm_gnutls_release_array (&c_data_handle);
 456
 457   if (EXPECT_FALSE (err))
 458     {
 459       gnutls_openpgp_keyring_deinit (c_keyring);
 460       scm_gnutls_error (err, FUNC_NAME);
 461     }
 462
 463   return (scm_from_gnutls_openpgp_keyring (c_keyring));
 464 }
 465 #undef FUNC_NAME
 466
 467 SCM_DEFINE (scm_gnutls_openpgp_keyring_contains_key_id_p,
 468             "openpgp-keyring-contains-key-id?",
 469             2, 0, 0,
 470             (SCM keyring, SCM id),
 471             "Return @code{#f} if key ID @var{id} is in @var{keyring}, "
 472             "@code{#f} otherwise.")
 473 #define FUNC_NAME s_scm_gnutls_openpgp_keyring_contains_key_id_p
 474 {
 475   int c_result;
 476   gnutls_openpgp_keyring_t c_keyring;
 477   scm_t_array_handle c_id_handle;
 478   const char *c_id;
 479   size_t c_id_len;
 480
 481   c_keyring = scm_to_gnutls_openpgp_keyring (keyring, 1, FUNC_NAME);
 482   SCM_VALIDATE_ARRAY (1, id);
 483
 484   c_id = scm_gnutls_get_array (id, &c_id_handle, &c_id_len,
 485                                FUNC_NAME);
 486   if (EXPECT_FALSE (c_id_len != 8))
 487     {
 488       scm_gnutls_release_array (&c_id_handle);
 489       scm_wrong_type_arg (FUNC_NAME, 1, id);
 490     }
 491
 492   c_result = gnutls_openpgp_keyring_check_id (c_keyring,
 493                                               (unsigned char *) c_id,
 494                                               0 /* unused */);
 495
 496   scm_gnutls_release_array (&c_id_handle);
 497
 498   return (scm_from_bool (c_result == 0));
 499 }
 500 #undef FUNC_NAME
 501
 502 \f
 503 /* Certificates.  */
 504
 505 SCM_DEFINE (scm_gnutls_set_certificate_credentials_openpgp_keys_x,
 506             "set-certificate-credentials-openpgp-keys!",
 507             3, 0, 0,
 508             (SCM cred, SCM pub, SCM sec),
 509             "Use certificate @var{pub} and secret key @var{sec} in "
 510             "certificate credentials @var{cred}.")
 511 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_openpgp_keys_x
 512 {
 513   int err;
 514   gnutls_certificate_credentials_t c_cred;
 515   gnutls_openpgp_crt_t c_pub;
 516   gnutls_openpgp_privkey_t c_sec;
 517
 518   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
 519   c_pub = scm_to_gnutls_openpgp_certificate (pub, 2, FUNC_NAME);
 520   c_sec = scm_to_gnutls_openpgp_private_key (sec, 3, FUNC_NAME);
 521
 522   err = gnutls_certificate_set_openpgp_key (c_cred, c_pub, c_sec);
 523   if (EXPECT_FALSE (err))
 524     scm_gnutls_error (err, FUNC_NAME);
 525
 526   return SCM_UNSPECIFIED;
 527 }
 528 #undef FUNC_NAME
 529
 530 \f
 531 /* Initialization.  */
 532
 533 void
 534 scm_init_gnutls_extra (void)
 535 {
 536 #include "extra.x"
 537
 538   (void) gnutls_global_init_extra ();
 539
 540   scm_gnutls_define_enums ();
 541 }
 542
 543 /* arch-tag: 655f308d-5643-4bc7-9db4-1f84bd902bef
 544  */