/* 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 . */ #ifdef HAVE_CONFIG_H #include #endif #include #include #include #include #include #include #include #include #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); }