guile/src/core.c

   1 /* GnuTLS --- Guile bindings for GnuTLS.
   2    Copyright (C) 2007-2012 Free Software Foundation, Inc.
   3
   4    GnuTLS is free software; you can redistribute it and/or
   5    modify it under the terms of the GNU Lesser General Public
   6    License as published by the Free Software Foundation; either
   7    version 2.1 of the License, or (at your option) any later version.
   8
   9    GnuTLS 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 GNU
  12    Lesser General Public License for more details.
  13
  14    You should have received a copy of the GNU Lesser General Public
  15    License along with GnuTLS; if not, write to the Free Software
  16    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA  */
  17
  18 /* Written by Ludovic Courtès <ludo@gnu.org>.  */
  19
  20 #ifdef HAVE_CONFIG_H
  21 #include <config.h>
  22 #endif
  23
  24 #include <stdio.h>
  25 #include <stdint.h>
  26 #include <string.h>
  27 #include <gnutls/gnutls.h>
  28 #include <gnutls/openpgp.h>
  29 #include <libguile.h>
  30
  31 #include <alloca.h>
  32
  33 #include "enums.h"
  34 #include "smobs.h"
  35 #include "errors.h"
  36 #include "utils.h"
  37 \f
  38
  39
  40 /* SMOB and enums type definitions.  */
  41 #include "enum-map.i.c"
  42 #include "smob-types.i.c"
  43
  44 const char scm_gnutls_array_error_message[] =
  45   "cannot handle non-contiguous array: ~A";
  46
  47
  48 /* Data that are attached to `gnutls_session_t' objects.
  49
  50    We need to keep several pieces of information along with each session:
  51
  52      - A boolean indicating whether its underlying transport is a file
  53        descriptor or Scheme port.  This is used to decide whether to leave
  54        "Guile mode" when invoking `gnutls_record_recv ()'.
  55
  56      - The record port attached to the session (returned by
  57        `session-record-port').  This is so that several calls to
  58        `session-record-port' return the same port.
  59
  60    Currently, this information is maintained into a pair.  The whole pair is
  61    marked by the session mark procedure.  */
  62
  63 #define SCM_GNUTLS_MAKE_SESSION_DATA()          \
  64   scm_cons (SCM_BOOL_F, SCM_BOOL_F)
  65 #define SCM_GNUTLS_SET_SESSION_DATA(c_session, data)                    \
  66   gnutls_session_set_ptr (c_session, (void *) SCM_UNPACK (data))
  67 #define SCM_GNUTLS_SESSION_DATA(c_session)                      \
  68   SCM_PACK ((scm_t_bits) gnutls_session_get_ptr (c_session))
  69
  70 #define SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD(c_session, c_is_fd)      \
  71   SCM_SETCAR (SCM_GNUTLS_SESSION_DATA (c_session),                      \
  72               scm_from_bool (c_is_fd))
  73 #define SCM_GNUTLS_SET_SESSION_RECORD_PORT(c_session, port)     \
  74   SCM_SETCDR (SCM_GNUTLS_SESSION_DATA (c_session), port)
  75
  76 #define SCM_GNUTLS_SESSION_TRANSPORT_IS_FD(c_session)           \
  77   scm_to_bool (SCM_CAR (SCM_GNUTLS_SESSION_DATA (c_session)))
  78 #define SCM_GNUTLS_SESSION_RECORD_PORT(c_session)       \
  79   SCM_CDR (SCM_GNUTLS_SESSION_DATA (c_session))
  80 \f
  81
  82
  83 /* Bindings.  */
  84
  85 /* Mark the data associated with SESSION.  */
  86 SCM_SMOB_MARK (scm_tc16_gnutls_session, mark_session, session)
  87 {
  88   gnutls_session_t c_session;
  89
  90   c_session = scm_to_gnutls_session (session, 1, "mark_session");
  91
  92   return (SCM_GNUTLS_SESSION_DATA (c_session));
  93 }
  94
  95 SCM_DEFINE (scm_gnutls_version, "gnutls-version", 0, 0, 0,
  96             (void),
  97             "Return a string denoting the version number of the underlying "
  98             "GnuTLS library, e.g., @code{\"1.7.2\"}.")
  99 #define FUNC_NAME s_scm_gnutls_version
 100 {
 101   return (scm_from_locale_string (gnutls_check_version (NULL)));
 102 }
 103
 104 #undef FUNC_NAME
 105
 106 SCM_DEFINE (scm_gnutls_make_session, "make-session", 1, 0, 0,
 107             (SCM end),
 108             "Return a new session for connection end @var{end}, either "
 109             "@code{connection-end/server} or @code{connection-end/client}.")
 110 #define FUNC_NAME s_scm_gnutls_make_session
 111 {
 112   int err;
 113   gnutls_session_t c_session;
 114   gnutls_connection_end_t c_end;
 115   SCM session_data;
 116
 117   c_end = scm_to_gnutls_connection_end (end, 1, FUNC_NAME);
 118
 119   session_data = SCM_GNUTLS_MAKE_SESSION_DATA ();
 120   err = gnutls_init (&c_session, c_end);
 121
 122   if (EXPECT_FALSE (err))
 123     scm_gnutls_error (err, FUNC_NAME);
 124
 125   SCM_GNUTLS_SET_SESSION_DATA (c_session, session_data);
 126
 127   return (scm_from_gnutls_session (c_session));
 128 }
 129
 130 #undef FUNC_NAME
 131
 132 SCM_DEFINE (scm_gnutls_bye, "bye", 2, 0, 0,
 133             (SCM session, SCM how),
 134             "Close @var{session} according to @var{how}.")
 135 #define FUNC_NAME s_scm_gnutls_bye
 136 {
 137   int err;
 138   gnutls_session_t c_session;
 139   gnutls_close_request_t c_how;
 140
 141   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 142   c_how = scm_to_gnutls_close_request (how, 2, FUNC_NAME);
 143
 144   err = gnutls_bye (c_session, c_how);
 145   if (EXPECT_FALSE (err))
 146     scm_gnutls_error (err, FUNC_NAME);
 147
 148   return SCM_UNSPECIFIED;
 149 }
 150
 151 #undef FUNC_NAME
 152
 153 SCM_DEFINE (scm_gnutls_handshake, "handshake", 1, 0, 0,
 154             (SCM session), "Perform a handshake for @var{session}.")
 155 #define FUNC_NAME s_scm_gnutls_handshake
 156 {
 157   int err;
 158   gnutls_session_t c_session;
 159
 160   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 161
 162   err = gnutls_handshake (c_session);
 163   if (EXPECT_FALSE (err))
 164     scm_gnutls_error (err, FUNC_NAME);
 165
 166   return SCM_UNSPECIFIED;
 167 }
 168
 169 #undef FUNC_NAME
 170
 171 SCM_DEFINE (scm_gnutls_rehandshake, "rehandshake", 1, 0, 0,
 172             (SCM session), "Perform a re-handshaking for @var{session}.")
 173 #define FUNC_NAME s_scm_gnutls_rehandshake
 174 {
 175   int err;
 176   gnutls_session_t c_session;
 177
 178   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 179
 180   err = gnutls_rehandshake (c_session);
 181   if (EXPECT_FALSE (err))
 182     scm_gnutls_error (err, FUNC_NAME);
 183
 184   return SCM_UNSPECIFIED;
 185 }
 186
 187 #undef FUNC_NAME
 188
 189 SCM_DEFINE (scm_gnutls_alert_get, "alert-get", 1, 0, 0,
 190             (SCM session), "Get an aleter from @var{session}.")
 191 #define FUNC_NAME s_scm_gnutls_alert_get
 192 {
 193   gnutls_session_t c_session;
 194   gnutls_alert_description_t c_alert;
 195
 196   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 197
 198   c_alert = gnutls_alert_get (c_session);
 199
 200   return (scm_from_gnutls_alert_description (c_alert));
 201 }
 202
 203 #undef FUNC_NAME
 204
 205 SCM_DEFINE (scm_gnutls_alert_send, "alert-send", 3, 0, 0,
 206             (SCM session, SCM level, SCM alert),
 207             "Send @var{alert} via @var{session}.")
 208 #define FUNC_NAME s_scm_gnutls_alert_send
 209 {
 210   int err;
 211   gnutls_session_t c_session;
 212   gnutls_alert_level_t c_level;
 213   gnutls_alert_description_t c_alert;
 214
 215   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 216   c_level = scm_to_gnutls_alert_level (level, 2, FUNC_NAME);
 217   c_alert = scm_to_gnutls_alert_description (alert, 3, FUNC_NAME);
 218
 219   err = gnutls_alert_send (c_session, c_level, c_alert);
 220   if (EXPECT_FALSE (err))
 221     scm_gnutls_error (err, FUNC_NAME);
 222
 223   return SCM_UNSPECIFIED;
 224 }
 225
 226 #undef FUNC_NAME
 227
 228 /* FIXME: Omitting `alert-send-appropriate'.  */
 229 \f
 230
 231 /* Session accessors.  */
 232
 233 SCM_DEFINE (scm_gnutls_session_cipher, "session-cipher", 1, 0, 0,
 234             (SCM session), "Return @var{session}'s cipher.")
 235 #define FUNC_NAME s_scm_gnutls_session_cipher
 236 {
 237   gnutls_session_t c_session;
 238   gnutls_cipher_algorithm_t c_cipher;
 239
 240   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 241
 242   c_cipher = gnutls_cipher_get (c_session);
 243
 244   return (scm_from_gnutls_cipher (c_cipher));
 245 }
 246
 247 #undef FUNC_NAME
 248
 249 SCM_DEFINE (scm_gnutls_session_kx, "session-kx", 1, 0, 0,
 250             (SCM session), "Return @var{session}'s kx.")
 251 #define FUNC_NAME s_scm_gnutls_session_kx
 252 {
 253   gnutls_session_t c_session;
 254   gnutls_kx_algorithm_t c_kx;
 255
 256   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 257
 258   c_kx = gnutls_kx_get (c_session);
 259
 260   return (scm_from_gnutls_kx (c_kx));
 261 }
 262
 263 #undef FUNC_NAME
 264
 265 SCM_DEFINE (scm_gnutls_session_mac, "session-mac", 1, 0, 0,
 266             (SCM session), "Return @var{session}'s MAC.")
 267 #define FUNC_NAME s_scm_gnutls_session_mac
 268 {
 269   gnutls_session_t c_session;
 270   gnutls_mac_algorithm_t c_mac;
 271
 272   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 273
 274   c_mac = gnutls_mac_get (c_session);
 275
 276   return (scm_from_gnutls_mac (c_mac));
 277 }
 278
 279 #undef FUNC_NAME
 280
 281 SCM_DEFINE (scm_gnutls_session_compression_method,
 282             "session-compression-method", 1, 0, 0,
 283             (SCM session), "Return @var{session}'s compression method.")
 284 #define FUNC_NAME s_scm_gnutls_session_compression_method
 285 {
 286   gnutls_session_t c_session;
 287   gnutls_compression_method_t c_comp;
 288
 289   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 290
 291   c_comp = gnutls_compression_get (c_session);
 292
 293   return (scm_from_gnutls_compression_method (c_comp));
 294 }
 295
 296 #undef FUNC_NAME
 297
 298 SCM_DEFINE (scm_gnutls_session_certificate_type,
 299             "session-certificate-type", 1, 0, 0,
 300             (SCM session), "Return @var{session}'s certificate type.")
 301 #define FUNC_NAME s_scm_gnutls_session_certificate_type
 302 {
 303   gnutls_session_t c_session;
 304   gnutls_certificate_type_t c_cert;
 305
 306   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 307
 308   c_cert = gnutls_certificate_type_get (c_session);
 309
 310   return (scm_from_gnutls_certificate_type (c_cert));
 311 }
 312
 313 #undef FUNC_NAME
 314
 315 SCM_DEFINE (scm_gnutls_session_protocol, "session-protocol", 1, 0, 0,
 316             (SCM session), "Return the protocol used by @var{session}.")
 317 #define FUNC_NAME s_scm_gnutls_session_protocol
 318 {
 319   gnutls_session_t c_session;
 320   gnutls_protocol_t c_protocol;
 321
 322   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 323
 324   c_protocol = gnutls_protocol_get_version (c_session);
 325
 326   return (scm_from_gnutls_protocol (c_protocol));
 327 }
 328
 329 #undef FUNC_NAME
 330
 331 SCM_DEFINE (scm_gnutls_session_authentication_type,
 332             "session-authentication-type",
 333             1, 0, 0,
 334             (SCM session),
 335             "Return the authentication type (a @code{credential-type} value) "
 336             "used by @var{session}.")
 337 #define FUNC_NAME s_scm_gnutls_session_authentication_type
 338 {
 339   gnutls_session_t c_session;
 340   gnutls_credentials_type_t c_auth;
 341
 342   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 343
 344   c_auth = gnutls_auth_get_type (c_session);
 345
 346   return (scm_from_gnutls_credentials (c_auth));
 347 }
 348
 349 #undef FUNC_NAME
 350
 351 SCM_DEFINE (scm_gnutls_session_server_authentication_type,
 352             "session-server-authentication-type",
 353             1, 0, 0,
 354             (SCM session),
 355             "Return the server authentication type (a "
 356             "@code{credential-type} value) used in @var{session}.")
 357 #define FUNC_NAME s_scm_gnutls_session_server_authentication_type
 358 {
 359   gnutls_session_t c_session;
 360   gnutls_credentials_type_t c_auth;
 361
 362   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 363
 364   c_auth = gnutls_auth_server_get_type (c_session);
 365
 366   return (scm_from_gnutls_credentials (c_auth));
 367 }
 368
 369 #undef FUNC_NAME
 370
 371 SCM_DEFINE (scm_gnutls_session_client_authentication_type,
 372             "session-client-authentication-type",
 373             1, 0, 0,
 374             (SCM session),
 375             "Return the client authentication type (a "
 376             "@code{credential-type} value) used in @var{session}.")
 377 #define FUNC_NAME s_scm_gnutls_session_client_authentication_type
 378 {
 379   gnutls_session_t c_session;
 380   gnutls_credentials_type_t c_auth;
 381
 382   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 383
 384   c_auth = gnutls_auth_client_get_type (c_session);
 385
 386   return (scm_from_gnutls_credentials (c_auth));
 387 }
 388
 389 #undef FUNC_NAME
 390
 391 SCM_DEFINE (scm_gnutls_session_peer_certificate_chain,
 392             "session-peer-certificate-chain",
 393             1, 0, 0,
 394             (SCM session),
 395             "Return the a list of certificates in raw format (u8vectors) "
 396             "where the first one is the peer's certificate.  In the case "
 397             "of OpenPGP, there is always exactly one certificate.  In the "
 398             "case of X.509, subsequent certificates indicate form a "
 399             "certificate chain.  Return the empty list if no certificate "
 400             "was sent.")
 401 #define FUNC_NAME s_scm_gnutls_session_peer_certificate_chain
 402 {
 403   SCM result;
 404   gnutls_session_t c_session;
 405   const gnutls_datum_t *c_cert;
 406   unsigned int c_list_size;
 407
 408   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 409
 410   c_cert = gnutls_certificate_get_peers (c_session, &c_list_size);
 411
 412   if (EXPECT_FALSE (c_cert == NULL))
 413     result = SCM_EOL;
 414   else
 415     {
 416       SCM pair;
 417       unsigned int i;
 418
 419       result = scm_make_list (scm_from_uint (c_list_size), SCM_UNSPECIFIED);
 420
 421       for (i = 0, pair = result; i < c_list_size; i++, pair = SCM_CDR (pair))
 422         {
 423           unsigned char *c_cert_copy;
 424
 425           c_cert_copy = (unsigned char *) malloc (c_cert[i].size);
 426           if (EXPECT_FALSE (c_cert_copy == NULL))
 427             scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
 428
 429           memcpy (c_cert_copy, c_cert[i].data, c_cert[i].size);
 430
 431           SCM_SETCAR (pair, scm_take_u8vector (c_cert_copy, c_cert[i].size));
 432         }
 433     }
 434
 435   return result;
 436 }
 437
 438 #undef FUNC_NAME
 439
 440 SCM_DEFINE (scm_gnutls_session_our_certificate_chain,
 441             "session-our-certificate-chain",
 442             1, 0, 0,
 443             (SCM session),
 444             "Return our certificate chain for @var{session} (as sent to "
 445             "the peer) in raw format (a u8vector).  In the case of OpenPGP "
 446             "there is exactly one certificate.  Return the empty list "
 447             "if no certificate was used.")
 448 #define FUNC_NAME s_scm_gnutls_session_our_certificate_chain
 449 {
 450   SCM result;
 451   gnutls_session_t c_session;
 452   const gnutls_datum_t *c_cert;
 453   unsigned char *c_cert_copy;
 454
 455   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 456
 457   /* XXX: Currently, the C function actually returns only one certificate.
 458      Future versions of the API may provide the full certificate chain, as
 459      for `gnutls_certificate_get_peers ()'.  */
 460   c_cert = gnutls_certificate_get_ours (c_session);
 461
 462   if (EXPECT_FALSE (c_cert == NULL))
 463     result = SCM_EOL;
 464   else
 465     {
 466       c_cert_copy = (unsigned char *) malloc (c_cert->size);
 467       if (EXPECT_FALSE (c_cert_copy == NULL))
 468         scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
 469
 470       memcpy (c_cert_copy, c_cert->data, c_cert->size);
 471
 472       result = scm_list_1 (scm_take_u8vector (c_cert_copy, c_cert->size));
 473     }
 474
 475   return result;
 476 }
 477
 478 #undef FUNC_NAME
 479
 480 SCM_DEFINE (scm_gnutls_set_server_session_certificate_request_x,
 481             "set-server-session-certificate-request!",
 482             2, 0, 0,
 483             (SCM session, SCM request),
 484             "Tell how @var{session}, a server-side session, should deal "
 485             "with certificate requests.  @var{request} should be either "
 486             "@code{certificate-request/request} or "
 487             "@code{certificate-request/require}.")
 488 #define FUNC_NAME s_scm_gnutls_set_server_session_certificate_request_x
 489 {
 490   gnutls_session_t c_session;
 491   gnutls_certificate_status_t c_request;
 492
 493   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 494   c_request = scm_to_gnutls_certificate_request (request, 2, FUNC_NAME);
 495
 496   gnutls_certificate_server_set_request (c_session, c_request);
 497
 498   return SCM_UNSPECIFIED;
 499 }
 500
 501 #undef FUNC_NAME
 502 \f
 503
 504 /* Choice of a protocol and cipher suite.  */
 505
 506 #include "priorities.i.c"
 507
 508 SCM_DEFINE (scm_gnutls_set_default_priority_x,
 509             "set-session-default-priority!", 1, 0, 0,
 510             (SCM session), "Have @var{session} use the default priorities.")
 511 #define FUNC_NAME s_scm_gnutls_set_default_priority_x
 512 {
 513   gnutls_session_t c_session;
 514
 515   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 516   gnutls_set_default_priority (c_session);
 517
 518   return SCM_UNSPECIFIED;
 519 }
 520
 521 #undef FUNC_NAME
 522
 523 SCM_DEFINE (scm_gnutls_set_default_export_priority_x,
 524             "set-session-default-export-priority!", 1, 0, 0,
 525             (SCM session),
 526             "Have @var{session} use the default export priorities.")
 527 #define FUNC_NAME s_scm_gnutls_set_default_export_priority_x
 528 {
 529   gnutls_session_t c_session;
 530
 531   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 532   gnutls_set_default_export_priority (c_session);
 533
 534   return SCM_UNSPECIFIED;
 535 }
 536 #undef FUNC_NAME
 537
 538 SCM_DEFINE (scm_gnutls_set_session_priorities_x,
 539             "set-session-priorities!", 2, 0, 0,
 540             (SCM session, SCM priorities),
 541             "Have @var{session} use the given @var{priorities} for "
 542             "the ciphers, key exchange methods, MACs and compression "
 543             "methods.  @var{priorities} must be a string (see "
 544             "Priority Strings).  When @var{priorities} cannot be "
 545             "parsed, an @code{error/invalid-request} error is raised, "
 546             "with an extra argument indication the position of the "
 547             "error.\n")
 548 #define FUNC_NAME s_scm_gnutls_set_session_priorities_x
 549 {
 550   int err;
 551   char *c_priorities;
 552   const char *err_pos;
 553   gnutls_session_t c_session;
 554   size_t pos;
 555
 556   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 557   c_priorities = scm_to_locale_string (priorities); /* XXX: to_latin1_string */
 558
 559   err = gnutls_priority_set_direct (c_session, c_priorities, &err_pos);
 560   if (err == GNUTLS_E_INVALID_REQUEST)
 561     pos = err_pos - c_priorities;
 562
 563   free (c_priorities);
 564
 565   switch (err)
 566     {
 567     case GNUTLS_E_SUCCESS:
 568       break;
 569     case GNUTLS_E_INVALID_REQUEST:
 570       {
 571         scm_gnutls_error_with_args (err, FUNC_NAME,
 572                                     scm_list_1 (scm_from_size_t (pos)));
 573         break;
 574       }
 575     default:
 576       scm_gnutls_error (err, FUNC_NAME);
 577     }
 578
 579   return SCM_UNSPECIFIED;
 580 }
 581 #undef FUNC_NAME
 582
 583 SCM_DEFINE (scm_gnutls_cipher_suite_to_string, "cipher-suite->string",
 584             3, 0, 0,
 585             (SCM kx, SCM cipher, SCM mac),
 586             "Return the name of the given cipher suite.")
 587 #define FUNC_NAME s_scm_gnutls_cipher_suite_to_string
 588 {
 589   gnutls_kx_algorithm_t c_kx;
 590   gnutls_cipher_algorithm_t c_cipher;
 591   gnutls_mac_algorithm_t c_mac;
 592   const char *c_name;
 593
 594   c_kx = scm_to_gnutls_kx (kx, 1, FUNC_NAME);
 595   c_cipher = scm_to_gnutls_cipher (cipher, 2, FUNC_NAME);
 596   c_mac = scm_to_gnutls_mac (mac, 3, FUNC_NAME);
 597
 598   c_name = gnutls_cipher_suite_get_name (c_kx, c_cipher, c_mac);
 599
 600   return (scm_from_locale_string (c_name));
 601 }
 602
 603 #undef FUNC_NAME
 604
 605 SCM_DEFINE (scm_gnutls_set_session_credentials_x, "set-session-credentials!",
 606             2, 0, 0,
 607             (SCM session, SCM cred),
 608             "Use @var{cred} as @var{session}'s credentials.")
 609 #define FUNC_NAME s_scm_gnutls_set_session_credentials_x
 610 {
 611   int err = 0;
 612   gnutls_session_t c_session;
 613
 614   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 615
 616   if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_certificate_credentials, cred))
 617     {
 618       gnutls_certificate_credentials_t c_cred;
 619
 620       c_cred = scm_to_gnutls_certificate_credentials (cred, 2, FUNC_NAME);
 621       err =
 622         gnutls_credentials_set (c_session, GNUTLS_CRD_CERTIFICATE, c_cred);
 623     }
 624   else
 625     if (SCM_SMOB_PREDICATE
 626         (scm_tc16_gnutls_anonymous_client_credentials, cred))
 627     {
 628       gnutls_anon_client_credentials_t c_cred;
 629
 630       c_cred = scm_to_gnutls_anonymous_client_credentials (cred, 2,
 631                                                            FUNC_NAME);
 632       err = gnutls_credentials_set (c_session, GNUTLS_CRD_ANON, c_cred);
 633     }
 634   else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_anonymous_server_credentials,
 635                                cred))
 636     {
 637       gnutls_anon_server_credentials_t c_cred;
 638
 639       c_cred = scm_to_gnutls_anonymous_server_credentials (cred, 2,
 640                                                            FUNC_NAME);
 641       err = gnutls_credentials_set (c_session, GNUTLS_CRD_ANON, c_cred);
 642     }
 643 #ifdef ENABLE_SRP
 644   else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_srp_client_credentials, cred))
 645     {
 646       gnutls_srp_client_credentials_t c_cred;
 647
 648       c_cred = scm_to_gnutls_srp_client_credentials (cred, 2, FUNC_NAME);
 649       err = gnutls_credentials_set (c_session, GNUTLS_CRD_SRP, c_cred);
 650     }
 651   else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_srp_server_credentials, cred))
 652     {
 653       gnutls_srp_server_credentials_t c_cred;
 654
 655       c_cred = scm_to_gnutls_srp_server_credentials (cred, 2, FUNC_NAME);
 656       err = gnutls_credentials_set (c_session, GNUTLS_CRD_SRP, c_cred);
 657     }
 658 #endif
 659   else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_psk_client_credentials, cred))
 660     {
 661       gnutls_psk_client_credentials_t c_cred;
 662
 663       c_cred = scm_to_gnutls_psk_client_credentials (cred, 2, FUNC_NAME);
 664       err = gnutls_credentials_set (c_session, GNUTLS_CRD_PSK, c_cred);
 665     }
 666   else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_psk_server_credentials, cred))
 667     {
 668       gnutls_psk_server_credentials_t c_cred;
 669
 670       c_cred = scm_to_gnutls_psk_server_credentials (cred, 2, FUNC_NAME);
 671       err = gnutls_credentials_set (c_session, GNUTLS_CRD_PSK, c_cred);
 672     }
 673   else
 674     scm_wrong_type_arg (FUNC_NAME, 2, cred);
 675
 676   if (EXPECT_FALSE (err))
 677     scm_gnutls_error (err, FUNC_NAME);
 678
 679   return SCM_UNSPECIFIED;
 680 }
 681
 682 #undef FUNC_NAME
 683 \f
 684
 685 /* Record layer.  */
 686
 687 SCM_DEFINE (scm_gnutls_record_send, "record-send", 2, 0, 0,
 688             (SCM session, SCM array),
 689             "Send the record constituted by @var{array} through "
 690             "@var{session}.")
 691 #define FUNC_NAME s_scm_gnutls_record_send
 692 {
 693   SCM result;
 694   ssize_t c_result;
 695   gnutls_session_t c_session;
 696   scm_t_array_handle c_handle;
 697   const char *c_array;
 698   size_t c_len;
 699
 700   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 701   SCM_VALIDATE_ARRAY (2, array);
 702
 703   c_array = scm_gnutls_get_array (array, &c_handle, &c_len, FUNC_NAME);
 704
 705   c_result = gnutls_record_send (c_session, c_array, c_len);
 706
 707   scm_gnutls_release_array (&c_handle);
 708
 709   if (EXPECT_TRUE (c_result >= 0))
 710     result = scm_from_ssize_t (c_result);
 711   else
 712     scm_gnutls_error (c_result, FUNC_NAME);
 713
 714   return (result);
 715 }
 716
 717 #undef FUNC_NAME
 718
 719 SCM_DEFINE (scm_gnutls_record_receive_x, "record-receive!", 2, 0, 0,
 720             (SCM session, SCM array),
 721             "Receive data from @var{session} into @var{array}, a uniform "
 722             "homogeneous array.  Return the number of bytes actually "
 723             "received.")
 724 #define FUNC_NAME s_scm_gnutls_record_receive_x
 725 {
 726   SCM result;
 727   ssize_t c_result;
 728   gnutls_session_t c_session;
 729   scm_t_array_handle c_handle;
 730   char *c_array;
 731   size_t c_len;
 732
 733   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 734   SCM_VALIDATE_ARRAY (2, array);
 735
 736   c_array = scm_gnutls_get_writable_array (array, &c_handle, &c_len,
 737                                            FUNC_NAME);
 738
 739   c_result = gnutls_record_recv (c_session, c_array, c_len);
 740
 741   scm_gnutls_release_array (&c_handle);
 742
 743   if (EXPECT_TRUE (c_result >= 0))
 744     result = scm_from_ssize_t (c_result);
 745   else
 746     scm_gnutls_error (c_result, FUNC_NAME);
 747
 748   return (result);
 749 }
 750
 751 #undef FUNC_NAME
 752
 753
 754 /* The session record port type.  */
 755 static scm_t_bits session_record_port_type;
 756
 757 /* Return the session associated with PORT.  */
 758 #define SCM_GNUTLS_SESSION_RECORD_PORT_SESSION(_port) \
 759   (SCM_PACK (SCM_STREAM (_port)))
 760
 761 /* Size of a session port's input buffer.  */
 762 #define SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE 4096
 763
 764 /* Hint for the `scm_gc_' functions.  */
 765 static const char session_record_port_gc_hint[] =
 766   "gnutls-session-record-port";
 767
 768
 769 #if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION <= 8
 770
 771 /* Mark the session associated with PORT.  */
 772 static SCM
 773 mark_session_record_port (SCM port)
 774 {
 775   return (SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port));
 776 }
 777
 778 static size_t
 779 free_session_record_port (SCM port)
 780 #define FUNC_NAME "free_session_record_port"
 781 {
 782   SCM session;
 783   scm_t_port *c_port;
 784
 785   session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
 786
 787   /* SESSION _can_ be invalid at this point: it can be freed in the same GC
 788      cycle as PORT, just before PORT.  Thus, we need to check whether SESSION
 789      still points to a session SMOB.  */
 790   if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_session, session))
 791     {
 792       /* SESSION is still valid.  Disassociate PORT from SESSION.  */
 793       gnutls_session_t c_session;
 794
 795       c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 796       SCM_GNUTLS_SET_SESSION_RECORD_PORT (c_session, SCM_BOOL_F);
 797     }
 798
 799   /* Free the input buffer of PORT.  */
 800   c_port = SCM_PTAB_ENTRY (port);
 801   scm_gc_free (c_port->read_buf, c_port->read_buf_size,
 802                session_record_port_gc_hint);
 803
 804   return 0;
 805 }
 806
 807 #undef FUNC_NAME
 808
 809 #endif /* SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION <= 8 */
 810
 811
 812 /* Data passed to `do_fill_port ()'.  */
 813 typedef struct
 814 {
 815   scm_t_port *c_port;
 816   gnutls_session_t c_session;
 817 } fill_port_data_t;
 818
 819 /* Actually fill a session record port (see below).  */
 820 static void *
 821 do_fill_port (void *data)
 822 {
 823   int chr;
 824   ssize_t result;
 825   scm_t_port *c_port;
 826   const fill_port_data_t *args = (fill_port_data_t *) data;
 827
 828   c_port = args->c_port;
 829   result = gnutls_record_recv (args->c_session,
 830                                c_port->read_buf, c_port->read_buf_size);
 831   if (EXPECT_TRUE (result > 0))
 832     {
 833       c_port->read_pos = c_port->read_buf;
 834       c_port->read_end = c_port->read_buf + result;
 835       chr = (int) *c_port->read_buf;
 836     }
 837   else if (result == 0)
 838     chr = EOF;
 839   else
 840     scm_gnutls_error (result, "fill_session_record_port_input");
 841
 842   return ((void *) (uintptr_t) chr);
 843 }
 844
 845 /* Fill in the input buffer of PORT.  */
 846 static int
 847 fill_session_record_port_input (SCM port)
 848 #define FUNC_NAME "fill_session_record_port_input"
 849 {
 850   int chr;
 851   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
 852
 853   if (c_port->read_pos >= c_port->read_end)
 854     {
 855       SCM session;
 856       fill_port_data_t c_args;
 857       gnutls_session_t c_session;
 858
 859       session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
 860       c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 861
 862       c_args.c_session = c_session;
 863       c_args.c_port = c_port;
 864
 865       if (SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session))
 866         /* SESSION's underlying transport is a raw file descriptor, so we
 867            must leave "Guile mode" to allow the GC to run.  */
 868         chr = (intptr_t) scm_without_guile (do_fill_port, &c_args);
 869       else
 870         /* SESSION's underlying transport is a port, so don't leave "Guile
 871            mode".  */
 872         chr = (intptr_t) do_fill_port (&c_args);
 873     }
 874   else
 875     chr = (int) *c_port->read_pos;
 876
 877   return chr;
 878 }
 879
 880 #undef FUNC_NAME
 881
 882 /* Write SIZE octets from DATA to PORT.  */
 883 static void
 884 write_to_session_record_port (SCM port, const void *data, size_t size)
 885 #define FUNC_NAME "write_to_session_record_port"
 886 {
 887   SCM session;
 888   gnutls_session_t c_session;
 889   ssize_t c_result;
 890   size_t c_sent = 0;
 891
 892   session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
 893   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 894
 895   while (c_sent < size)
 896     {
 897       c_result = gnutls_record_send (c_session, (char *) data + c_sent,
 898                                      size - c_sent);
 899       if (EXPECT_FALSE (c_result < 0))
 900         scm_gnutls_error (c_result, FUNC_NAME);
 901       else
 902         c_sent += c_result;
 903     }
 904 }
 905
 906 #undef FUNC_NAME
 907
 908 /* Return a new session port for SESSION.  */
 909 static inline SCM
 910 make_session_record_port (SCM session)
 911 {
 912   SCM port;
 913   scm_t_port *c_port;
 914   unsigned char *c_port_buf;
 915   const unsigned long mode_bits = SCM_OPN | SCM_RDNG | SCM_WRTNG;
 916
 917   c_port_buf = (unsigned char *)
 918 #ifdef HAVE_SCM_GC_MALLOC_POINTERLESS
 919     scm_gc_malloc_pointerless
 920 #else
 921     scm_gc_malloc
 922 #endif
 923     (SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE, session_record_port_gc_hint);
 924
 925   /* Create a new port.  */
 926   port = scm_new_port_table_entry (session_record_port_type);
 927   c_port = SCM_PTAB_ENTRY (port);
 928
 929   /* Mark PORT as open, readable and writable (hmm, how elegant...).  */
 930   SCM_SET_CELL_TYPE (port, session_record_port_type | mode_bits);
 931
 932   /* Associate it with SESSION.  */
 933   SCM_SETSTREAM (port, SCM_UNPACK (session));
 934
 935   c_port->read_pos = c_port->read_end = c_port->read_buf = c_port_buf;
 936   c_port->read_buf_size = SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE;
 937
 938   c_port->write_buf = c_port->write_pos = &c_port->shortbuf;
 939   c_port->write_buf_size = 1;
 940
 941   return (port);
 942 }
 943
 944 SCM_DEFINE (scm_gnutls_session_record_port, "session-record-port", 1, 0, 0,
 945             (SCM session),
 946             "Return a read-write port that may be used to communicate over "
 947             "@var{session}.  All invocations of @code{session-port} on a "
 948             "given session return the same object (in the sense of "
 949             "@code{eq?}).")
 950 #define FUNC_NAME s_scm_gnutls_session_record_port
 951 {
 952   SCM port;
 953   gnutls_session_t c_session;
 954
 955   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
 956   port = SCM_GNUTLS_SESSION_RECORD_PORT (c_session);
 957
 958   if (!SCM_PORTP (port))
 959     {
 960       /* Lazily create a new session port.  */
 961       port = make_session_record_port (session);
 962       SCM_GNUTLS_SET_SESSION_RECORD_PORT (c_session, port);
 963     }
 964
 965   return (port);
 966 }
 967
 968 #undef FUNC_NAME
 969
 970 /* Create the session port type.  */
 971 static inline void
 972 scm_init_gnutls_session_record_port_type (void)
 973 {
 974   session_record_port_type =
 975     scm_make_port_type ("gnutls-session-port",
 976                         fill_session_record_port_input,
 977                         write_to_session_record_port);
 978
 979   /* Guile >= 1.9.3 doesn't need a custom mark procedure, and doesn't need a
 980      finalizer (since memory associated with the port is automatically
 981      reclaimed.)  */
 982 #if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION <= 8
 983   scm_set_port_mark (session_record_port_type, mark_session_record_port);
 984   scm_set_port_free (session_record_port_type, free_session_record_port);
 985 #endif
 986 }
 987 \f
 988
 989 /* Transport.  */
 990
 991 SCM_DEFINE (scm_gnutls_set_session_transport_fd_x,
 992             "set-session-transport-fd!", 2, 0, 0, (SCM session, SCM fd),
 993             "Use file descriptor @var{fd} as the underlying transport for "
 994             "@var{session}.")
 995 #define FUNC_NAME s_scm_gnutls_set_session_transport_fd_x
 996 {
 997   gnutls_session_t c_session;
 998   int c_fd;
 999
1000   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
1001   c_fd = (int) scm_to_uint (fd);
1002
1003   gnutls_transport_set_ptr (c_session,
1004                             (gnutls_transport_ptr_t) (intptr_t) c_fd);
1005
1006   SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD (c_session, 1);
1007
1008   return SCM_UNSPECIFIED;
1009 }
1010
1011 #undef FUNC_NAME
1012
1013 /* Pull SIZE octets from TRANSPORT (a Scheme port) into DATA.  */
1014 static ssize_t
1015 pull_from_port (gnutls_transport_ptr_t transport, void *data, size_t size)
1016 {
1017   SCM port;
1018   ssize_t result;
1019
1020   port = SCM_PACK ((scm_t_bits) transport);
1021
1022   result = scm_c_read (port, data, size);
1023
1024   return ((ssize_t) result);
1025 }
1026
1027 /* Write SIZE octets from DATA to TRANSPORT (a Scheme port).  */
1028 static ssize_t
1029 push_to_port (gnutls_transport_ptr_t transport, const void *data, size_t size)
1030 {
1031   SCM port;
1032
1033   port = SCM_PACK ((scm_t_bits) transport);
1034
1035   scm_c_write (port, data, size);
1036
1037   /* All we can do is assume that all SIZE octets were written.  */
1038   return (size);
1039 }
1040
1041 SCM_DEFINE (scm_gnutls_set_session_transport_port_x,
1042             "set-session-transport-port!",
1043             2, 0, 0,
1044             (SCM session, SCM port),
1045             "Use @var{port} as the input/output port for @var{session}.")
1046 #define FUNC_NAME s_scm_gnutls_set_session_transport_port_x
1047 {
1048   gnutls_session_t c_session;
1049
1050   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
1051   SCM_VALIDATE_PORT (2, port);
1052
1053   /* Note: We do not attempt to optimize the case where PORT is a file port
1054      (i.e., over a file descriptor), because of port buffering issues.  Users
1055      are expected to explicitly use `set-session-transport-fd!' and `fileno'
1056      when they wish to do it.  */
1057
1058   gnutls_transport_set_ptr (c_session,
1059                             (gnutls_transport_ptr_t) SCM_UNPACK (port));
1060   gnutls_transport_set_push_function (c_session, push_to_port);
1061   gnutls_transport_set_pull_function (c_session, pull_from_port);
1062
1063   SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD (c_session, 0);
1064
1065   return SCM_UNSPECIFIED;
1066 }
1067
1068 #undef FUNC_NAME
1069 \f
1070
1071 /* Diffie-Hellman.  */
1072
1073 typedef int (*pkcs_export_function_t) (void *, gnutls_x509_crt_fmt_t,
1074                                        unsigned char *, size_t *);
1075
1076 /* Hint for the `scm_gc' functions.  */
1077 static const char pkcs_export_gc_hint[] = "gnutls-pkcs-export";
1078
1079
1080 /* Export DH/RSA parameters PARAMS through EXPORT, using format FORMAT.
1081    Return a `u8vector'.  */
1082 static inline SCM
1083 pkcs_export_parameters (pkcs_export_function_t export,
1084                         void *params, gnutls_x509_crt_fmt_t format,
1085                         const char *func_name)
1086 #define FUNC_NAME func_name
1087 {
1088   int err;
1089   unsigned char *output;
1090   size_t output_len, output_total_len = 4096;
1091
1092   output = (unsigned char *) scm_gc_malloc (output_total_len,
1093                                             pkcs_export_gc_hint);
1094   do
1095     {
1096       output_len = output_total_len;
1097       err = export (params, format, output, &output_len);
1098
1099       if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
1100         {
1101           output = scm_gc_realloc (output, output_total_len,
1102                                    output_total_len * 2, pkcs_export_gc_hint);
1103           output_total_len *= 2;
1104         }
1105     }
1106   while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
1107
1108   if (EXPECT_FALSE (err))
1109     {
1110       scm_gc_free (output, output_total_len, pkcs_export_gc_hint);
1111       scm_gnutls_error (err, FUNC_NAME);
1112     }
1113
1114   if (output_len != output_total_len)
1115     /* Shrink the output buffer.  */
1116     output = scm_gc_realloc (output, output_total_len,
1117                              output_len, pkcs_export_gc_hint);
1118
1119   return (scm_take_u8vector (output, output_len));
1120 }
1121
1122 #undef FUNC_NAME
1123
1124
1125 SCM_DEFINE (scm_gnutls_make_dh_parameters, "make-dh-parameters", 1, 0, 0,
1126             (SCM bits), "Return new Diffie-Hellman parameters.")
1127 #define FUNC_NAME s_scm_gnutls_make_dh_parameters
1128 {
1129   int err;
1130   unsigned c_bits;
1131   gnutls_dh_params_t c_dh_params;
1132
1133   c_bits = scm_to_uint (bits);
1134
1135   err = gnutls_dh_params_init (&c_dh_params);
1136   if (EXPECT_FALSE (err))
1137     scm_gnutls_error (err, FUNC_NAME);
1138
1139   err = gnutls_dh_params_generate2 (c_dh_params, c_bits);
1140   if (EXPECT_FALSE (err))
1141     {
1142       gnutls_dh_params_deinit (c_dh_params);
1143       scm_gnutls_error (err, FUNC_NAME);
1144     }
1145
1146   return (scm_from_gnutls_dh_parameters (c_dh_params));
1147 }
1148
1149 #undef FUNC_NAME
1150
1151 SCM_DEFINE (scm_gnutls_pkcs3_import_dh_parameters,
1152             "pkcs3-import-dh-parameters",
1153             2, 0, 0,
1154             (SCM array, SCM format),
1155             "Import Diffie-Hellman parameters in PKCS3 format (further "
1156             "specified by @var{format}, an @code{x509-certificate-format} "
1157             "value) from @var{array} (a homogeneous array) and return a "
1158             "new @code{dh-params} object.")
1159 #define FUNC_NAME s_scm_gnutls_pkcs3_import_dh_parameters
1160 {
1161   int err;
1162   gnutls_x509_crt_fmt_t c_format;
1163   gnutls_dh_params_t c_dh_params;
1164   scm_t_array_handle c_handle;
1165   const char *c_array;
1166   size_t c_len;
1167   gnutls_datum_t c_datum;
1168
1169   c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
1170
1171   c_array = scm_gnutls_get_array (array, &c_handle, &c_len, FUNC_NAME);
1172   c_datum.data = (unsigned char *) c_array;
1173   c_datum.size = c_len;
1174
1175   err = gnutls_dh_params_init (&c_dh_params);
1176   if (EXPECT_FALSE (err))
1177     {
1178       scm_gnutls_release_array (&c_handle);
1179       scm_gnutls_error (err, FUNC_NAME);
1180     }
1181
1182   err = gnutls_dh_params_import_pkcs3 (c_dh_params, &c_datum, c_format);
1183   scm_gnutls_release_array (&c_handle);
1184
1185   if (EXPECT_FALSE (err))
1186     {
1187       gnutls_dh_params_deinit (c_dh_params);
1188       scm_gnutls_error (err, FUNC_NAME);
1189     }
1190
1191   return (scm_from_gnutls_dh_parameters (c_dh_params));
1192 }
1193
1194 #undef FUNC_NAME
1195
1196 SCM_DEFINE (scm_gnutls_pkcs3_export_dh_parameters,
1197             "pkcs3-export-dh-parameters",
1198             2, 0, 0,
1199             (SCM dh_params, SCM format),
1200             "Export Diffie-Hellman parameters @var{dh_params} in PKCS3 "
1201             "format according for @var{format} (an "
1202             "@code{x509-certificate-format} value).  Return a "
1203             "@code{u8vector} containing the result.")
1204 #define FUNC_NAME s_scm_gnutls_pkcs3_export_dh_parameters
1205 {
1206   SCM result;
1207   gnutls_dh_params_t c_dh_params;
1208   gnutls_x509_crt_fmt_t c_format;
1209
1210   c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 1, FUNC_NAME);
1211   c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
1212
1213   result = pkcs_export_parameters ((pkcs_export_function_t)
1214                                    gnutls_dh_params_export_pkcs3,
1215                                    (void *) c_dh_params, c_format, FUNC_NAME);
1216
1217   return (result);
1218 }
1219
1220 #undef FUNC_NAME
1221
1222 SCM_DEFINE (scm_gnutls_set_session_dh_prime_bits_x,
1223             "set-session-dh-prime-bits!", 2, 0, 0,
1224             (SCM session, SCM bits),
1225             "Use @var{bits} DH prime bits for @var{session}.")
1226 #define FUNC_NAME s_scm_gnutls_set_session_dh_prime_bits_x
1227 {
1228   unsigned int c_bits;
1229   gnutls_session_t c_session;
1230
1231   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
1232   c_bits = scm_to_uint (bits);
1233
1234   gnutls_dh_set_prime_bits (c_session, c_bits);
1235
1236   return SCM_UNSPECIFIED;
1237 }
1238
1239 #undef FUNC_NAME
1240 \f
1241
1242 /* Anonymous credentials.  */
1243
1244 SCM_DEFINE (scm_gnutls_make_anon_server_credentials,
1245             "make-anonymous-server-credentials",
1246             0, 0, 0, (void), "Return anonymous server credentials.")
1247 #define FUNC_NAME s_scm_gnutls_make_anon_server_credentials
1248 {
1249   int err;
1250   gnutls_anon_server_credentials_t c_cred;
1251
1252   err = gnutls_anon_allocate_server_credentials (&c_cred);
1253
1254   if (EXPECT_FALSE (err))
1255     scm_gnutls_error (err, FUNC_NAME);
1256
1257   return (scm_from_gnutls_anonymous_server_credentials (c_cred));
1258 }
1259
1260 #undef FUNC_NAME
1261
1262 SCM_DEFINE (scm_gnutls_make_anon_client_credentials,
1263             "make-anonymous-client-credentials",
1264             0, 0, 0, (void), "Return anonymous client credentials.")
1265 #define FUNC_NAME s_scm_gnutls_make_anon_client_credentials
1266 {
1267   int err;
1268   gnutls_anon_client_credentials_t c_cred;
1269
1270   err = gnutls_anon_allocate_client_credentials (&c_cred);
1271
1272   if (EXPECT_FALSE (err))
1273     scm_gnutls_error (err, FUNC_NAME);
1274
1275   return (scm_from_gnutls_anonymous_client_credentials (c_cred));
1276 }
1277
1278 #undef FUNC_NAME
1279
1280 SCM_DEFINE (scm_gnutls_set_anonymous_server_dh_parameters_x,
1281             "set-anonymous-server-dh-parameters!", 2, 0, 0,
1282             (SCM cred, SCM dh_params),
1283             "Set the Diffie-Hellman parameters of anonymous server "
1284             "credentials @var{cred}.")
1285 #define FUNC_NAME s_scm_gnutls_set_anonymous_server_dh_parameters_x
1286 {
1287   gnutls_dh_params_t c_dh_params;
1288   gnutls_anon_server_credentials_t c_cred;
1289
1290   c_cred = scm_to_gnutls_anonymous_server_credentials (cred, 1, FUNC_NAME);
1291   c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 2, FUNC_NAME);
1292
1293   gnutls_anon_set_server_dh_params (c_cred, c_dh_params);
1294
1295   return SCM_UNSPECIFIED;
1296 }
1297
1298 #undef FUNC_NAME
1299 \f
1300
1301 /* RSA parameters.  */
1302
1303 SCM_DEFINE (scm_gnutls_make_rsa_parameters, "make-rsa-parameters", 1, 0, 0,
1304             (SCM bits), "Return new RSA parameters.")
1305 #define FUNC_NAME s_scm_gnutls_make_rsa_parameters
1306 {
1307   int err;
1308   unsigned c_bits;
1309   gnutls_rsa_params_t c_rsa_params;
1310
1311   c_bits = scm_to_uint (bits);
1312
1313   err = gnutls_rsa_params_init (&c_rsa_params);
1314   if (EXPECT_FALSE (err))
1315     scm_gnutls_error (err, FUNC_NAME);
1316
1317   err = gnutls_rsa_params_generate2 (c_rsa_params, c_bits);
1318   if (EXPECT_FALSE (err))
1319     {
1320       gnutls_rsa_params_deinit (c_rsa_params);
1321       scm_gnutls_error (err, FUNC_NAME);
1322     }
1323
1324   return (scm_from_gnutls_rsa_parameters (c_rsa_params));
1325 }
1326
1327 #undef FUNC_NAME
1328
1329 SCM_DEFINE (scm_gnutls_pkcs1_import_rsa_parameters,
1330             "pkcs1-import-rsa-parameters",
1331             2, 0, 0,
1332             (SCM array, SCM format),
1333             "Import Diffie-Hellman parameters in PKCS1 format (further "
1334             "specified by @var{format}, an @code{x509-certificate-format} "
1335             "value) from @var{array} (a homogeneous array) and return a "
1336             "new @code{rsa-params} object.")
1337 #define FUNC_NAME s_scm_gnutls_pkcs1_import_rsa_parameters
1338 {
1339   int err;
1340   gnutls_x509_crt_fmt_t c_format;
1341   gnutls_rsa_params_t c_rsa_params;
1342   scm_t_array_handle c_handle;
1343   const char *c_array;
1344   size_t c_len;
1345   gnutls_datum_t c_datum;
1346
1347   c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
1348
1349   c_array = scm_gnutls_get_array (array, &c_handle, &c_len, FUNC_NAME);
1350   c_datum.data = (unsigned char *) c_array;
1351   c_datum.size = c_len;
1352
1353   err = gnutls_rsa_params_init (&c_rsa_params);
1354   if (EXPECT_FALSE (err))
1355     {
1356       scm_gnutls_release_array (&c_handle);
1357       scm_gnutls_error (err, FUNC_NAME);
1358     }
1359
1360   err = gnutls_rsa_params_import_pkcs1 (c_rsa_params, &c_datum, c_format);
1361   scm_gnutls_release_array (&c_handle);
1362
1363   if (EXPECT_FALSE (err))
1364     {
1365       gnutls_rsa_params_deinit (c_rsa_params);
1366       scm_gnutls_error (err, FUNC_NAME);
1367     }
1368
1369   return (scm_from_gnutls_rsa_parameters (c_rsa_params));
1370 }
1371
1372 #undef FUNC_NAME
1373
1374 SCM_DEFINE (scm_gnutls_pkcs1_export_rsa_parameters,
1375             "pkcs1-export-rsa-parameters",
1376             2, 0, 0,
1377             (SCM rsa_params, SCM format),
1378             "Export Diffie-Hellman parameters @var{rsa_params} in PKCS1 "
1379             "format according for @var{format} (an "
1380             "@code{x509-certificate-format} value).  Return a "
1381             "@code{u8vector} containing the result.")
1382 #define FUNC_NAME s_scm_gnutls_pkcs1_export_rsa_parameters
1383 {
1384   SCM result;
1385   gnutls_rsa_params_t c_rsa_params;
1386   gnutls_x509_crt_fmt_t c_format;
1387
1388   c_rsa_params = scm_to_gnutls_rsa_parameters (rsa_params, 1, FUNC_NAME);
1389   c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
1390
1391   result = pkcs_export_parameters ((pkcs_export_function_t)
1392                                    gnutls_rsa_params_export_pkcs1,
1393                                    (void *) c_rsa_params,
1394                                    c_format, FUNC_NAME);
1395
1396   return (result);
1397 }
1398
1399 #undef FUNC_NAME
1400 \f
1401
1402 /* Certificate credentials.  */
1403
1404 typedef
1405   int (*certificate_set_file_function_t) (gnutls_certificate_credentials_t,
1406                                           const char *,
1407                                           gnutls_x509_crt_fmt_t);
1408
1409 typedef
1410   int (*certificate_set_data_function_t) (gnutls_certificate_credentials_t,
1411                                           const gnutls_datum_t *,
1412                                           gnutls_x509_crt_fmt_t);
1413
1414 /* Helper function to implement the `set-file!' functions.  */
1415 static unsigned int
1416 set_certificate_file (certificate_set_file_function_t set_file,
1417                       SCM cred, SCM file, SCM format, const char *func_name)
1418 #define FUNC_NAME func_name
1419 {
1420   int err;
1421   char *c_file;
1422   size_t c_file_len;
1423
1424   gnutls_certificate_credentials_t c_cred;
1425   gnutls_x509_crt_fmt_t c_format;
1426
1427   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
1428   SCM_VALIDATE_STRING (2, file);
1429   c_format = scm_to_gnutls_x509_certificate_format (format, 3, FUNC_NAME);
1430
1431   c_file_len = scm_c_string_length (file);
1432   c_file = alloca (c_file_len + 1);
1433
1434   (void) scm_to_locale_stringbuf (file, c_file, c_file_len + 1);
1435   c_file[c_file_len] = '\0';
1436
1437   err = set_file (c_cred, c_file, c_format);
1438   if (EXPECT_FALSE (err < 0))
1439     scm_gnutls_error (err, FUNC_NAME);
1440
1441   /* Return the number of certificates processed.  */
1442   return ((unsigned int) err);
1443 }
1444
1445 #undef FUNC_NAME
1446
1447 /* Helper function implementing the `set-data!' functions.  */
1448 static inline unsigned int
1449 set_certificate_data (certificate_set_data_function_t set_data,
1450                       SCM cred, SCM data, SCM format, const char *func_name)
1451 #define FUNC_NAME func_name
1452 {
1453   int err;
1454   gnutls_certificate_credentials_t c_cred;
1455   gnutls_x509_crt_fmt_t c_format;
1456   gnutls_datum_t c_datum;
1457   scm_t_array_handle c_handle;
1458   const char *c_data;
1459   size_t c_len;
1460
1461   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
1462   SCM_VALIDATE_ARRAY (2, data);
1463   c_format = scm_to_gnutls_x509_certificate_format (format, 3, FUNC_NAME);
1464
1465   c_data = scm_gnutls_get_array (data, &c_handle, &c_len, FUNC_NAME);
1466   c_datum.data = (unsigned char *) c_data;
1467   c_datum.size = c_len;
1468
1469   err = set_data (c_cred, &c_datum, c_format);
1470   scm_gnutls_release_array (&c_handle);
1471
1472   if (EXPECT_FALSE (err < 0))
1473     scm_gnutls_error (err, FUNC_NAME);
1474
1475   /* Return the number of certificates processed.  */
1476   return ((unsigned int) err);
1477 }
1478
1479 #undef FUNC_NAME
1480
1481
1482 SCM_DEFINE (scm_gnutls_make_certificate_credentials,
1483             "make-certificate-credentials",
1484             0, 0, 0,
1485             (void),
1486             "Return new certificate credentials (i.e., for use with "
1487             "either X.509 or OpenPGP certificates.")
1488 #define FUNC_NAME s_scm_gnutls_make_certificate_credentials
1489 {
1490   int err;
1491   gnutls_certificate_credentials_t c_cred;
1492
1493   err = gnutls_certificate_allocate_credentials (&c_cred);
1494   if (err)
1495     scm_gnutls_error (err, FUNC_NAME);
1496
1497   return (scm_from_gnutls_certificate_credentials (c_cred));
1498 }
1499
1500 #undef FUNC_NAME
1501
1502 SCM_DEFINE (scm_gnutls_set_certificate_credentials_dh_params_x,
1503             "set-certificate-credentials-dh-parameters!",
1504             2, 0, 0,
1505             (SCM cred, SCM dh_params),
1506             "Use Diffie-Hellman parameters @var{dh_params} for "
1507             "certificate credentials @var{cred}.")
1508 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_dh_params_x
1509 {
1510   gnutls_dh_params_t c_dh_params;
1511   gnutls_certificate_credentials_t c_cred;
1512
1513   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
1514   c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 2, FUNC_NAME);
1515
1516   gnutls_certificate_set_dh_params (c_cred, c_dh_params);
1517
1518   return SCM_UNSPECIFIED;
1519 }
1520
1521 #undef FUNC_NAME
1522
1523 SCM_DEFINE (scm_gnutls_set_certificate_credentials_rsa_export_params_x,
1524             "set-certificate-credentials-rsa-export-parameters!",
1525             2, 0, 0,
1526             (SCM cred, SCM rsa_params),
1527             "Use RSA parameters @var{rsa_params} for certificate "
1528             "credentials @var{cred}.")
1529 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_rsa_export_params_x
1530 {
1531   gnutls_rsa_params_t c_rsa_params;
1532   gnutls_certificate_credentials_t c_cred;
1533
1534   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
1535   c_rsa_params = scm_to_gnutls_rsa_parameters (rsa_params, 2, FUNC_NAME);
1536
1537   gnutls_certificate_set_rsa_export_params (c_cred, c_rsa_params);
1538
1539   return SCM_UNSPECIFIED;
1540 }
1541
1542 #undef FUNC_NAME
1543
1544 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_key_files_x,
1545             "set-certificate-credentials-x509-key-files!",
1546             4, 0, 0,
1547             (SCM cred, SCM cert_file, SCM key_file, SCM format),
1548             "Use @var{file} as the password file for PSK server "
1549             "credentials @var{cred}.")
1550 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_key_files_x
1551 {
1552   int err;
1553   gnutls_certificate_credentials_t c_cred;
1554   gnutls_x509_crt_fmt_t c_format;
1555   char *c_cert_file, *c_key_file;
1556   size_t c_cert_file_len, c_key_file_len;
1557
1558   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
1559   SCM_VALIDATE_STRING (2, cert_file);
1560   SCM_VALIDATE_STRING (3, key_file);
1561   c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
1562
1563   c_cert_file_len = scm_c_string_length (cert_file);
1564   c_cert_file = alloca (c_cert_file_len + 1);
1565
1566   c_key_file_len = scm_c_string_length (key_file);
1567   c_key_file = alloca (c_key_file_len + 1);
1568
1569   (void) scm_to_locale_stringbuf (cert_file, c_cert_file,
1570                                   c_cert_file_len + 1);
1571   c_cert_file[c_cert_file_len] = '\0';
1572   (void) scm_to_locale_stringbuf (key_file, c_key_file, c_key_file_len + 1);
1573   c_key_file[c_key_file_len] = '\0';
1574
1575   err = gnutls_certificate_set_x509_key_file (c_cred, c_cert_file, c_key_file,
1576                                               c_format);
1577   if (EXPECT_FALSE (err))
1578     scm_gnutls_error (err, FUNC_NAME);
1579
1580   return SCM_UNSPECIFIED;
1581 }
1582
1583 #undef FUNC_NAME
1584
1585 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_trust_file_x,
1586             "set-certificate-credentials-x509-trust-file!",
1587             3, 0, 0,
1588             (SCM cred, SCM file, SCM format),
1589             "Use @var{file} as the X.509 trust file for certificate "
1590             "credentials @var{cred}.  On success, return the number of "
1591             "certificates processed.")
1592 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_trust_file_x
1593 {
1594   unsigned int count;
1595
1596   count = set_certificate_file (gnutls_certificate_set_x509_trust_file,
1597                                 cred, file, format, FUNC_NAME);
1598
1599   return scm_from_uint (count);
1600 }
1601
1602 #undef FUNC_NAME
1603
1604 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_crl_file_x,
1605             "set-certificate-credentials-x509-crl-file!",
1606             3, 0, 0,
1607             (SCM cred, SCM file, SCM format),
1608             "Use @var{file} as the X.509 CRL (certificate revocation list) "
1609             "file for certificate credentials @var{cred}.  On success, "
1610             "return the number of CRLs processed.")
1611 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_crl_file_x
1612 {
1613   unsigned int count;
1614
1615   count = set_certificate_file (gnutls_certificate_set_x509_crl_file,
1616                                 cred, file, format, FUNC_NAME);
1617
1618   return scm_from_uint (count);
1619 }
1620
1621 #undef FUNC_NAME
1622
1623 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_trust_data_x,
1624             "set-certificate-credentials-x509-trust-data!",
1625             3, 0, 0,
1626             (SCM cred, SCM data, SCM format),
1627             "Use @var{data} (a uniform array) as the X.509 trust "
1628             "database for @var{cred}.  On success, return the number "
1629             "of certificates processed.")
1630 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_trust_data_x
1631 {
1632   unsigned int count;
1633
1634   count = set_certificate_data (gnutls_certificate_set_x509_trust_mem,
1635                                 cred, data, format, FUNC_NAME);
1636
1637   return scm_from_uint (count);
1638 }
1639
1640 #undef FUNC_NAME
1641
1642 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_crl_data_x,
1643             "set-certificate-credentials-x509-crl-data!",
1644             3, 0, 0,
1645             (SCM cred, SCM data, SCM format),
1646             "Use @var{data} (a uniform array) as the X.509 CRL "
1647             "(certificate revocation list) database for @var{cred}.  "
1648             "On success, return the number of CRLs processed.")
1649 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_crl_data_x
1650 {
1651   unsigned int count;
1652
1653   count = set_certificate_data (gnutls_certificate_set_x509_crl_mem,
1654                                 cred, data, format, FUNC_NAME);
1655
1656   return scm_from_uint (count);
1657 }
1658
1659 #undef FUNC_NAME
1660
1661 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_key_data_x,
1662             "set-certificate-credentials-x509-key-data!",
1663             4, 0, 0,
1664             (SCM cred, SCM cert, SCM key, SCM format),
1665             "Use X.509 certificate @var{cert} and private key @var{key}, "
1666             "both uniform arrays containing the X.509 certificate and key "
1667             "in format @var{format}, for certificate credentials "
1668             "@var{cred}.")
1669 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_key_data_x
1670 {
1671   int err;
1672   gnutls_x509_crt_fmt_t c_format;
1673   gnutls_certificate_credentials_t c_cred;
1674   gnutls_datum_t c_cert_d, c_key_d;
1675   scm_t_array_handle c_cert_handle, c_key_handle;
1676   const char *c_cert, *c_key;
1677   size_t c_cert_len, c_key_len;
1678
1679   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
1680   c_format = scm_to_gnutls_x509_certificate_format (format, 4, FUNC_NAME);
1681   SCM_VALIDATE_ARRAY (2, cert);
1682   SCM_VALIDATE_ARRAY (3, key);
1683
1684   /* FIXME: If the second call fails, an exception is raised and
1685      C_CERT_HANDLE is not released.  */
1686   c_cert = scm_gnutls_get_array (cert, &c_cert_handle, &c_cert_len,
1687                                  FUNC_NAME);
1688   c_key = scm_gnutls_get_array (key, &c_key_handle, &c_key_len, FUNC_NAME);
1689
1690   c_cert_d.data = (unsigned char *) c_cert;
1691   c_cert_d.size = c_cert_len;
1692   c_key_d.data = (unsigned char *) c_key;
1693   c_key_d.size = c_key_len;
1694
1695   err = gnutls_certificate_set_x509_key_mem (c_cred, &c_cert_d, &c_key_d,
1696                                              c_format);
1697   scm_gnutls_release_array (&c_cert_handle);
1698   scm_gnutls_release_array (&c_key_handle);
1699
1700   if (EXPECT_FALSE (err))
1701     scm_gnutls_error (err, FUNC_NAME);
1702
1703   return SCM_UNSPECIFIED;
1704 }
1705
1706 #undef FUNC_NAME
1707
1708 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_keys_x,
1709             "set-certificate-credentials-x509-keys!",
1710             3, 0, 0,
1711             (SCM cred, SCM certs, SCM privkey),
1712             "Have certificate credentials @var{cred} use the X.509 "
1713             "certificates listed in @var{certs} and X.509 private key "
1714             "@var{privkey}.")
1715 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_keys_x
1716 {
1717   int err;
1718   gnutls_x509_crt_t *c_certs;
1719   gnutls_x509_privkey_t c_key;
1720   gnutls_certificate_credentials_t c_cred;
1721   long int c_cert_count, i;
1722
1723   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
1724   SCM_VALIDATE_LIST_COPYLEN (2, certs, c_cert_count);
1725   c_key = scm_to_gnutls_x509_private_key (privkey, 3, FUNC_NAME);
1726
1727   c_certs = alloca (c_cert_count * sizeof (*c_certs));
1728   for (i = 0; scm_is_pair (certs); certs = SCM_CDR (certs), i++)
1729     {
1730       c_certs[i] = scm_to_gnutls_x509_certificate (SCM_CAR (certs),
1731                                                    2, FUNC_NAME);
1732     }
1733
1734   err = gnutls_certificate_set_x509_key (c_cred, c_certs, c_cert_count,
1735                                          c_key);
1736   if (EXPECT_FALSE (err))
1737     scm_gnutls_error (err, FUNC_NAME);
1738
1739   return SCM_UNSPECIFIED;
1740 }
1741
1742 #undef FUNC_NAME
1743
1744 SCM_DEFINE (scm_gnutls_set_certificate_credentials_verify_limits_x,
1745             "set-certificate-credentials-verify-limits!",
1746             3, 0, 0,
1747             (SCM cred, SCM max_bits, SCM max_depth),
1748             "Set the verification limits of @code{peer-certificate-status} "
1749             "for certificate credentials @var{cred} to @var{max_bits} "
1750             "bits for an acceptable certificate and @var{max_depth} "
1751             "as the maximum depth of a certificate chain.")
1752 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_verify_limits_x
1753 {
1754   gnutls_certificate_credentials_t c_cred;
1755   unsigned int c_max_bits, c_max_depth;
1756
1757   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
1758   c_max_bits = scm_to_uint (max_bits);
1759   c_max_depth = scm_to_uint (max_depth);
1760
1761   gnutls_certificate_set_verify_limits (c_cred, c_max_bits, c_max_depth);
1762
1763   return SCM_UNSPECIFIED;
1764 }
1765
1766 #undef FUNC_NAME
1767
1768 SCM_DEFINE (scm_gnutls_set_certificate_credentials_verify_flags_x,
1769             "set-certificate-credentials-verify-flags!",
1770             1, 0, 1,
1771             (SCM cred, SCM flags),
1772             "Set the certificate verification flags to @var{flags}, a "
1773             "series of @code{certificate-verify} values.")
1774 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_verify_flags_x
1775 {
1776   unsigned int c_flags, c_pos;
1777   gnutls_certificate_credentials_t c_cred;
1778
1779   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
1780
1781   for (c_flags = 0, c_pos = 2;
1782        !scm_is_null (flags); flags = SCM_CDR (flags), c_pos++)
1783     {
1784       c_flags |= (unsigned int)
1785         scm_to_gnutls_certificate_verify (SCM_CAR (flags), c_pos, FUNC_NAME);
1786     }
1787
1788   gnutls_certificate_set_verify_flags (c_cred, c_flags);
1789
1790   return SCM_UNSPECIFIED;
1791 }
1792
1793 #undef FUNC_NAME
1794
1795 SCM_DEFINE (scm_gnutls_peer_certificate_status, "peer-certificate-status",
1796             1, 0, 0,
1797             (SCM session),
1798             "Verify the peer certificate for @var{session} and return "
1799             "a list of @code{certificate-status} values (such as "
1800             "@code{certificate-status/revoked}), or the empty list if "
1801             "the certificate is valid.")
1802 #define FUNC_NAME s_scm_gnutls_peer_certificate_status
1803 {
1804   int err;
1805   unsigned int c_status;
1806   gnutls_session_t c_session;
1807   SCM result = SCM_EOL;
1808
1809   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
1810
1811   err = gnutls_certificate_verify_peers2 (c_session, &c_status);
1812   if (EXPECT_FALSE (err))
1813     scm_gnutls_error (err, FUNC_NAME);
1814
1815 #define MATCH_STATUS(_value)                                            \
1816   if (c_status & (_value))                                              \
1817     {                                                                   \
1818       result = scm_cons (scm_from_gnutls_certificate_status (_value),   \
1819                          result);                                       \
1820       c_status &= ~(_value);                                            \
1821     }
1822
1823   MATCH_STATUS (GNUTLS_CERT_INVALID);
1824   MATCH_STATUS (GNUTLS_CERT_REVOKED);
1825   MATCH_STATUS (GNUTLS_CERT_SIGNER_NOT_FOUND);
1826   MATCH_STATUS (GNUTLS_CERT_SIGNER_NOT_CA);
1827   MATCH_STATUS (GNUTLS_CERT_INSECURE_ALGORITHM);
1828
1829   if (EXPECT_FALSE (c_status != 0))
1830     /* XXX: We failed to interpret one of the status flags.  */
1831     scm_gnutls_error (GNUTLS_E_UNIMPLEMENTED_FEATURE, FUNC_NAME);
1832
1833 #undef MATCH_STATUS
1834
1835   return (result);
1836 }
1837
1838 #undef FUNC_NAME
1839 \f
1840
1841 /* SRP credentials.  */
1842
1843 #ifdef ENABLE_SRP
1844 SCM_DEFINE (scm_gnutls_make_srp_server_credentials,
1845             "make-srp-server-credentials",
1846             0, 0, 0, (void), "Return new SRP server credentials.")
1847 #define FUNC_NAME s_scm_gnutls_make_srp_server_credentials
1848 {
1849   int err;
1850   gnutls_srp_server_credentials_t c_cred;
1851
1852   err = gnutls_srp_allocate_server_credentials (&c_cred);
1853   if (EXPECT_FALSE (err))
1854     scm_gnutls_error (err, FUNC_NAME);
1855
1856   return (scm_from_gnutls_srp_server_credentials (c_cred));
1857 }
1858
1859 #undef FUNC_NAME
1860
1861 SCM_DEFINE (scm_gnutls_set_srp_server_credentials_files_x,
1862             "set-srp-server-credentials-files!",
1863             3, 0, 0,
1864             (SCM cred, SCM password_file, SCM password_conf_file),
1865             "Set the credentials files for @var{cred}, an SRP server "
1866             "credentials object.")
1867 #define FUNC_NAME s_scm_gnutls_set_srp_server_credentials_files_x
1868 {
1869   int err;
1870   gnutls_srp_server_credentials_t c_cred;
1871   char *c_password_file, *c_password_conf_file;
1872   size_t c_password_file_len, c_password_conf_file_len;
1873
1874   c_cred = scm_to_gnutls_srp_server_credentials (cred, 1, FUNC_NAME);
1875   SCM_VALIDATE_STRING (2, password_file);
1876   SCM_VALIDATE_STRING (3, password_conf_file);
1877
1878   c_password_file_len = scm_c_string_length (password_file);
1879   c_password_conf_file_len = scm_c_string_length (password_conf_file);
1880
1881   c_password_file = alloca (c_password_file_len + 1);
1882   c_password_conf_file = alloca (c_password_conf_file_len + 1);
1883
1884   (void) scm_to_locale_stringbuf (password_file, c_password_file,
1885                                   c_password_file_len + 1);
1886   c_password_file[c_password_file_len] = '\0';
1887   (void) scm_to_locale_stringbuf (password_conf_file, c_password_conf_file,
1888                                   c_password_conf_file_len + 1);
1889   c_password_conf_file[c_password_conf_file_len] = '\0';
1890
1891   err = gnutls_srp_set_server_credentials_file (c_cred, c_password_file,
1892                                                 c_password_conf_file);
1893   if (EXPECT_FALSE (err))
1894     scm_gnutls_error (err, FUNC_NAME);
1895
1896   return SCM_UNSPECIFIED;
1897 }
1898
1899 #undef FUNC_NAME
1900
1901 SCM_DEFINE (scm_gnutls_make_srp_client_credentials,
1902             "make-srp-client-credentials",
1903             0, 0, 0, (void), "Return new SRP client credentials.")
1904 #define FUNC_NAME s_scm_gnutls_make_srp_client_credentials
1905 {
1906   int err;
1907   gnutls_srp_client_credentials_t c_cred;
1908
1909   err = gnutls_srp_allocate_client_credentials (&c_cred);
1910   if (EXPECT_FALSE (err))
1911     scm_gnutls_error (err, FUNC_NAME);
1912
1913   return (scm_from_gnutls_srp_client_credentials (c_cred));
1914 }
1915
1916 #undef FUNC_NAME
1917
1918
1919 SCM_DEFINE (scm_gnutls_set_srp_client_credentials_x,
1920             "set-srp-client-credentials!",
1921             3, 0, 0,
1922             (SCM cred, SCM username, SCM password),
1923             "Use @var{username} and @var{password} as the credentials "
1924             "for @var{cred}, a client-side SRP credentials object.")
1925 #define FUNC_NAME s_scm_gnutls_make_srp_client_credentials
1926 {
1927   int err;
1928   gnutls_srp_client_credentials_t c_cred;
1929   char *c_username, *c_password;
1930   size_t c_username_len, c_password_len;
1931
1932   c_cred = scm_to_gnutls_srp_client_credentials (cred, 1, FUNC_NAME);
1933   SCM_VALIDATE_STRING (2, username);
1934   SCM_VALIDATE_STRING (3, password);
1935
1936   c_username_len = scm_c_string_length (username);
1937   c_password_len = scm_c_string_length (password);
1938
1939   c_username = alloca (c_username_len + 1);
1940   c_password = alloca (c_password_len + 1);
1941
1942   (void) scm_to_locale_stringbuf (username, c_username, c_username_len + 1);
1943   c_username[c_username_len] = '\0';
1944   (void) scm_to_locale_stringbuf (password, c_password, c_password_len + 1);
1945   c_password[c_password_len] = '\0';
1946
1947   err = gnutls_srp_set_client_credentials (c_cred, c_username, c_password);
1948   if (EXPECT_FALSE (err))
1949     scm_gnutls_error (err, FUNC_NAME);
1950
1951   return SCM_UNSPECIFIED;
1952 }
1953
1954 #undef FUNC_NAME
1955
1956 SCM_DEFINE (scm_gnutls_server_session_srp_username,
1957             "server-session-srp-username",
1958             1, 0, 0,
1959             (SCM session),
1960             "Return the SRP username used in @var{session} (a server-side "
1961             "session).")
1962 #define FUNC_NAME s_scm_gnutls_server_session_srp_username
1963 {
1964   SCM result;
1965   const char *c_username;
1966   gnutls_session_t c_session;
1967
1968   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
1969   c_username = gnutls_srp_server_get_username (c_session);
1970
1971   if (EXPECT_FALSE (c_username == NULL))
1972     result = SCM_BOOL_F;
1973   else
1974     result = scm_from_locale_string (c_username);
1975
1976   return (result);
1977 }
1978
1979 #undef FUNC_NAME
1980
1981 SCM_DEFINE (scm_gnutls_srp_base64_encode, "srp-base64-encode",
1982             1, 0, 0,
1983             (SCM str),
1984             "Encode @var{str} using SRP's base64 algorithm.  Return "
1985             "the encoded string.")
1986 #define FUNC_NAME s_scm_gnutls_srp_base64_encode
1987 {
1988   int err;
1989   char *c_str, *c_result;
1990   size_t c_str_len, c_result_len, c_result_actual_len;
1991   gnutls_datum_t c_str_d;
1992
1993   SCM_VALIDATE_STRING (1, str);
1994
1995   c_str_len = scm_c_string_length (str);
1996   c_str = alloca (c_str_len + 1);
1997   (void) scm_to_locale_stringbuf (str, c_str, c_str_len + 1);
1998   c_str[c_str_len] = '\0';
1999
2000   /* Typical size ratio is 4/3 so 3/2 is an upper bound.  */
2001   c_result_len = (c_str_len * 3) / 2;
2002   c_result = (char *) scm_malloc (c_result_len);
2003   if (EXPECT_FALSE (c_result == NULL))
2004     scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
2005
2006   c_str_d.data = (unsigned char *) c_str;
2007   c_str_d.size = c_str_len;
2008
2009   do
2010     {
2011       c_result_actual_len = c_result_len;
2012       err = gnutls_srp_base64_encode (&c_str_d, c_result,
2013                                       &c_result_actual_len);
2014       if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
2015         {
2016           char *c_new_buf;
2017
2018           c_new_buf = scm_realloc (c_result, c_result_len * 2);
2019           if (EXPECT_FALSE (c_new_buf == NULL))
2020             {
2021               free (c_result);
2022               scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
2023             }
2024           else
2025             c_result = c_new_buf, c_result_len *= 2;
2026         }
2027     }
2028   while (EXPECT_FALSE (err == GNUTLS_E_SHORT_MEMORY_BUFFER));
2029
2030   if (EXPECT_FALSE (err))
2031     scm_gnutls_error (err, FUNC_NAME);
2032
2033   if (c_result_actual_len + 1 < c_result_len)
2034     /* Shrink the buffer.  */
2035     c_result = scm_realloc (c_result, c_result_actual_len + 1);
2036
2037   c_result[c_result_actual_len] = '\0';
2038
2039   return (scm_take_locale_string (c_result));
2040 }
2041
2042 #undef FUNC_NAME
2043
2044 SCM_DEFINE (scm_gnutls_srp_base64_decode, "srp-base64-decode",
2045             1, 0, 0,
2046             (SCM str),
2047             "Decode @var{str}, an SRP-base64 encoded string, and return "
2048             "the decoded string.")
2049 #define FUNC_NAME s_scm_gnutls_srp_base64_decode
2050 {
2051   int err;
2052   char *c_str, *c_result;
2053   size_t c_str_len, c_result_len, c_result_actual_len;
2054   gnutls_datum_t c_str_d;
2055
2056   SCM_VALIDATE_STRING (1, str);
2057
2058   c_str_len = scm_c_string_length (str);
2059   c_str = alloca (c_str_len + 1);
2060   (void) scm_to_locale_stringbuf (str, c_str, c_str_len + 1);
2061   c_str[c_str_len] = '\0';
2062
2063   /* We assume that the decoded string is smaller than the encoded
2064      string.  */
2065   c_result_len = c_str_len;
2066   c_result = alloca (c_result_len);
2067
2068   c_str_d.data = (unsigned char *) c_str;
2069   c_str_d.size = c_str_len;
2070
2071   c_result_actual_len = c_result_len;
2072   err = gnutls_srp_base64_decode (&c_str_d, c_result, &c_result_actual_len);
2073   if (EXPECT_FALSE (err))
2074     scm_gnutls_error (err, FUNC_NAME);
2075
2076   c_result[c_result_actual_len] = '\0';
2077
2078   return (scm_from_locale_string (c_result));
2079 }
2080
2081 #undef FUNC_NAME
2082 #endif /* ENABLE_SRP */
2083 \f
2084
2085 /* PSK credentials.  */
2086
2087 SCM_DEFINE (scm_gnutls_make_psk_server_credentials,
2088             "make-psk-server-credentials",
2089             0, 0, 0, (void), "Return new PSK server credentials.")
2090 #define FUNC_NAME s_scm_gnutls_make_psk_server_credentials
2091 {
2092   int err;
2093   gnutls_psk_server_credentials_t c_cred;
2094
2095   err = gnutls_psk_allocate_server_credentials (&c_cred);
2096   if (EXPECT_FALSE (err))
2097     scm_gnutls_error (err, FUNC_NAME);
2098
2099   return (scm_from_gnutls_psk_server_credentials (c_cred));
2100 }
2101
2102 #undef FUNC_NAME
2103
2104 SCM_DEFINE (scm_gnutls_set_psk_server_credentials_file_x,
2105             "set-psk-server-credentials-file!",
2106             2, 0, 0,
2107             (SCM cred, SCM file),
2108             "Use @var{file} as the password file for PSK server "
2109             "credentials @var{cred}.")
2110 #define FUNC_NAME s_scm_gnutls_set_psk_server_credentials_file_x
2111 {
2112   int err;
2113   gnutls_psk_server_credentials_t c_cred;
2114   char *c_file;
2115   size_t c_file_len;
2116
2117   c_cred = scm_to_gnutls_psk_server_credentials (cred, 1, FUNC_NAME);
2118   SCM_VALIDATE_STRING (2, file);
2119
2120   c_file_len = scm_c_string_length (file);
2121   c_file = alloca (c_file_len + 1);
2122
2123   (void) scm_to_locale_stringbuf (file, c_file, c_file_len + 1);
2124   c_file[c_file_len] = '\0';
2125
2126   err = gnutls_psk_set_server_credentials_file (c_cred, c_file);
2127   if (EXPECT_FALSE (err))
2128     scm_gnutls_error (err, FUNC_NAME);
2129
2130   return SCM_UNSPECIFIED;
2131 }
2132
2133 #undef FUNC_NAME
2134
2135 SCM_DEFINE (scm_gnutls_make_psk_client_credentials,
2136             "make-psk-client-credentials",
2137             0, 0, 0, (void), "Return a new PSK client credentials object.")
2138 #define FUNC_NAME s_scm_gnutls_make_psk_client_credentials
2139 {
2140   int err;
2141   gnutls_psk_client_credentials_t c_cred;
2142
2143   err = gnutls_psk_allocate_client_credentials (&c_cred);
2144   if (EXPECT_FALSE (err))
2145     scm_gnutls_error (err, FUNC_NAME);
2146
2147   return (scm_from_gnutls_psk_client_credentials (c_cred));
2148 }
2149
2150 #undef FUNC_NAME
2151
2152 SCM_DEFINE (scm_gnutls_set_psk_client_credentials_x,
2153             "set-psk-client-credentials!",
2154             4, 0, 0,
2155             (SCM cred, SCM username, SCM key, SCM key_format),
2156             "Set the client credentials for @var{cred}, a PSK client "
2157             "credentials object.")
2158 #define FUNC_NAME s_scm_gnutls_set_psk_client_credentials_x
2159 {
2160   int err;
2161   gnutls_psk_client_credentials_t c_cred;
2162   gnutls_psk_key_flags c_key_format;
2163   scm_t_array_handle c_handle;
2164   const char *c_key;
2165   char *c_username;
2166   size_t c_username_len, c_key_len;
2167   gnutls_datum_t c_datum;
2168
2169   c_cred = scm_to_gnutls_psk_client_credentials (cred, 1, FUNC_NAME);
2170   SCM_VALIDATE_STRING (2, username);
2171   SCM_VALIDATE_ARRAY (3, key);
2172   c_key_format = scm_to_gnutls_psk_key_format (key_format, 4, FUNC_NAME);
2173
2174   c_username_len = scm_c_string_length (username);
2175   c_username = alloca (c_username_len + 1);
2176
2177   (void) scm_to_locale_stringbuf (username, c_username, c_username_len + 1);
2178   c_username[c_username_len] = '\0';
2179
2180   c_key = scm_gnutls_get_array (key, &c_handle, &c_key_len, FUNC_NAME);
2181   c_datum.data = (unsigned char *) c_key;
2182   c_datum.size = c_key_len;
2183
2184   err = gnutls_psk_set_client_credentials (c_cred, c_username,
2185                                            &c_datum, c_key_format);
2186   scm_gnutls_release_array (&c_handle);
2187
2188   if (EXPECT_FALSE (err))
2189     scm_gnutls_error (err, FUNC_NAME);
2190
2191   return SCM_UNSPECIFIED;
2192 }
2193
2194 #undef FUNC_NAME
2195
2196 SCM_DEFINE (scm_gnutls_server_session_psk_username,
2197             "server-session-psk-username",
2198             1, 0, 0,
2199             (SCM session),
2200             "Return the username associated with PSK server session "
2201             "@var{session}.")
2202 #define FUNC_NAME s_scm_gnutls_server_session_psk_username
2203 {
2204   SCM result;
2205   const char *c_username;
2206   gnutls_session_t c_session;
2207
2208   c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
2209   c_username = gnutls_srp_server_get_username (c_session);
2210
2211   if (EXPECT_FALSE (c_username == NULL))
2212     result = SCM_BOOL_F;
2213   else
2214     result = scm_from_locale_string (c_username);
2215
2216   return (result);
2217 }
2218
2219 #undef FUNC_NAME
2220 \f
2221
2222 /* X.509 certificates.  */
2223
2224 SCM_DEFINE (scm_gnutls_import_x509_certificate, "import-x509-certificate",
2225             2, 0, 0,
2226             (SCM data, SCM format),
2227             "Return a new X.509 certificate object resulting from the "
2228             "import of @var{data} (a uniform array) according to "
2229             "@var{format}.")
2230 #define FUNC_NAME s_scm_gnutls_import_x509_certificate
2231 {
2232   int err;
2233   gnutls_x509_crt_t c_cert;
2234   gnutls_x509_crt_fmt_t c_format;
2235   gnutls_datum_t c_data_d;
2236   scm_t_array_handle c_data_handle;
2237   const char *c_data;
2238   size_t c_data_len;
2239
2240   SCM_VALIDATE_ARRAY (1, data);
2241   c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
2242
2243   c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
2244                                  FUNC_NAME);
2245   c_data_d.data = (unsigned char *) c_data;
2246   c_data_d.size = c_data_len;
2247
2248   err = gnutls_x509_crt_init (&c_cert);
2249   if (EXPECT_FALSE (err))
2250     {
2251       scm_gnutls_release_array (&c_data_handle);
2252       scm_gnutls_error (err, FUNC_NAME);
2253     }
2254
2255   err = gnutls_x509_crt_import (c_cert, &c_data_d, c_format);
2256   scm_gnutls_release_array (&c_data_handle);
2257
2258   if (EXPECT_FALSE (err))
2259     {
2260       gnutls_x509_crt_deinit (c_cert);
2261       scm_gnutls_error (err, FUNC_NAME);
2262     }
2263
2264   return (scm_from_gnutls_x509_certificate (c_cert));
2265 }
2266
2267 #undef FUNC_NAME
2268
2269 SCM_DEFINE (scm_gnutls_import_x509_private_key, "import-x509-private-key",
2270             2, 0, 0,
2271             (SCM data, SCM format),
2272             "Return a new X.509 private key object resulting from the "
2273             "import of @var{data} (a uniform array) according to "
2274             "@var{format}.")
2275 #define FUNC_NAME s_scm_gnutls_import_x509_private_key
2276 {
2277   int err;
2278   gnutls_x509_privkey_t c_key;
2279   gnutls_x509_crt_fmt_t c_format;
2280   gnutls_datum_t c_data_d;
2281   scm_t_array_handle c_data_handle;
2282   const char *c_data;
2283   size_t c_data_len;
2284
2285   SCM_VALIDATE_ARRAY (1, data);
2286   c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
2287
2288   c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
2289                                  FUNC_NAME);
2290   c_data_d.data = (unsigned char *) c_data;
2291   c_data_d.size = c_data_len;
2292
2293   err = gnutls_x509_privkey_init (&c_key);
2294   if (EXPECT_FALSE (err))
2295     {
2296       scm_gnutls_release_array (&c_data_handle);
2297       scm_gnutls_error (err, FUNC_NAME);
2298     }
2299
2300   err = gnutls_x509_privkey_import (c_key, &c_data_d, c_format);
2301   scm_gnutls_release_array (&c_data_handle);
2302
2303   if (EXPECT_FALSE (err))
2304     {
2305       gnutls_x509_privkey_deinit (c_key);
2306       scm_gnutls_error (err, FUNC_NAME);
2307     }
2308
2309   return (scm_from_gnutls_x509_private_key (c_key));
2310 }
2311
2312 #undef FUNC_NAME
2313
2314 SCM_DEFINE (scm_gnutls_pkcs8_import_x509_private_key,
2315             "pkcs8-import-x509-private-key",
2316             2, 2, 0,
2317             (SCM data, SCM format, SCM pass, SCM encrypted),
2318             "Return a new X.509 private key object resulting from the "
2319             "import of @var{data} (a uniform array) according to "
2320             "@var{format}.  Optionally, if @var{pass} is not @code{#f}, "
2321             "it should be a string denoting a passphrase.  "
2322             "@var{encrypted} tells whether the private key is encrypted "
2323             "(@code{#t} by default).")
2324 #define FUNC_NAME s_scm_gnutls_pkcs8_import_x509_private_key
2325 {
2326   int err;
2327   gnutls_x509_privkey_t c_key;
2328   gnutls_x509_crt_fmt_t c_format;
2329   unsigned int c_flags;
2330   gnutls_datum_t c_data_d;
2331   scm_t_array_handle c_data_handle;
2332   const char *c_data;
2333   char *c_pass;
2334   size_t c_data_len, c_pass_len;
2335
2336   SCM_VALIDATE_ARRAY (1, data);
2337   c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
2338   if ((pass == SCM_UNDEFINED) || (scm_is_false (pass)))
2339     c_pass = NULL;
2340   else
2341     {
2342       c_pass_len = scm_c_string_length (pass);
2343       c_pass = alloca (c_pass_len + 1);
2344       (void) scm_to_locale_stringbuf (pass, c_pass, c_pass_len + 1);
2345       c_pass[c_pass_len] = '\0';
2346     }
2347
2348   if (encrypted == SCM_UNDEFINED)
2349     c_flags = 0;
2350   else
2351     {
2352       SCM_VALIDATE_BOOL (4, encrypted);
2353       if (scm_is_true (encrypted))
2354         c_flags = 0;
2355       else
2356         c_flags = GNUTLS_PKCS8_PLAIN;
2357     }
2358
2359   c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
2360                                  FUNC_NAME);
2361   c_data_d.data = (unsigned char *) c_data;
2362   c_data_d.size = c_data_len;
2363
2364   err = gnutls_x509_privkey_init (&c_key);
2365   if (EXPECT_FALSE (err))
2366     {
2367       scm_gnutls_release_array (&c_data_handle);
2368       scm_gnutls_error (err, FUNC_NAME);
2369     }
2370
2371   err = gnutls_x509_privkey_import_pkcs8 (c_key, &c_data_d, c_format, c_pass,
2372                                           c_flags);
2373   scm_gnutls_release_array (&c_data_handle);
2374
2375   if (EXPECT_FALSE (err))
2376     {
2377       gnutls_x509_privkey_deinit (c_key);
2378       scm_gnutls_error (err, FUNC_NAME);
2379     }
2380
2381   return (scm_from_gnutls_x509_private_key (c_key));
2382 }
2383
2384 #undef FUNC_NAME
2385
2386 /* Provide the body of a `get_dn' function.  */
2387 #define X509_CERTIFICATE_DN_FUNCTION_BODY(get_the_dn)           \
2388   int err;                                                      \
2389   gnutls_x509_crt_t c_cert;                                     \
2390   char *c_dn;                                                   \
2391   size_t c_dn_len;                                              \
2392                                                                 \
2393   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME); \
2394                                                                 \
2395   /* Get the DN size.  */                                       \
2396   (void) get_the_dn (c_cert, NULL, &c_dn_len);                  \
2397                                                                 \
2398   /* Get the DN itself.  */                                     \
2399   c_dn = alloca (c_dn_len);                                     \
2400   err = get_the_dn (c_cert, c_dn, &c_dn_len);                   \
2401                                                                 \
2402   if (EXPECT_FALSE (err))                                       \
2403     scm_gnutls_error (err, FUNC_NAME);                          \
2404                                                                 \
2405   /* XXX: The returned string is actually ASCII or UTF-8.  */   \
2406   return (scm_from_locale_string (c_dn));
2407
2408 SCM_DEFINE (scm_gnutls_x509_certificate_dn, "x509-certificate-dn",
2409             1, 0, 0,
2410             (SCM cert),
2411             "Return the distinguished name (DN) of X.509 certificate "
2412             "@var{cert}.  The form of the DN is as described in @uref{"
2413             "http://tools.ietf.org/html/rfc2253, RFC 2253}.")
2414 #define FUNC_NAME s_scm_gnutls_x509_certificate_dn
2415 {
2416   X509_CERTIFICATE_DN_FUNCTION_BODY (gnutls_x509_crt_get_dn);
2417 }
2418
2419 #undef FUNC_NAME
2420
2421 SCM_DEFINE (scm_gnutls_x509_certificate_issuer_dn,
2422             "x509-certificate-issuer-dn",
2423             1, 0, 0,
2424             (SCM cert),
2425             "Return the distinguished name (DN) of X.509 certificate "
2426             "@var{cert}.")
2427 #define FUNC_NAME s_scm_gnutls_x509_certificate_issuer_dn
2428 {
2429   X509_CERTIFICATE_DN_FUNCTION_BODY (gnutls_x509_crt_get_issuer_dn);
2430 }
2431
2432 #undef FUNC_NAME
2433
2434 #undef X509_CERTIFICATE_DN_FUNCTION_BODY
2435
2436
2437 /* Provide the body of a `get_dn_oid' function.  */
2438 #define X509_CERTIFICATE_DN_OID_FUNCTION_BODY(get_dn_oid)               \
2439   int err;                                                              \
2440   gnutls_x509_crt_t c_cert;                                             \
2441   unsigned int c_index;                                                 \
2442   char *c_oid;                                                          \
2443   size_t c_oid_actual_len, c_oid_len;                                   \
2444   SCM result;                                                           \
2445                                                                         \
2446   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);         \
2447   c_index = scm_to_uint (index);                                        \
2448                                                                         \
2449   c_oid_len = 256;                                                      \
2450   c_oid = scm_malloc (c_oid_len);                                       \
2451                                                                         \
2452   do                                                                    \
2453     {                                                                   \
2454       c_oid_actual_len = c_oid_len;                                     \
2455       err = get_dn_oid (c_cert, c_index, c_oid, &c_oid_actual_len);     \
2456       if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)                          \
2457         {                                                               \
2458           c_oid = scm_realloc (c_oid, c_oid_len * 2);                   \
2459           c_oid_len *= 2;                                               \
2460         }                                                               \
2461     }                                                                   \
2462   while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);                          \
2463                                                                         \
2464   if (EXPECT_FALSE (err))                                               \
2465     {                                                                   \
2466       free (c_oid);                                                     \
2467                                                                         \
2468       if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE)                 \
2469         result = SCM_BOOL_F;                                            \
2470       else                                                              \
2471         scm_gnutls_error (err, FUNC_NAME);                              \
2472     }                                                                   \
2473   else                                                                  \
2474     {                                                                   \
2475       if (c_oid_actual_len < c_oid_len)                                 \
2476         c_oid = scm_realloc (c_oid, c_oid_actual_len);                  \
2477                                                                         \
2478       result = scm_take_locale_stringn (c_oid,                          \
2479                                         c_oid_actual_len);              \
2480     }                                                                   \
2481                                                                         \
2482   return result;
2483
2484 SCM_DEFINE (scm_gnutls_x509_certificate_dn_oid, "x509-certificate-dn-oid",
2485             2, 0, 0,
2486             (SCM cert, SCM index),
2487             "Return OID (a string) at @var{index} from @var{cert}.  "
2488             "Return @code{#f} if no OID is available at @var{index}.")
2489 #define FUNC_NAME s_scm_gnutls_x509_certificate_dn_oid
2490 {
2491   X509_CERTIFICATE_DN_OID_FUNCTION_BODY (gnutls_x509_crt_get_dn_oid);
2492 }
2493
2494 #undef FUNC_NAME
2495
2496 SCM_DEFINE (scm_gnutls_x509_certificate_issuer_dn_oid,
2497             "x509-certificate-issuer-dn-oid",
2498             2, 0, 0,
2499             (SCM cert, SCM index),
2500             "Return the OID (a string) at @var{index} from @var{cert}'s "
2501             "issuer DN.  Return @code{#f} if no OID is available at "
2502             "@var{index}.")
2503 #define FUNC_NAME s_scm_gnutls_x509_certificate_issuer_dn_oid
2504 {
2505   X509_CERTIFICATE_DN_OID_FUNCTION_BODY (gnutls_x509_crt_get_issuer_dn_oid);
2506 }
2507
2508 #undef FUNC_NAME
2509
2510 #undef X509_CERTIFICATE_DN_OID_FUNCTION_BODY
2511
2512
2513 SCM_DEFINE (scm_gnutls_x509_certificate_matches_hostname_p,
2514             "x509-certificate-matches-hostname?",
2515             2, 0, 0,
2516             (SCM cert, SCM hostname),
2517             "Return true if @var{cert} matches @var{hostname}, a string "
2518             "denoting a DNS host name.  This is the basic implementation "
2519             "of @uref{http://tools.ietf.org/html/rfc2818, RFC 2818} (aka. "
2520             "HTTPS).")
2521 #define FUNC_NAME s_scm_gnutls_x509_certificate_matches_hostname_p
2522 {
2523   SCM result;
2524   gnutls_x509_crt_t c_cert;
2525   char *c_hostname;
2526   size_t c_hostname_len;
2527
2528   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
2529   SCM_VALIDATE_STRING (2, hostname);
2530
2531   c_hostname_len = scm_c_string_length (hostname);
2532   c_hostname = alloca (c_hostname_len + 1);
2533
2534   (void) scm_to_locale_stringbuf (hostname, c_hostname, c_hostname_len + 1);
2535   c_hostname[c_hostname_len] = '\0';
2536
2537   if (gnutls_x509_crt_check_hostname (c_cert, c_hostname))
2538     result = SCM_BOOL_T;
2539   else
2540     result = SCM_BOOL_F;
2541
2542   return result;
2543 }
2544
2545 #undef FUNC_NAME
2546
2547 SCM_DEFINE (scm_gnutls_x509_certificate_signature_algorithm,
2548             "x509-certificate-signature-algorithm",
2549             1, 0, 0,
2550             (SCM cert),
2551             "Return the signature algorithm used by @var{cert} (i.e., "
2552             "one of the @code{sign-algorithm/} values).")
2553 #define FUNC_NAME s_scm_gnutls_x509_certificate_signature_algorithm
2554 {
2555   int c_result;
2556   gnutls_x509_crt_t c_cert;
2557
2558   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
2559
2560   c_result = gnutls_x509_crt_get_signature_algorithm (c_cert);
2561   if (EXPECT_FALSE (c_result < 0))
2562     scm_gnutls_error (c_result, FUNC_NAME);
2563
2564   return (scm_from_gnutls_sign_algorithm (c_result));
2565 }
2566
2567 #undef FUNC_NAME
2568
2569 SCM_DEFINE (scm_gnutls_x509_certificate_public_key_algorithm,
2570             "x509-certificate-public-key-algorithm",
2571             1, 0, 0,
2572             (SCM cert),
2573             "Return two values: the public key algorithm (i.e., "
2574             "one of the @code{pk-algorithm/} values) of @var{cert} "
2575             "and the number of bits used.")
2576 #define FUNC_NAME s_scm_gnutls_x509_certificate_public_key_algorithm
2577 {
2578   gnutls_x509_crt_t c_cert;
2579   gnutls_pk_algorithm_t c_pk;
2580   unsigned int c_bits;
2581
2582   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
2583
2584   c_pk = gnutls_x509_crt_get_pk_algorithm (c_cert, &c_bits);
2585
2586   return (scm_values (scm_list_2 (scm_from_gnutls_pk_algorithm (c_pk),
2587                                   scm_from_uint (c_bits))));
2588 }
2589
2590 #undef FUNC_NAME
2591
2592 SCM_DEFINE (scm_gnutls_x509_certificate_key_usage,
2593             "x509-certificate-key-usage",
2594             1, 0, 0,
2595             (SCM cert),
2596             "Return the key usage of @var{cert} (i.e., a list of "
2597             "@code{key-usage/} values), or the empty list if @var{cert} "
2598             "does not contain such information.")
2599 #define FUNC_NAME s_scm_gnutls_x509_certificate_key_usage
2600 {
2601   int err;
2602   SCM usage;
2603   gnutls_x509_crt_t c_cert;
2604   unsigned int c_usage, c_critical;
2605
2606   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
2607
2608   err = gnutls_x509_crt_get_key_usage (c_cert, &c_usage, &c_critical);
2609   if (EXPECT_FALSE (err))
2610     {
2611       if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE)
2612         usage = SCM_EOL;
2613       else
2614         scm_gnutls_error (err, FUNC_NAME);
2615     }
2616   else
2617     usage = scm_from_gnutls_key_usage_flags (c_usage);
2618
2619   return usage;
2620 }
2621
2622 #undef FUNC_NAME
2623
2624 SCM_DEFINE (scm_gnutls_x509_certificate_version, "x509-certificate-version",
2625             1, 0, 0, (SCM cert), "Return the version of @var{cert}.")
2626 #define FUNC_NAME s_scm_gnutls_x509_certificate_version
2627 {
2628   int c_result;
2629   gnutls_x509_crt_t c_cert;
2630
2631   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
2632
2633   c_result = gnutls_x509_crt_get_version (c_cert);
2634   if (EXPECT_FALSE (c_result < 0))
2635     scm_gnutls_error (c_result, FUNC_NAME);
2636
2637   return (scm_from_int (c_result));
2638 }
2639
2640 #undef FUNC_NAME
2641
2642 SCM_DEFINE (scm_gnutls_x509_certificate_key_id, "x509-certificate-key-id",
2643             1, 0, 0,
2644             (SCM cert),
2645             "Return a statistically unique ID (a u8vector) for @var{cert} "
2646             "that depends on its public key parameters.  This is normally "
2647             "a 20-byte SHA-1 hash.")
2648 #define FUNC_NAME s_scm_gnutls_x509_certificate_key_id
2649 {
2650   int err;
2651   SCM result;
2652   scm_t_array_handle c_id_handle;
2653   gnutls_x509_crt_t c_cert;
2654   scm_t_uint8 *c_id;
2655   size_t c_id_len = 20;
2656
2657   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
2658
2659   result = scm_make_u8vector (scm_from_uint (c_id_len), SCM_INUM0);
2660   scm_array_get_handle (result, &c_id_handle);
2661   c_id = scm_array_handle_u8_writable_elements (&c_id_handle);
2662
2663   err = gnutls_x509_crt_get_key_id (c_cert, 0, c_id, &c_id_len);
2664   scm_array_handle_release (&c_id_handle);
2665
2666   if (EXPECT_FALSE (err))
2667     scm_gnutls_error (err, FUNC_NAME);
2668
2669   return result;
2670 }
2671
2672 #undef FUNC_NAME
2673
2674 SCM_DEFINE (scm_gnutls_x509_certificate_authority_key_id,
2675             "x509-certificate-authority-key-id",
2676             1, 0, 0,
2677             (SCM cert),
2678             "Return the key ID (a u8vector) of the X.509 certificate "
2679             "authority of @var{cert}.")
2680 #define FUNC_NAME s_scm_gnutls_x509_certificate_authority_key_id
2681 {
2682   int err;
2683   SCM result;
2684   scm_t_array_handle c_id_handle;
2685   gnutls_x509_crt_t c_cert;
2686   scm_t_uint8 *c_id;
2687   size_t c_id_len = 20;
2688
2689   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
2690
2691   result = scm_make_u8vector (scm_from_uint (c_id_len), SCM_INUM0);
2692   scm_array_get_handle (result, &c_id_handle);
2693   c_id = scm_array_handle_u8_writable_elements (&c_id_handle);
2694
2695   err = gnutls_x509_crt_get_authority_key_id (c_cert, c_id, &c_id_len, NULL);
2696   scm_array_handle_release (&c_id_handle);
2697
2698   if (EXPECT_FALSE (err))
2699     scm_gnutls_error (err, FUNC_NAME);
2700
2701   return result;
2702 }
2703
2704 #undef FUNC_NAME
2705
2706 SCM_DEFINE (scm_gnutls_x509_certificate_subject_key_id,
2707             "x509-certificate-subject-key-id",
2708             1, 0, 0,
2709             (SCM cert),
2710             "Return the subject key ID (a u8vector) for @var{cert}.")
2711 #define FUNC_NAME s_scm_gnutls_x509_certificate_subject_key_id
2712 {
2713   int err;
2714   SCM result;
2715   scm_t_array_handle c_id_handle;
2716   gnutls_x509_crt_t c_cert;
2717   scm_t_uint8 *c_id;
2718   size_t c_id_len = 20;
2719
2720   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
2721
2722   result = scm_make_u8vector (scm_from_uint (c_id_len), SCM_INUM0);
2723   scm_array_get_handle (result, &c_id_handle);
2724   c_id = scm_array_handle_u8_writable_elements (&c_id_handle);
2725
2726   err = gnutls_x509_crt_get_subject_key_id (c_cert, c_id, &c_id_len, NULL);
2727   scm_array_handle_release (&c_id_handle);
2728
2729   if (EXPECT_FALSE (err))
2730     scm_gnutls_error (err, FUNC_NAME);
2731
2732   return result;
2733 }
2734
2735 #undef FUNC_NAME
2736
2737 SCM_DEFINE (scm_gnutls_x509_certificate_subject_alternative_name,
2738             "x509-certificate-subject-alternative-name",
2739             2, 0, 0,
2740             (SCM cert, SCM index),
2741             "Return two values: the alternative name type for @var{cert} "
2742             "(i.e., one of the @code{x509-subject-alternative-name/} values) "
2743             "and the actual subject alternative name (a string) at "
2744             "@var{index}. Both values are @code{#f} if no alternative name "
2745             "is available at @var{index}.")
2746 #define FUNC_NAME s_scm_gnutls_x509_certificate_subject_alternative_name
2747 {
2748   int err;
2749   SCM result;
2750   gnutls_x509_crt_t c_cert;
2751   unsigned int c_index;
2752   char *c_name;
2753   size_t c_name_len = 512, c_name_actual_len;
2754
2755   c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
2756   c_index = scm_to_uint (index);
2757
2758   c_name = scm_malloc (c_name_len);
2759   do
2760     {
2761       c_name_actual_len = c_name_len;
2762       err = gnutls_x509_crt_get_subject_alt_name (c_cert, c_index,
2763                                                   c_name, &c_name_actual_len,
2764                                                   NULL);
2765       if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
2766         {
2767           c_name = scm_realloc (c_name, c_name_len * 2);
2768           c_name_len *= 2;
2769         }
2770     }
2771   while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
2772
2773   if (EXPECT_FALSE (err < 0))
2774     {
2775       free (c_name);
2776
2777       if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE)
2778         result = scm_values (scm_list_2 (SCM_BOOL_F, SCM_BOOL_F));
2779       else
2780         scm_gnutls_error (err, FUNC_NAME);
2781     }
2782   else
2783     {
2784       if (c_name_actual_len < c_name_len)
2785         c_name = scm_realloc (c_name, c_name_actual_len);
2786
2787       result =
2788         scm_values (scm_list_2
2789                     (scm_from_gnutls_x509_subject_alternative_name (err),
2790                      scm_take_locale_string (c_name)));
2791     }
2792
2793   return result;
2794 }
2795
2796 #undef FUNC_NAME
2797 \f
2798
2799 /* OpenPGP keys.  */
2800
2801
2802 /* Maximum size we support for the name of OpenPGP keys.  */
2803 #define GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH  2048
2804
2805 SCM_DEFINE (scm_gnutls_import_openpgp_certificate,
2806             "import-openpgp-certificate", 2, 0, 0, (SCM data, SCM format),
2807             "Return a new OpenPGP certificate object resulting from the "
2808             "import of @var{data} (a uniform array) according to "
2809             "@var{format}.")
2810 #define FUNC_NAME s_scm_gnutls_import_openpgp_certificate
2811 {
2812   int err;
2813   gnutls_openpgp_crt_t c_key;
2814   gnutls_openpgp_crt_fmt_t c_format;
2815   gnutls_datum_t c_data_d;
2816   scm_t_array_handle c_data_handle;
2817   const char *c_data;
2818   size_t c_data_len;
2819
2820   SCM_VALIDATE_ARRAY (1, data);
2821   c_format = scm_to_gnutls_openpgp_certificate_format (format, 2, FUNC_NAME);
2822
2823   c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
2824                                  FUNC_NAME);
2825   c_data_d.data = (unsigned char *) c_data;
2826   c_data_d.size = c_data_len;
2827
2828   err = gnutls_openpgp_crt_init (&c_key);
2829   if (EXPECT_FALSE (err))
2830     {
2831       scm_gnutls_release_array (&c_data_handle);
2832       scm_gnutls_error (err, FUNC_NAME);
2833     }
2834
2835   err = gnutls_openpgp_crt_import (c_key, &c_data_d, c_format);
2836   scm_gnutls_release_array (&c_data_handle);
2837
2838   if (EXPECT_FALSE (err))
2839     {
2840       gnutls_openpgp_crt_deinit (c_key);
2841       scm_gnutls_error (err, FUNC_NAME);
2842     }
2843
2844   return (scm_from_gnutls_openpgp_certificate (c_key));
2845 }
2846
2847 #undef FUNC_NAME
2848
2849 SCM_DEFINE (scm_gnutls_import_openpgp_private_key,
2850             "import-openpgp-private-key", 2, 1, 0, (SCM data, SCM format,
2851                                                     SCM pass),
2852             "Return a new OpenPGP private key object resulting from the "
2853             "import of @var{data} (a uniform array) according to "
2854             "@var{format}.  Optionally, a passphrase may be provided.")
2855 #define FUNC_NAME s_scm_gnutls_import_openpgp_private_key
2856 {
2857   int err;
2858   gnutls_openpgp_privkey_t c_key;
2859   gnutls_openpgp_crt_fmt_t c_format;
2860   gnutls_datum_t c_data_d;
2861   scm_t_array_handle c_data_handle;
2862   const char *c_data;
2863   char *c_pass;
2864   size_t c_data_len, c_pass_len;
2865
2866   SCM_VALIDATE_ARRAY (1, data);
2867   c_format = scm_to_gnutls_openpgp_certificate_format (format, 2, FUNC_NAME);
2868   if ((pass == SCM_UNDEFINED) || (scm_is_false (pass)))
2869     c_pass = NULL;
2870   else
2871     {
2872       c_pass_len = scm_c_string_length (pass);
2873       c_pass = alloca (c_pass_len + 1);
2874       (void) scm_to_locale_stringbuf (pass, c_pass, c_pass_len + 1);
2875       c_pass[c_pass_len] = '\0';
2876     }
2877
2878   c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
2879                                  FUNC_NAME);
2880   c_data_d.data = (unsigned char *) c_data;
2881   c_data_d.size = c_data_len;
2882
2883   err = gnutls_openpgp_privkey_init (&c_key);
2884   if (EXPECT_FALSE (err))
2885     {
2886       scm_gnutls_release_array (&c_data_handle);
2887       scm_gnutls_error (err, FUNC_NAME);
2888     }
2889
2890   err = gnutls_openpgp_privkey_import (c_key, &c_data_d, c_format, c_pass,
2891                                        0 /* currently unused */ );
2892   scm_gnutls_release_array (&c_data_handle);
2893
2894   if (EXPECT_FALSE (err))
2895     {
2896       gnutls_openpgp_privkey_deinit (c_key);
2897       scm_gnutls_error (err, FUNC_NAME);
2898     }
2899
2900   return (scm_from_gnutls_openpgp_private_key (c_key));
2901 }
2902
2903 #undef FUNC_NAME
2904
2905 SCM_DEFINE (scm_gnutls_openpgp_certificate_id, "openpgp-certificate-id",
2906             1, 0, 0,
2907             (SCM key),
2908             "Return the ID (an 8-element u8vector) of certificate "
2909             "@var{key}.")
2910 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_id
2911 {
2912   int err;
2913   unsigned char *c_id;
2914   gnutls_openpgp_crt_t c_key;
2915
2916   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
2917
2918   c_id = (unsigned char *) malloc (8);
2919   if (c_id == NULL)
2920     scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
2921
2922   err = gnutls_openpgp_crt_get_key_id (c_key, c_id);
2923   if (EXPECT_FALSE (err))
2924     scm_gnutls_error (err, FUNC_NAME);
2925
2926   return (scm_take_u8vector (c_id, 8));
2927 }
2928
2929 #undef FUNC_NAME
2930
2931 SCM_DEFINE (scm_gnutls_openpgp_certificate_id_x, "openpgp-certificate-id!",
2932             2, 0, 0,
2933             (SCM key, SCM id),
2934             "Store the ID (an 8 byte sequence) of certificate "
2935             "@var{key} in @var{id} (a u8vector).")
2936 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_id_x
2937 {
2938   int err;
2939   char *c_id;
2940   scm_t_array_handle c_id_handle;
2941   size_t c_id_size;
2942   gnutls_openpgp_crt_t c_key;
2943
2944   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
2945   c_id = scm_gnutls_get_writable_array (id, &c_id_handle, &c_id_size,
2946                                         FUNC_NAME);
2947
2948   if (EXPECT_FALSE (c_id_size < 8))
2949     {
2950       scm_gnutls_release_array (&c_id_handle);
2951       scm_misc_error (FUNC_NAME, "ID vector too small: ~A", scm_list_1 (id));
2952     }
2953
2954   err = gnutls_openpgp_crt_get_key_id (c_key, (unsigned char *) c_id);
2955   scm_gnutls_release_array (&c_id_handle);
2956
2957   if (EXPECT_FALSE (err))
2958     scm_gnutls_error (err, FUNC_NAME);
2959
2960   return SCM_UNSPECIFIED;
2961 }
2962
2963 #undef FUNC_NAME
2964
2965 SCM_DEFINE (scm_gnutls_openpgp_certificate_fingerpint_x,
2966             "openpgp-certificate-fingerprint!",
2967             2, 0, 0,
2968             (SCM key, SCM fpr),
2969             "Store in @var{fpr} (a u8vector) the fingerprint of @var{key}.  "
2970             "Return the number of bytes stored in @var{fpr}.")
2971 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_fingerpint_x
2972 {
2973   int err;
2974   gnutls_openpgp_crt_t c_key;
2975   char *c_fpr;
2976   scm_t_array_handle c_fpr_handle;
2977   size_t c_fpr_len, c_actual_len = 0;
2978
2979   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
2980   SCM_VALIDATE_ARRAY (2, fpr);
2981
2982   c_fpr = scm_gnutls_get_writable_array (fpr, &c_fpr_handle, &c_fpr_len,
2983                                          FUNC_NAME);
2984
2985   err = gnutls_openpgp_crt_get_fingerprint (c_key, c_fpr, &c_actual_len);
2986   scm_gnutls_release_array (&c_fpr_handle);
2987
2988   if (EXPECT_FALSE (err))
2989     scm_gnutls_error (err, FUNC_NAME);
2990
2991   return (scm_from_size_t (c_actual_len));
2992 }
2993
2994 #undef FUNC_NAME
2995
2996 SCM_DEFINE (scm_gnutls_openpgp_certificate_fingerprint,
2997             "openpgp-certificate-fingerprint",
2998             1, 0, 0,
2999             (SCM key),
3000             "Return a new u8vector denoting the fingerprint of " "@var{key}.")
3001 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_fingerprint
3002 {
3003   int err;
3004   gnutls_openpgp_crt_t c_key;
3005   unsigned char *c_fpr;
3006   size_t c_fpr_len, c_actual_len;
3007
3008   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
3009
3010   /* V4 fingerprints are 160-bit SHA-1 hashes (see RFC2440).  */
3011   c_fpr_len = 20;
3012   c_fpr = (unsigned char *) malloc (c_fpr_len);
3013   if (EXPECT_FALSE (c_fpr == NULL))
3014     scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
3015
3016   do
3017     {
3018       c_actual_len = 0;
3019       err = gnutls_openpgp_crt_get_fingerprint (c_key, c_fpr, &c_actual_len);
3020       if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
3021         {
3022           /* Grow C_FPR.  */
3023           unsigned char *c_new;
3024
3025           c_new = (unsigned char *) realloc (c_fpr, c_fpr_len * 2);
3026           if (EXPECT_FALSE (c_new == NULL))
3027             {
3028               free (c_fpr);
3029               scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
3030             }
3031           else
3032             {
3033               c_fpr_len *= 2;
3034               c_fpr = c_new;
3035             }
3036         }
3037     }
3038   while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
3039
3040   if (EXPECT_FALSE (err))
3041     {
3042       free (c_fpr);
3043       scm_gnutls_error (err, FUNC_NAME);
3044     }
3045
3046   if (c_actual_len < c_fpr_len)
3047     /* Shrink C_FPR.  */
3048     c_fpr = realloc (c_fpr, c_actual_len);
3049
3050   return (scm_take_u8vector (c_fpr, c_actual_len));
3051 }
3052
3053 #undef FUNC_NAME
3054
3055 SCM_DEFINE (scm_gnutls_openpgp_certificate_name, "openpgp-certificate-name",
3056             2, 0, 0,
3057             (SCM key, SCM index),
3058             "Return the @var{index}th name of @var{key}.")
3059 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_name
3060 {
3061   int err;
3062   gnutls_openpgp_crt_t c_key;
3063   int c_index;
3064   char c_name[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH];
3065   size_t c_name_len = sizeof (c_name);
3066
3067   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
3068   c_index = scm_to_int (index);
3069
3070   err = gnutls_openpgp_crt_get_name (c_key, c_index, c_name, &c_name_len);
3071   if (EXPECT_FALSE (err))
3072     scm_gnutls_error (err, FUNC_NAME);
3073
3074   /* XXX: The name is really UTF-8.  */
3075   return (scm_from_locale_string (c_name));
3076 }
3077
3078 #undef FUNC_NAME
3079
3080 SCM_DEFINE (scm_gnutls_openpgp_certificate_names, "openpgp-certificate-names",
3081             1, 0, 0, (SCM key), "Return the list of names for @var{key}.")
3082 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_names
3083 {
3084   int err;
3085   SCM result = SCM_EOL;
3086   gnutls_openpgp_crt_t c_key;
3087   int c_index = 0;
3088   char c_name[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH];
3089   size_t c_name_len = sizeof (c_name);
3090
3091   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
3092
3093   do
3094     {
3095       err = gnutls_openpgp_crt_get_name (c_key, c_index, c_name, &c_name_len);
3096       if (!err)
3097         {
3098           result = scm_cons (scm_from_locale_string (c_name), result);
3099           c_index++;
3100         }
3101     }
3102   while (!err);
3103
3104   if (EXPECT_FALSE (err != GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE))
3105     scm_gnutls_error (err, FUNC_NAME);
3106
3107   return (scm_reverse_x (result, SCM_EOL));
3108 }
3109
3110 #undef FUNC_NAME
3111
3112 SCM_DEFINE (scm_gnutls_openpgp_certificate_algorithm,
3113             "openpgp-certificate-algorithm",
3114             1, 0, 0,
3115             (SCM key),
3116             "Return two values: the certificate algorithm used by "
3117             "@var{key} and the number of bits used.")
3118 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_algorithm
3119 {
3120   gnutls_openpgp_crt_t c_key;
3121   unsigned int c_bits;
3122   gnutls_pk_algorithm_t c_algo;
3123
3124   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
3125   c_algo = gnutls_openpgp_crt_get_pk_algorithm (c_key, &c_bits);
3126
3127   return (scm_values (scm_list_2 (scm_from_gnutls_pk_algorithm (c_algo),
3128                                   scm_from_uint (c_bits))));
3129 }
3130
3131 #undef FUNC_NAME
3132
3133 SCM_DEFINE (scm_gnutls_openpgp_certificate_version,
3134             "openpgp-certificate-version",
3135             1, 0, 0,
3136             (SCM key),
3137             "Return the version of the OpenPGP message format (RFC2440) "
3138             "honored by @var{key}.")
3139 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_version
3140 {
3141   int c_version;
3142   gnutls_openpgp_crt_t c_key;
3143
3144   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
3145   c_version = gnutls_openpgp_crt_get_version (c_key);
3146
3147   return (scm_from_int (c_version));
3148 }
3149
3150 #undef FUNC_NAME
3151
3152 SCM_DEFINE (scm_gnutls_openpgp_certificate_usage, "openpgp-certificate-usage",
3153             1, 0, 0,
3154             (SCM key),
3155             "Return a list of values denoting the key usage of @var{key}.")
3156 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_usage
3157 {
3158   int err;
3159   unsigned int c_usage = 0;
3160   gnutls_openpgp_crt_t c_key;
3161
3162   c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
3163
3164   err = gnutls_openpgp_crt_get_key_usage (c_key, &c_usage);
3165   if (EXPECT_FALSE (err))
3166     scm_gnutls_error (err, FUNC_NAME);
3167
3168   return (scm_from_gnutls_key_usage_flags (c_usage));
3169 }
3170
3171 #undef FUNC_NAME
3172 \f
3173
3174
3175 /* OpenPGP keyrings.  */
3176
3177 SCM_DEFINE (scm_gnutls_import_openpgp_keyring, "import-openpgp-keyring",
3178             2, 0, 0,
3179             (SCM data, SCM format),
3180             "Import @var{data} (a u8vector) according to @var{format} "
3181             "and return the imported keyring.")
3182 #define FUNC_NAME s_scm_gnutls_import_openpgp_keyring
3183 {
3184   int err;
3185   gnutls_openpgp_keyring_t c_keyring;
3186   gnutls_openpgp_crt_fmt_t c_format;
3187   gnutls_datum_t c_data_d;
3188   scm_t_array_handle c_data_handle;
3189   const char *c_data;
3190   size_t c_data_len;
3191
3192   SCM_VALIDATE_ARRAY (1, data);
3193   c_format = scm_to_gnutls_openpgp_certificate_format (format, 2, FUNC_NAME);
3194
3195   c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
3196                                  FUNC_NAME);
3197
3198   c_data_d.data = (unsigned char *) c_data;
3199   c_data_d.size = c_data_len;
3200
3201   err = gnutls_openpgp_keyring_init (&c_keyring);
3202   if (EXPECT_FALSE (err))
3203     {
3204       scm_gnutls_release_array (&c_data_handle);
3205       scm_gnutls_error (err, FUNC_NAME);
3206     }
3207
3208   err = gnutls_openpgp_keyring_import (c_keyring, &c_data_d, c_format);
3209   scm_gnutls_release_array (&c_data_handle);
3210
3211   if (EXPECT_FALSE (err))
3212     {
3213       gnutls_openpgp_keyring_deinit (c_keyring);
3214       scm_gnutls_error (err, FUNC_NAME);
3215     }
3216
3217   return (scm_from_gnutls_openpgp_keyring (c_keyring));
3218 }
3219
3220 #undef FUNC_NAME
3221
3222 SCM_DEFINE (scm_gnutls_openpgp_keyring_contains_key_id_p,
3223             "openpgp-keyring-contains-key-id?",
3224             2, 0, 0,
3225             (SCM keyring, SCM id),
3226             "Return @code{#f} if key ID @var{id} is in @var{keyring}, "
3227             "@code{#f} otherwise.")
3228 #define FUNC_NAME s_scm_gnutls_openpgp_keyring_contains_key_id_p
3229 {
3230   int c_result;
3231   gnutls_openpgp_keyring_t c_keyring;
3232   scm_t_array_handle c_id_handle;
3233   const char *c_id;
3234   size_t c_id_len;
3235
3236   c_keyring = scm_to_gnutls_openpgp_keyring (keyring, 1, FUNC_NAME);
3237   SCM_VALIDATE_ARRAY (1, id);
3238
3239   c_id = scm_gnutls_get_array (id, &c_id_handle, &c_id_len, FUNC_NAME);
3240   if (EXPECT_FALSE (c_id_len != 8))
3241     {
3242       scm_gnutls_release_array (&c_id_handle);
3243       scm_wrong_type_arg (FUNC_NAME, 1, id);
3244     }
3245
3246   c_result = gnutls_openpgp_keyring_check_id (c_keyring,
3247                                               (unsigned char *) c_id,
3248                                               0 /* unused */ );
3249
3250   scm_gnutls_release_array (&c_id_handle);
3251
3252   return (scm_from_bool (c_result == 0));
3253 }
3254
3255 #undef FUNC_NAME
3256 \f
3257
3258 /* OpenPGP certificates.  */
3259
3260 SCM_DEFINE (scm_gnutls_set_certificate_credentials_openpgp_keys_x,
3261             "set-certificate-credentials-openpgp-keys!",
3262             3, 0, 0,
3263             (SCM cred, SCM pub, SCM sec),
3264             "Use certificate @var{pub} and secret key @var{sec} in "
3265             "certificate credentials @var{cred}.")
3266 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_openpgp_keys_x
3267 {
3268   int err;
3269   gnutls_certificate_credentials_t c_cred;
3270   gnutls_openpgp_crt_t c_pub;
3271   gnutls_openpgp_privkey_t c_sec;
3272
3273   c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
3274   c_pub = scm_to_gnutls_openpgp_certificate (pub, 2, FUNC_NAME);
3275   c_sec = scm_to_gnutls_openpgp_private_key (sec, 3, FUNC_NAME);
3276
3277   err = gnutls_certificate_set_openpgp_key (c_cred, c_pub, c_sec);
3278   if (EXPECT_FALSE (err))
3279     scm_gnutls_error (err, FUNC_NAME);
3280
3281   return SCM_UNSPECIFIED;
3282 }
3283
3284 #undef FUNC_NAME
3285
3286 \f
3287
3288 /* Debugging.  */
3289
3290 static SCM log_procedure = SCM_BOOL_F;
3291
3292 static void
3293 scm_gnutls_log (int level, const char *str)
3294 {
3295   if (scm_is_true (log_procedure))
3296     (void) scm_call_2 (log_procedure, scm_from_int (level),
3297                        scm_from_locale_string (str));
3298 }
3299
3300 SCM_DEFINE (scm_gnutls_set_log_procedure_x, "set-log-procedure!",
3301             1, 0, 0,
3302             (SCM proc),
3303             "Use @var{proc} (a two-argument procedure) as the global "
3304             "GnuTLS log procedure.")
3305 #define FUNC_NAME s_scm_gnutls_set_log_procedure_x
3306 {
3307   SCM_VALIDATE_PROC (1, proc);
3308
3309   if (scm_is_true (log_procedure))
3310     (void) scm_gc_unprotect_object (log_procedure);
3311
3312   log_procedure = scm_gc_protect_object (proc);
3313   gnutls_global_set_log_function (scm_gnutls_log);
3314
3315   return SCM_UNSPECIFIED;
3316 }
3317
3318 #undef FUNC_NAME
3319
3320 SCM_DEFINE (scm_gnutls_set_log_level_x, "set-log-level!", 1, 0, 0,
3321             (SCM level),
3322             "Enable GnuTLS logging up to @var{level} (an integer).")
3323 #define FUNC_NAME s_scm_gnutls_set_log_level_x
3324 {
3325   unsigned int c_level;
3326
3327   c_level = scm_to_uint (level);
3328   gnutls_global_set_log_level (c_level);
3329
3330   return SCM_UNSPECIFIED;
3331 }
3332
3333 #undef FUNC_NAME
3334 \f
3335
3336 /* Initialization.  */
3337
3338 void
3339 scm_init_gnutls (void)
3340 {
3341 #include "core.x"
3342
3343   /* Use Guile's allocation routines, which will run the GC if need be.  */
3344   gnutls_malloc = scm_malloc;
3345   gnutls_realloc = scm_realloc;
3346   gnutls_secure_malloc = scm_malloc;
3347   gnutls_free = free;
3348
3349   (void) gnutls_global_init ();
3350
3351   scm_gnutls_define_enums ();
3352
3353   scm_init_gnutls_error ();
3354
3355   scm_init_gnutls_session_record_port_type ();
3356 }