guile/src/core.c

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