1 /* GnuTLS --- Guile bindings for GnuTLS.
2 Copyright (C) 2007-2012 Free Software Foundation, Inc.
4 GnuTLS is free software; you can redistribute it and/or
5 modify it under the terms of the GNU Lesser General Public
6 License as published by the Free Software Foundation; either
7 version 2.1 of the License, or (at your option) any later version.
9 GnuTLS is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 Lesser General Public License for more details.
14 You should have received a copy of the GNU Lesser General Public
15 License along with GnuTLS; if not, write to the Free Software
16 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
18 /* Written by Ludovic Courtès <ludo@gnu.org>. */
27 #include <gnutls/gnutls.h>
28 #include <gnutls/openpgp.h>
40 /* SMOB and enums type definitions. */
41 #include "enum-map.i.c"
42 #include "smob-types.i.c"
44 const char scm_gnutls_array_error_message
[] =
45 "cannot handle non-contiguous array: ~A";
48 /* Data that are attached to `gnutls_session_t' objects.
50 We need to keep several pieces of information along with each session:
52 - A boolean indicating whether its underlying transport is a file
53 descriptor or Scheme port. This is used to decide whether to leave
54 "Guile mode" when invoking `gnutls_record_recv ()'.
56 - The record port attached to the session (returned by
57 `session-record-port'). This is so that several calls to
58 `session-record-port' return the same port.
60 Currently, this information is maintained into a pair. The whole pair is
61 marked by the session mark procedure. */
63 #define SCM_GNUTLS_MAKE_SESSION_DATA() \
64 scm_cons (SCM_BOOL_F, SCM_BOOL_F)
65 #define SCM_GNUTLS_SET_SESSION_DATA(c_session, data) \
66 gnutls_session_set_ptr (c_session, (void *) SCM_UNPACK (data))
67 #define SCM_GNUTLS_SESSION_DATA(c_session) \
68 SCM_PACK ((scm_t_bits) gnutls_session_get_ptr (c_session))
70 #define SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD(c_session, c_is_fd) \
71 SCM_SETCAR (SCM_GNUTLS_SESSION_DATA (c_session), \
72 scm_from_bool (c_is_fd))
73 #define SCM_GNUTLS_SET_SESSION_RECORD_PORT(c_session, port) \
74 SCM_SETCDR (SCM_GNUTLS_SESSION_DATA (c_session), port)
76 #define SCM_GNUTLS_SESSION_TRANSPORT_IS_FD(c_session) \
77 scm_to_bool (SCM_CAR (SCM_GNUTLS_SESSION_DATA (c_session)))
78 #define SCM_GNUTLS_SESSION_RECORD_PORT(c_session) \
79 SCM_CDR (SCM_GNUTLS_SESSION_DATA (c_session))
85 /* Mark the data associated with SESSION. */
86 SCM_SMOB_MARK (scm_tc16_gnutls_session
, mark_session
, session
)
88 gnutls_session_t c_session
;
90 c_session
= scm_to_gnutls_session (session
, 1, "mark_session");
92 return (SCM_GNUTLS_SESSION_DATA (c_session
));
95 SCM_DEFINE (scm_gnutls_version
, "gnutls-version", 0, 0, 0,
97 "Return a string denoting the version number of the underlying "
98 "GnuTLS library, e.g., @code{\"1.7.2\"}.")
99 #define FUNC_NAME s_scm_gnutls_version
101 return (scm_from_locale_string (gnutls_check_version (NULL
)));
106 SCM_DEFINE (scm_gnutls_make_session
, "make-session", 1, 0, 0,
108 "Return a new session for connection end @var{end}, either "
109 "@code{connection-end/server} or @code{connection-end/client}.")
110 #define FUNC_NAME s_scm_gnutls_make_session
113 gnutls_session_t c_session
;
114 gnutls_connection_end_t c_end
;
117 c_end
= scm_to_gnutls_connection_end (end
, 1, FUNC_NAME
);
119 session_data
= SCM_GNUTLS_MAKE_SESSION_DATA ();
120 err
= gnutls_init (&c_session
, c_end
);
122 if (EXPECT_FALSE (err
))
123 scm_gnutls_error (err
, FUNC_NAME
);
125 SCM_GNUTLS_SET_SESSION_DATA (c_session
, session_data
);
127 return (scm_from_gnutls_session (c_session
));
132 SCM_DEFINE (scm_gnutls_bye
, "bye", 2, 0, 0,
133 (SCM session
, SCM how
),
134 "Close @var{session} according to @var{how}.")
135 #define FUNC_NAME s_scm_gnutls_bye
138 gnutls_session_t c_session
;
139 gnutls_close_request_t c_how
;
141 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
142 c_how
= scm_to_gnutls_close_request (how
, 2, FUNC_NAME
);
144 err
= gnutls_bye (c_session
, c_how
);
145 if (EXPECT_FALSE (err
))
146 scm_gnutls_error (err
, FUNC_NAME
);
148 return SCM_UNSPECIFIED
;
153 SCM_DEFINE (scm_gnutls_handshake
, "handshake", 1, 0, 0,
154 (SCM session
), "Perform a handshake for @var{session}.")
155 #define FUNC_NAME s_scm_gnutls_handshake
158 gnutls_session_t c_session
;
160 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
162 err
= gnutls_handshake (c_session
);
163 if (EXPECT_FALSE (err
))
164 scm_gnutls_error (err
, FUNC_NAME
);
166 return SCM_UNSPECIFIED
;
171 SCM_DEFINE (scm_gnutls_rehandshake
, "rehandshake", 1, 0, 0,
172 (SCM session
), "Perform a re-handshaking for @var{session}.")
173 #define FUNC_NAME s_scm_gnutls_rehandshake
176 gnutls_session_t c_session
;
178 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
180 err
= gnutls_rehandshake (c_session
);
181 if (EXPECT_FALSE (err
))
182 scm_gnutls_error (err
, FUNC_NAME
);
184 return SCM_UNSPECIFIED
;
189 SCM_DEFINE (scm_gnutls_alert_get
, "alert-get", 1, 0, 0,
190 (SCM session
), "Get an aleter from @var{session}.")
191 #define FUNC_NAME s_scm_gnutls_alert_get
193 gnutls_session_t c_session
;
194 gnutls_alert_description_t c_alert
;
196 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
198 c_alert
= gnutls_alert_get (c_session
);
200 return (scm_from_gnutls_alert_description (c_alert
));
205 SCM_DEFINE (scm_gnutls_alert_send
, "alert-send", 3, 0, 0,
206 (SCM session
, SCM level
, SCM alert
),
207 "Send @var{alert} via @var{session}.")
208 #define FUNC_NAME s_scm_gnutls_alert_send
211 gnutls_session_t c_session
;
212 gnutls_alert_level_t c_level
;
213 gnutls_alert_description_t c_alert
;
215 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
216 c_level
= scm_to_gnutls_alert_level (level
, 2, FUNC_NAME
);
217 c_alert
= scm_to_gnutls_alert_description (alert
, 3, FUNC_NAME
);
219 err
= gnutls_alert_send (c_session
, c_level
, c_alert
);
220 if (EXPECT_FALSE (err
))
221 scm_gnutls_error (err
, FUNC_NAME
);
223 return SCM_UNSPECIFIED
;
228 /* FIXME: Omitting `alert-send-appropriate'. */
231 /* Session accessors. */
233 SCM_DEFINE (scm_gnutls_session_cipher
, "session-cipher", 1, 0, 0,
234 (SCM session
), "Return @var{session}'s cipher.")
235 #define FUNC_NAME s_scm_gnutls_session_cipher
237 gnutls_session_t c_session
;
238 gnutls_cipher_algorithm_t c_cipher
;
240 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
242 c_cipher
= gnutls_cipher_get (c_session
);
244 return (scm_from_gnutls_cipher (c_cipher
));
249 SCM_DEFINE (scm_gnutls_session_kx
, "session-kx", 1, 0, 0,
250 (SCM session
), "Return @var{session}'s kx.")
251 #define FUNC_NAME s_scm_gnutls_session_kx
253 gnutls_session_t c_session
;
254 gnutls_kx_algorithm_t c_kx
;
256 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
258 c_kx
= gnutls_kx_get (c_session
);
260 return (scm_from_gnutls_kx (c_kx
));
265 SCM_DEFINE (scm_gnutls_session_mac
, "session-mac", 1, 0, 0,
266 (SCM session
), "Return @var{session}'s MAC.")
267 #define FUNC_NAME s_scm_gnutls_session_mac
269 gnutls_session_t c_session
;
270 gnutls_mac_algorithm_t c_mac
;
272 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
274 c_mac
= gnutls_mac_get (c_session
);
276 return (scm_from_gnutls_mac (c_mac
));
281 SCM_DEFINE (scm_gnutls_session_compression_method
,
282 "session-compression-method", 1, 0, 0,
283 (SCM session
), "Return @var{session}'s compression method.")
284 #define FUNC_NAME s_scm_gnutls_session_compression_method
286 gnutls_session_t c_session
;
287 gnutls_compression_method_t c_comp
;
289 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
291 c_comp
= gnutls_compression_get (c_session
);
293 return (scm_from_gnutls_compression_method (c_comp
));
298 SCM_DEFINE (scm_gnutls_session_certificate_type
,
299 "session-certificate-type", 1, 0, 0,
300 (SCM session
), "Return @var{session}'s certificate type.")
301 #define FUNC_NAME s_scm_gnutls_session_certificate_type
303 gnutls_session_t c_session
;
304 gnutls_certificate_type_t c_cert
;
306 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
308 c_cert
= gnutls_certificate_type_get (c_session
);
310 return (scm_from_gnutls_certificate_type (c_cert
));
315 SCM_DEFINE (scm_gnutls_session_protocol
, "session-protocol", 1, 0, 0,
316 (SCM session
), "Return the protocol used by @var{session}.")
317 #define FUNC_NAME s_scm_gnutls_session_protocol
319 gnutls_session_t c_session
;
320 gnutls_protocol_t c_protocol
;
322 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
324 c_protocol
= gnutls_protocol_get_version (c_session
);
326 return (scm_from_gnutls_protocol (c_protocol
));
331 SCM_DEFINE (scm_gnutls_session_authentication_type
,
332 "session-authentication-type",
335 "Return the authentication type (a @code{credential-type} value) "
336 "used by @var{session}.")
337 #define FUNC_NAME s_scm_gnutls_session_authentication_type
339 gnutls_session_t c_session
;
340 gnutls_credentials_type_t c_auth
;
342 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
344 c_auth
= gnutls_auth_get_type (c_session
);
346 return (scm_from_gnutls_credentials (c_auth
));
351 SCM_DEFINE (scm_gnutls_session_server_authentication_type
,
352 "session-server-authentication-type",
355 "Return the server authentication type (a "
356 "@code{credential-type} value) used in @var{session}.")
357 #define FUNC_NAME s_scm_gnutls_session_server_authentication_type
359 gnutls_session_t c_session
;
360 gnutls_credentials_type_t c_auth
;
362 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
364 c_auth
= gnutls_auth_server_get_type (c_session
);
366 return (scm_from_gnutls_credentials (c_auth
));
371 SCM_DEFINE (scm_gnutls_session_client_authentication_type
,
372 "session-client-authentication-type",
375 "Return the client authentication type (a "
376 "@code{credential-type} value) used in @var{session}.")
377 #define FUNC_NAME s_scm_gnutls_session_client_authentication_type
379 gnutls_session_t c_session
;
380 gnutls_credentials_type_t c_auth
;
382 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
384 c_auth
= gnutls_auth_client_get_type (c_session
);
386 return (scm_from_gnutls_credentials (c_auth
));
391 SCM_DEFINE (scm_gnutls_session_peer_certificate_chain
,
392 "session-peer-certificate-chain",
395 "Return the a list of certificates in raw format (u8vectors) "
396 "where the first one is the peer's certificate. In the case "
397 "of OpenPGP, there is always exactly one certificate. In the "
398 "case of X.509, subsequent certificates indicate form a "
399 "certificate chain. Return the empty list if no certificate "
401 #define FUNC_NAME s_scm_gnutls_session_peer_certificate_chain
404 gnutls_session_t c_session
;
405 const gnutls_datum_t
*c_cert
;
406 unsigned int c_list_size
;
408 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
410 c_cert
= gnutls_certificate_get_peers (c_session
, &c_list_size
);
412 if (EXPECT_FALSE (c_cert
== NULL
))
419 result
= scm_make_list (scm_from_uint (c_list_size
), SCM_UNSPECIFIED
);
421 for (i
= 0, pair
= result
; i
< c_list_size
; i
++, pair
= SCM_CDR (pair
))
423 unsigned char *c_cert_copy
;
425 c_cert_copy
= (unsigned char *) malloc (c_cert
[i
].size
);
426 if (EXPECT_FALSE (c_cert_copy
== NULL
))
427 scm_gnutls_error (GNUTLS_E_MEMORY_ERROR
, FUNC_NAME
);
429 memcpy (c_cert_copy
, c_cert
[i
].data
, c_cert
[i
].size
);
431 SCM_SETCAR (pair
, scm_take_u8vector (c_cert_copy
, c_cert
[i
].size
));
440 SCM_DEFINE (scm_gnutls_session_our_certificate_chain
,
441 "session-our-certificate-chain",
444 "Return our certificate chain for @var{session} (as sent to "
445 "the peer) in raw format (a u8vector). In the case of OpenPGP "
446 "there is exactly one certificate. Return the empty list "
447 "if no certificate was used.")
448 #define FUNC_NAME s_scm_gnutls_session_our_certificate_chain
451 gnutls_session_t c_session
;
452 const gnutls_datum_t
*c_cert
;
453 unsigned char *c_cert_copy
;
455 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
457 /* XXX: Currently, the C function actually returns only one certificate.
458 Future versions of the API may provide the full certificate chain, as
459 for `gnutls_certificate_get_peers ()'. */
460 c_cert
= gnutls_certificate_get_ours (c_session
);
462 if (EXPECT_FALSE (c_cert
== NULL
))
466 c_cert_copy
= (unsigned char *) malloc (c_cert
->size
);
467 if (EXPECT_FALSE (c_cert_copy
== NULL
))
468 scm_gnutls_error (GNUTLS_E_MEMORY_ERROR
, FUNC_NAME
);
470 memcpy (c_cert_copy
, c_cert
->data
, c_cert
->size
);
472 result
= scm_list_1 (scm_take_u8vector (c_cert_copy
, c_cert
->size
));
480 SCM_DEFINE (scm_gnutls_set_server_session_certificate_request_x
,
481 "set-server-session-certificate-request!",
483 (SCM session
, SCM request
),
484 "Tell how @var{session}, a server-side session, should deal "
485 "with certificate requests. @var{request} should be either "
486 "@code{certificate-request/request} or "
487 "@code{certificate-request/require}.")
488 #define FUNC_NAME s_scm_gnutls_set_server_session_certificate_request_x
490 gnutls_session_t c_session
;
491 gnutls_certificate_status_t c_request
;
493 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
494 c_request
= scm_to_gnutls_certificate_request (request
, 2, FUNC_NAME
);
496 gnutls_certificate_server_set_request (c_session
, c_request
);
498 return SCM_UNSPECIFIED
;
504 /* Choice of a protocol and cipher suite. */
506 #include "priorities.i.c"
508 SCM_DEFINE (scm_gnutls_set_default_priority_x
,
509 "set-session-default-priority!", 1, 0, 0,
510 (SCM session
), "Have @var{session} use the default priorities.")
511 #define FUNC_NAME s_scm_gnutls_set_default_priority_x
513 gnutls_session_t c_session
;
515 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
516 gnutls_set_default_priority (c_session
);
518 return SCM_UNSPECIFIED
;
523 SCM_DEFINE (scm_gnutls_set_default_export_priority_x
,
524 "set-session-default-export-priority!", 1, 0, 0,
526 "Have @var{session} use the default export priorities.")
527 #define FUNC_NAME s_scm_gnutls_set_default_export_priority_x
529 gnutls_session_t c_session
;
531 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
532 gnutls_set_default_export_priority (c_session
);
534 return SCM_UNSPECIFIED
;
538 SCM_DEFINE (scm_gnutls_set_session_priorities_x
,
539 "set-session-priorities!", 2, 0, 0,
540 (SCM session
, SCM priorities
),
541 "Have @var{session} use the given @var{priorities} for "
542 "the ciphers, key exchange methods, MACs and compression "
543 "methods. @var{priorities} must be a string (see "
544 "Priority Strings). When @var{priorities} cannot be "
545 "parsed, an @code{error/invalid-request} error is raised, "
546 "with an extra argument indication the position of the "
548 #define FUNC_NAME s_scm_gnutls_set_session_priorities_x
553 gnutls_session_t c_session
;
556 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
557 c_priorities
= scm_to_locale_string (priorities
); /* XXX: to_latin1_string */
559 err
= gnutls_priority_set_direct (c_session
, c_priorities
, &err_pos
);
560 if (err
== GNUTLS_E_INVALID_REQUEST
)
561 pos
= err_pos
- c_priorities
;
567 case GNUTLS_E_SUCCESS
:
569 case GNUTLS_E_INVALID_REQUEST
:
571 scm_gnutls_error_with_args (err
, FUNC_NAME
,
572 scm_list_1 (scm_from_size_t (pos
)));
576 scm_gnutls_error (err
, FUNC_NAME
);
579 return SCM_UNSPECIFIED
;
583 SCM_DEFINE (scm_gnutls_cipher_suite_to_string
, "cipher-suite->string",
585 (SCM kx
, SCM cipher
, SCM mac
),
586 "Return the name of the given cipher suite.")
587 #define FUNC_NAME s_scm_gnutls_cipher_suite_to_string
589 gnutls_kx_algorithm_t c_kx
;
590 gnutls_cipher_algorithm_t c_cipher
;
591 gnutls_mac_algorithm_t c_mac
;
594 c_kx
= scm_to_gnutls_kx (kx
, 1, FUNC_NAME
);
595 c_cipher
= scm_to_gnutls_cipher (cipher
, 2, FUNC_NAME
);
596 c_mac
= scm_to_gnutls_mac (mac
, 3, FUNC_NAME
);
598 c_name
= gnutls_cipher_suite_get_name (c_kx
, c_cipher
, c_mac
);
600 return (scm_from_locale_string (c_name
));
605 SCM_DEFINE (scm_gnutls_set_session_credentials_x
, "set-session-credentials!",
607 (SCM session
, SCM cred
),
608 "Use @var{cred} as @var{session}'s credentials.")
609 #define FUNC_NAME s_scm_gnutls_set_session_credentials_x
612 gnutls_session_t c_session
;
614 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
616 if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_certificate_credentials
, cred
))
618 gnutls_certificate_credentials_t c_cred
;
620 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 2, FUNC_NAME
);
622 gnutls_credentials_set (c_session
, GNUTLS_CRD_CERTIFICATE
, c_cred
);
625 if (SCM_SMOB_PREDICATE
626 (scm_tc16_gnutls_anonymous_client_credentials
, cred
))
628 gnutls_anon_client_credentials_t c_cred
;
630 c_cred
= scm_to_gnutls_anonymous_client_credentials (cred
, 2,
632 err
= gnutls_credentials_set (c_session
, GNUTLS_CRD_ANON
, c_cred
);
634 else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_anonymous_server_credentials
,
637 gnutls_anon_server_credentials_t c_cred
;
639 c_cred
= scm_to_gnutls_anonymous_server_credentials (cred
, 2,
641 err
= gnutls_credentials_set (c_session
, GNUTLS_CRD_ANON
, c_cred
);
644 else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_srp_client_credentials
, cred
))
646 gnutls_srp_client_credentials_t c_cred
;
648 c_cred
= scm_to_gnutls_srp_client_credentials (cred
, 2, FUNC_NAME
);
649 err
= gnutls_credentials_set (c_session
, GNUTLS_CRD_SRP
, c_cred
);
651 else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_srp_server_credentials
, cred
))
653 gnutls_srp_server_credentials_t c_cred
;
655 c_cred
= scm_to_gnutls_srp_server_credentials (cred
, 2, FUNC_NAME
);
656 err
= gnutls_credentials_set (c_session
, GNUTLS_CRD_SRP
, c_cred
);
659 else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_psk_client_credentials
, cred
))
661 gnutls_psk_client_credentials_t c_cred
;
663 c_cred
= scm_to_gnutls_psk_client_credentials (cred
, 2, FUNC_NAME
);
664 err
= gnutls_credentials_set (c_session
, GNUTLS_CRD_PSK
, c_cred
);
666 else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_psk_server_credentials
, cred
))
668 gnutls_psk_server_credentials_t c_cred
;
670 c_cred
= scm_to_gnutls_psk_server_credentials (cred
, 2, FUNC_NAME
);
671 err
= gnutls_credentials_set (c_session
, GNUTLS_CRD_PSK
, c_cred
);
674 scm_wrong_type_arg (FUNC_NAME
, 2, cred
);
676 if (EXPECT_FALSE (err
))
677 scm_gnutls_error (err
, FUNC_NAME
);
679 return SCM_UNSPECIFIED
;
687 SCM_DEFINE (scm_gnutls_record_send
, "record-send", 2, 0, 0,
688 (SCM session
, SCM array
),
689 "Send the record constituted by @var{array} through "
691 #define FUNC_NAME s_scm_gnutls_record_send
695 gnutls_session_t c_session
;
696 scm_t_array_handle c_handle
;
700 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
701 SCM_VALIDATE_ARRAY (2, array
);
703 c_array
= scm_gnutls_get_array (array
, &c_handle
, &c_len
, FUNC_NAME
);
705 c_result
= gnutls_record_send (c_session
, c_array
, c_len
);
707 scm_gnutls_release_array (&c_handle
);
709 if (EXPECT_TRUE (c_result
>= 0))
710 result
= scm_from_ssize_t (c_result
);
712 scm_gnutls_error (c_result
, FUNC_NAME
);
719 SCM_DEFINE (scm_gnutls_record_receive_x
, "record-receive!", 2, 0, 0,
720 (SCM session
, SCM array
),
721 "Receive data from @var{session} into @var{array}, a uniform "
722 "homogeneous array. Return the number of bytes actually "
724 #define FUNC_NAME s_scm_gnutls_record_receive_x
728 gnutls_session_t c_session
;
729 scm_t_array_handle c_handle
;
733 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
734 SCM_VALIDATE_ARRAY (2, array
);
736 c_array
= scm_gnutls_get_writable_array (array
, &c_handle
, &c_len
,
739 c_result
= gnutls_record_recv (c_session
, c_array
, c_len
);
741 scm_gnutls_release_array (&c_handle
);
743 if (EXPECT_TRUE (c_result
>= 0))
744 result
= scm_from_ssize_t (c_result
);
746 scm_gnutls_error (c_result
, FUNC_NAME
);
754 /* The session record port type. */
755 static scm_t_bits session_record_port_type
;
757 /* Return the session associated with PORT. */
758 #define SCM_GNUTLS_SESSION_RECORD_PORT_SESSION(_port) \
759 (SCM_PACK (SCM_STREAM (_port)))
761 /* Size of a session port's input buffer. */
762 #define SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE 4096
764 /* Hint for the `scm_gc_' functions. */
765 static const char session_record_port_gc_hint
[] =
766 "gnutls-session-record-port";
769 #if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION <= 8
771 /* Mark the session associated with PORT. */
773 mark_session_record_port (SCM port
)
775 return (SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port
));
779 free_session_record_port (SCM port
)
780 #define FUNC_NAME "free_session_record_port"
785 session
= SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port
);
787 /* SESSION _can_ be invalid at this point: it can be freed in the same GC
788 cycle as PORT, just before PORT. Thus, we need to check whether SESSION
789 still points to a session SMOB. */
790 if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_session
, session
))
792 /* SESSION is still valid. Disassociate PORT from SESSION. */
793 gnutls_session_t c_session
;
795 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
796 SCM_GNUTLS_SET_SESSION_RECORD_PORT (c_session
, SCM_BOOL_F
);
799 /* Free the input buffer of PORT. */
800 c_port
= SCM_PTAB_ENTRY (port
);
801 scm_gc_free (c_port
->read_buf
, c_port
->read_buf_size
,
802 session_record_port_gc_hint
);
809 #endif /* SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION <= 8 */
812 /* Data passed to `do_fill_port ()'. */
816 gnutls_session_t c_session
;
819 /* Actually fill a session record port (see below). */
821 do_fill_port (void *data
)
826 const fill_port_data_t
*args
= (fill_port_data_t
*) data
;
828 c_port
= args
->c_port
;
829 result
= gnutls_record_recv (args
->c_session
,
830 c_port
->read_buf
, c_port
->read_buf_size
);
831 if (EXPECT_TRUE (result
> 0))
833 c_port
->read_pos
= c_port
->read_buf
;
834 c_port
->read_end
= c_port
->read_buf
+ result
;
835 chr
= (int) *c_port
->read_buf
;
837 else if (result
== 0)
840 scm_gnutls_error (result
, "fill_session_record_port_input");
842 return ((void *) (uintptr_t) chr
);
845 /* Fill in the input buffer of PORT. */
847 fill_session_record_port_input (SCM port
)
848 #define FUNC_NAME "fill_session_record_port_input"
851 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
853 if (c_port
->read_pos
>= c_port
->read_end
)
856 fill_port_data_t c_args
;
857 gnutls_session_t c_session
;
859 session
= SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port
);
860 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
862 c_args
.c_session
= c_session
;
863 c_args
.c_port
= c_port
;
865 if (SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session
))
866 /* SESSION's underlying transport is a raw file descriptor, so we
867 must leave "Guile mode" to allow the GC to run. */
868 chr
= (intptr_t) scm_without_guile (do_fill_port
, &c_args
);
870 /* SESSION's underlying transport is a port, so don't leave "Guile
872 chr
= (intptr_t) do_fill_port (&c_args
);
875 chr
= (int) *c_port
->read_pos
;
882 /* Write SIZE octets from DATA to PORT. */
884 write_to_session_record_port (SCM port
, const void *data
, size_t size
)
885 #define FUNC_NAME "write_to_session_record_port"
888 gnutls_session_t c_session
;
892 session
= SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port
);
893 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
895 while (c_sent
< size
)
897 c_result
= gnutls_record_send (c_session
, (char *) data
+ c_sent
,
899 if (EXPECT_FALSE (c_result
< 0))
900 scm_gnutls_error (c_result
, FUNC_NAME
);
908 /* Return a new session port for SESSION. */
910 make_session_record_port (SCM session
)
914 unsigned char *c_port_buf
;
915 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
| SCM_WRTNG
;
917 c_port_buf
= (unsigned char *)
918 #ifdef HAVE_SCM_GC_MALLOC_POINTERLESS
919 scm_gc_malloc_pointerless
923 (SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE
, session_record_port_gc_hint
);
925 /* Create a new port. */
926 port
= scm_new_port_table_entry (session_record_port_type
);
927 c_port
= SCM_PTAB_ENTRY (port
);
929 /* Mark PORT as open, readable and writable (hmm, how elegant...). */
930 SCM_SET_CELL_TYPE (port
, session_record_port_type
| mode_bits
);
932 /* Associate it with SESSION. */
933 SCM_SETSTREAM (port
, SCM_UNPACK (session
));
935 c_port
->read_pos
= c_port
->read_end
= c_port
->read_buf
= c_port_buf
;
936 c_port
->read_buf_size
= SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE
;
938 c_port
->write_buf
= c_port
->write_pos
= &c_port
->shortbuf
;
939 c_port
->write_buf_size
= 1;
944 SCM_DEFINE (scm_gnutls_session_record_port
, "session-record-port", 1, 0, 0,
946 "Return a read-write port that may be used to communicate over "
947 "@var{session}. All invocations of @code{session-port} on a "
948 "given session return the same object (in the sense of "
950 #define FUNC_NAME s_scm_gnutls_session_record_port
953 gnutls_session_t c_session
;
955 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
956 port
= SCM_GNUTLS_SESSION_RECORD_PORT (c_session
);
958 if (!SCM_PORTP (port
))
960 /* Lazily create a new session port. */
961 port
= make_session_record_port (session
);
962 SCM_GNUTLS_SET_SESSION_RECORD_PORT (c_session
, port
);
970 /* Create the session port type. */
972 scm_init_gnutls_session_record_port_type (void)
974 session_record_port_type
=
975 scm_make_port_type ("gnutls-session-port",
976 fill_session_record_port_input
,
977 write_to_session_record_port
);
979 /* Guile >= 1.9.3 doesn't need a custom mark procedure, and doesn't need a
980 finalizer (since memory associated with the port is automatically
982 #if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION <= 8
983 scm_set_port_mark (session_record_port_type
, mark_session_record_port
);
984 scm_set_port_free (session_record_port_type
, free_session_record_port
);
991 SCM_DEFINE (scm_gnutls_set_session_transport_fd_x
,
992 "set-session-transport-fd!", 2, 0, 0, (SCM session
, SCM fd
),
993 "Use file descriptor @var{fd} as the underlying transport for "
995 #define FUNC_NAME s_scm_gnutls_set_session_transport_fd_x
997 gnutls_session_t c_session
;
1000 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
1001 c_fd
= (int) scm_to_uint (fd
);
1003 gnutls_transport_set_ptr (c_session
,
1004 (gnutls_transport_ptr_t
) (intptr_t) c_fd
);
1006 SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD (c_session
, 1);
1008 return SCM_UNSPECIFIED
;
1013 /* Pull SIZE octets from TRANSPORT (a Scheme port) into DATA. */
1015 pull_from_port (gnutls_transport_ptr_t transport
, void *data
, size_t size
)
1020 port
= SCM_PACK ((scm_t_bits
) transport
);
1022 result
= scm_c_read (port
, data
, size
);
1024 return ((ssize_t
) result
);
1027 /* Write SIZE octets from DATA to TRANSPORT (a Scheme port). */
1029 push_to_port (gnutls_transport_ptr_t transport
, const void *data
, size_t size
)
1033 port
= SCM_PACK ((scm_t_bits
) transport
);
1035 scm_c_write (port
, data
, size
);
1037 /* All we can do is assume that all SIZE octets were written. */
1041 SCM_DEFINE (scm_gnutls_set_session_transport_port_x
,
1042 "set-session-transport-port!",
1044 (SCM session
, SCM port
),
1045 "Use @var{port} as the input/output port for @var{session}.")
1046 #define FUNC_NAME s_scm_gnutls_set_session_transport_port_x
1048 gnutls_session_t c_session
;
1050 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
1051 SCM_VALIDATE_PORT (2, port
);
1053 /* Note: We do not attempt to optimize the case where PORT is a file port
1054 (i.e., over a file descriptor), because of port buffering issues. Users
1055 are expected to explicitly use `set-session-transport-fd!' and `fileno'
1056 when they wish to do it. */
1058 gnutls_transport_set_ptr (c_session
,
1059 (gnutls_transport_ptr_t
) SCM_UNPACK (port
));
1060 gnutls_transport_set_push_function (c_session
, push_to_port
);
1061 gnutls_transport_set_pull_function (c_session
, pull_from_port
);
1063 SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD (c_session
, 0);
1065 return SCM_UNSPECIFIED
;
1071 /* Diffie-Hellman. */
1073 typedef int (*pkcs_export_function_t
) (void *, gnutls_x509_crt_fmt_t
,
1074 unsigned char *, size_t *);
1076 /* Hint for the `scm_gc' functions. */
1077 static const char pkcs_export_gc_hint
[] = "gnutls-pkcs-export";
1080 /* Export DH/RSA parameters PARAMS through EXPORT, using format FORMAT.
1081 Return a `u8vector'. */
1083 pkcs_export_parameters (pkcs_export_function_t export
,
1084 void *params
, gnutls_x509_crt_fmt_t format
,
1085 const char *func_name
)
1086 #define FUNC_NAME func_name
1089 unsigned char *output
;
1090 size_t output_len
, output_total_len
= 4096;
1092 output
= (unsigned char *) scm_gc_malloc (output_total_len
,
1093 pkcs_export_gc_hint
);
1096 output_len
= output_total_len
;
1097 err
= export (params
, format
, output
, &output_len
);
1099 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
1101 output
= scm_gc_realloc (output
, output_total_len
,
1102 output_total_len
* 2, pkcs_export_gc_hint
);
1103 output_total_len
*= 2;
1106 while (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
);
1108 if (EXPECT_FALSE (err
))
1110 scm_gc_free (output
, output_total_len
, pkcs_export_gc_hint
);
1111 scm_gnutls_error (err
, FUNC_NAME
);
1114 if (output_len
!= output_total_len
)
1115 /* Shrink the output buffer. */
1116 output
= scm_gc_realloc (output
, output_total_len
,
1117 output_len
, pkcs_export_gc_hint
);
1119 return (scm_take_u8vector (output
, output_len
));
1125 SCM_DEFINE (scm_gnutls_make_dh_parameters
, "make-dh-parameters", 1, 0, 0,
1126 (SCM bits
), "Return new Diffie-Hellman parameters.")
1127 #define FUNC_NAME s_scm_gnutls_make_dh_parameters
1131 gnutls_dh_params_t c_dh_params
;
1133 c_bits
= scm_to_uint (bits
);
1135 err
= gnutls_dh_params_init (&c_dh_params
);
1136 if (EXPECT_FALSE (err
))
1137 scm_gnutls_error (err
, FUNC_NAME
);
1139 err
= gnutls_dh_params_generate2 (c_dh_params
, c_bits
);
1140 if (EXPECT_FALSE (err
))
1142 gnutls_dh_params_deinit (c_dh_params
);
1143 scm_gnutls_error (err
, FUNC_NAME
);
1146 return (scm_from_gnutls_dh_parameters (c_dh_params
));
1151 SCM_DEFINE (scm_gnutls_pkcs3_import_dh_parameters
,
1152 "pkcs3-import-dh-parameters",
1154 (SCM array
, SCM format
),
1155 "Import Diffie-Hellman parameters in PKCS3 format (further "
1156 "specified by @var{format}, an @code{x509-certificate-format} "
1157 "value) from @var{array} (a homogeneous array) and return a "
1158 "new @code{dh-params} object.")
1159 #define FUNC_NAME s_scm_gnutls_pkcs3_import_dh_parameters
1162 gnutls_x509_crt_fmt_t c_format
;
1163 gnutls_dh_params_t c_dh_params
;
1164 scm_t_array_handle c_handle
;
1165 const char *c_array
;
1167 gnutls_datum_t c_datum
;
1169 c_format
= scm_to_gnutls_x509_certificate_format (format
, 2, FUNC_NAME
);
1171 c_array
= scm_gnutls_get_array (array
, &c_handle
, &c_len
, FUNC_NAME
);
1172 c_datum
.data
= (unsigned char *) c_array
;
1173 c_datum
.size
= c_len
;
1175 err
= gnutls_dh_params_init (&c_dh_params
);
1176 if (EXPECT_FALSE (err
))
1178 scm_gnutls_release_array (&c_handle
);
1179 scm_gnutls_error (err
, FUNC_NAME
);
1182 err
= gnutls_dh_params_import_pkcs3 (c_dh_params
, &c_datum
, c_format
);
1183 scm_gnutls_release_array (&c_handle
);
1185 if (EXPECT_FALSE (err
))
1187 gnutls_dh_params_deinit (c_dh_params
);
1188 scm_gnutls_error (err
, FUNC_NAME
);
1191 return (scm_from_gnutls_dh_parameters (c_dh_params
));
1196 SCM_DEFINE (scm_gnutls_pkcs3_export_dh_parameters
,
1197 "pkcs3-export-dh-parameters",
1199 (SCM dh_params
, SCM format
),
1200 "Export Diffie-Hellman parameters @var{dh_params} in PKCS3 "
1201 "format according for @var{format} (an "
1202 "@code{x509-certificate-format} value). Return a "
1203 "@code{u8vector} containing the result.")
1204 #define FUNC_NAME s_scm_gnutls_pkcs3_export_dh_parameters
1207 gnutls_dh_params_t c_dh_params
;
1208 gnutls_x509_crt_fmt_t c_format
;
1210 c_dh_params
= scm_to_gnutls_dh_parameters (dh_params
, 1, FUNC_NAME
);
1211 c_format
= scm_to_gnutls_x509_certificate_format (format
, 2, FUNC_NAME
);
1213 result
= pkcs_export_parameters ((pkcs_export_function_t
)
1214 gnutls_dh_params_export_pkcs3
,
1215 (void *) c_dh_params
, c_format
, FUNC_NAME
);
1222 SCM_DEFINE (scm_gnutls_set_session_dh_prime_bits_x
,
1223 "set-session-dh-prime-bits!", 2, 0, 0,
1224 (SCM session
, SCM bits
),
1225 "Use @var{bits} DH prime bits for @var{session}.")
1226 #define FUNC_NAME s_scm_gnutls_set_session_dh_prime_bits_x
1228 unsigned int c_bits
;
1229 gnutls_session_t c_session
;
1231 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
1232 c_bits
= scm_to_uint (bits
);
1234 gnutls_dh_set_prime_bits (c_session
, c_bits
);
1236 return SCM_UNSPECIFIED
;
1242 /* Anonymous credentials. */
1244 SCM_DEFINE (scm_gnutls_make_anon_server_credentials
,
1245 "make-anonymous-server-credentials",
1246 0, 0, 0, (void), "Return anonymous server credentials.")
1247 #define FUNC_NAME s_scm_gnutls_make_anon_server_credentials
1250 gnutls_anon_server_credentials_t c_cred
;
1252 err
= gnutls_anon_allocate_server_credentials (&c_cred
);
1254 if (EXPECT_FALSE (err
))
1255 scm_gnutls_error (err
, FUNC_NAME
);
1257 return (scm_from_gnutls_anonymous_server_credentials (c_cred
));
1262 SCM_DEFINE (scm_gnutls_make_anon_client_credentials
,
1263 "make-anonymous-client-credentials",
1264 0, 0, 0, (void), "Return anonymous client credentials.")
1265 #define FUNC_NAME s_scm_gnutls_make_anon_client_credentials
1268 gnutls_anon_client_credentials_t c_cred
;
1270 err
= gnutls_anon_allocate_client_credentials (&c_cred
);
1272 if (EXPECT_FALSE (err
))
1273 scm_gnutls_error (err
, FUNC_NAME
);
1275 return (scm_from_gnutls_anonymous_client_credentials (c_cred
));
1280 SCM_DEFINE (scm_gnutls_set_anonymous_server_dh_parameters_x
,
1281 "set-anonymous-server-dh-parameters!", 2, 0, 0,
1282 (SCM cred
, SCM dh_params
),
1283 "Set the Diffie-Hellman parameters of anonymous server "
1284 "credentials @var{cred}.")
1285 #define FUNC_NAME s_scm_gnutls_set_anonymous_server_dh_parameters_x
1287 gnutls_dh_params_t c_dh_params
;
1288 gnutls_anon_server_credentials_t c_cred
;
1290 c_cred
= scm_to_gnutls_anonymous_server_credentials (cred
, 1, FUNC_NAME
);
1291 c_dh_params
= scm_to_gnutls_dh_parameters (dh_params
, 2, FUNC_NAME
);
1293 gnutls_anon_set_server_dh_params (c_cred
, c_dh_params
);
1295 return SCM_UNSPECIFIED
;
1301 /* RSA parameters. */
1303 SCM_DEFINE (scm_gnutls_make_rsa_parameters
, "make-rsa-parameters", 1, 0, 0,
1304 (SCM bits
), "Return new RSA parameters.")
1305 #define FUNC_NAME s_scm_gnutls_make_rsa_parameters
1309 gnutls_rsa_params_t c_rsa_params
;
1311 c_bits
= scm_to_uint (bits
);
1313 err
= gnutls_rsa_params_init (&c_rsa_params
);
1314 if (EXPECT_FALSE (err
))
1315 scm_gnutls_error (err
, FUNC_NAME
);
1317 err
= gnutls_rsa_params_generate2 (c_rsa_params
, c_bits
);
1318 if (EXPECT_FALSE (err
))
1320 gnutls_rsa_params_deinit (c_rsa_params
);
1321 scm_gnutls_error (err
, FUNC_NAME
);
1324 return (scm_from_gnutls_rsa_parameters (c_rsa_params
));
1329 SCM_DEFINE (scm_gnutls_pkcs1_import_rsa_parameters
,
1330 "pkcs1-import-rsa-parameters",
1332 (SCM array
, SCM format
),
1333 "Import Diffie-Hellman parameters in PKCS1 format (further "
1334 "specified by @var{format}, an @code{x509-certificate-format} "
1335 "value) from @var{array} (a homogeneous array) and return a "
1336 "new @code{rsa-params} object.")
1337 #define FUNC_NAME s_scm_gnutls_pkcs1_import_rsa_parameters
1340 gnutls_x509_crt_fmt_t c_format
;
1341 gnutls_rsa_params_t c_rsa_params
;
1342 scm_t_array_handle c_handle
;
1343 const char *c_array
;
1345 gnutls_datum_t c_datum
;
1347 c_format
= scm_to_gnutls_x509_certificate_format (format
, 2, FUNC_NAME
);
1349 c_array
= scm_gnutls_get_array (array
, &c_handle
, &c_len
, FUNC_NAME
);
1350 c_datum
.data
= (unsigned char *) c_array
;
1351 c_datum
.size
= c_len
;
1353 err
= gnutls_rsa_params_init (&c_rsa_params
);
1354 if (EXPECT_FALSE (err
))
1356 scm_gnutls_release_array (&c_handle
);
1357 scm_gnutls_error (err
, FUNC_NAME
);
1360 err
= gnutls_rsa_params_import_pkcs1 (c_rsa_params
, &c_datum
, c_format
);
1361 scm_gnutls_release_array (&c_handle
);
1363 if (EXPECT_FALSE (err
))
1365 gnutls_rsa_params_deinit (c_rsa_params
);
1366 scm_gnutls_error (err
, FUNC_NAME
);
1369 return (scm_from_gnutls_rsa_parameters (c_rsa_params
));
1374 SCM_DEFINE (scm_gnutls_pkcs1_export_rsa_parameters
,
1375 "pkcs1-export-rsa-parameters",
1377 (SCM rsa_params
, SCM format
),
1378 "Export Diffie-Hellman parameters @var{rsa_params} in PKCS1 "
1379 "format according for @var{format} (an "
1380 "@code{x509-certificate-format} value). Return a "
1381 "@code{u8vector} containing the result.")
1382 #define FUNC_NAME s_scm_gnutls_pkcs1_export_rsa_parameters
1385 gnutls_rsa_params_t c_rsa_params
;
1386 gnutls_x509_crt_fmt_t c_format
;
1388 c_rsa_params
= scm_to_gnutls_rsa_parameters (rsa_params
, 1, FUNC_NAME
);
1389 c_format
= scm_to_gnutls_x509_certificate_format (format
, 2, FUNC_NAME
);
1391 result
= pkcs_export_parameters ((pkcs_export_function_t
)
1392 gnutls_rsa_params_export_pkcs1
,
1393 (void *) c_rsa_params
,
1394 c_format
, FUNC_NAME
);
1402 /* Certificate credentials. */
1405 int (*certificate_set_file_function_t
) (gnutls_certificate_credentials_t
,
1407 gnutls_x509_crt_fmt_t
);
1410 int (*certificate_set_data_function_t
) (gnutls_certificate_credentials_t
,
1411 const gnutls_datum_t
*,
1412 gnutls_x509_crt_fmt_t
);
1414 /* Helper function to implement the `set-file!' functions. */
1416 set_certificate_file (certificate_set_file_function_t set_file
,
1417 SCM cred
, SCM file
, SCM format
, const char *func_name
)
1418 #define FUNC_NAME func_name
1424 gnutls_certificate_credentials_t c_cred
;
1425 gnutls_x509_crt_fmt_t c_format
;
1427 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
1428 SCM_VALIDATE_STRING (2, file
);
1429 c_format
= scm_to_gnutls_x509_certificate_format (format
, 3, FUNC_NAME
);
1431 c_file_len
= scm_c_string_length (file
);
1432 c_file
= alloca (c_file_len
+ 1);
1434 (void) scm_to_locale_stringbuf (file
, c_file
, c_file_len
+ 1);
1435 c_file
[c_file_len
] = '\0';
1437 err
= set_file (c_cred
, c_file
, c_format
);
1438 if (EXPECT_FALSE (err
< 0))
1439 scm_gnutls_error (err
, FUNC_NAME
);
1441 /* Return the number of certificates processed. */
1442 return ((unsigned int) err
);
1447 /* Helper function implementing the `set-data!' functions. */
1448 static inline unsigned int
1449 set_certificate_data (certificate_set_data_function_t set_data
,
1450 SCM cred
, SCM data
, SCM format
, const char *func_name
)
1451 #define FUNC_NAME func_name
1454 gnutls_certificate_credentials_t c_cred
;
1455 gnutls_x509_crt_fmt_t c_format
;
1456 gnutls_datum_t c_datum
;
1457 scm_t_array_handle c_handle
;
1461 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
1462 SCM_VALIDATE_ARRAY (2, data
);
1463 c_format
= scm_to_gnutls_x509_certificate_format (format
, 3, FUNC_NAME
);
1465 c_data
= scm_gnutls_get_array (data
, &c_handle
, &c_len
, FUNC_NAME
);
1466 c_datum
.data
= (unsigned char *) c_data
;
1467 c_datum
.size
= c_len
;
1469 err
= set_data (c_cred
, &c_datum
, c_format
);
1470 scm_gnutls_release_array (&c_handle
);
1472 if (EXPECT_FALSE (err
< 0))
1473 scm_gnutls_error (err
, FUNC_NAME
);
1475 /* Return the number of certificates processed. */
1476 return ((unsigned int) err
);
1482 SCM_DEFINE (scm_gnutls_make_certificate_credentials
,
1483 "make-certificate-credentials",
1486 "Return new certificate credentials (i.e., for use with "
1487 "either X.509 or OpenPGP certificates.")
1488 #define FUNC_NAME s_scm_gnutls_make_certificate_credentials
1491 gnutls_certificate_credentials_t c_cred
;
1493 err
= gnutls_certificate_allocate_credentials (&c_cred
);
1495 scm_gnutls_error (err
, FUNC_NAME
);
1497 return (scm_from_gnutls_certificate_credentials (c_cred
));
1502 SCM_DEFINE (scm_gnutls_set_certificate_credentials_dh_params_x
,
1503 "set-certificate-credentials-dh-parameters!",
1505 (SCM cred
, SCM dh_params
),
1506 "Use Diffie-Hellman parameters @var{dh_params} for "
1507 "certificate credentials @var{cred}.")
1508 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_dh_params_x
1510 gnutls_dh_params_t c_dh_params
;
1511 gnutls_certificate_credentials_t c_cred
;
1513 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
1514 c_dh_params
= scm_to_gnutls_dh_parameters (dh_params
, 2, FUNC_NAME
);
1516 gnutls_certificate_set_dh_params (c_cred
, c_dh_params
);
1518 return SCM_UNSPECIFIED
;
1523 SCM_DEFINE (scm_gnutls_set_certificate_credentials_rsa_export_params_x
,
1524 "set-certificate-credentials-rsa-export-parameters!",
1526 (SCM cred
, SCM rsa_params
),
1527 "Use RSA parameters @var{rsa_params} for certificate "
1528 "credentials @var{cred}.")
1529 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_rsa_export_params_x
1531 gnutls_rsa_params_t c_rsa_params
;
1532 gnutls_certificate_credentials_t c_cred
;
1534 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
1535 c_rsa_params
= scm_to_gnutls_rsa_parameters (rsa_params
, 2, FUNC_NAME
);
1537 gnutls_certificate_set_rsa_export_params (c_cred
, c_rsa_params
);
1539 return SCM_UNSPECIFIED
;
1544 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_key_files_x
,
1545 "set-certificate-credentials-x509-key-files!",
1547 (SCM cred
, SCM cert_file
, SCM key_file
, SCM format
),
1548 "Use @var{file} as the password file for PSK server "
1549 "credentials @var{cred}.")
1550 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_key_files_x
1553 gnutls_certificate_credentials_t c_cred
;
1554 gnutls_x509_crt_fmt_t c_format
;
1555 char *c_cert_file
, *c_key_file
;
1556 size_t c_cert_file_len
, c_key_file_len
;
1558 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
1559 SCM_VALIDATE_STRING (2, cert_file
);
1560 SCM_VALIDATE_STRING (3, key_file
);
1561 c_format
= scm_to_gnutls_x509_certificate_format (format
, 2, FUNC_NAME
);
1563 c_cert_file_len
= scm_c_string_length (cert_file
);
1564 c_cert_file
= alloca (c_cert_file_len
+ 1);
1566 c_key_file_len
= scm_c_string_length (key_file
);
1567 c_key_file
= alloca (c_key_file_len
+ 1);
1569 (void) scm_to_locale_stringbuf (cert_file
, c_cert_file
,
1570 c_cert_file_len
+ 1);
1571 c_cert_file
[c_cert_file_len
] = '\0';
1572 (void) scm_to_locale_stringbuf (key_file
, c_key_file
, c_key_file_len
+ 1);
1573 c_key_file
[c_key_file_len
] = '\0';
1575 err
= gnutls_certificate_set_x509_key_file (c_cred
, c_cert_file
, c_key_file
,
1577 if (EXPECT_FALSE (err
))
1578 scm_gnutls_error (err
, FUNC_NAME
);
1580 return SCM_UNSPECIFIED
;
1585 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_trust_file_x
,
1586 "set-certificate-credentials-x509-trust-file!",
1588 (SCM cred
, SCM file
, SCM format
),
1589 "Use @var{file} as the X.509 trust file for certificate "
1590 "credentials @var{cred}. On success, return the number of "
1591 "certificates processed.")
1592 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_trust_file_x
1596 count
= set_certificate_file (gnutls_certificate_set_x509_trust_file
,
1597 cred
, file
, format
, FUNC_NAME
);
1599 return scm_from_uint (count
);
1604 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_crl_file_x
,
1605 "set-certificate-credentials-x509-crl-file!",
1607 (SCM cred
, SCM file
, SCM format
),
1608 "Use @var{file} as the X.509 CRL (certificate revocation list) "
1609 "file for certificate credentials @var{cred}. On success, "
1610 "return the number of CRLs processed.")
1611 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_crl_file_x
1615 count
= set_certificate_file (gnutls_certificate_set_x509_crl_file
,
1616 cred
, file
, format
, FUNC_NAME
);
1618 return scm_from_uint (count
);
1623 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_trust_data_x
,
1624 "set-certificate-credentials-x509-trust-data!",
1626 (SCM cred
, SCM data
, SCM format
),
1627 "Use @var{data} (a uniform array) as the X.509 trust "
1628 "database for @var{cred}. On success, return the number "
1629 "of certificates processed.")
1630 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_trust_data_x
1634 count
= set_certificate_data (gnutls_certificate_set_x509_trust_mem
,
1635 cred
, data
, format
, FUNC_NAME
);
1637 return scm_from_uint (count
);
1642 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_crl_data_x
,
1643 "set-certificate-credentials-x509-crl-data!",
1645 (SCM cred
, SCM data
, SCM format
),
1646 "Use @var{data} (a uniform array) as the X.509 CRL "
1647 "(certificate revocation list) database for @var{cred}. "
1648 "On success, return the number of CRLs processed.")
1649 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_crl_data_x
1653 count
= set_certificate_data (gnutls_certificate_set_x509_crl_mem
,
1654 cred
, data
, format
, FUNC_NAME
);
1656 return scm_from_uint (count
);
1661 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_key_data_x
,
1662 "set-certificate-credentials-x509-key-data!",
1664 (SCM cred
, SCM cert
, SCM key
, SCM format
),
1665 "Use X.509 certificate @var{cert} and private key @var{key}, "
1666 "both uniform arrays containing the X.509 certificate and key "
1667 "in format @var{format}, for certificate credentials "
1669 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_key_data_x
1672 gnutls_x509_crt_fmt_t c_format
;
1673 gnutls_certificate_credentials_t c_cred
;
1674 gnutls_datum_t c_cert_d
, c_key_d
;
1675 scm_t_array_handle c_cert_handle
, c_key_handle
;
1676 const char *c_cert
, *c_key
;
1677 size_t c_cert_len
, c_key_len
;
1679 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
1680 c_format
= scm_to_gnutls_x509_certificate_format (format
, 4, FUNC_NAME
);
1681 SCM_VALIDATE_ARRAY (2, cert
);
1682 SCM_VALIDATE_ARRAY (3, key
);
1684 /* FIXME: If the second call fails, an exception is raised and
1685 C_CERT_HANDLE is not released. */
1686 c_cert
= scm_gnutls_get_array (cert
, &c_cert_handle
, &c_cert_len
,
1688 c_key
= scm_gnutls_get_array (key
, &c_key_handle
, &c_key_len
, FUNC_NAME
);
1690 c_cert_d
.data
= (unsigned char *) c_cert
;
1691 c_cert_d
.size
= c_cert_len
;
1692 c_key_d
.data
= (unsigned char *) c_key
;
1693 c_key_d
.size
= c_key_len
;
1695 err
= gnutls_certificate_set_x509_key_mem (c_cred
, &c_cert_d
, &c_key_d
,
1697 scm_gnutls_release_array (&c_cert_handle
);
1698 scm_gnutls_release_array (&c_key_handle
);
1700 if (EXPECT_FALSE (err
))
1701 scm_gnutls_error (err
, FUNC_NAME
);
1703 return SCM_UNSPECIFIED
;
1708 SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_keys_x
,
1709 "set-certificate-credentials-x509-keys!",
1711 (SCM cred
, SCM certs
, SCM privkey
),
1712 "Have certificate credentials @var{cred} use the X.509 "
1713 "certificates listed in @var{certs} and X.509 private key "
1715 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_keys_x
1718 gnutls_x509_crt_t
*c_certs
;
1719 gnutls_x509_privkey_t c_key
;
1720 gnutls_certificate_credentials_t c_cred
;
1721 long int c_cert_count
, i
;
1723 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
1724 SCM_VALIDATE_LIST_COPYLEN (2, certs
, c_cert_count
);
1725 c_key
= scm_to_gnutls_x509_private_key (privkey
, 3, FUNC_NAME
);
1727 c_certs
= alloca (c_cert_count
* sizeof (*c_certs
));
1728 for (i
= 0; scm_is_pair (certs
); certs
= SCM_CDR (certs
), i
++)
1730 c_certs
[i
] = scm_to_gnutls_x509_certificate (SCM_CAR (certs
),
1734 err
= gnutls_certificate_set_x509_key (c_cred
, c_certs
, c_cert_count
,
1736 if (EXPECT_FALSE (err
))
1737 scm_gnutls_error (err
, FUNC_NAME
);
1739 return SCM_UNSPECIFIED
;
1744 SCM_DEFINE (scm_gnutls_set_certificate_credentials_verify_limits_x
,
1745 "set-certificate-credentials-verify-limits!",
1747 (SCM cred
, SCM max_bits
, SCM max_depth
),
1748 "Set the verification limits of @code{peer-certificate-status} "
1749 "for certificate credentials @var{cred} to @var{max_bits} "
1750 "bits for an acceptable certificate and @var{max_depth} "
1751 "as the maximum depth of a certificate chain.")
1752 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_verify_limits_x
1754 gnutls_certificate_credentials_t c_cred
;
1755 unsigned int c_max_bits
, c_max_depth
;
1757 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
1758 c_max_bits
= scm_to_uint (max_bits
);
1759 c_max_depth
= scm_to_uint (max_depth
);
1761 gnutls_certificate_set_verify_limits (c_cred
, c_max_bits
, c_max_depth
);
1763 return SCM_UNSPECIFIED
;
1768 SCM_DEFINE (scm_gnutls_set_certificate_credentials_verify_flags_x
,
1769 "set-certificate-credentials-verify-flags!",
1771 (SCM cred
, SCM flags
),
1772 "Set the certificate verification flags to @var{flags}, a "
1773 "series of @code{certificate-verify} values.")
1774 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_verify_flags_x
1776 unsigned int c_flags
, c_pos
;
1777 gnutls_certificate_credentials_t c_cred
;
1779 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
1781 for (c_flags
= 0, c_pos
= 2;
1782 !scm_is_null (flags
); flags
= SCM_CDR (flags
), c_pos
++)
1784 c_flags
|= (unsigned int)
1785 scm_to_gnutls_certificate_verify (SCM_CAR (flags
), c_pos
, FUNC_NAME
);
1788 gnutls_certificate_set_verify_flags (c_cred
, c_flags
);
1790 return SCM_UNSPECIFIED
;
1795 SCM_DEFINE (scm_gnutls_peer_certificate_status
, "peer-certificate-status",
1798 "Verify the peer certificate for @var{session} and return "
1799 "a list of @code{certificate-status} values (such as "
1800 "@code{certificate-status/revoked}), or the empty list if "
1801 "the certificate is valid.")
1802 #define FUNC_NAME s_scm_gnutls_peer_certificate_status
1805 unsigned int c_status
;
1806 gnutls_session_t c_session
;
1807 SCM result
= SCM_EOL
;
1809 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
1811 err
= gnutls_certificate_verify_peers2 (c_session
, &c_status
);
1812 if (EXPECT_FALSE (err
))
1813 scm_gnutls_error (err
, FUNC_NAME
);
1815 #define MATCH_STATUS(_value) \
1816 if (c_status & (_value)) \
1818 result = scm_cons (scm_from_gnutls_certificate_status (_value), \
1820 c_status &= ~(_value); \
1823 MATCH_STATUS (GNUTLS_CERT_INVALID
);
1824 MATCH_STATUS (GNUTLS_CERT_REVOKED
);
1825 MATCH_STATUS (GNUTLS_CERT_SIGNER_NOT_FOUND
);
1826 MATCH_STATUS (GNUTLS_CERT_SIGNER_NOT_CA
);
1827 MATCH_STATUS (GNUTLS_CERT_INSECURE_ALGORITHM
);
1829 if (EXPECT_FALSE (c_status
!= 0))
1830 /* XXX: We failed to interpret one of the status flags. */
1831 scm_gnutls_error (GNUTLS_E_UNIMPLEMENTED_FEATURE
, FUNC_NAME
);
1841 /* SRP credentials. */
1844 SCM_DEFINE (scm_gnutls_make_srp_server_credentials
,
1845 "make-srp-server-credentials",
1846 0, 0, 0, (void), "Return new SRP server credentials.")
1847 #define FUNC_NAME s_scm_gnutls_make_srp_server_credentials
1850 gnutls_srp_server_credentials_t c_cred
;
1852 err
= gnutls_srp_allocate_server_credentials (&c_cred
);
1853 if (EXPECT_FALSE (err
))
1854 scm_gnutls_error (err
, FUNC_NAME
);
1856 return (scm_from_gnutls_srp_server_credentials (c_cred
));
1861 SCM_DEFINE (scm_gnutls_set_srp_server_credentials_files_x
,
1862 "set-srp-server-credentials-files!",
1864 (SCM cred
, SCM password_file
, SCM password_conf_file
),
1865 "Set the credentials files for @var{cred}, an SRP server "
1866 "credentials object.")
1867 #define FUNC_NAME s_scm_gnutls_set_srp_server_credentials_files_x
1870 gnutls_srp_server_credentials_t c_cred
;
1871 char *c_password_file
, *c_password_conf_file
;
1872 size_t c_password_file_len
, c_password_conf_file_len
;
1874 c_cred
= scm_to_gnutls_srp_server_credentials (cred
, 1, FUNC_NAME
);
1875 SCM_VALIDATE_STRING (2, password_file
);
1876 SCM_VALIDATE_STRING (3, password_conf_file
);
1878 c_password_file_len
= scm_c_string_length (password_file
);
1879 c_password_conf_file_len
= scm_c_string_length (password_conf_file
);
1881 c_password_file
= alloca (c_password_file_len
+ 1);
1882 c_password_conf_file
= alloca (c_password_conf_file_len
+ 1);
1884 (void) scm_to_locale_stringbuf (password_file
, c_password_file
,
1885 c_password_file_len
+ 1);
1886 c_password_file
[c_password_file_len
] = '\0';
1887 (void) scm_to_locale_stringbuf (password_conf_file
, c_password_conf_file
,
1888 c_password_conf_file_len
+ 1);
1889 c_password_conf_file
[c_password_conf_file_len
] = '\0';
1891 err
= gnutls_srp_set_server_credentials_file (c_cred
, c_password_file
,
1892 c_password_conf_file
);
1893 if (EXPECT_FALSE (err
))
1894 scm_gnutls_error (err
, FUNC_NAME
);
1896 return SCM_UNSPECIFIED
;
1901 SCM_DEFINE (scm_gnutls_make_srp_client_credentials
,
1902 "make-srp-client-credentials",
1903 0, 0, 0, (void), "Return new SRP client credentials.")
1904 #define FUNC_NAME s_scm_gnutls_make_srp_client_credentials
1907 gnutls_srp_client_credentials_t c_cred
;
1909 err
= gnutls_srp_allocate_client_credentials (&c_cred
);
1910 if (EXPECT_FALSE (err
))
1911 scm_gnutls_error (err
, FUNC_NAME
);
1913 return (scm_from_gnutls_srp_client_credentials (c_cred
));
1919 SCM_DEFINE (scm_gnutls_set_srp_client_credentials_x
,
1920 "set-srp-client-credentials!",
1922 (SCM cred
, SCM username
, SCM password
),
1923 "Use @var{username} and @var{password} as the credentials "
1924 "for @var{cred}, a client-side SRP credentials object.")
1925 #define FUNC_NAME s_scm_gnutls_make_srp_client_credentials
1928 gnutls_srp_client_credentials_t c_cred
;
1929 char *c_username
, *c_password
;
1930 size_t c_username_len
, c_password_len
;
1932 c_cred
= scm_to_gnutls_srp_client_credentials (cred
, 1, FUNC_NAME
);
1933 SCM_VALIDATE_STRING (2, username
);
1934 SCM_VALIDATE_STRING (3, password
);
1936 c_username_len
= scm_c_string_length (username
);
1937 c_password_len
= scm_c_string_length (password
);
1939 c_username
= alloca (c_username_len
+ 1);
1940 c_password
= alloca (c_password_len
+ 1);
1942 (void) scm_to_locale_stringbuf (username
, c_username
, c_username_len
+ 1);
1943 c_username
[c_username_len
] = '\0';
1944 (void) scm_to_locale_stringbuf (password
, c_password
, c_password_len
+ 1);
1945 c_password
[c_password_len
] = '\0';
1947 err
= gnutls_srp_set_client_credentials (c_cred
, c_username
, c_password
);
1948 if (EXPECT_FALSE (err
))
1949 scm_gnutls_error (err
, FUNC_NAME
);
1951 return SCM_UNSPECIFIED
;
1956 SCM_DEFINE (scm_gnutls_server_session_srp_username
,
1957 "server-session-srp-username",
1960 "Return the SRP username used in @var{session} (a server-side "
1962 #define FUNC_NAME s_scm_gnutls_server_session_srp_username
1965 const char *c_username
;
1966 gnutls_session_t c_session
;
1968 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
1969 c_username
= gnutls_srp_server_get_username (c_session
);
1971 if (EXPECT_FALSE (c_username
== NULL
))
1972 result
= SCM_BOOL_F
;
1974 result
= scm_from_locale_string (c_username
);
1981 SCM_DEFINE (scm_gnutls_srp_base64_encode
, "srp-base64-encode",
1984 "Encode @var{str} using SRP's base64 algorithm. Return "
1985 "the encoded string.")
1986 #define FUNC_NAME s_scm_gnutls_srp_base64_encode
1989 char *c_str
, *c_result
;
1990 size_t c_str_len
, c_result_len
, c_result_actual_len
;
1991 gnutls_datum_t c_str_d
;
1993 SCM_VALIDATE_STRING (1, str
);
1995 c_str_len
= scm_c_string_length (str
);
1996 c_str
= alloca (c_str_len
+ 1);
1997 (void) scm_to_locale_stringbuf (str
, c_str
, c_str_len
+ 1);
1998 c_str
[c_str_len
] = '\0';
2000 /* Typical size ratio is 4/3 so 3/2 is an upper bound. */
2001 c_result_len
= (c_str_len
* 3) / 2;
2002 c_result
= (char *) scm_malloc (c_result_len
);
2003 if (EXPECT_FALSE (c_result
== NULL
))
2004 scm_gnutls_error (GNUTLS_E_MEMORY_ERROR
, FUNC_NAME
);
2006 c_str_d
.data
= (unsigned char *) c_str
;
2007 c_str_d
.size
= c_str_len
;
2011 c_result_actual_len
= c_result_len
;
2012 err
= gnutls_srp_base64_encode (&c_str_d
, c_result
,
2013 &c_result_actual_len
);
2014 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
2018 c_new_buf
= scm_realloc (c_result
, c_result_len
* 2);
2019 if (EXPECT_FALSE (c_new_buf
== NULL
))
2022 scm_gnutls_error (GNUTLS_E_MEMORY_ERROR
, FUNC_NAME
);
2025 c_result
= c_new_buf
, c_result_len
*= 2;
2028 while (EXPECT_FALSE (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
));
2030 if (EXPECT_FALSE (err
))
2031 scm_gnutls_error (err
, FUNC_NAME
);
2033 if (c_result_actual_len
+ 1 < c_result_len
)
2034 /* Shrink the buffer. */
2035 c_result
= scm_realloc (c_result
, c_result_actual_len
+ 1);
2037 c_result
[c_result_actual_len
] = '\0';
2039 return (scm_take_locale_string (c_result
));
2044 SCM_DEFINE (scm_gnutls_srp_base64_decode
, "srp-base64-decode",
2047 "Decode @var{str}, an SRP-base64 encoded string, and return "
2048 "the decoded string.")
2049 #define FUNC_NAME s_scm_gnutls_srp_base64_decode
2052 char *c_str
, *c_result
;
2053 size_t c_str_len
, c_result_len
, c_result_actual_len
;
2054 gnutls_datum_t c_str_d
;
2056 SCM_VALIDATE_STRING (1, str
);
2058 c_str_len
= scm_c_string_length (str
);
2059 c_str
= alloca (c_str_len
+ 1);
2060 (void) scm_to_locale_stringbuf (str
, c_str
, c_str_len
+ 1);
2061 c_str
[c_str_len
] = '\0';
2063 /* We assume that the decoded string is smaller than the encoded
2065 c_result_len
= c_str_len
;
2066 c_result
= alloca (c_result_len
);
2068 c_str_d
.data
= (unsigned char *) c_str
;
2069 c_str_d
.size
= c_str_len
;
2071 c_result_actual_len
= c_result_len
;
2072 err
= gnutls_srp_base64_decode (&c_str_d
, c_result
, &c_result_actual_len
);
2073 if (EXPECT_FALSE (err
))
2074 scm_gnutls_error (err
, FUNC_NAME
);
2076 c_result
[c_result_actual_len
] = '\0';
2078 return (scm_from_locale_string (c_result
));
2082 #endif /* ENABLE_SRP */
2085 /* PSK credentials. */
2087 SCM_DEFINE (scm_gnutls_make_psk_server_credentials
,
2088 "make-psk-server-credentials",
2089 0, 0, 0, (void), "Return new PSK server credentials.")
2090 #define FUNC_NAME s_scm_gnutls_make_psk_server_credentials
2093 gnutls_psk_server_credentials_t c_cred
;
2095 err
= gnutls_psk_allocate_server_credentials (&c_cred
);
2096 if (EXPECT_FALSE (err
))
2097 scm_gnutls_error (err
, FUNC_NAME
);
2099 return (scm_from_gnutls_psk_server_credentials (c_cred
));
2104 SCM_DEFINE (scm_gnutls_set_psk_server_credentials_file_x
,
2105 "set-psk-server-credentials-file!",
2107 (SCM cred
, SCM file
),
2108 "Use @var{file} as the password file for PSK server "
2109 "credentials @var{cred}.")
2110 #define FUNC_NAME s_scm_gnutls_set_psk_server_credentials_file_x
2113 gnutls_psk_server_credentials_t c_cred
;
2117 c_cred
= scm_to_gnutls_psk_server_credentials (cred
, 1, FUNC_NAME
);
2118 SCM_VALIDATE_STRING (2, file
);
2120 c_file_len
= scm_c_string_length (file
);
2121 c_file
= alloca (c_file_len
+ 1);
2123 (void) scm_to_locale_stringbuf (file
, c_file
, c_file_len
+ 1);
2124 c_file
[c_file_len
] = '\0';
2126 err
= gnutls_psk_set_server_credentials_file (c_cred
, c_file
);
2127 if (EXPECT_FALSE (err
))
2128 scm_gnutls_error (err
, FUNC_NAME
);
2130 return SCM_UNSPECIFIED
;
2135 SCM_DEFINE (scm_gnutls_make_psk_client_credentials
,
2136 "make-psk-client-credentials",
2137 0, 0, 0, (void), "Return a new PSK client credentials object.")
2138 #define FUNC_NAME s_scm_gnutls_make_psk_client_credentials
2141 gnutls_psk_client_credentials_t c_cred
;
2143 err
= gnutls_psk_allocate_client_credentials (&c_cred
);
2144 if (EXPECT_FALSE (err
))
2145 scm_gnutls_error (err
, FUNC_NAME
);
2147 return (scm_from_gnutls_psk_client_credentials (c_cred
));
2152 SCM_DEFINE (scm_gnutls_set_psk_client_credentials_x
,
2153 "set-psk-client-credentials!",
2155 (SCM cred
, SCM username
, SCM key
, SCM key_format
),
2156 "Set the client credentials for @var{cred}, a PSK client "
2157 "credentials object.")
2158 #define FUNC_NAME s_scm_gnutls_set_psk_client_credentials_x
2161 gnutls_psk_client_credentials_t c_cred
;
2162 gnutls_psk_key_flags c_key_format
;
2163 scm_t_array_handle c_handle
;
2166 size_t c_username_len
, c_key_len
;
2167 gnutls_datum_t c_datum
;
2169 c_cred
= scm_to_gnutls_psk_client_credentials (cred
, 1, FUNC_NAME
);
2170 SCM_VALIDATE_STRING (2, username
);
2171 SCM_VALIDATE_ARRAY (3, key
);
2172 c_key_format
= scm_to_gnutls_psk_key_format (key_format
, 4, FUNC_NAME
);
2174 c_username_len
= scm_c_string_length (username
);
2175 c_username
= alloca (c_username_len
+ 1);
2177 (void) scm_to_locale_stringbuf (username
, c_username
, c_username_len
+ 1);
2178 c_username
[c_username_len
] = '\0';
2180 c_key
= scm_gnutls_get_array (key
, &c_handle
, &c_key_len
, FUNC_NAME
);
2181 c_datum
.data
= (unsigned char *) c_key
;
2182 c_datum
.size
= c_key_len
;
2184 err
= gnutls_psk_set_client_credentials (c_cred
, c_username
,
2185 &c_datum
, c_key_format
);
2186 scm_gnutls_release_array (&c_handle
);
2188 if (EXPECT_FALSE (err
))
2189 scm_gnutls_error (err
, FUNC_NAME
);
2191 return SCM_UNSPECIFIED
;
2196 SCM_DEFINE (scm_gnutls_server_session_psk_username
,
2197 "server-session-psk-username",
2200 "Return the username associated with PSK server session "
2202 #define FUNC_NAME s_scm_gnutls_server_session_psk_username
2205 const char *c_username
;
2206 gnutls_session_t c_session
;
2208 c_session
= scm_to_gnutls_session (session
, 1, FUNC_NAME
);
2209 c_username
= gnutls_srp_server_get_username (c_session
);
2211 if (EXPECT_FALSE (c_username
== NULL
))
2212 result
= SCM_BOOL_F
;
2214 result
= scm_from_locale_string (c_username
);
2222 /* X.509 certificates. */
2224 SCM_DEFINE (scm_gnutls_import_x509_certificate
, "import-x509-certificate",
2226 (SCM data
, SCM format
),
2227 "Return a new X.509 certificate object resulting from the "
2228 "import of @var{data} (a uniform array) according to "
2230 #define FUNC_NAME s_scm_gnutls_import_x509_certificate
2233 gnutls_x509_crt_t c_cert
;
2234 gnutls_x509_crt_fmt_t c_format
;
2235 gnutls_datum_t c_data_d
;
2236 scm_t_array_handle c_data_handle
;
2240 SCM_VALIDATE_ARRAY (1, data
);
2241 c_format
= scm_to_gnutls_x509_certificate_format (format
, 2, FUNC_NAME
);
2243 c_data
= scm_gnutls_get_array (data
, &c_data_handle
, &c_data_len
,
2245 c_data_d
.data
= (unsigned char *) c_data
;
2246 c_data_d
.size
= c_data_len
;
2248 err
= gnutls_x509_crt_init (&c_cert
);
2249 if (EXPECT_FALSE (err
))
2251 scm_gnutls_release_array (&c_data_handle
);
2252 scm_gnutls_error (err
, FUNC_NAME
);
2255 err
= gnutls_x509_crt_import (c_cert
, &c_data_d
, c_format
);
2256 scm_gnutls_release_array (&c_data_handle
);
2258 if (EXPECT_FALSE (err
))
2260 gnutls_x509_crt_deinit (c_cert
);
2261 scm_gnutls_error (err
, FUNC_NAME
);
2264 return (scm_from_gnutls_x509_certificate (c_cert
));
2269 SCM_DEFINE (scm_gnutls_import_x509_private_key
, "import-x509-private-key",
2271 (SCM data
, SCM format
),
2272 "Return a new X.509 private key object resulting from the "
2273 "import of @var{data} (a uniform array) according to "
2275 #define FUNC_NAME s_scm_gnutls_import_x509_private_key
2278 gnutls_x509_privkey_t c_key
;
2279 gnutls_x509_crt_fmt_t c_format
;
2280 gnutls_datum_t c_data_d
;
2281 scm_t_array_handle c_data_handle
;
2285 SCM_VALIDATE_ARRAY (1, data
);
2286 c_format
= scm_to_gnutls_x509_certificate_format (format
, 2, FUNC_NAME
);
2288 c_data
= scm_gnutls_get_array (data
, &c_data_handle
, &c_data_len
,
2290 c_data_d
.data
= (unsigned char *) c_data
;
2291 c_data_d
.size
= c_data_len
;
2293 err
= gnutls_x509_privkey_init (&c_key
);
2294 if (EXPECT_FALSE (err
))
2296 scm_gnutls_release_array (&c_data_handle
);
2297 scm_gnutls_error (err
, FUNC_NAME
);
2300 err
= gnutls_x509_privkey_import (c_key
, &c_data_d
, c_format
);
2301 scm_gnutls_release_array (&c_data_handle
);
2303 if (EXPECT_FALSE (err
))
2305 gnutls_x509_privkey_deinit (c_key
);
2306 scm_gnutls_error (err
, FUNC_NAME
);
2309 return (scm_from_gnutls_x509_private_key (c_key
));
2314 SCM_DEFINE (scm_gnutls_pkcs8_import_x509_private_key
,
2315 "pkcs8-import-x509-private-key",
2317 (SCM data
, SCM format
, SCM pass
, SCM encrypted
),
2318 "Return a new X.509 private key object resulting from the "
2319 "import of @var{data} (a uniform array) according to "
2320 "@var{format}. Optionally, if @var{pass} is not @code{#f}, "
2321 "it should be a string denoting a passphrase. "
2322 "@var{encrypted} tells whether the private key is encrypted "
2323 "(@code{#t} by default).")
2324 #define FUNC_NAME s_scm_gnutls_pkcs8_import_x509_private_key
2327 gnutls_x509_privkey_t c_key
;
2328 gnutls_x509_crt_fmt_t c_format
;
2329 unsigned int c_flags
;
2330 gnutls_datum_t c_data_d
;
2331 scm_t_array_handle c_data_handle
;
2334 size_t c_data_len
, c_pass_len
;
2336 SCM_VALIDATE_ARRAY (1, data
);
2337 c_format
= scm_to_gnutls_x509_certificate_format (format
, 2, FUNC_NAME
);
2338 if ((pass
== SCM_UNDEFINED
) || (scm_is_false (pass
)))
2342 c_pass_len
= scm_c_string_length (pass
);
2343 c_pass
= alloca (c_pass_len
+ 1);
2344 (void) scm_to_locale_stringbuf (pass
, c_pass
, c_pass_len
+ 1);
2345 c_pass
[c_pass_len
] = '\0';
2348 if (encrypted
== SCM_UNDEFINED
)
2352 SCM_VALIDATE_BOOL (4, encrypted
);
2353 if (scm_is_true (encrypted
))
2356 c_flags
= GNUTLS_PKCS8_PLAIN
;
2359 c_data
= scm_gnutls_get_array (data
, &c_data_handle
, &c_data_len
,
2361 c_data_d
.data
= (unsigned char *) c_data
;
2362 c_data_d
.size
= c_data_len
;
2364 err
= gnutls_x509_privkey_init (&c_key
);
2365 if (EXPECT_FALSE (err
))
2367 scm_gnutls_release_array (&c_data_handle
);
2368 scm_gnutls_error (err
, FUNC_NAME
);
2371 err
= gnutls_x509_privkey_import_pkcs8 (c_key
, &c_data_d
, c_format
, c_pass
,
2373 scm_gnutls_release_array (&c_data_handle
);
2375 if (EXPECT_FALSE (err
))
2377 gnutls_x509_privkey_deinit (c_key
);
2378 scm_gnutls_error (err
, FUNC_NAME
);
2381 return (scm_from_gnutls_x509_private_key (c_key
));
2386 /* Provide the body of a `get_dn' function. */
2387 #define X509_CERTIFICATE_DN_FUNCTION_BODY(get_the_dn) \
2389 gnutls_x509_crt_t c_cert; \
2393 c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME); \
2395 /* Get the DN size. */ \
2396 (void) get_the_dn (c_cert, NULL, &c_dn_len); \
2398 /* Get the DN itself. */ \
2399 c_dn = alloca (c_dn_len); \
2400 err = get_the_dn (c_cert, c_dn, &c_dn_len); \
2402 if (EXPECT_FALSE (err)) \
2403 scm_gnutls_error (err, FUNC_NAME); \
2405 /* XXX: The returned string is actually ASCII or UTF-8. */ \
2406 return (scm_from_locale_string (c_dn));
2408 SCM_DEFINE (scm_gnutls_x509_certificate_dn
, "x509-certificate-dn",
2411 "Return the distinguished name (DN) of X.509 certificate "
2412 "@var{cert}. The form of the DN is as described in @uref{"
2413 "http://tools.ietf.org/html/rfc2253, RFC 2253}.")
2414 #define FUNC_NAME s_scm_gnutls_x509_certificate_dn
2416 X509_CERTIFICATE_DN_FUNCTION_BODY (gnutls_x509_crt_get_dn
);
2421 SCM_DEFINE (scm_gnutls_x509_certificate_issuer_dn
,
2422 "x509-certificate-issuer-dn",
2425 "Return the distinguished name (DN) of X.509 certificate "
2427 #define FUNC_NAME s_scm_gnutls_x509_certificate_issuer_dn
2429 X509_CERTIFICATE_DN_FUNCTION_BODY (gnutls_x509_crt_get_issuer_dn
);
2434 #undef X509_CERTIFICATE_DN_FUNCTION_BODY
2437 /* Provide the body of a `get_dn_oid' function. */
2438 #define X509_CERTIFICATE_DN_OID_FUNCTION_BODY(get_dn_oid) \
2440 gnutls_x509_crt_t c_cert; \
2441 unsigned int c_index; \
2443 size_t c_oid_actual_len, c_oid_len; \
2446 c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME); \
2447 c_index = scm_to_uint (index); \
2450 c_oid = scm_malloc (c_oid_len); \
2454 c_oid_actual_len = c_oid_len; \
2455 err = get_dn_oid (c_cert, c_index, c_oid, &c_oid_actual_len); \
2456 if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) \
2458 c_oid = scm_realloc (c_oid, c_oid_len * 2); \
2462 while (err == GNUTLS_E_SHORT_MEMORY_BUFFER); \
2464 if (EXPECT_FALSE (err)) \
2468 if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE) \
2469 result = SCM_BOOL_F; \
2471 scm_gnutls_error (err, FUNC_NAME); \
2475 if (c_oid_actual_len < c_oid_len) \
2476 c_oid = scm_realloc (c_oid, c_oid_actual_len); \
2478 result = scm_take_locale_stringn (c_oid, \
2479 c_oid_actual_len); \
2484 SCM_DEFINE (scm_gnutls_x509_certificate_dn_oid
, "x509-certificate-dn-oid",
2486 (SCM cert
, SCM index
),
2487 "Return OID (a string) at @var{index} from @var{cert}. "
2488 "Return @code{#f} if no OID is available at @var{index}.")
2489 #define FUNC_NAME s_scm_gnutls_x509_certificate_dn_oid
2491 X509_CERTIFICATE_DN_OID_FUNCTION_BODY (gnutls_x509_crt_get_dn_oid
);
2496 SCM_DEFINE (scm_gnutls_x509_certificate_issuer_dn_oid
,
2497 "x509-certificate-issuer-dn-oid",
2499 (SCM cert
, SCM index
),
2500 "Return the OID (a string) at @var{index} from @var{cert}'s "
2501 "issuer DN. Return @code{#f} if no OID is available at "
2503 #define FUNC_NAME s_scm_gnutls_x509_certificate_issuer_dn_oid
2505 X509_CERTIFICATE_DN_OID_FUNCTION_BODY (gnutls_x509_crt_get_issuer_dn_oid
);
2510 #undef X509_CERTIFICATE_DN_OID_FUNCTION_BODY
2513 SCM_DEFINE (scm_gnutls_x509_certificate_matches_hostname_p
,
2514 "x509-certificate-matches-hostname?",
2516 (SCM cert
, SCM hostname
),
2517 "Return true if @var{cert} matches @var{hostname}, a string "
2518 "denoting a DNS host name. This is the basic implementation "
2519 "of @uref{http://tools.ietf.org/html/rfc2818, RFC 2818} (aka. "
2521 #define FUNC_NAME s_scm_gnutls_x509_certificate_matches_hostname_p
2524 gnutls_x509_crt_t c_cert
;
2526 size_t c_hostname_len
;
2528 c_cert
= scm_to_gnutls_x509_certificate (cert
, 1, FUNC_NAME
);
2529 SCM_VALIDATE_STRING (2, hostname
);
2531 c_hostname_len
= scm_c_string_length (hostname
);
2532 c_hostname
= alloca (c_hostname_len
+ 1);
2534 (void) scm_to_locale_stringbuf (hostname
, c_hostname
, c_hostname_len
+ 1);
2535 c_hostname
[c_hostname_len
] = '\0';
2537 if (gnutls_x509_crt_check_hostname (c_cert
, c_hostname
))
2538 result
= SCM_BOOL_T
;
2540 result
= SCM_BOOL_F
;
2547 SCM_DEFINE (scm_gnutls_x509_certificate_signature_algorithm
,
2548 "x509-certificate-signature-algorithm",
2551 "Return the signature algorithm used by @var{cert} (i.e., "
2552 "one of the @code{sign-algorithm/} values).")
2553 #define FUNC_NAME s_scm_gnutls_x509_certificate_signature_algorithm
2556 gnutls_x509_crt_t c_cert
;
2558 c_cert
= scm_to_gnutls_x509_certificate (cert
, 1, FUNC_NAME
);
2560 c_result
= gnutls_x509_crt_get_signature_algorithm (c_cert
);
2561 if (EXPECT_FALSE (c_result
< 0))
2562 scm_gnutls_error (c_result
, FUNC_NAME
);
2564 return (scm_from_gnutls_sign_algorithm (c_result
));
2569 SCM_DEFINE (scm_gnutls_x509_certificate_public_key_algorithm
,
2570 "x509-certificate-public-key-algorithm",
2573 "Return two values: the public key algorithm (i.e., "
2574 "one of the @code{pk-algorithm/} values) of @var{cert} "
2575 "and the number of bits used.")
2576 #define FUNC_NAME s_scm_gnutls_x509_certificate_public_key_algorithm
2578 gnutls_x509_crt_t c_cert
;
2579 gnutls_pk_algorithm_t c_pk
;
2580 unsigned int c_bits
;
2582 c_cert
= scm_to_gnutls_x509_certificate (cert
, 1, FUNC_NAME
);
2584 c_pk
= gnutls_x509_crt_get_pk_algorithm (c_cert
, &c_bits
);
2586 return (scm_values (scm_list_2 (scm_from_gnutls_pk_algorithm (c_pk
),
2587 scm_from_uint (c_bits
))));
2592 SCM_DEFINE (scm_gnutls_x509_certificate_key_usage
,
2593 "x509-certificate-key-usage",
2596 "Return the key usage of @var{cert} (i.e., a list of "
2597 "@code{key-usage/} values), or the empty list if @var{cert} "
2598 "does not contain such information.")
2599 #define FUNC_NAME s_scm_gnutls_x509_certificate_key_usage
2603 gnutls_x509_crt_t c_cert
;
2604 unsigned int c_usage
, c_critical
;
2606 c_cert
= scm_to_gnutls_x509_certificate (cert
, 1, FUNC_NAME
);
2608 err
= gnutls_x509_crt_get_key_usage (c_cert
, &c_usage
, &c_critical
);
2609 if (EXPECT_FALSE (err
))
2611 if (err
== GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE
)
2614 scm_gnutls_error (err
, FUNC_NAME
);
2617 usage
= scm_from_gnutls_key_usage_flags (c_usage
);
2624 SCM_DEFINE (scm_gnutls_x509_certificate_version
, "x509-certificate-version",
2625 1, 0, 0, (SCM cert
), "Return the version of @var{cert}.")
2626 #define FUNC_NAME s_scm_gnutls_x509_certificate_version
2629 gnutls_x509_crt_t c_cert
;
2631 c_cert
= scm_to_gnutls_x509_certificate (cert
, 1, FUNC_NAME
);
2633 c_result
= gnutls_x509_crt_get_version (c_cert
);
2634 if (EXPECT_FALSE (c_result
< 0))
2635 scm_gnutls_error (c_result
, FUNC_NAME
);
2637 return (scm_from_int (c_result
));
2642 SCM_DEFINE (scm_gnutls_x509_certificate_key_id
, "x509-certificate-key-id",
2645 "Return a statistically unique ID (a u8vector) for @var{cert} "
2646 "that depends on its public key parameters. This is normally "
2647 "a 20-byte SHA-1 hash.")
2648 #define FUNC_NAME s_scm_gnutls_x509_certificate_key_id
2652 scm_t_array_handle c_id_handle
;
2653 gnutls_x509_crt_t c_cert
;
2655 size_t c_id_len
= 20;
2657 c_cert
= scm_to_gnutls_x509_certificate (cert
, 1, FUNC_NAME
);
2659 result
= scm_make_u8vector (scm_from_uint (c_id_len
), SCM_INUM0
);
2660 scm_array_get_handle (result
, &c_id_handle
);
2661 c_id
= scm_array_handle_u8_writable_elements (&c_id_handle
);
2663 err
= gnutls_x509_crt_get_key_id (c_cert
, 0, c_id
, &c_id_len
);
2664 scm_array_handle_release (&c_id_handle
);
2666 if (EXPECT_FALSE (err
))
2667 scm_gnutls_error (err
, FUNC_NAME
);
2674 SCM_DEFINE (scm_gnutls_x509_certificate_authority_key_id
,
2675 "x509-certificate-authority-key-id",
2678 "Return the key ID (a u8vector) of the X.509 certificate "
2679 "authority of @var{cert}.")
2680 #define FUNC_NAME s_scm_gnutls_x509_certificate_authority_key_id
2684 scm_t_array_handle c_id_handle
;
2685 gnutls_x509_crt_t c_cert
;
2687 size_t c_id_len
= 20;
2689 c_cert
= scm_to_gnutls_x509_certificate (cert
, 1, FUNC_NAME
);
2691 result
= scm_make_u8vector (scm_from_uint (c_id_len
), SCM_INUM0
);
2692 scm_array_get_handle (result
, &c_id_handle
);
2693 c_id
= scm_array_handle_u8_writable_elements (&c_id_handle
);
2695 err
= gnutls_x509_crt_get_authority_key_id (c_cert
, c_id
, &c_id_len
, NULL
);
2696 scm_array_handle_release (&c_id_handle
);
2698 if (EXPECT_FALSE (err
))
2699 scm_gnutls_error (err
, FUNC_NAME
);
2706 SCM_DEFINE (scm_gnutls_x509_certificate_subject_key_id
,
2707 "x509-certificate-subject-key-id",
2710 "Return the subject key ID (a u8vector) for @var{cert}.")
2711 #define FUNC_NAME s_scm_gnutls_x509_certificate_subject_key_id
2715 scm_t_array_handle c_id_handle
;
2716 gnutls_x509_crt_t c_cert
;
2718 size_t c_id_len
= 20;
2720 c_cert
= scm_to_gnutls_x509_certificate (cert
, 1, FUNC_NAME
);
2722 result
= scm_make_u8vector (scm_from_uint (c_id_len
), SCM_INUM0
);
2723 scm_array_get_handle (result
, &c_id_handle
);
2724 c_id
= scm_array_handle_u8_writable_elements (&c_id_handle
);
2726 err
= gnutls_x509_crt_get_subject_key_id (c_cert
, c_id
, &c_id_len
, NULL
);
2727 scm_array_handle_release (&c_id_handle
);
2729 if (EXPECT_FALSE (err
))
2730 scm_gnutls_error (err
, FUNC_NAME
);
2737 SCM_DEFINE (scm_gnutls_x509_certificate_subject_alternative_name
,
2738 "x509-certificate-subject-alternative-name",
2740 (SCM cert
, SCM index
),
2741 "Return two values: the alternative name type for @var{cert} "
2742 "(i.e., one of the @code{x509-subject-alternative-name/} values) "
2743 "and the actual subject alternative name (a string) at "
2744 "@var{index}. Both values are @code{#f} if no alternative name "
2745 "is available at @var{index}.")
2746 #define FUNC_NAME s_scm_gnutls_x509_certificate_subject_alternative_name
2750 gnutls_x509_crt_t c_cert
;
2751 unsigned int c_index
;
2753 size_t c_name_len
= 512, c_name_actual_len
;
2755 c_cert
= scm_to_gnutls_x509_certificate (cert
, 1, FUNC_NAME
);
2756 c_index
= scm_to_uint (index
);
2758 c_name
= scm_malloc (c_name_len
);
2761 c_name_actual_len
= c_name_len
;
2762 err
= gnutls_x509_crt_get_subject_alt_name (c_cert
, c_index
,
2763 c_name
, &c_name_actual_len
,
2765 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
2767 c_name
= scm_realloc (c_name
, c_name_len
* 2);
2771 while (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
);
2773 if (EXPECT_FALSE (err
< 0))
2777 if (err
== GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE
)
2778 result
= scm_values (scm_list_2 (SCM_BOOL_F
, SCM_BOOL_F
));
2780 scm_gnutls_error (err
, FUNC_NAME
);
2784 if (c_name_actual_len
< c_name_len
)
2785 c_name
= scm_realloc (c_name
, c_name_actual_len
);
2788 scm_values (scm_list_2
2789 (scm_from_gnutls_x509_subject_alternative_name (err
),
2790 scm_take_locale_string (c_name
)));
2802 /* Maximum size we support for the name of OpenPGP keys. */
2803 #define GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH 2048
2805 SCM_DEFINE (scm_gnutls_import_openpgp_certificate
,
2806 "import-openpgp-certificate", 2, 0, 0, (SCM data
, SCM format
),
2807 "Return a new OpenPGP certificate object resulting from the "
2808 "import of @var{data} (a uniform array) according to "
2810 #define FUNC_NAME s_scm_gnutls_import_openpgp_certificate
2813 gnutls_openpgp_crt_t c_key
;
2814 gnutls_openpgp_crt_fmt_t c_format
;
2815 gnutls_datum_t c_data_d
;
2816 scm_t_array_handle c_data_handle
;
2820 SCM_VALIDATE_ARRAY (1, data
);
2821 c_format
= scm_to_gnutls_openpgp_certificate_format (format
, 2, FUNC_NAME
);
2823 c_data
= scm_gnutls_get_array (data
, &c_data_handle
, &c_data_len
,
2825 c_data_d
.data
= (unsigned char *) c_data
;
2826 c_data_d
.size
= c_data_len
;
2828 err
= gnutls_openpgp_crt_init (&c_key
);
2829 if (EXPECT_FALSE (err
))
2831 scm_gnutls_release_array (&c_data_handle
);
2832 scm_gnutls_error (err
, FUNC_NAME
);
2835 err
= gnutls_openpgp_crt_import (c_key
, &c_data_d
, c_format
);
2836 scm_gnutls_release_array (&c_data_handle
);
2838 if (EXPECT_FALSE (err
))
2840 gnutls_openpgp_crt_deinit (c_key
);
2841 scm_gnutls_error (err
, FUNC_NAME
);
2844 return (scm_from_gnutls_openpgp_certificate (c_key
));
2849 SCM_DEFINE (scm_gnutls_import_openpgp_private_key
,
2850 "import-openpgp-private-key", 2, 1, 0, (SCM data
, SCM format
,
2852 "Return a new OpenPGP private key object resulting from the "
2853 "import of @var{data} (a uniform array) according to "
2854 "@var{format}. Optionally, a passphrase may be provided.")
2855 #define FUNC_NAME s_scm_gnutls_import_openpgp_private_key
2858 gnutls_openpgp_privkey_t c_key
;
2859 gnutls_openpgp_crt_fmt_t c_format
;
2860 gnutls_datum_t c_data_d
;
2861 scm_t_array_handle c_data_handle
;
2864 size_t c_data_len
, c_pass_len
;
2866 SCM_VALIDATE_ARRAY (1, data
);
2867 c_format
= scm_to_gnutls_openpgp_certificate_format (format
, 2, FUNC_NAME
);
2868 if ((pass
== SCM_UNDEFINED
) || (scm_is_false (pass
)))
2872 c_pass_len
= scm_c_string_length (pass
);
2873 c_pass
= alloca (c_pass_len
+ 1);
2874 (void) scm_to_locale_stringbuf (pass
, c_pass
, c_pass_len
+ 1);
2875 c_pass
[c_pass_len
] = '\0';
2878 c_data
= scm_gnutls_get_array (data
, &c_data_handle
, &c_data_len
,
2880 c_data_d
.data
= (unsigned char *) c_data
;
2881 c_data_d
.size
= c_data_len
;
2883 err
= gnutls_openpgp_privkey_init (&c_key
);
2884 if (EXPECT_FALSE (err
))
2886 scm_gnutls_release_array (&c_data_handle
);
2887 scm_gnutls_error (err
, FUNC_NAME
);
2890 err
= gnutls_openpgp_privkey_import (c_key
, &c_data_d
, c_format
, c_pass
,
2891 0 /* currently unused */ );
2892 scm_gnutls_release_array (&c_data_handle
);
2894 if (EXPECT_FALSE (err
))
2896 gnutls_openpgp_privkey_deinit (c_key
);
2897 scm_gnutls_error (err
, FUNC_NAME
);
2900 return (scm_from_gnutls_openpgp_private_key (c_key
));
2905 SCM_DEFINE (scm_gnutls_openpgp_certificate_id
, "openpgp-certificate-id",
2908 "Return the ID (an 8-element u8vector) of certificate "
2910 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_id
2913 unsigned char *c_id
;
2914 gnutls_openpgp_crt_t c_key
;
2916 c_key
= scm_to_gnutls_openpgp_certificate (key
, 1, FUNC_NAME
);
2918 c_id
= (unsigned char *) malloc (8);
2920 scm_gnutls_error (GNUTLS_E_MEMORY_ERROR
, FUNC_NAME
);
2922 err
= gnutls_openpgp_crt_get_key_id (c_key
, c_id
);
2923 if (EXPECT_FALSE (err
))
2924 scm_gnutls_error (err
, FUNC_NAME
);
2926 return (scm_take_u8vector (c_id
, 8));
2931 SCM_DEFINE (scm_gnutls_openpgp_certificate_id_x
, "openpgp-certificate-id!",
2934 "Store the ID (an 8 byte sequence) of certificate "
2935 "@var{key} in @var{id} (a u8vector).")
2936 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_id_x
2940 scm_t_array_handle c_id_handle
;
2942 gnutls_openpgp_crt_t c_key
;
2944 c_key
= scm_to_gnutls_openpgp_certificate (key
, 1, FUNC_NAME
);
2945 c_id
= scm_gnutls_get_writable_array (id
, &c_id_handle
, &c_id_size
,
2948 if (EXPECT_FALSE (c_id_size
< 8))
2950 scm_gnutls_release_array (&c_id_handle
);
2951 scm_misc_error (FUNC_NAME
, "ID vector too small: ~A", scm_list_1 (id
));
2954 err
= gnutls_openpgp_crt_get_key_id (c_key
, (unsigned char *) c_id
);
2955 scm_gnutls_release_array (&c_id_handle
);
2957 if (EXPECT_FALSE (err
))
2958 scm_gnutls_error (err
, FUNC_NAME
);
2960 return SCM_UNSPECIFIED
;
2965 SCM_DEFINE (scm_gnutls_openpgp_certificate_fingerpint_x
,
2966 "openpgp-certificate-fingerprint!",
2969 "Store in @var{fpr} (a u8vector) the fingerprint of @var{key}. "
2970 "Return the number of bytes stored in @var{fpr}.")
2971 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_fingerpint_x
2974 gnutls_openpgp_crt_t c_key
;
2976 scm_t_array_handle c_fpr_handle
;
2977 size_t c_fpr_len
, c_actual_len
= 0;
2979 c_key
= scm_to_gnutls_openpgp_certificate (key
, 1, FUNC_NAME
);
2980 SCM_VALIDATE_ARRAY (2, fpr
);
2982 c_fpr
= scm_gnutls_get_writable_array (fpr
, &c_fpr_handle
, &c_fpr_len
,
2985 err
= gnutls_openpgp_crt_get_fingerprint (c_key
, c_fpr
, &c_actual_len
);
2986 scm_gnutls_release_array (&c_fpr_handle
);
2988 if (EXPECT_FALSE (err
))
2989 scm_gnutls_error (err
, FUNC_NAME
);
2991 return (scm_from_size_t (c_actual_len
));
2996 SCM_DEFINE (scm_gnutls_openpgp_certificate_fingerprint
,
2997 "openpgp-certificate-fingerprint",
3000 "Return a new u8vector denoting the fingerprint of " "@var{key}.")
3001 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_fingerprint
3004 gnutls_openpgp_crt_t c_key
;
3005 unsigned char *c_fpr
;
3006 size_t c_fpr_len
, c_actual_len
;
3008 c_key
= scm_to_gnutls_openpgp_certificate (key
, 1, FUNC_NAME
);
3010 /* V4 fingerprints are 160-bit SHA-1 hashes (see RFC2440). */
3012 c_fpr
= (unsigned char *) malloc (c_fpr_len
);
3013 if (EXPECT_FALSE (c_fpr
== NULL
))
3014 scm_gnutls_error (GNUTLS_E_MEMORY_ERROR
, FUNC_NAME
);
3019 err
= gnutls_openpgp_crt_get_fingerprint (c_key
, c_fpr
, &c_actual_len
);
3020 if (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
)
3023 unsigned char *c_new
;
3025 c_new
= (unsigned char *) realloc (c_fpr
, c_fpr_len
* 2);
3026 if (EXPECT_FALSE (c_new
== NULL
))
3029 scm_gnutls_error (GNUTLS_E_MEMORY_ERROR
, FUNC_NAME
);
3038 while (err
== GNUTLS_E_SHORT_MEMORY_BUFFER
);
3040 if (EXPECT_FALSE (err
))
3043 scm_gnutls_error (err
, FUNC_NAME
);
3046 if (c_actual_len
< c_fpr_len
)
3048 c_fpr
= realloc (c_fpr
, c_actual_len
);
3050 return (scm_take_u8vector (c_fpr
, c_actual_len
));
3055 SCM_DEFINE (scm_gnutls_openpgp_certificate_name
, "openpgp-certificate-name",
3057 (SCM key
, SCM index
),
3058 "Return the @var{index}th name of @var{key}.")
3059 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_name
3062 gnutls_openpgp_crt_t c_key
;
3064 char c_name
[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH
];
3065 size_t c_name_len
= sizeof (c_name
);
3067 c_key
= scm_to_gnutls_openpgp_certificate (key
, 1, FUNC_NAME
);
3068 c_index
= scm_to_int (index
);
3070 err
= gnutls_openpgp_crt_get_name (c_key
, c_index
, c_name
, &c_name_len
);
3071 if (EXPECT_FALSE (err
))
3072 scm_gnutls_error (err
, FUNC_NAME
);
3074 /* XXX: The name is really UTF-8. */
3075 return (scm_from_locale_string (c_name
));
3080 SCM_DEFINE (scm_gnutls_openpgp_certificate_names
, "openpgp-certificate-names",
3081 1, 0, 0, (SCM key
), "Return the list of names for @var{key}.")
3082 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_names
3085 SCM result
= SCM_EOL
;
3086 gnutls_openpgp_crt_t c_key
;
3088 char c_name
[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH
];
3089 size_t c_name_len
= sizeof (c_name
);
3091 c_key
= scm_to_gnutls_openpgp_certificate (key
, 1, FUNC_NAME
);
3095 err
= gnutls_openpgp_crt_get_name (c_key
, c_index
, c_name
, &c_name_len
);
3098 result
= scm_cons (scm_from_locale_string (c_name
), result
);
3104 if (EXPECT_FALSE (err
!= GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE
))
3105 scm_gnutls_error (err
, FUNC_NAME
);
3107 return (scm_reverse_x (result
, SCM_EOL
));
3112 SCM_DEFINE (scm_gnutls_openpgp_certificate_algorithm
,
3113 "openpgp-certificate-algorithm",
3116 "Return two values: the certificate algorithm used by "
3117 "@var{key} and the number of bits used.")
3118 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_algorithm
3120 gnutls_openpgp_crt_t c_key
;
3121 unsigned int c_bits
;
3122 gnutls_pk_algorithm_t c_algo
;
3124 c_key
= scm_to_gnutls_openpgp_certificate (key
, 1, FUNC_NAME
);
3125 c_algo
= gnutls_openpgp_crt_get_pk_algorithm (c_key
, &c_bits
);
3127 return (scm_values (scm_list_2 (scm_from_gnutls_pk_algorithm (c_algo
),
3128 scm_from_uint (c_bits
))));
3133 SCM_DEFINE (scm_gnutls_openpgp_certificate_version
,
3134 "openpgp-certificate-version",
3137 "Return the version of the OpenPGP message format (RFC2440) "
3138 "honored by @var{key}.")
3139 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_version
3142 gnutls_openpgp_crt_t c_key
;
3144 c_key
= scm_to_gnutls_openpgp_certificate (key
, 1, FUNC_NAME
);
3145 c_version
= gnutls_openpgp_crt_get_version (c_key
);
3147 return (scm_from_int (c_version
));
3152 SCM_DEFINE (scm_gnutls_openpgp_certificate_usage
, "openpgp-certificate-usage",
3155 "Return a list of values denoting the key usage of @var{key}.")
3156 #define FUNC_NAME s_scm_gnutls_openpgp_certificate_usage
3159 unsigned int c_usage
= 0;
3160 gnutls_openpgp_crt_t c_key
;
3162 c_key
= scm_to_gnutls_openpgp_certificate (key
, 1, FUNC_NAME
);
3164 err
= gnutls_openpgp_crt_get_key_usage (c_key
, &c_usage
);
3165 if (EXPECT_FALSE (err
))
3166 scm_gnutls_error (err
, FUNC_NAME
);
3168 return (scm_from_gnutls_key_usage_flags (c_usage
));
3175 /* OpenPGP keyrings. */
3177 SCM_DEFINE (scm_gnutls_import_openpgp_keyring
, "import-openpgp-keyring",
3179 (SCM data
, SCM format
),
3180 "Import @var{data} (a u8vector) according to @var{format} "
3181 "and return the imported keyring.")
3182 #define FUNC_NAME s_scm_gnutls_import_openpgp_keyring
3185 gnutls_openpgp_keyring_t c_keyring
;
3186 gnutls_openpgp_crt_fmt_t c_format
;
3187 gnutls_datum_t c_data_d
;
3188 scm_t_array_handle c_data_handle
;
3192 SCM_VALIDATE_ARRAY (1, data
);
3193 c_format
= scm_to_gnutls_openpgp_certificate_format (format
, 2, FUNC_NAME
);
3195 c_data
= scm_gnutls_get_array (data
, &c_data_handle
, &c_data_len
,
3198 c_data_d
.data
= (unsigned char *) c_data
;
3199 c_data_d
.size
= c_data_len
;
3201 err
= gnutls_openpgp_keyring_init (&c_keyring
);
3202 if (EXPECT_FALSE (err
))
3204 scm_gnutls_release_array (&c_data_handle
);
3205 scm_gnutls_error (err
, FUNC_NAME
);
3208 err
= gnutls_openpgp_keyring_import (c_keyring
, &c_data_d
, c_format
);
3209 scm_gnutls_release_array (&c_data_handle
);
3211 if (EXPECT_FALSE (err
))
3213 gnutls_openpgp_keyring_deinit (c_keyring
);
3214 scm_gnutls_error (err
, FUNC_NAME
);
3217 return (scm_from_gnutls_openpgp_keyring (c_keyring
));
3222 SCM_DEFINE (scm_gnutls_openpgp_keyring_contains_key_id_p
,
3223 "openpgp-keyring-contains-key-id?",
3225 (SCM keyring
, SCM id
),
3226 "Return @code{#f} if key ID @var{id} is in @var{keyring}, "
3227 "@code{#f} otherwise.")
3228 #define FUNC_NAME s_scm_gnutls_openpgp_keyring_contains_key_id_p
3231 gnutls_openpgp_keyring_t c_keyring
;
3232 scm_t_array_handle c_id_handle
;
3236 c_keyring
= scm_to_gnutls_openpgp_keyring (keyring
, 1, FUNC_NAME
);
3237 SCM_VALIDATE_ARRAY (1, id
);
3239 c_id
= scm_gnutls_get_array (id
, &c_id_handle
, &c_id_len
, FUNC_NAME
);
3240 if (EXPECT_FALSE (c_id_len
!= 8))
3242 scm_gnutls_release_array (&c_id_handle
);
3243 scm_wrong_type_arg (FUNC_NAME
, 1, id
);
3246 c_result
= gnutls_openpgp_keyring_check_id (c_keyring
,
3247 (unsigned char *) c_id
,
3250 scm_gnutls_release_array (&c_id_handle
);
3252 return (scm_from_bool (c_result
== 0));
3258 /* OpenPGP certificates. */
3260 SCM_DEFINE (scm_gnutls_set_certificate_credentials_openpgp_keys_x
,
3261 "set-certificate-credentials-openpgp-keys!",
3263 (SCM cred
, SCM pub
, SCM sec
),
3264 "Use certificate @var{pub} and secret key @var{sec} in "
3265 "certificate credentials @var{cred}.")
3266 #define FUNC_NAME s_scm_gnutls_set_certificate_credentials_openpgp_keys_x
3269 gnutls_certificate_credentials_t c_cred
;
3270 gnutls_openpgp_crt_t c_pub
;
3271 gnutls_openpgp_privkey_t c_sec
;
3273 c_cred
= scm_to_gnutls_certificate_credentials (cred
, 1, FUNC_NAME
);
3274 c_pub
= scm_to_gnutls_openpgp_certificate (pub
, 2, FUNC_NAME
);
3275 c_sec
= scm_to_gnutls_openpgp_private_key (sec
, 3, FUNC_NAME
);
3277 err
= gnutls_certificate_set_openpgp_key (c_cred
, c_pub
, c_sec
);
3278 if (EXPECT_FALSE (err
))
3279 scm_gnutls_error (err
, FUNC_NAME
);
3281 return SCM_UNSPECIFIED
;
3290 static SCM log_procedure
= SCM_BOOL_F
;
3293 scm_gnutls_log (int level
, const char *str
)
3295 if (scm_is_true (log_procedure
))
3296 (void) scm_call_2 (log_procedure
, scm_from_int (level
),
3297 scm_from_locale_string (str
));
3300 SCM_DEFINE (scm_gnutls_set_log_procedure_x
, "set-log-procedure!",
3303 "Use @var{proc} (a two-argument procedure) as the global "
3304 "GnuTLS log procedure.")
3305 #define FUNC_NAME s_scm_gnutls_set_log_procedure_x
3307 SCM_VALIDATE_PROC (1, proc
);
3309 if (scm_is_true (log_procedure
))
3310 (void) scm_gc_unprotect_object (log_procedure
);
3312 log_procedure
= scm_gc_protect_object (proc
);
3313 gnutls_global_set_log_function (scm_gnutls_log
);
3315 return SCM_UNSPECIFIED
;
3320 SCM_DEFINE (scm_gnutls_set_log_level_x
, "set-log-level!", 1, 0, 0,
3322 "Enable GnuTLS logging up to @var{level} (an integer).")
3323 #define FUNC_NAME s_scm_gnutls_set_log_level_x
3325 unsigned int c_level
;
3327 c_level
= scm_to_uint (level
);
3328 gnutls_global_set_log_level (c_level
);
3330 return SCM_UNSPECIFIED
;
3336 /* Initialization. */
3339 scm_init_gnutls (void)
3343 /* Use Guile's allocation routines, which will run the GC if need be. */
3344 gnutls_malloc
= scm_malloc
;
3345 gnutls_realloc
= scm_realloc
;
3346 gnutls_secure_malloc
= scm_malloc
;
3349 (void) gnutls_global_init ();
3351 scm_gnutls_define_enums ();
3353 scm_init_gnutls_error ();
3355 scm_init_gnutls_session_record_port_type ();