/* GnuTLS --- Guile bindings for GnuTLS.
Copyright (C) 2007-2014, 2016, 2019 Free Software Foundation, Inc.
GnuTLS is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
GnuTLS is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with GnuTLS; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
/* Written by Ludovic Courtès <ludo@gnu.org>. */
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include <stdio.h>
#include <stdint.h>
#include <string.h>
#include <gnutls/gnutls.h>
#include <gnutls/openpgp.h>
#include <libguile.h>
#include <alloca.h>
#include <assert.h>
#include "enums.h"
#include "smobs.h"
#include "errors.h"
#include "utils.h"
#ifndef HAVE_SCM_GC_MALLOC_POINTERLESS
# define scm_gc_malloc_pointerless scm_gc_malloc
#endif
/* Maximum size allowed for 'alloca'. */
#define ALLOCA_MAX_SIZE 1024U
/* Allocate SIZE bytes, either on the C stack or on the GC-managed heap. */
#define FAST_ALLOC(size) \
(((size) <= ALLOCA_MAX_SIZE) \
? alloca (size) \
: scm_gc_malloc_pointerless ((size), "gnutls-alloc"))
/* SMOB and enums type definitions. */
#include "enum-map.i.c"
#include "smob-types.i.c"
const char scm_gnutls_array_error_message[] =
"cannot handle non-contiguous array: ~A";
/* Data that are attached to `gnutls_session_t' objects.
We need to keep several pieces of information along with each session:
- A boolean indicating whether its underlying transport is a file
descriptor or Scheme port. This is used to decide whether to leave
"Guile mode" when invoking `gnutls_record_recv ()'.
- The record port attached to the session (returned by
`session-record-port'). This is so that several calls to
`session-record-port' return the same port.
Currently, this information is maintained into a pair. The whole pair is
marked by the session mark procedure. */
#define SCM_GNUTLS_MAKE_SESSION_DATA() \
scm_cons (SCM_BOOL_F, SCM_BOOL_F)
#define SCM_GNUTLS_SET_SESSION_DATA(c_session, data) \
gnutls_session_set_ptr (c_session, (void *) SCM_UNPACK (data))
#define SCM_GNUTLS_SESSION_DATA(c_session) \
SCM_PACK ((scm_t_bits) gnutls_session_get_ptr (c_session))
#define SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD(c_session, c_is_fd) \
SCM_SETCAR (SCM_GNUTLS_SESSION_DATA (c_session), \
scm_from_bool (c_is_fd))
#define SCM_GNUTLS_SET_SESSION_RECORD_PORT(c_session, port) \
SCM_SETCDR (SCM_GNUTLS_SESSION_DATA (c_session), port)
#define SCM_GNUTLS_SESSION_TRANSPORT_IS_FD(c_session) \
scm_to_bool (SCM_CAR (SCM_GNUTLS_SESSION_DATA (c_session)))
#define SCM_GNUTLS_SESSION_RECORD_PORT(c_session) \
SCM_CDR (SCM_GNUTLS_SESSION_DATA (c_session))
/* Weak-key hash table. */
static SCM weak_refs;
/* Register a weak reference from @FROM to @TO, such that the lifetime of TO is
greater than or equal to that of FROM. */
static void
register_weak_reference (SCM from, SCM to)
{
scm_hashq_set_x (weak_refs, from, to);
}
/* Bindings. */
/* Mark the data associated with SESSION. */
SCM_SMOB_MARK (scm_tc16_gnutls_session, mark_session, session)
{
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, "mark_session");
return (SCM_GNUTLS_SESSION_DATA (c_session));
}
SCM_DEFINE (scm_gnutls_version, "gnutls-version", 0, 0, 0,
(void),
"Return a string denoting the version number of the underlying "
"GnuTLS library, e.g., @code{\"1.7.2\"}.")
#define FUNC_NAME s_scm_gnutls_version
{
return (scm_from_locale_string (gnutls_check_version (NULL)));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_make_session, "make-session", 1, 0, 1,
(SCM end, SCM flags),
"Return a new session for connection end @var{end}, either "
"@code{connection-end/server} or @code{connection-end/client}. "
"The optional @var{flags} arguments are @code{connection-flag} "
"values such as @code{connection-flag/auto-reauth}.")
#define FUNC_NAME s_scm_gnutls_make_session
{
int err, i;
gnutls_session_t c_session;
gnutls_connection_end_t c_end;
gnutls_init_flags_t c_flags = 0;
SCM session_data;
c_end = scm_to_gnutls_connection_end (end, 1, FUNC_NAME);
session_data = SCM_GNUTLS_MAKE_SESSION_DATA ();
for (i = 2; scm_is_pair (flags); flags = scm_cdr (flags), i++)
c_flags |= scm_to_gnutls_connection_flag (scm_car (flags), i, FUNC_NAME);
err = gnutls_init (&c_session, c_end | c_flags);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
SCM_GNUTLS_SET_SESSION_DATA (c_session, session_data);
return (scm_from_gnutls_session (c_session));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_bye, "bye", 2, 0, 0,
(SCM session, SCM how),
"Close @var{session} according to @var{how}.")
#define FUNC_NAME s_scm_gnutls_bye
{
int err;
gnutls_session_t c_session;
gnutls_close_request_t c_how;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_how = scm_to_gnutls_close_request (how, 2, FUNC_NAME);
err = gnutls_bye (c_session, c_how);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_handshake, "handshake", 1, 0, 0,
(SCM session), "Perform a handshake for @var{session}.")
#define FUNC_NAME s_scm_gnutls_handshake
{
int err;
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
err = gnutls_handshake (c_session);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_rehandshake, "rehandshake", 1, 0, 0,
(SCM session), "Perform a re-handshaking for @var{session}.")
#define FUNC_NAME s_scm_gnutls_rehandshake
{
int err;
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
err = gnutls_rehandshake (c_session);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_reauthenticate, "reauthenticate", 1, 0, 0,
(SCM session), "Perform a re-authentication step for @var{session}.")
#define FUNC_NAME s_scm_gnutls_reauthenticate
{
int err;
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
/* FIXME: Allow flags as an argument. */
err = gnutls_reauth (c_session, 0);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_alert_get, "alert-get", 1, 0, 0,
(SCM session), "Get an aleter from @var{session}.")
#define FUNC_NAME s_scm_gnutls_alert_get
{
gnutls_session_t c_session;
gnutls_alert_description_t c_alert;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_alert = gnutls_alert_get (c_session);
return (scm_from_gnutls_alert_description (c_alert));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_alert_send, "alert-send", 3, 0, 0,
(SCM session, SCM level, SCM alert),
"Send @var{alert} via @var{session}.")
#define FUNC_NAME s_scm_gnutls_alert_send
{
int err;
gnutls_session_t c_session;
gnutls_alert_level_t c_level;
gnutls_alert_description_t c_alert;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_level = scm_to_gnutls_alert_level (level, 2, FUNC_NAME);
c_alert = scm_to_gnutls_alert_description (alert, 3, FUNC_NAME);
err = gnutls_alert_send (c_session, c_level, c_alert);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* FIXME: Omitting `alert-send-appropriate'. */
/* Session accessors. */
SCM_DEFINE (scm_gnutls_session_cipher, "session-cipher", 1, 0, 0,
(SCM session), "Return @var{session}'s cipher.")
#define FUNC_NAME s_scm_gnutls_session_cipher
{
gnutls_session_t c_session;
gnutls_cipher_algorithm_t c_cipher;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_cipher = gnutls_cipher_get (c_session);
return (scm_from_gnutls_cipher (c_cipher));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_kx, "session-kx", 1, 0, 0,
(SCM session), "Return @var{session}'s kx.")
#define FUNC_NAME s_scm_gnutls_session_kx
{
gnutls_session_t c_session;
gnutls_kx_algorithm_t c_kx;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_kx = gnutls_kx_get (c_session);
return (scm_from_gnutls_kx (c_kx));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_mac, "session-mac", 1, 0, 0,
(SCM session), "Return @var{session}'s MAC.")
#define FUNC_NAME s_scm_gnutls_session_mac
{
gnutls_session_t c_session;
gnutls_mac_algorithm_t c_mac;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_mac = gnutls_mac_get (c_session);
return (scm_from_gnutls_mac (c_mac));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_compression_method,
"session-compression-method", 1, 0, 0,
(SCM session), "Return @var{session}'s compression method.")
#define FUNC_NAME s_scm_gnutls_session_compression_method
{
gnutls_session_t c_session;
gnutls_compression_method_t c_comp;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_comp = gnutls_compression_get (c_session);
return (scm_from_gnutls_compression_method (c_comp));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_certificate_type,
"session-certificate-type", 1, 0, 0,
(SCM session), "Return @var{session}'s certificate type.")
#define FUNC_NAME s_scm_gnutls_session_certificate_type
{
gnutls_session_t c_session;
gnutls_certificate_type_t c_cert;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_cert = gnutls_certificate_type_get (c_session);
return (scm_from_gnutls_certificate_type (c_cert));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_protocol, "session-protocol", 1, 0, 0,
(SCM session), "Return the protocol used by @var{session}.")
#define FUNC_NAME s_scm_gnutls_session_protocol
{
gnutls_session_t c_session;
gnutls_protocol_t c_protocol;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_protocol = gnutls_protocol_get_version (c_session);
return (scm_from_gnutls_protocol (c_protocol));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_authentication_type,
"session-authentication-type",
1, 0, 0,
(SCM session),
"Return the authentication type (a @code{credential-type} value) "
"used by @var{session}.")
#define FUNC_NAME s_scm_gnutls_session_authentication_type
{
gnutls_session_t c_session;
gnutls_credentials_type_t c_auth;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_auth = gnutls_auth_get_type (c_session);
return (scm_from_gnutls_credentials (c_auth));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_server_authentication_type,
"session-server-authentication-type",
1, 0, 0,
(SCM session),
"Return the server authentication type (a "
"@code{credential-type} value) used in @var{session}.")
#define FUNC_NAME s_scm_gnutls_session_server_authentication_type
{
gnutls_session_t c_session;
gnutls_credentials_type_t c_auth;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_auth = gnutls_auth_server_get_type (c_session);
return (scm_from_gnutls_credentials (c_auth));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_client_authentication_type,
"session-client-authentication-type",
1, 0, 0,
(SCM session),
"Return the client authentication type (a "
"@code{credential-type} value) used in @var{session}.")
#define FUNC_NAME s_scm_gnutls_session_client_authentication_type
{
gnutls_session_t c_session;
gnutls_credentials_type_t c_auth;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_auth = gnutls_auth_client_get_type (c_session);
return (scm_from_gnutls_credentials (c_auth));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_peer_certificate_chain,
"session-peer-certificate-chain",
1, 0, 0,
(SCM session),
"Return the a list of certificates in raw format (u8vectors) "
"where the first one is the peer's certificate. In the case "
"of OpenPGP, there is always exactly one certificate. In the "
"case of X.509, subsequent certificates indicate form a "
"certificate chain. Return the empty list if no certificate "
"was sent.")
#define FUNC_NAME s_scm_gnutls_session_peer_certificate_chain
{
SCM result;
gnutls_session_t c_session;
const gnutls_datum_t *c_cert;
unsigned int c_list_size;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_cert = gnutls_certificate_get_peers (c_session, &c_list_size);
if (EXPECT_FALSE (c_cert == NULL))
result = SCM_EOL;
else
{
SCM pair;
unsigned int i;
result = scm_make_list (scm_from_uint (c_list_size), SCM_UNSPECIFIED);
for (i = 0, pair = result; i < c_list_size; i++, pair = SCM_CDR (pair))
{
unsigned char *c_cert_copy;
c_cert_copy = (unsigned char *) malloc (c_cert[i].size);
if (EXPECT_FALSE (c_cert_copy == NULL))
scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
memcpy (c_cert_copy, c_cert[i].data, c_cert[i].size);
SCM_SETCAR (pair, scm_take_u8vector (c_cert_copy, c_cert[i].size));
}
}
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_session_our_certificate_chain,
"session-our-certificate-chain",
1, 0, 0,
(SCM session),
"Return our certificate chain for @var{session} (as sent to "
"the peer) in raw format (a u8vector). In the case of OpenPGP "
"there is exactly one certificate. Return the empty list "
"if no certificate was used.")
#define FUNC_NAME s_scm_gnutls_session_our_certificate_chain
{
SCM result;
gnutls_session_t c_session;
const gnutls_datum_t *c_cert;
unsigned char *c_cert_copy;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
/* XXX: Currently, the C function actually returns only one certificate.
Future versions of the API may provide the full certificate chain, as
for `gnutls_certificate_get_peers ()'. */
c_cert = gnutls_certificate_get_ours (c_session);
if (EXPECT_FALSE (c_cert == NULL))
result = SCM_EOL;
else
{
c_cert_copy = (unsigned char *) malloc (c_cert->size);
if (EXPECT_FALSE (c_cert_copy == NULL))
scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
memcpy (c_cert_copy, c_cert->data, c_cert->size);
result = scm_list_1 (scm_take_u8vector (c_cert_copy, c_cert->size));
}
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_server_session_certificate_request_x,
"set-server-session-certificate-request!",
2, 0, 0,
(SCM session, SCM request),
"Tell how @var{session}, a server-side session, should deal "
"with certificate requests. @var{request} should be either "
"@code{certificate-request/request} or "
"@code{certificate-request/require}.")
#define FUNC_NAME s_scm_gnutls_set_server_session_certificate_request_x
{
gnutls_session_t c_session;
gnutls_certificate_status_t c_request;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_request = scm_to_gnutls_certificate_request (request, 2, FUNC_NAME);
gnutls_certificate_server_set_request (c_session, c_request);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Choice of a protocol and cipher suite. */
SCM_DEFINE (scm_gnutls_set_default_priority_x,
"set-session-default-priority!", 1, 0, 0,
(SCM session), "Have @var{session} use the default priorities.")
#define FUNC_NAME s_scm_gnutls_set_default_priority_x
{
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
gnutls_set_default_priority (c_session);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_session_priorities_x,
"set-session-priorities!", 2, 0, 0,
(SCM session, SCM priorities),
"Have @var{session} use the given @var{priorities} for "
"the ciphers, key exchange methods, MACs and compression "
"methods. @var{priorities} must be a string (@pxref{"
"Priority Strings,,, gnutls, GnuTLS@comma{} Transport Layer "
"Security Library for the GNU system}). When @var{priorities} "
"cannot be parsed, an @code{error/invalid-request} error "
"is raised, with an extra argument indication the position "
"of the error.\n")
#define FUNC_NAME s_scm_gnutls_set_session_priorities_x
{
int err;
char *c_priorities;
const char *err_pos;
gnutls_session_t c_session;
size_t pos;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_priorities = scm_to_locale_string (priorities); /* XXX: to_latin1_string */
err = gnutls_priority_set_direct (c_session, c_priorities, &err_pos);
if (err == GNUTLS_E_INVALID_REQUEST)
pos = err_pos - c_priorities;
free (c_priorities);
switch (err)
{
case GNUTLS_E_SUCCESS:
break;
case GNUTLS_E_INVALID_REQUEST:
{
scm_gnutls_error_with_args (err, FUNC_NAME,
scm_list_1 (scm_from_size_t (pos)));
break;
}
default:
scm_gnutls_error (err, FUNC_NAME);
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_cipher_suite_to_string, "cipher-suite->string",
3, 0, 0,
(SCM kx, SCM cipher, SCM mac),
"Return the name of the given cipher suite.")
#define FUNC_NAME s_scm_gnutls_cipher_suite_to_string
{
gnutls_kx_algorithm_t c_kx;
gnutls_cipher_algorithm_t c_cipher;
gnutls_mac_algorithm_t c_mac;
const char *c_name;
c_kx = scm_to_gnutls_kx (kx, 1, FUNC_NAME);
c_cipher = scm_to_gnutls_cipher (cipher, 2, FUNC_NAME);
c_mac = scm_to_gnutls_mac (mac, 3, FUNC_NAME);
c_name = gnutls_cipher_suite_get_name (c_kx, c_cipher, c_mac);
return (scm_from_locale_string (c_name));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_session_credentials_x, "set-session-credentials!",
2, 0, 0,
(SCM session, SCM cred),
"Use @var{cred} as @var{session}'s credentials.")
#define FUNC_NAME s_scm_gnutls_set_session_credentials_x
{
int err = 0;
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_certificate_credentials, cred))
{
gnutls_certificate_credentials_t c_cred;
c_cred = scm_to_gnutls_certificate_credentials (cred, 2, FUNC_NAME);
err =
gnutls_credentials_set (c_session, GNUTLS_CRD_CERTIFICATE, c_cred);
}
else
if (SCM_SMOB_PREDICATE
(scm_tc16_gnutls_anonymous_client_credentials, cred))
{
gnutls_anon_client_credentials_t c_cred;
c_cred = scm_to_gnutls_anonymous_client_credentials (cred, 2,
FUNC_NAME);
err = gnutls_credentials_set (c_session, GNUTLS_CRD_ANON, c_cred);
}
else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_anonymous_server_credentials,
cred))
{
gnutls_anon_server_credentials_t c_cred;
c_cred = scm_to_gnutls_anonymous_server_credentials (cred, 2,
FUNC_NAME);
err = gnutls_credentials_set (c_session, GNUTLS_CRD_ANON, c_cred);
}
#ifdef ENABLE_SRP
else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_srp_client_credentials, cred))
{
gnutls_srp_client_credentials_t c_cred;
c_cred = scm_to_gnutls_srp_client_credentials (cred, 2, FUNC_NAME);
err = gnutls_credentials_set (c_session, GNUTLS_CRD_SRP, c_cred);
}
else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_srp_server_credentials, cred))
{
gnutls_srp_server_credentials_t c_cred;
c_cred = scm_to_gnutls_srp_server_credentials (cred, 2, FUNC_NAME);
err = gnutls_credentials_set (c_session, GNUTLS_CRD_SRP, c_cred);
}
#endif
else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_psk_client_credentials, cred))
{
gnutls_psk_client_credentials_t c_cred;
c_cred = scm_to_gnutls_psk_client_credentials (cred, 2, FUNC_NAME);
err = gnutls_credentials_set (c_session, GNUTLS_CRD_PSK, c_cred);
}
else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_psk_server_credentials, cred))
{
gnutls_psk_server_credentials_t c_cred;
c_cred = scm_to_gnutls_psk_server_credentials (cred, 2, FUNC_NAME);
err = gnutls_credentials_set (c_session, GNUTLS_CRD_PSK, c_cred);
}
else
scm_wrong_type_arg (FUNC_NAME, 2, cred);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
else
register_weak_reference (session, cred);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_session_server_name_x, "set-session-server-name!",
3, 0, 0,
(SCM session, SCM type, SCM name),
"For a client, this procedure provides a way to inform "
"the server that it is known under @var{name}, @i{via} the "
"@code{SERVER NAME} TLS extension. @var{type} must be "
"a @code{server-name-type} value, @var{server-name-type/dns} "
"for DNS names.")
#define FUNC_NAME s_scm_gnutls_set_session_server_name_x
{
int err;
gnutls_session_t c_session;
gnutls_server_name_type_t c_type;
char *c_name;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_type = scm_to_gnutls_server_name_type (type, 2, FUNC_NAME);
SCM_VALIDATE_STRING (3, name);
c_name = scm_to_locale_string (name);
err = gnutls_server_name_set (c_session, c_type, c_name,
strlen (c_name));
free (c_name);
if (EXPECT_FALSE (err != GNUTLS_E_SUCCESS))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Record layer. */
SCM_DEFINE (scm_gnutls_record_send, "record-send", 2, 0, 0,
(SCM session, SCM array),
"Send the record constituted by @var{array} through "
"@var{session}.")
#define FUNC_NAME s_scm_gnutls_record_send
{
SCM result;
ssize_t c_result;
gnutls_session_t c_session;
scm_t_array_handle c_handle;
const char *c_array;
size_t c_len;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
SCM_VALIDATE_ARRAY (2, array);
c_array = scm_gnutls_get_array (array, &c_handle, &c_len, FUNC_NAME);
c_result = gnutls_record_send (c_session, c_array, c_len);
scm_gnutls_release_array (&c_handle);
if (EXPECT_TRUE (c_result >= 0))
result = scm_from_ssize_t (c_result);
else
scm_gnutls_error (c_result, FUNC_NAME);
return (result);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_record_receive_x, "record-receive!", 2, 0, 0,
(SCM session, SCM array),
"Receive data from @var{session} into @var{array}, a uniform "
"homogeneous array. Return the number of bytes actually "
"received.")
#define FUNC_NAME s_scm_gnutls_record_receive_x
{
SCM result;
ssize_t c_result;
gnutls_session_t c_session;
scm_t_array_handle c_handle;
char *c_array;
size_t c_len;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
SCM_VALIDATE_ARRAY (2, array);
c_array = scm_gnutls_get_writable_array (array, &c_handle, &c_len,
FUNC_NAME);
c_result = gnutls_record_recv (c_session, c_array, c_len);
scm_gnutls_release_array (&c_handle);
if (EXPECT_TRUE (c_result >= 0))
result = scm_from_ssize_t (c_result);
else
scm_gnutls_error (c_result, FUNC_NAME);
return (result);
}
#undef FUNC_NAME
/* Whether we're using Guile < 2.2. */
#define USING_GUILE_BEFORE_2_2 \
(SCM_MAJOR_VERSION < 2 \
|| (SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION == 0))
/* The session record port type. Guile 2.1.4 introduced a brand new port API,
so we have a separate implementation for these newer versions. */
#if USING_GUILE_BEFORE_2_2
static scm_t_bits session_record_port_type;
/* Hint for the `scm_gc_' functions. */
static const char session_record_port_gc_hint[] =
"gnutls-session-record-port";
#else
static scm_t_port_type *session_record_port_type;
#endif
/* Return the session associated with PORT. */
#define SCM_GNUTLS_SESSION_RECORD_PORT_SESSION(_port) \
(SCM_PACK (SCM_STREAM (_port)))
/* Size of a session port's input buffer. */
#define SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE 4096
#if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION <= 8
/* Mark the session associated with PORT. */
static SCM
mark_session_record_port (SCM port)
{
return (SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port));
}
static size_t
free_session_record_port (SCM port)
#define FUNC_NAME "free_session_record_port"
{
SCM session;
scm_t_port *c_port;
session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
/* SESSION _can_ be invalid at this point: it can be freed in the same GC
cycle as PORT, just before PORT. Thus, we need to check whether SESSION
still points to a session SMOB. */
if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_session, session))
{
/* SESSION is still valid. Disassociate PORT from SESSION. */
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
SCM_GNUTLS_SET_SESSION_RECORD_PORT (c_session, SCM_BOOL_F);
}
/* Free the input buffer of PORT. */
c_port = SCM_PTAB_ENTRY (port);
scm_gc_free (c_port->read_buf, c_port->read_buf_size,
session_record_port_gc_hint);
return 0;
}
#undef FUNC_NAME
#endif /* SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION <= 8 */
#if USING_GUILE_BEFORE_2_2
/* Data passed to `do_fill_port ()'. */
typedef struct
{
scm_t_port *c_port;
gnutls_session_t c_session;
} fill_port_data_t;
/* Actually fill a session record port (see below). */
static void *
do_fill_port (void *data)
{
int chr;
ssize_t result;
scm_t_port *c_port;
const fill_port_data_t *args = (fill_port_data_t *) data;
c_port = args->c_port;
/* We can get GNUTLS_E_AGAIN due to a "short read", which does _not_
correspond to an actual EAGAIN from read(2) since the underlying file
descriptor is blocking. Thus, we can safely loop right away. */
do
result = gnutls_record_recv (args->c_session,
c_port->read_buf, c_port->read_buf_size);
while (result == GNUTLS_E_AGAIN || result == GNUTLS_E_INTERRUPTED);
if (EXPECT_TRUE (result > 0))
{
c_port->read_pos = c_port->read_buf;
c_port->read_end = c_port->read_buf + result;
chr = (int) *c_port->read_buf;
}
else if (result == 0)
chr = EOF;
else
scm_gnutls_error (result, "fill_session_record_port_input");
return ((void *) (uintptr_t) chr);
}
/* Fill in the input buffer of PORT. */
static int
fill_session_record_port_input (SCM port)
#define FUNC_NAME "fill_session_record_port_input"
{
int chr;
scm_t_port *c_port = SCM_PTAB_ENTRY (port);
if (c_port->read_pos >= c_port->read_end)
{
SCM session;
fill_port_data_t c_args;
gnutls_session_t c_session;
session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_args.c_session = c_session;
c_args.c_port = c_port;
if (SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session))
/* SESSION's underlying transport is a raw file descriptor, so we
must leave "Guile mode" to allow the GC to run. */
chr = (intptr_t) scm_without_guile (do_fill_port, &c_args);
else
/* SESSION's underlying transport is a port, so don't leave "Guile
mode". */
chr = (intptr_t) do_fill_port (&c_args);
}
else
chr = (int) *c_port->read_pos;
return chr;
}
#undef FUNC_NAME
/* Write SIZE octets from DATA to PORT. */
static void
write_to_session_record_port (SCM port, const void *data, size_t size)
#define FUNC_NAME "write_to_session_record_port"
{
SCM session;
gnutls_session_t c_session;
ssize_t c_result;
size_t c_sent = 0;
session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
while (c_sent < size)
{
c_result = gnutls_record_send (c_session, (char *) data + c_sent,
size - c_sent);
if (EXPECT_FALSE (c_result < 0))
scm_gnutls_error (c_result, FUNC_NAME);
else
c_sent += c_result;
}
}
#undef FUNC_NAME
/* Return a new session port for SESSION. */
static SCM
make_session_record_port (SCM session)
{
SCM port;
scm_t_port *c_port;
unsigned char *c_port_buf;
const unsigned long mode_bits = SCM_OPN | SCM_RDNG | SCM_WRTNG;
c_port_buf = (unsigned char *)
scm_gc_malloc_pointerless (SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE,
session_record_port_gc_hint);
/* Create a new port. */
port = scm_new_port_table_entry (session_record_port_type);
c_port = SCM_PTAB_ENTRY (port);
/* Mark PORT as open, readable and writable (hmm, how elegant...). */
SCM_SET_CELL_TYPE (port, session_record_port_type | mode_bits);
/* Associate it with SESSION. */
SCM_SETSTREAM (port, SCM_UNPACK (session));
c_port->read_pos = c_port->read_end = c_port->read_buf = c_port_buf;
c_port->read_buf_size = SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE;
c_port->write_buf = c_port->write_pos = &c_port->shortbuf;
c_port->write_buf_size = 1;
return (port);
}
#else /* !USING_GUILE_BEFORE_2_2 */
static size_t
read_from_session_record_port (SCM port, SCM dst, size_t start, size_t count)
#define FUNC_NAME "read_from_session_record_port"
{
SCM session;
gnutls_session_t c_session;
char *read_buf;
ssize_t result;
session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
read_buf = (char *) SCM_BYTEVECTOR_CONTENTS (dst) + start;
/* We can get GNUTLS_E_AGAIN due to a "short read", which does _not_
correspond to an actual EAGAIN from read(2) if the underlying file
descriptor is blocking--e.g., from 'get_last_packet', returning
GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE.
If SESSION is backed by a file descriptor, return -1 to indicate that
we'd better poll; otherwise loop, which is good enough if the underlying
port is blocking. */
do
result = gnutls_record_recv (c_session, read_buf, count);
while (result == GNUTLS_E_INTERRUPTED
|| (result == GNUTLS_E_AGAIN
&& !SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session)));
if (result == GNUTLS_E_AGAIN
&& SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session))
/* Tell Guile that reading would block. */
return (size_t) -1;
if (EXPECT_FALSE (result < 0))
/* FIXME: Silently swallowed! */
scm_gnutls_error (result, FUNC_NAME);
return result;
}
#undef FUNC_NAME
/* Return the file descriptor that backs PORT. This function is called upon a
blocking read--i.e., 'read_from_session_record_port' returned -1. */
static int
session_record_port_fd (SCM port)
{
SCM session;
gnutls_session_t c_session;
session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
c_session = scm_to_gnutls_session (session, 1, __func__);
assert (SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session));
return gnutls_transport_get_int (c_session);
}
static size_t
write_to_session_record_port (SCM port, SCM src, size_t start, size_t count)
#define FUNC_NAME "write_to_session_record_port"
{
SCM session;
gnutls_session_t c_session;
char *data;
ssize_t result;
session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
data = (char *) SCM_BYTEVECTOR_CONTENTS (src) + start;
result = gnutls_record_send (c_session, data, count);
if (EXPECT_FALSE (result < 0))
scm_gnutls_error (result, FUNC_NAME);
return result;
}
#undef FUNC_NAME
/* Return a new session port for SESSION. */
static SCM
make_session_record_port (SCM session)
{
return scm_c_make_port (session_record_port_type,
SCM_OPN | SCM_RDNG | SCM_WRTNG | SCM_BUF0,
SCM_UNPACK (session));
}
#endif /* !USING_GUILE_BEFORE_2_2 */
SCM_DEFINE (scm_gnutls_session_record_port, "session-record-port", 1, 0, 0,
(SCM session),
"Return a read-write port that may be used to communicate over "
"@var{session}. All invocations of @code{session-port} on a "
"given session return the same object (in the sense of "
"@code{eq?}).")
#define FUNC_NAME s_scm_gnutls_session_record_port
{
SCM port;
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
port = SCM_GNUTLS_SESSION_RECORD_PORT (c_session);
if (!SCM_PORTP (port))
{
/* Lazily create a new session port. */
port = make_session_record_port (session);
SCM_GNUTLS_SET_SESSION_RECORD_PORT (c_session, port);
}
return (port);
}
#undef FUNC_NAME
/* Create the session port type. */
static void
scm_init_gnutls_session_record_port_type (void)
{
session_record_port_type =
scm_make_port_type ("gnutls-session-port",
#if USING_GUILE_BEFORE_2_2
fill_session_record_port_input,
#else
read_from_session_record_port,
#endif
write_to_session_record_port);
#if !USING_GUILE_BEFORE_2_2
scm_set_port_read_wait_fd (session_record_port_type,
session_record_port_fd);
#endif
/* Guile >= 1.9.3 doesn't need a custom mark procedure, and doesn't need a
finalizer (since memory associated with the port is automatically
reclaimed.) */
#if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION <= 8
scm_set_port_mark (session_record_port_type, mark_session_record_port);
scm_set_port_free (session_record_port_type, free_session_record_port);
#endif
}
/* Transport. */
SCM_DEFINE (scm_gnutls_set_session_transport_fd_x,
"set-session-transport-fd!", 2, 0, 0, (SCM session, SCM fd),
"Use file descriptor @var{fd} as the underlying transport for "
"@var{session}.")
#define FUNC_NAME s_scm_gnutls_set_session_transport_fd_x
{
gnutls_session_t c_session;
int c_fd;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_fd = (int) scm_to_uint (fd);
gnutls_transport_set_ptr (c_session,
(gnutls_transport_ptr_t) (intptr_t) c_fd);
SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD (c_session, 1);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Pull SIZE octets from TRANSPORT (a Scheme port) into DATA. */
static ssize_t
pull_from_port (gnutls_transport_ptr_t transport, void *data, size_t size)
{
SCM port;
ssize_t result;
port = SCM_PACK ((scm_t_bits) transport);
result = scm_c_read (port, data, size);
return ((ssize_t) result);
}
/* Write SIZE octets from DATA to TRANSPORT (a Scheme port). */
static ssize_t
push_to_port (gnutls_transport_ptr_t transport, const void *data, size_t size)
{
SCM port;
port = SCM_PACK ((scm_t_bits) transport);
scm_c_write (port, data, size);
/* All we can do is assume that all SIZE octets were written. */
return (size);
}
SCM_DEFINE (scm_gnutls_set_session_transport_port_x,
"set-session-transport-port!",
2, 0, 0,
(SCM session, SCM port),
"Use @var{port} as the input/output port for @var{session}.")
#define FUNC_NAME s_scm_gnutls_set_session_transport_port_x
{
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
SCM_VALIDATE_PORT (2, port);
/* Note: We do not attempt to optimize the case where PORT is a file port
(i.e., over a file descriptor), because of port buffering issues. Users
are expected to explicitly use `set-session-transport-fd!' and `fileno'
when they wish to do it. */
gnutls_transport_set_ptr (c_session,
(gnutls_transport_ptr_t) SCM_UNPACK (port));
gnutls_transport_set_push_function (c_session, push_to_port);
gnutls_transport_set_pull_function (c_session, pull_from_port);
SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD (c_session, 0);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Diffie-Hellman. */
typedef int (*pkcs_export_function_t) (void *, gnutls_x509_crt_fmt_t,
unsigned char *, size_t *);
/* Hint for the `scm_gc' functions. */
static const char pkcs_export_gc_hint[] = "gnutls-pkcs-export";
/* Export DH/RSA parameters PARAMS through EXPORT, using format FORMAT.
Return a `u8vector'. */
static inline SCM
pkcs_export_parameters (pkcs_export_function_t export,
void *params, gnutls_x509_crt_fmt_t format,
const char *func_name)
#define FUNC_NAME func_name
{
int err;
unsigned char *output;
size_t output_len, output_total_len = 4096;
output = (unsigned char *) scm_gc_malloc (output_total_len,
pkcs_export_gc_hint);
do
{
output_len = output_total_len;
err = export (params, format, output, &output_len);
if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
{
output = scm_gc_realloc (output, output_total_len,
output_total_len * 2, pkcs_export_gc_hint);
output_total_len *= 2;
}
}
while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
if (EXPECT_FALSE (err))
{
scm_gc_free (output, output_total_len, pkcs_export_gc_hint);
scm_gnutls_error (err, FUNC_NAME);
}
if (output_len != output_total_len)
/* Shrink the output buffer. */
output = scm_gc_realloc (output, output_total_len,
output_len, pkcs_export_gc_hint);
return (scm_take_u8vector (output, output_len));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_make_dh_parameters, "make-dh-parameters", 1, 0, 0,
(SCM bits), "Return new Diffie-Hellman parameters.")
#define FUNC_NAME s_scm_gnutls_make_dh_parameters
{
int err;
unsigned c_bits;
gnutls_dh_params_t c_dh_params;
c_bits = scm_to_uint (bits);
err = gnutls_dh_params_init (&c_dh_params);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
err = gnutls_dh_params_generate2 (c_dh_params, c_bits);
if (EXPECT_FALSE (err))
{
gnutls_dh_params_deinit (c_dh_params);
scm_gnutls_error (err, FUNC_NAME);
}
return (scm_from_gnutls_dh_parameters (c_dh_params));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_pkcs3_import_dh_parameters,
"pkcs3-import-dh-parameters",
2, 0, 0,
(SCM array, SCM format),
"Import Diffie-Hellman parameters in PKCS3 format (further "
"specified by @var{format}, an @code{x509-certificate-format} "
"value) from @var{array} (a homogeneous array) and return a "
"new @code{dh-params} object.")
#define FUNC_NAME s_scm_gnutls_pkcs3_import_dh_parameters
{
int err;
gnutls_x509_crt_fmt_t c_format;
gnutls_dh_params_t c_dh_params;
scm_t_array_handle c_handle;
const char *c_array;
size_t c_len;
gnutls_datum_t c_datum;
c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
c_array = scm_gnutls_get_array (array, &c_handle, &c_len, FUNC_NAME);
c_datum.data = (unsigned char *) c_array;
c_datum.size = c_len;
err = gnutls_dh_params_init (&c_dh_params);
if (EXPECT_FALSE (err))
{
scm_gnutls_release_array (&c_handle);
scm_gnutls_error (err, FUNC_NAME);
}
err = gnutls_dh_params_import_pkcs3 (c_dh_params, &c_datum, c_format);
scm_gnutls_release_array (&c_handle);
if (EXPECT_FALSE (err))
{
gnutls_dh_params_deinit (c_dh_params);
scm_gnutls_error (err, FUNC_NAME);
}
return (scm_from_gnutls_dh_parameters (c_dh_params));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_pkcs3_export_dh_parameters,
"pkcs3-export-dh-parameters",
2, 0, 0,
(SCM dh_params, SCM format),
"Export Diffie-Hellman parameters @var{dh_params} in PKCS3 "
"format according for @var{format} (an "
"@code{x509-certificate-format} value). Return a "
"@code{u8vector} containing the result.")
#define FUNC_NAME s_scm_gnutls_pkcs3_export_dh_parameters
{
SCM result;
gnutls_dh_params_t c_dh_params;
gnutls_x509_crt_fmt_t c_format;
c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 1, FUNC_NAME);
c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
result = pkcs_export_parameters ((pkcs_export_function_t)
gnutls_dh_params_export_pkcs3,
(void *) c_dh_params, c_format, FUNC_NAME);
return (result);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_session_dh_prime_bits_x,
"set-session-dh-prime-bits!", 2, 0, 0,
(SCM session, SCM bits),
"Use @var{bits} DH prime bits for @var{session}.")
#define FUNC_NAME s_scm_gnutls_set_session_dh_prime_bits_x
{
unsigned int c_bits;
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_bits = scm_to_uint (bits);
gnutls_dh_set_prime_bits (c_session, c_bits);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Anonymous credentials. */
SCM_DEFINE (scm_gnutls_make_anon_server_credentials,
"make-anonymous-server-credentials",
0, 0, 0, (void), "Return anonymous server credentials.")
#define FUNC_NAME s_scm_gnutls_make_anon_server_credentials
{
int err;
gnutls_anon_server_credentials_t c_cred;
err = gnutls_anon_allocate_server_credentials (&c_cred);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return (scm_from_gnutls_anonymous_server_credentials (c_cred));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_make_anon_client_credentials,
"make-anonymous-client-credentials",
0, 0, 0, (void), "Return anonymous client credentials.")
#define FUNC_NAME s_scm_gnutls_make_anon_client_credentials
{
int err;
gnutls_anon_client_credentials_t c_cred;
err = gnutls_anon_allocate_client_credentials (&c_cred);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return (scm_from_gnutls_anonymous_client_credentials (c_cred));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_anonymous_server_dh_parameters_x,
"set-anonymous-server-dh-parameters!", 2, 0, 0,
(SCM cred, SCM dh_params),
"Set the Diffie-Hellman parameters of anonymous server "
"credentials @var{cred}.")
#define FUNC_NAME s_scm_gnutls_set_anonymous_server_dh_parameters_x
{
gnutls_dh_params_t c_dh_params;
gnutls_anon_server_credentials_t c_cred;
c_cred = scm_to_gnutls_anonymous_server_credentials (cred, 1, FUNC_NAME);
c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 2, FUNC_NAME);
gnutls_anon_set_server_dh_params (c_cred, c_dh_params);
register_weak_reference (cred, dh_params);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Certificate credentials. */
typedef
int (*certificate_set_file_function_t) (gnutls_certificate_credentials_t,
const char *,
gnutls_x509_crt_fmt_t);
typedef
int (*certificate_set_data_function_t) (gnutls_certificate_credentials_t,
const gnutls_datum_t *,
gnutls_x509_crt_fmt_t);
/* Helper function to implement the `set-file!' functions. */
static unsigned int
set_certificate_file (certificate_set_file_function_t set_file,
SCM cred, SCM file, SCM format, const char *func_name)
#define FUNC_NAME func_name
{
int err;
char *c_file;
size_t c_file_len;
gnutls_certificate_credentials_t c_cred;
gnutls_x509_crt_fmt_t c_format;
c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, file);
c_format = scm_to_gnutls_x509_certificate_format (format, 3, FUNC_NAME);
c_file_len = scm_c_string_length (file);
c_file = FAST_ALLOC (c_file_len + 1);
(void) scm_to_locale_stringbuf (file, c_file, c_file_len + 1);
c_file[c_file_len] = '\0';
err = set_file (c_cred, c_file, c_format);
if (EXPECT_FALSE (err < 0))
scm_gnutls_error (err, FUNC_NAME);
/* Return the number of certificates processed. */
return ((unsigned int) err);
}
#undef FUNC_NAME
/* Helper function implementing the `set-data!' functions. */
static inline unsigned int
set_certificate_data (certificate_set_data_function_t set_data,
SCM cred, SCM data, SCM format, const char *func_name)
#define FUNC_NAME func_name
{
int err;
gnutls_certificate_credentials_t c_cred;
gnutls_x509_crt_fmt_t c_format;
gnutls_datum_t c_datum;
scm_t_array_handle c_handle;
const char *c_data;
size_t c_len;
c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
SCM_VALIDATE_ARRAY (2, data);
c_format = scm_to_gnutls_x509_certificate_format (format, 3, FUNC_NAME);
c_data = scm_gnutls_get_array (data, &c_handle, &c_len, FUNC_NAME);
c_datum.data = (unsigned char *) c_data;
c_datum.size = c_len;
err = set_data (c_cred, &c_datum, c_format);
scm_gnutls_release_array (&c_handle);
if (EXPECT_FALSE (err < 0))
scm_gnutls_error (err, FUNC_NAME);
/* Return the number of certificates processed. */
return ((unsigned int) err);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_make_certificate_credentials,
"make-certificate-credentials",
0, 0, 0,
(void),
"Return new certificate credentials (i.e., for use with "
"either X.509 or OpenPGP certificates.")
#define FUNC_NAME s_scm_gnutls_make_certificate_credentials
{
int err;
gnutls_certificate_credentials_t c_cred;
err = gnutls_certificate_allocate_credentials (&c_cred);
if (err)
scm_gnutls_error (err, FUNC_NAME);
return (scm_from_gnutls_certificate_credentials (c_cred));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_dh_params_x,
"set-certificate-credentials-dh-parameters!",
2, 0, 0,
(SCM cred, SCM dh_params),
"Use Diffie-Hellman parameters @var{dh_params} for "
"certificate credentials @var{cred}.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_dh_params_x
{
gnutls_dh_params_t c_dh_params;
gnutls_certificate_credentials_t c_cred;
c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 2, FUNC_NAME);
gnutls_certificate_set_dh_params (c_cred, c_dh_params);
register_weak_reference (cred, dh_params);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_key_files_x,
"set-certificate-credentials-x509-key-files!",
4, 0, 0,
(SCM cred, SCM cert_file, SCM key_file, SCM format),
"Use @var{file} as the password file for PSK server "
"credentials @var{cred}.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_key_files_x
{
int err;
gnutls_certificate_credentials_t c_cred;
gnutls_x509_crt_fmt_t c_format;
char *c_cert_file, *c_key_file;
size_t c_cert_file_len, c_key_file_len;
c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, cert_file);
SCM_VALIDATE_STRING (3, key_file);
c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
c_cert_file_len = scm_c_string_length (cert_file);
c_cert_file = FAST_ALLOC (c_cert_file_len + 1);
c_key_file_len = scm_c_string_length (key_file);
c_key_file = FAST_ALLOC (c_key_file_len + 1);
(void) scm_to_locale_stringbuf (cert_file, c_cert_file,
c_cert_file_len + 1);
c_cert_file[c_cert_file_len] = '\0';
(void) scm_to_locale_stringbuf (key_file, c_key_file, c_key_file_len + 1);
c_key_file[c_key_file_len] = '\0';
err = gnutls_certificate_set_x509_key_file (c_cred, c_cert_file, c_key_file,
c_format);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_trust_file_x,
"set-certificate-credentials-x509-trust-file!",
3, 0, 0,
(SCM cred, SCM file, SCM format),
"Use @var{file} as the X.509 trust file for certificate "
"credentials @var{cred}. On success, return the number of "
"certificates processed.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_trust_file_x
{
unsigned int count;
count = set_certificate_file (gnutls_certificate_set_x509_trust_file,
cred, file, format, FUNC_NAME);
return scm_from_uint (count);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_crl_file_x,
"set-certificate-credentials-x509-crl-file!",
3, 0, 0,
(SCM cred, SCM file, SCM format),
"Use @var{file} as the X.509 CRL (certificate revocation list) "
"file for certificate credentials @var{cred}. On success, "
"return the number of CRLs processed.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_crl_file_x
{
unsigned int count;
count = set_certificate_file (gnutls_certificate_set_x509_crl_file,
cred, file, format, FUNC_NAME);
return scm_from_uint (count);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_trust_data_x,
"set-certificate-credentials-x509-trust-data!",
3, 0, 0,
(SCM cred, SCM data, SCM format),
"Use @var{data} (a uniform array) as the X.509 trust "
"database for @var{cred}. On success, return the number "
"of certificates processed.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_trust_data_x
{
unsigned int count;
count = set_certificate_data (gnutls_certificate_set_x509_trust_mem,
cred, data, format, FUNC_NAME);
return scm_from_uint (count);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_crl_data_x,
"set-certificate-credentials-x509-crl-data!",
3, 0, 0,
(SCM cred, SCM data, SCM format),
"Use @var{data} (a uniform array) as the X.509 CRL "
"(certificate revocation list) database for @var{cred}. "
"On success, return the number of CRLs processed.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_crl_data_x
{
unsigned int count;
count = set_certificate_data (gnutls_certificate_set_x509_crl_mem,
cred, data, format, FUNC_NAME);
return scm_from_uint (count);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_key_data_x,
"set-certificate-credentials-x509-key-data!",
4, 0, 0,
(SCM cred, SCM cert, SCM key, SCM format),
"Use X.509 certificate @var{cert} and private key @var{key}, "
"both uniform arrays containing the X.509 certificate and key "
"in format @var{format}, for certificate credentials "
"@var{cred}.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_key_data_x
{
int err;
gnutls_x509_crt_fmt_t c_format;
gnutls_certificate_credentials_t c_cred;
gnutls_datum_t c_cert_d, c_key_d;
scm_t_array_handle c_cert_handle, c_key_handle;
const char *c_cert, *c_key;
size_t c_cert_len, c_key_len;
c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
c_format = scm_to_gnutls_x509_certificate_format (format, 4, FUNC_NAME);
SCM_VALIDATE_ARRAY (2, cert);
SCM_VALIDATE_ARRAY (3, key);
/* FIXME: If the second call fails, an exception is raised and
C_CERT_HANDLE is not released. */
c_cert = scm_gnutls_get_array (cert, &c_cert_handle, &c_cert_len,
FUNC_NAME);
c_key = scm_gnutls_get_array (key, &c_key_handle, &c_key_len, FUNC_NAME);
c_cert_d.data = (unsigned char *) c_cert;
c_cert_d.size = c_cert_len;
c_key_d.data = (unsigned char *) c_key;
c_key_d.size = c_key_len;
err = gnutls_certificate_set_x509_key_mem (c_cred, &c_cert_d, &c_key_d,
c_format);
scm_gnutls_release_array (&c_cert_handle);
scm_gnutls_release_array (&c_key_handle);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_keys_x,
"set-certificate-credentials-x509-keys!",
3, 0, 0,
(SCM cred, SCM certs, SCM privkey),
"Have certificate credentials @var{cred} use the X.509 "
"certificates listed in @var{certs} and X.509 private key "
"@var{privkey}.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_keys_x
{
int err;
gnutls_x509_crt_t *c_certs;
gnutls_x509_privkey_t c_key;
gnutls_certificate_credentials_t c_cred;
long int c_cert_count, i;
c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
SCM_VALIDATE_LIST_COPYLEN (2, certs, c_cert_count);
c_key = scm_to_gnutls_x509_private_key (privkey, 3, FUNC_NAME);
c_certs = FAST_ALLOC (c_cert_count * sizeof (*c_certs));
for (i = 0; scm_is_pair (certs); certs = SCM_CDR (certs), i++)
{
c_certs[i] = scm_to_gnutls_x509_certificate (SCM_CAR (certs),
2, FUNC_NAME);
}
err = gnutls_certificate_set_x509_key (c_cred, c_certs, c_cert_count,
c_key);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
else
{
register_weak_reference (cred, privkey);
register_weak_reference (cred, scm_list_copy (certs));
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_verify_limits_x,
"set-certificate-credentials-verify-limits!",
3, 0, 0,
(SCM cred, SCM max_bits, SCM max_depth),
"Set the verification limits of @code{peer-certificate-status} "
"for certificate credentials @var{cred} to @var{max_bits} "
"bits for an acceptable certificate and @var{max_depth} "
"as the maximum depth of a certificate chain.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_verify_limits_x
{
gnutls_certificate_credentials_t c_cred;
unsigned int c_max_bits, c_max_depth;
c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
c_max_bits = scm_to_uint (max_bits);
c_max_depth = scm_to_uint (max_depth);
gnutls_certificate_set_verify_limits (c_cred, c_max_bits, c_max_depth);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_certificate_credentials_verify_flags_x,
"set-certificate-credentials-verify-flags!",
1, 0, 1,
(SCM cred, SCM flags),
"Set the certificate verification flags to @var{flags}, a "
"series of @code{certificate-verify} values.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_verify_flags_x
{
unsigned int c_flags, c_pos;
gnutls_certificate_credentials_t c_cred;
c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
for (c_flags = 0, c_pos = 2;
!scm_is_null (flags); flags = SCM_CDR (flags), c_pos++)
{
c_flags |= (unsigned int)
scm_to_gnutls_certificate_verify (SCM_CAR (flags), c_pos, FUNC_NAME);
}
gnutls_certificate_set_verify_flags (c_cred, c_flags);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_peer_certificate_status, "peer-certificate-status",
1, 0, 0,
(SCM session),
"Verify the peer certificate for @var{session} and return "
"a list of @code{certificate-status} values (such as "
"@code{certificate-status/revoked}), or the empty list if "
"the certificate is valid.")
#define FUNC_NAME s_scm_gnutls_peer_certificate_status
{
int err;
unsigned int c_status;
gnutls_session_t c_session;
SCM result = SCM_EOL;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
err = gnutls_certificate_verify_peers2 (c_session, &c_status);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
#define MATCH_STATUS(_value) \
if (c_status & (_value)) \
{ \
result = scm_cons (scm_from_gnutls_certificate_status (_value), \
result); \
c_status &= ~(_value); \
}
MATCH_STATUS (GNUTLS_CERT_INVALID);
MATCH_STATUS (GNUTLS_CERT_REVOKED);
MATCH_STATUS (GNUTLS_CERT_SIGNER_NOT_FOUND);
MATCH_STATUS (GNUTLS_CERT_SIGNER_NOT_CA);
MATCH_STATUS (GNUTLS_CERT_INSECURE_ALGORITHM);
MATCH_STATUS (GNUTLS_CERT_NOT_ACTIVATED);
MATCH_STATUS (GNUTLS_CERT_EXPIRED);
MATCH_STATUS (GNUTLS_CERT_SIGNATURE_FAILURE);
MATCH_STATUS (GNUTLS_CERT_REVOCATION_DATA_SUPERSEDED);
MATCH_STATUS (GNUTLS_CERT_UNEXPECTED_OWNER);
MATCH_STATUS (GNUTLS_CERT_REVOCATION_DATA_ISSUED_IN_FUTURE);
MATCH_STATUS (GNUTLS_CERT_SIGNER_CONSTRAINTS_FAILURE);
MATCH_STATUS (GNUTLS_CERT_MISMATCH);
MATCH_STATUS (GNUTLS_CERT_PURPOSE_MISMATCH);
MATCH_STATUS (GNUTLS_CERT_MISSING_OCSP_STATUS);
MATCH_STATUS (GNUTLS_CERT_INVALID_OCSP_STATUS);
MATCH_STATUS (GNUTLS_CERT_UNKNOWN_CRIT_EXTENSIONS);
if (EXPECT_FALSE (c_status != 0))
/* XXX: We failed to interpret one of the status flags. */
scm_gnutls_error (GNUTLS_E_UNIMPLEMENTED_FEATURE, FUNC_NAME);
#undef MATCH_STATUS
return (result);
}
#undef FUNC_NAME
/* SRP credentials. */
#ifdef ENABLE_SRP
SCM_DEFINE (scm_gnutls_make_srp_server_credentials,
"make-srp-server-credentials",
0, 0, 0, (void), "Return new SRP server credentials.")
#define FUNC_NAME s_scm_gnutls_make_srp_server_credentials
{
int err;
gnutls_srp_server_credentials_t c_cred;
err = gnutls_srp_allocate_server_credentials (&c_cred);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return (scm_from_gnutls_srp_server_credentials (c_cred));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_srp_server_credentials_files_x,
"set-srp-server-credentials-files!",
3, 0, 0,
(SCM cred, SCM password_file, SCM password_conf_file),
"Set the credentials files for @var{cred}, an SRP server "
"credentials object.")
#define FUNC_NAME s_scm_gnutls_set_srp_server_credentials_files_x
{
int err;
gnutls_srp_server_credentials_t c_cred;
char *c_password_file, *c_password_conf_file;
size_t c_password_file_len, c_password_conf_file_len;
c_cred = scm_to_gnutls_srp_server_credentials (cred, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, password_file);
SCM_VALIDATE_STRING (3, password_conf_file);
c_password_file_len = scm_c_string_length (password_file);
c_password_conf_file_len = scm_c_string_length (password_conf_file);
c_password_file = FAST_ALLOC (c_password_file_len + 1);
c_password_conf_file = FAST_ALLOC (c_password_conf_file_len + 1);
(void) scm_to_locale_stringbuf (password_file, c_password_file,
c_password_file_len + 1);
c_password_file[c_password_file_len] = '\0';
(void) scm_to_locale_stringbuf (password_conf_file, c_password_conf_file,
c_password_conf_file_len + 1);
c_password_conf_file[c_password_conf_file_len] = '\0';
err = gnutls_srp_set_server_credentials_file (c_cred, c_password_file,
c_password_conf_file);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_make_srp_client_credentials,
"make-srp-client-credentials",
0, 0, 0, (void), "Return new SRP client credentials.")
#define FUNC_NAME s_scm_gnutls_make_srp_client_credentials
{
int err;
gnutls_srp_client_credentials_t c_cred;
err = gnutls_srp_allocate_client_credentials (&c_cred);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return (scm_from_gnutls_srp_client_credentials (c_cred));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_srp_client_credentials_x,
"set-srp-client-credentials!",
3, 0, 0,
(SCM cred, SCM username, SCM password),
"Use @var{username} and @var{password} as the credentials "
"for @var{cred}, a client-side SRP credentials object.")
#define FUNC_NAME s_scm_gnutls_make_srp_client_credentials
{
int err;
gnutls_srp_client_credentials_t c_cred;
char *c_username, *c_password;
size_t c_username_len, c_password_len;
c_cred = scm_to_gnutls_srp_client_credentials (cred, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, username);
SCM_VALIDATE_STRING (3, password);
c_username_len = scm_c_string_length (username);
c_password_len = scm_c_string_length (password);
c_username = FAST_ALLOC (c_username_len + 1);
c_password = FAST_ALLOC (c_password_len + 1);
(void) scm_to_locale_stringbuf (username, c_username, c_username_len + 1);
c_username[c_username_len] = '\0';
(void) scm_to_locale_stringbuf (password, c_password, c_password_len + 1);
c_password[c_password_len] = '\0';
err = gnutls_srp_set_client_credentials (c_cred, c_username, c_password);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_server_session_srp_username,
"server-session-srp-username",
1, 0, 0,
(SCM session),
"Return the SRP username used in @var{session} (a server-side "
"session).")
#define FUNC_NAME s_scm_gnutls_server_session_srp_username
{
SCM result;
const char *c_username;
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_username = gnutls_srp_server_get_username (c_session);
if (EXPECT_FALSE (c_username == NULL))
result = SCM_BOOL_F;
else
result = scm_from_locale_string (c_username);
return (result);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_srp_base64_encode, "srp-base64-encode",
1, 0, 0,
(SCM str),
"Encode @var{str} using SRP's base64 algorithm. Return "
"the encoded string.")
#define FUNC_NAME s_scm_gnutls_srp_base64_encode
{
int err;
char *c_str, *c_result;
size_t c_str_len, c_result_len, c_result_actual_len;
gnutls_datum_t c_str_d;
SCM_VALIDATE_STRING (1, str);
c_str_len = scm_c_string_length (str);
c_str = FAST_ALLOC (c_str_len + 1);
(void) scm_to_locale_stringbuf (str, c_str, c_str_len + 1);
c_str[c_str_len] = '\0';
/* Typical size ratio is 4/3 so 3/2 is an upper bound. */
c_result_len = (c_str_len * 3) / 2;
c_result = (char *) scm_malloc (c_result_len);
if (EXPECT_FALSE (c_result == NULL))
scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
c_str_d.data = (unsigned char *) c_str;
c_str_d.size = c_str_len;
do
{
c_result_actual_len = c_result_len;
err = gnutls_srp_base64_encode (&c_str_d, c_result,
&c_result_actual_len);
if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
{
char *c_new_buf;
c_new_buf = scm_realloc (c_result, c_result_len * 2);
if (EXPECT_FALSE (c_new_buf == NULL))
{
free (c_result);
scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
}
else
c_result = c_new_buf, c_result_len *= 2;
}
}
while (EXPECT_FALSE (err == GNUTLS_E_SHORT_MEMORY_BUFFER));
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
if (c_result_actual_len + 1 < c_result_len)
/* Shrink the buffer. */
c_result = scm_realloc (c_result, c_result_actual_len + 1);
c_result[c_result_actual_len] = '\0';
return (scm_take_locale_string (c_result));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_srp_base64_decode, "srp-base64-decode",
1, 0, 0,
(SCM str),
"Decode @var{str}, an SRP-base64 encoded string, and return "
"the decoded string.")
#define FUNC_NAME s_scm_gnutls_srp_base64_decode
{
int err;
char *c_str, *c_result;
size_t c_str_len, c_result_len, c_result_actual_len;
gnutls_datum_t c_str_d;
SCM_VALIDATE_STRING (1, str);
c_str_len = scm_c_string_length (str);
c_str = FAST_ALLOC (c_str_len + 1);
(void) scm_to_locale_stringbuf (str, c_str, c_str_len + 1);
c_str[c_str_len] = '\0';
/* We assume that the decoded string is smaller than the encoded
string. */
c_result_len = c_str_len;
c_result = FAST_ALLOC (c_result_len + 1);
c_str_d.data = (unsigned char *) c_str;
c_str_d.size = c_str_len;
c_result_actual_len = c_result_len;
err = gnutls_srp_base64_decode (&c_str_d, c_result, &c_result_actual_len);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
c_result[c_result_actual_len] = '\0';
return (scm_from_locale_string (c_result));
}
#undef FUNC_NAME
#endif /* ENABLE_SRP */
/* PSK credentials. */
SCM_DEFINE (scm_gnutls_make_psk_server_credentials,
"make-psk-server-credentials",
0, 0, 0, (void), "Return new PSK server credentials.")
#define FUNC_NAME s_scm_gnutls_make_psk_server_credentials
{
int err;
gnutls_psk_server_credentials_t c_cred;
err = gnutls_psk_allocate_server_credentials (&c_cred);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return (scm_from_gnutls_psk_server_credentials (c_cred));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_psk_server_credentials_file_x,
"set-psk-server-credentials-file!",
2, 0, 0,
(SCM cred, SCM file),
"Use @var{file} as the password file for PSK server "
"credentials @var{cred}.")
#define FUNC_NAME s_scm_gnutls_set_psk_server_credentials_file_x
{
int err;
gnutls_psk_server_credentials_t c_cred;
char *c_file;
size_t c_file_len;
c_cred = scm_to_gnutls_psk_server_credentials (cred, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, file);
c_file_len = scm_c_string_length (file);
c_file = FAST_ALLOC (c_file_len + 1);
(void) scm_to_locale_stringbuf (file, c_file, c_file_len + 1);
c_file[c_file_len] = '\0';
err = gnutls_psk_set_server_credentials_file (c_cred, c_file);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_make_psk_client_credentials,
"make-psk-client-credentials",
0, 0, 0, (void), "Return a new PSK client credentials object.")
#define FUNC_NAME s_scm_gnutls_make_psk_client_credentials
{
int err;
gnutls_psk_client_credentials_t c_cred;
err = gnutls_psk_allocate_client_credentials (&c_cred);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return (scm_from_gnutls_psk_client_credentials (c_cred));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_psk_client_credentials_x,
"set-psk-client-credentials!",
4, 0, 0,
(SCM cred, SCM username, SCM key, SCM key_format),
"Set the client credentials for @var{cred}, a PSK client "
"credentials object.")
#define FUNC_NAME s_scm_gnutls_set_psk_client_credentials_x
{
int err;
gnutls_psk_client_credentials_t c_cred;
gnutls_psk_key_flags c_key_format;
scm_t_array_handle c_handle;
const char *c_key;
char *c_username;
size_t c_username_len, c_key_len;
gnutls_datum_t c_datum;
c_cred = scm_to_gnutls_psk_client_credentials (cred, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, username);
SCM_VALIDATE_ARRAY (3, key);
c_key_format = scm_to_gnutls_psk_key_format (key_format, 4, FUNC_NAME);
c_username_len = scm_c_string_length (username);
c_username = FAST_ALLOC (c_username_len + 1);
(void) scm_to_locale_stringbuf (username, c_username, c_username_len + 1);
c_username[c_username_len] = '\0';
c_key = scm_gnutls_get_array (key, &c_handle, &c_key_len, FUNC_NAME);
c_datum.data = (unsigned char *) c_key;
c_datum.size = c_key_len;
err = gnutls_psk_set_client_credentials (c_cred, c_username,
&c_datum, c_key_format);
scm_gnutls_release_array (&c_handle);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_server_session_psk_username,
"server-session-psk-username",
1, 0, 0,
(SCM session),
"Return the username associated with PSK server session "
"@var{session}.")
#define FUNC_NAME s_scm_gnutls_server_session_psk_username
{
SCM result;
const char *c_username;
gnutls_session_t c_session;
c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
c_username = gnutls_srp_server_get_username (c_session);
if (EXPECT_FALSE (c_username == NULL))
result = SCM_BOOL_F;
else
result = scm_from_locale_string (c_username);
return (result);
}
#undef FUNC_NAME
/* X.509 certificates. */
SCM_DEFINE (scm_gnutls_import_x509_certificate, "import-x509-certificate",
2, 0, 0,
(SCM data, SCM format),
"Return a new X.509 certificate object resulting from the "
"import of @var{data} (a uniform array) according to "
"@var{format}.")
#define FUNC_NAME s_scm_gnutls_import_x509_certificate
{
int err;
gnutls_x509_crt_t c_cert;
gnutls_x509_crt_fmt_t c_format;
gnutls_datum_t c_data_d;
scm_t_array_handle c_data_handle;
const char *c_data;
size_t c_data_len;
SCM_VALIDATE_ARRAY (1, data);
c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
FUNC_NAME);
c_data_d.data = (unsigned char *) c_data;
c_data_d.size = c_data_len;
err = gnutls_x509_crt_init (&c_cert);
if (EXPECT_FALSE (err))
{
scm_gnutls_release_array (&c_data_handle);
scm_gnutls_error (err, FUNC_NAME);
}
err = gnutls_x509_crt_import (c_cert, &c_data_d, c_format);
scm_gnutls_release_array (&c_data_handle);
if (EXPECT_FALSE (err))
{
gnutls_x509_crt_deinit (c_cert);
scm_gnutls_error (err, FUNC_NAME);
}
return (scm_from_gnutls_x509_certificate (c_cert));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_import_x509_private_key, "import-x509-private-key",
2, 0, 0,
(SCM data, SCM format),
"Return a new X.509 private key object resulting from the "
"import of @var{data} (a uniform array) according to "
"@var{format}.")
#define FUNC_NAME s_scm_gnutls_import_x509_private_key
{
int err;
gnutls_x509_privkey_t c_key;
gnutls_x509_crt_fmt_t c_format;
gnutls_datum_t c_data_d;
scm_t_array_handle c_data_handle;
const char *c_data;
size_t c_data_len;
SCM_VALIDATE_ARRAY (1, data);
c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
FUNC_NAME);
c_data_d.data = (unsigned char *) c_data;
c_data_d.size = c_data_len;
err = gnutls_x509_privkey_init (&c_key);
if (EXPECT_FALSE (err))
{
scm_gnutls_release_array (&c_data_handle);
scm_gnutls_error (err, FUNC_NAME);
}
err = gnutls_x509_privkey_import (c_key, &c_data_d, c_format);
scm_gnutls_release_array (&c_data_handle);
if (EXPECT_FALSE (err))
{
gnutls_x509_privkey_deinit (c_key);
scm_gnutls_error (err, FUNC_NAME);
}
return (scm_from_gnutls_x509_private_key (c_key));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_pkcs8_import_x509_private_key,
"pkcs8-import-x509-private-key",
2, 2, 0,
(SCM data, SCM format, SCM pass, SCM encrypted),
"Return a new X.509 private key object resulting from the "
"import of @var{data} (a uniform array) according to "
"@var{format}. Optionally, if @var{pass} is not @code{#f}, "
"it should be a string denoting a passphrase. "
"@var{encrypted} tells whether the private key is encrypted "
"(@code{#t} by default).")
#define FUNC_NAME s_scm_gnutls_pkcs8_import_x509_private_key
{
int err;
gnutls_x509_privkey_t c_key;
gnutls_x509_crt_fmt_t c_format;
unsigned int c_flags;
gnutls_datum_t c_data_d;
scm_t_array_handle c_data_handle;
const char *c_data;
char *c_pass;
size_t c_data_len, c_pass_len;
SCM_VALIDATE_ARRAY (1, data);
c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
if ((pass == SCM_UNDEFINED) || (scm_is_false (pass)))
c_pass = NULL;
else
{
c_pass_len = scm_c_string_length (pass);
c_pass = FAST_ALLOC (c_pass_len + 1);
(void) scm_to_locale_stringbuf (pass, c_pass, c_pass_len + 1);
c_pass[c_pass_len] = '\0';
}
if (encrypted == SCM_UNDEFINED)
c_flags = 0;
else
{
SCM_VALIDATE_BOOL (4, encrypted);
if (scm_is_true (encrypted))
c_flags = 0;
else
c_flags = GNUTLS_PKCS8_PLAIN;
}
c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
FUNC_NAME);
c_data_d.data = (unsigned char *) c_data;
c_data_d.size = c_data_len;
err = gnutls_x509_privkey_init (&c_key);
if (EXPECT_FALSE (err))
{
scm_gnutls_release_array (&c_data_handle);
scm_gnutls_error (err, FUNC_NAME);
}
err = gnutls_x509_privkey_import_pkcs8 (c_key, &c_data_d, c_format, c_pass,
c_flags);
scm_gnutls_release_array (&c_data_handle);
if (EXPECT_FALSE (err))
{
gnutls_x509_privkey_deinit (c_key);
scm_gnutls_error (err, FUNC_NAME);
}
return (scm_from_gnutls_x509_private_key (c_key));
}
#undef FUNC_NAME
/* Provide the body of a `get_dn' function. */
#define X509_CERTIFICATE_DN_FUNCTION_BODY(get_the_dn) \
int err; \
gnutls_x509_crt_t c_cert; \
char *c_dn; \
size_t c_dn_len; \
\
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME); \
\
/* Get the DN size. */ \
(void) get_the_dn (c_cert, NULL, &c_dn_len); \
\
/* Get the DN itself. */ \
c_dn = FAST_ALLOC (c_dn_len); \
err = get_the_dn (c_cert, c_dn, &c_dn_len); \
\
if (EXPECT_FALSE (err)) \
scm_gnutls_error (err, FUNC_NAME); \
\
/* XXX: The returned string is actually ASCII or UTF-8. */ \
return (scm_from_locale_string (c_dn));
SCM_DEFINE (scm_gnutls_x509_certificate_dn, "x509-certificate-dn",
1, 0, 0,
(SCM cert),
"Return the distinguished name (DN) of X.509 certificate "
"@var{cert}. The form of the DN is as described in @uref{"
"https://tools.ietf.org/html/rfc2253, RFC 2253}.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_dn
{
X509_CERTIFICATE_DN_FUNCTION_BODY (gnutls_x509_crt_get_dn);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_issuer_dn,
"x509-certificate-issuer-dn",
1, 0, 0,
(SCM cert),
"Return the distinguished name (DN) of X.509 certificate "
"@var{cert}.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_issuer_dn
{
X509_CERTIFICATE_DN_FUNCTION_BODY (gnutls_x509_crt_get_issuer_dn);
}
#undef FUNC_NAME
#undef X509_CERTIFICATE_DN_FUNCTION_BODY
/* Provide the body of a `get_dn_oid' function. */
#define X509_CERTIFICATE_DN_OID_FUNCTION_BODY(get_dn_oid) \
int err; \
gnutls_x509_crt_t c_cert; \
unsigned int c_index; \
char *c_oid; \
size_t c_oid_actual_len, c_oid_len; \
SCM result; \
\
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME); \
c_index = scm_to_uint (index); \
\
c_oid_len = 256; \
c_oid = scm_malloc (c_oid_len); \
\
do \
{ \
c_oid_actual_len = c_oid_len; \
err = get_dn_oid (c_cert, c_index, c_oid, &c_oid_actual_len); \
if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) \
{ \
c_oid = scm_realloc (c_oid, c_oid_len * 2); \
c_oid_len *= 2; \
} \
} \
while (err == GNUTLS_E_SHORT_MEMORY_BUFFER); \
\
if (EXPECT_FALSE (err)) \
{ \
free (c_oid); \
\
if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE) \
result = SCM_BOOL_F; \
else \
scm_gnutls_error (err, FUNC_NAME); \
} \
else \
{ \
if (c_oid_actual_len < c_oid_len) \
c_oid = scm_realloc (c_oid, c_oid_actual_len); \
\
result = scm_take_locale_stringn (c_oid, \
c_oid_actual_len); \
} \
\
return result;
SCM_DEFINE (scm_gnutls_x509_certificate_dn_oid, "x509-certificate-dn-oid",
2, 0, 0,
(SCM cert, SCM index),
"Return OID (a string) at @var{index} from @var{cert}. "
"Return @code{#f} if no OID is available at @var{index}.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_dn_oid
{
X509_CERTIFICATE_DN_OID_FUNCTION_BODY (gnutls_x509_crt_get_dn_oid);
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_issuer_dn_oid,
"x509-certificate-issuer-dn-oid",
2, 0, 0,
(SCM cert, SCM index),
"Return the OID (a string) at @var{index} from @var{cert}'s "
"issuer DN. Return @code{#f} if no OID is available at "
"@var{index}.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_issuer_dn_oid
{
X509_CERTIFICATE_DN_OID_FUNCTION_BODY (gnutls_x509_crt_get_issuer_dn_oid);
}
#undef FUNC_NAME
#undef X509_CERTIFICATE_DN_OID_FUNCTION_BODY
SCM_DEFINE (scm_gnutls_x509_certificate_matches_hostname_p,
"x509-certificate-matches-hostname?",
2, 0, 0,
(SCM cert, SCM hostname),
"Return true if @var{cert} matches @var{hostname}, a string "
"denoting a DNS host name. This is the basic implementation "
"of @uref{https://tools.ietf.org/html/rfc2818, RFC 2818} (aka. "
"HTTPS).")
#define FUNC_NAME s_scm_gnutls_x509_certificate_matches_hostname_p
{
SCM result;
gnutls_x509_crt_t c_cert;
char *c_hostname;
size_t c_hostname_len;
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, hostname);
c_hostname_len = scm_c_string_length (hostname);
c_hostname = FAST_ALLOC (c_hostname_len + 1);
(void) scm_to_locale_stringbuf (hostname, c_hostname, c_hostname_len + 1);
c_hostname[c_hostname_len] = '\0';
if (gnutls_x509_crt_check_hostname (c_cert, c_hostname))
result = SCM_BOOL_T;
else
result = SCM_BOOL_F;
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_signature_algorithm,
"x509-certificate-signature-algorithm",
1, 0, 0,
(SCM cert),
"Return the signature algorithm used by @var{cert} (i.e., "
"one of the @code{sign-algorithm/} values).")
#define FUNC_NAME s_scm_gnutls_x509_certificate_signature_algorithm
{
int c_result;
gnutls_x509_crt_t c_cert;
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
c_result = gnutls_x509_crt_get_signature_algorithm (c_cert);
if (EXPECT_FALSE (c_result < 0))
scm_gnutls_error (c_result, FUNC_NAME);
return (scm_from_gnutls_sign_algorithm (c_result));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_public_key_algorithm,
"x509-certificate-public-key-algorithm",
1, 0, 0,
(SCM cert),
"Return two values: the public key algorithm (i.e., "
"one of the @code{pk-algorithm/} values) of @var{cert} "
"and the number of bits used.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_public_key_algorithm
{
gnutls_x509_crt_t c_cert;
gnutls_pk_algorithm_t c_pk;
unsigned int c_bits;
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
c_pk = gnutls_x509_crt_get_pk_algorithm (c_cert, &c_bits);
return (scm_values (scm_list_2 (scm_from_gnutls_pk_algorithm (c_pk),
scm_from_uint (c_bits))));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_key_usage,
"x509-certificate-key-usage",
1, 0, 0,
(SCM cert),
"Return the key usage of @var{cert} (i.e., a list of "
"@code{key-usage/} values), or the empty list if @var{cert} "
"does not contain such information.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_key_usage
{
int err;
SCM usage;
gnutls_x509_crt_t c_cert;
unsigned int c_usage, c_critical;
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
err = gnutls_x509_crt_get_key_usage (c_cert, &c_usage, &c_critical);
if (EXPECT_FALSE (err))
{
if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE)
usage = SCM_EOL;
else
scm_gnutls_error (err, FUNC_NAME);
}
else
usage = scm_from_gnutls_key_usage_flags (c_usage);
return usage;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_version, "x509-certificate-version",
1, 0, 0, (SCM cert), "Return the version of @var{cert}.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_version
{
int c_result;
gnutls_x509_crt_t c_cert;
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
c_result = gnutls_x509_crt_get_version (c_cert);
if (EXPECT_FALSE (c_result < 0))
scm_gnutls_error (c_result, FUNC_NAME);
return (scm_from_int (c_result));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_key_id, "x509-certificate-key-id",
1, 0, 0,
(SCM cert),
"Return a statistically unique ID (a u8vector) for @var{cert} "
"that depends on its public key parameters. This is normally "
"a 20-byte SHA-1 hash.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_key_id
{
int err;
SCM result;
scm_t_array_handle c_id_handle;
gnutls_x509_crt_t c_cert;
scm_t_uint8 *c_id;
size_t c_id_len = 20;
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
result = scm_make_u8vector (scm_from_uint (c_id_len), SCM_INUM0);
scm_array_get_handle (result, &c_id_handle);
c_id = scm_array_handle_u8_writable_elements (&c_id_handle);
err = gnutls_x509_crt_get_key_id (c_cert, 0, c_id, &c_id_len);
scm_array_handle_release (&c_id_handle);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_authority_key_id,
"x509-certificate-authority-key-id",
1, 0, 0,
(SCM cert),
"Return the key ID (a u8vector) of the X.509 certificate "
"authority of @var{cert}.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_authority_key_id
{
int err;
SCM result;
scm_t_array_handle c_id_handle;
gnutls_x509_crt_t c_cert;
scm_t_uint8 *c_id;
size_t c_id_len = 20;
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
result = scm_make_u8vector (scm_from_uint (c_id_len), SCM_INUM0);
scm_array_get_handle (result, &c_id_handle);
c_id = scm_array_handle_u8_writable_elements (&c_id_handle);
err = gnutls_x509_crt_get_authority_key_id (c_cert, c_id, &c_id_len, NULL);
scm_array_handle_release (&c_id_handle);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_subject_key_id,
"x509-certificate-subject-key-id",
1, 0, 0,
(SCM cert),
"Return the subject key ID (a u8vector) for @var{cert}.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_subject_key_id
{
int err;
SCM result;
scm_t_array_handle c_id_handle;
gnutls_x509_crt_t c_cert;
scm_t_uint8 *c_id;
size_t c_id_len = 20;
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
result = scm_make_u8vector (scm_from_uint (c_id_len), SCM_INUM0);
scm_array_get_handle (result, &c_id_handle);
c_id = scm_array_handle_u8_writable_elements (&c_id_handle);
err = gnutls_x509_crt_get_subject_key_id (c_cert, c_id, &c_id_len, NULL);
scm_array_handle_release (&c_id_handle);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_x509_certificate_subject_alternative_name,
"x509-certificate-subject-alternative-name",
2, 0, 0,
(SCM cert, SCM index),
"Return two values: the alternative name type for @var{cert} "
"(i.e., one of the @code{x509-subject-alternative-name/} values) "
"and the actual subject alternative name (a string) at "
"@var{index}. Both values are @code{#f} if no alternative name "
"is available at @var{index}.")
#define FUNC_NAME s_scm_gnutls_x509_certificate_subject_alternative_name
{
int err;
SCM result;
gnutls_x509_crt_t c_cert;
unsigned int c_index;
char *c_name;
size_t c_name_len = 512, c_name_actual_len;
c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
c_index = scm_to_uint (index);
c_name = scm_malloc (c_name_len);
do
{
c_name_actual_len = c_name_len;
err = gnutls_x509_crt_get_subject_alt_name (c_cert, c_index,
c_name, &c_name_actual_len,
NULL);
if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
{
c_name = scm_realloc (c_name, c_name_len * 2);
c_name_len *= 2;
}
}
while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
if (EXPECT_FALSE (err < 0))
{
free (c_name);
if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE)
result = scm_values (scm_list_2 (SCM_BOOL_F, SCM_BOOL_F));
else
scm_gnutls_error (err, FUNC_NAME);
}
else
{
if (c_name_actual_len < c_name_len)
c_name = scm_realloc (c_name, c_name_actual_len);
result =
scm_values (scm_list_2
(scm_from_gnutls_x509_subject_alternative_name (err),
scm_take_locale_string (c_name)));
}
return result;
}
#undef FUNC_NAME
/* OpenPGP keys. */
/* Maximum size we support for the name of OpenPGP keys. */
#define GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH 2048
SCM_DEFINE (scm_gnutls_import_openpgp_certificate,
"%import-openpgp-certificate", 2, 0, 0, (SCM data, SCM format),
"Return a new OpenPGP certificate object resulting from the "
"import of @var{data} (a uniform array) according to "
"@var{format}.")
#define FUNC_NAME s_scm_gnutls_import_openpgp_certificate
{
int err;
gnutls_openpgp_crt_t c_key;
gnutls_openpgp_crt_fmt_t c_format;
gnutls_datum_t c_data_d;
scm_t_array_handle c_data_handle;
const char *c_data;
size_t c_data_len;
SCM_VALIDATE_ARRAY (1, data);
c_format = scm_to_gnutls_openpgp_certificate_format (format, 2, FUNC_NAME);
c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
FUNC_NAME);
c_data_d.data = (unsigned char *) c_data;
c_data_d.size = c_data_len;
err = gnutls_openpgp_crt_init (&c_key);
if (EXPECT_FALSE (err))
{
scm_gnutls_release_array (&c_data_handle);
scm_gnutls_error (err, FUNC_NAME);
}
err = gnutls_openpgp_crt_import (c_key, &c_data_d, c_format);
scm_gnutls_release_array (&c_data_handle);
if (EXPECT_FALSE (err))
{
gnutls_openpgp_crt_deinit (c_key);
scm_gnutls_error (err, FUNC_NAME);
}
return (scm_from_gnutls_openpgp_certificate (c_key));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_import_openpgp_private_key,
"%import-openpgp-private-key", 2, 1, 0, (SCM data, SCM format,
SCM pass),
"Return a new OpenPGP private key object resulting from the "
"import of @var{data} (a uniform array) according to "
"@var{format}. Optionally, a passphrase may be provided.")
#define FUNC_NAME s_scm_gnutls_import_openpgp_private_key
{
int err;
gnutls_openpgp_privkey_t c_key;
gnutls_openpgp_crt_fmt_t c_format;
gnutls_datum_t c_data_d;
scm_t_array_handle c_data_handle;
const char *c_data;
char *c_pass;
size_t c_data_len, c_pass_len;
SCM_VALIDATE_ARRAY (1, data);
c_format = scm_to_gnutls_openpgp_certificate_format (format, 2, FUNC_NAME);
if ((pass == SCM_UNDEFINED) || (scm_is_false (pass)))
c_pass = NULL;
else
{
c_pass_len = scm_c_string_length (pass);
c_pass = FAST_ALLOC (c_pass_len + 1);
(void) scm_to_locale_stringbuf (pass, c_pass, c_pass_len + 1);
c_pass[c_pass_len] = '\0';
}
c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
FUNC_NAME);
c_data_d.data = (unsigned char *) c_data;
c_data_d.size = c_data_len;
err = gnutls_openpgp_privkey_init (&c_key);
if (EXPECT_FALSE (err))
{
scm_gnutls_release_array (&c_data_handle);
scm_gnutls_error (err, FUNC_NAME);
}
err = gnutls_openpgp_privkey_import (c_key, &c_data_d, c_format, c_pass,
0 /* currently unused */ );
scm_gnutls_release_array (&c_data_handle);
if (EXPECT_FALSE (err))
{
gnutls_openpgp_privkey_deinit (c_key);
scm_gnutls_error (err, FUNC_NAME);
}
return (scm_from_gnutls_openpgp_private_key (c_key));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_certificate_id, "%openpgp-certificate-id",
1, 0, 0,
(SCM key),
"Return the ID (an 8-element u8vector) of certificate "
"@var{key}.")
#define FUNC_NAME s_scm_gnutls_openpgp_certificate_id
{
int err;
unsigned char *c_id;
gnutls_openpgp_crt_t c_key;
c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
c_id = (unsigned char *) malloc (8);
if (c_id == NULL)
scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
err = gnutls_openpgp_crt_get_key_id (c_key, c_id);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return (scm_take_u8vector (c_id, 8));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_certificate_id_x, "%openpgp-certificate-id!",
2, 0, 0,
(SCM key, SCM id),
"Store the ID (an 8 byte sequence) of certificate "
"@var{key} in @var{id} (a u8vector).")
#define FUNC_NAME s_scm_gnutls_openpgp_certificate_id_x
{
int err;
char *c_id;
scm_t_array_handle c_id_handle;
size_t c_id_size;
gnutls_openpgp_crt_t c_key;
c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
c_id = scm_gnutls_get_writable_array (id, &c_id_handle, &c_id_size,
FUNC_NAME);
if (EXPECT_FALSE (c_id_size < 8))
{
scm_gnutls_release_array (&c_id_handle);
scm_misc_error (FUNC_NAME, "ID vector too small: ~A", scm_list_1 (id));
}
err = gnutls_openpgp_crt_get_key_id (c_key, (unsigned char *) c_id);
scm_gnutls_release_array (&c_id_handle);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_certificate_fingerpint_x,
"%openpgp-certificate-fingerprint!",
2, 0, 0,
(SCM key, SCM fpr),
"Store in @var{fpr} (a u8vector) the fingerprint of @var{key}. "
"Return the number of bytes stored in @var{fpr}.")
#define FUNC_NAME s_scm_gnutls_openpgp_certificate_fingerpint_x
{
int err;
gnutls_openpgp_crt_t c_key;
char *c_fpr;
scm_t_array_handle c_fpr_handle;
size_t c_fpr_len, c_actual_len = 0;
c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
SCM_VALIDATE_ARRAY (2, fpr);
c_fpr = scm_gnutls_get_writable_array (fpr, &c_fpr_handle, &c_fpr_len,
FUNC_NAME);
err = gnutls_openpgp_crt_get_fingerprint (c_key, c_fpr, &c_actual_len);
scm_gnutls_release_array (&c_fpr_handle);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return (scm_from_size_t (c_actual_len));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_certificate_fingerprint,
"%openpgp-certificate-fingerprint",
1, 0, 0,
(SCM key),
"Return a new u8vector denoting the fingerprint of " "@var{key}.")
#define FUNC_NAME s_scm_gnutls_openpgp_certificate_fingerprint
{
int err;
gnutls_openpgp_crt_t c_key;
unsigned char *c_fpr;
size_t c_fpr_len, c_actual_len;
c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
/* V4 fingerprints are 160-bit SHA-1 hashes (see RFC2440). */
c_fpr_len = 20;
c_fpr = (unsigned char *) malloc (c_fpr_len);
if (EXPECT_FALSE (c_fpr == NULL))
scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
do
{
c_actual_len = 0;
err = gnutls_openpgp_crt_get_fingerprint (c_key, c_fpr, &c_actual_len);
if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
{
/* Grow C_FPR. */
unsigned char *c_new;
c_new = (unsigned char *) realloc (c_fpr, c_fpr_len * 2);
if (EXPECT_FALSE (c_new == NULL))
{
free (c_fpr);
scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
}
else
{
c_fpr_len *= 2;
c_fpr = c_new;
}
}
}
while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
if (EXPECT_FALSE (err))
{
free (c_fpr);
scm_gnutls_error (err, FUNC_NAME);
}
if (c_actual_len < c_fpr_len)
/* Shrink C_FPR. */
c_fpr = realloc (c_fpr, c_actual_len);
return (scm_take_u8vector (c_fpr, c_actual_len));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_certificate_name, "%openpgp-certificate-name",
2, 0, 0,
(SCM key, SCM index),
"Return the @var{index}th name of @var{key}.")
#define FUNC_NAME s_scm_gnutls_openpgp_certificate_name
{
int err;
gnutls_openpgp_crt_t c_key;
int c_index;
char c_name[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH];
size_t c_name_len = sizeof (c_name);
c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
c_index = scm_to_int (index);
err = gnutls_openpgp_crt_get_name (c_key, c_index, c_name, &c_name_len);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
/* XXX: The name is really UTF-8. */
return (scm_from_locale_string (c_name));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_certificate_names, "%openpgp-certificate-names",
1, 0, 0, (SCM key), "Return the list of names for @var{key}.")
#define FUNC_NAME s_scm_gnutls_openpgp_certificate_names
{
int err;
SCM result = SCM_EOL;
gnutls_openpgp_crt_t c_key;
int c_index = 0;
char c_name[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH];
size_t c_name_len = sizeof (c_name);
c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
do
{
err = gnutls_openpgp_crt_get_name (c_key, c_index, c_name, &c_name_len);
if (!err)
{
result = scm_cons (scm_from_locale_string (c_name), result);
c_index++;
}
}
while (!err);
if (EXPECT_FALSE (err != GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE))
scm_gnutls_error (err, FUNC_NAME);
return (scm_reverse_x (result, SCM_EOL));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_certificate_algorithm,
"%openpgp-certificate-algorithm",
1, 0, 0,
(SCM key),
"Return two values: the certificate algorithm used by "
"@var{key} and the number of bits used.")
#define FUNC_NAME s_scm_gnutls_openpgp_certificate_algorithm
{
gnutls_openpgp_crt_t c_key;
unsigned int c_bits;
gnutls_pk_algorithm_t c_algo;
c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
c_algo = gnutls_openpgp_crt_get_pk_algorithm (c_key, &c_bits);
return (scm_values (scm_list_2 (scm_from_gnutls_pk_algorithm (c_algo),
scm_from_uint (c_bits))));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_certificate_version,
"%openpgp-certificate-version",
1, 0, 0,
(SCM key),
"Return the version of the OpenPGP message format (RFC2440) "
"honored by @var{key}.")
#define FUNC_NAME s_scm_gnutls_openpgp_certificate_version
{
int c_version;
gnutls_openpgp_crt_t c_key;
c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
c_version = gnutls_openpgp_crt_get_version (c_key);
return (scm_from_int (c_version));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_certificate_usage, "%openpgp-certificate-usage",
1, 0, 0,
(SCM key),
"Return a list of values denoting the key usage of @var{key}.")
#define FUNC_NAME s_scm_gnutls_openpgp_certificate_usage
{
int err;
unsigned int c_usage = 0;
gnutls_openpgp_crt_t c_key;
c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME);
err = gnutls_openpgp_crt_get_key_usage (c_key, &c_usage);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return (scm_from_gnutls_key_usage_flags (c_usage));
}
#undef FUNC_NAME
/* OpenPGP keyrings. */
SCM_DEFINE (scm_gnutls_import_openpgp_keyring, "import-openpgp-keyring",
2, 0, 0,
(SCM data, SCM format),
"Import @var{data} (a u8vector) according to @var{format} "
"and return the imported keyring.")
#define FUNC_NAME s_scm_gnutls_import_openpgp_keyring
{
int err;
gnutls_openpgp_keyring_t c_keyring;
gnutls_openpgp_crt_fmt_t c_format;
gnutls_datum_t c_data_d;
scm_t_array_handle c_data_handle;
const char *c_data;
size_t c_data_len;
SCM_VALIDATE_ARRAY (1, data);
c_format = scm_to_gnutls_openpgp_certificate_format (format, 2, FUNC_NAME);
c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
FUNC_NAME);
c_data_d.data = (unsigned char *) c_data;
c_data_d.size = c_data_len;
err = gnutls_openpgp_keyring_init (&c_keyring);
if (EXPECT_FALSE (err))
{
scm_gnutls_release_array (&c_data_handle);
scm_gnutls_error (err, FUNC_NAME);
}
err = gnutls_openpgp_keyring_import (c_keyring, &c_data_d, c_format);
scm_gnutls_release_array (&c_data_handle);
if (EXPECT_FALSE (err))
{
gnutls_openpgp_keyring_deinit (c_keyring);
scm_gnutls_error (err, FUNC_NAME);
}
return (scm_from_gnutls_openpgp_keyring (c_keyring));
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_openpgp_keyring_contains_key_id_p,
"%openpgp-keyring-contains-key-id?",
2, 0, 0,
(SCM keyring, SCM id),
"Return @code{#f} if key ID @var{id} is in @var{keyring}, "
"@code{#f} otherwise.")
#define FUNC_NAME s_scm_gnutls_openpgp_keyring_contains_key_id_p
{
int c_result;
gnutls_openpgp_keyring_t c_keyring;
scm_t_array_handle c_id_handle;
const char *c_id;
size_t c_id_len;
c_keyring = scm_to_gnutls_openpgp_keyring (keyring, 1, FUNC_NAME);
SCM_VALIDATE_ARRAY (1, id);
c_id = scm_gnutls_get_array (id, &c_id_handle, &c_id_len, FUNC_NAME);
if (EXPECT_FALSE (c_id_len != 8))
{
scm_gnutls_release_array (&c_id_handle);
scm_wrong_type_arg (FUNC_NAME, 1, id);
}
c_result = gnutls_openpgp_keyring_check_id (c_keyring,
(unsigned char *) c_id,
0 /* unused */ );
scm_gnutls_release_array (&c_id_handle);
return (scm_from_bool (c_result == 0));
}
#undef FUNC_NAME
/* OpenPGP certificates. */
SCM_DEFINE (scm_gnutls_set_certificate_credentials_openpgp_keys_x,
"%set-certificate-credentials-openpgp-keys!",
3, 0, 0,
(SCM cred, SCM pub, SCM sec),
"Use certificate @var{pub} and secret key @var{sec} in "
"certificate credentials @var{cred}.")
#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_openpgp_keys_x
{
int err;
gnutls_certificate_credentials_t c_cred;
gnutls_openpgp_crt_t c_pub;
gnutls_openpgp_privkey_t c_sec;
c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
c_pub = scm_to_gnutls_openpgp_certificate (pub, 2, FUNC_NAME);
c_sec = scm_to_gnutls_openpgp_private_key (sec, 3, FUNC_NAME);
err = gnutls_certificate_set_openpgp_key (c_cred, c_pub, c_sec);
if (EXPECT_FALSE (err))
scm_gnutls_error (err, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Debugging. */
static SCM log_procedure = SCM_BOOL_F;
static void
scm_gnutls_log (int level, const char *str)
{
if (scm_is_true (log_procedure))
(void) scm_call_2 (log_procedure, scm_from_int (level),
scm_from_locale_string (str));
}
SCM_DEFINE (scm_gnutls_set_log_procedure_x, "set-log-procedure!",
1, 0, 0,
(SCM proc),
"Use @var{proc} (a two-argument procedure) as the global "
"GnuTLS log procedure.")
#define FUNC_NAME s_scm_gnutls_set_log_procedure_x
{
SCM_VALIDATE_PROC (1, proc);
if (scm_is_true (log_procedure))
(void) scm_gc_unprotect_object (log_procedure);
log_procedure = scm_gc_protect_object (proc);
gnutls_global_set_log_function (scm_gnutls_log);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gnutls_set_log_level_x, "set-log-level!", 1, 0, 0,
(SCM level),
"Enable GnuTLS logging up to @var{level} (an integer).")
#define FUNC_NAME s_scm_gnutls_set_log_level_x
{
unsigned int c_level;
c_level = scm_to_uint (level);
gnutls_global_set_log_level (c_level);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Initialization. */
void
scm_init_gnutls (void)
{
#include "core.x"
/* Use Guile's allocation routines, which will run the GC if need be. */
(void) gnutls_global_init ();
scm_gnutls_define_enums ();
scm_init_gnutls_error ();
scm_init_gnutls_session_record_port_type ();
weak_refs = scm_make_weak_key_hash_table (scm_from_int (42));
weak_refs = scm_permanent_object (weak_refs);
}