;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 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
set-psk-server-credentials-file!
server-session-psk-username
- ;; priority functions
+ ;; priorities
+ set-session-priorities!
+
+ ;; priority functions (deprecated)
set-session-cipher-priority! set-session-mac-priority!
set-session-compression-method-priority!
set-session-kx-priority! set-session-protocol-priority!
insuficient-credentials
insufficient-cred
insuficient-cred
+invalid-request
hash-failed
base64-decoding-error
mpi-print-failed
;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 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
(format port " ~a *c_items;~%"
(enum-type-c-type enum))
(format port " long int c_len, i;~%")
+ (format port " scm_c_issue_deprecation_warning \
+(\"`set-session-~a-priority!'is deprecated, \
+use `set-session-priorities!' instead\");~%" (enum-type-subsystem enum))
(format port " c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);~%")
(format port " SCM_VALIDATE_LIST_COPYLEN (2, items, c_len);~%")
(format port " c_items = (~a *) alloca (sizeof (* c_items) * c_len);~%"
/* GnuTLS --- Guile bindings for GnuTLS.
- Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2008, 2009, 2010, 2011 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
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; see the "
+ "manual for the syntax. 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;
+
+ 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);
+ free (c_priorities);
+
+ switch (err)
+ {
+ case GNUTLS_E_SUCCESS:
+ break;
+ case GNUTLS_E_INVALID_REQUEST:
+ {
+ size_t pos;
+ pos = err_pos - c_priorities;
+ 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",
/* GnuTLS --- Guile bindings for GnuTLS.
- Copyright (C) 2007, 2009, 2010 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009, 2010, 2011 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
SCM_SYMBOL (gnutls_error_key, "gnutls-error");
void
-scm_gnutls_error (int c_err, const char *c_func)
+scm_gnutls_error_with_args (int c_err, const char *c_func, SCM args)
{
SCM err, func;
err = scm_from_gnutls_error (c_err);
func = scm_from_locale_symbol (c_func);
- (void) scm_throw (gnutls_error_key, scm_list_2 (err, func));
+ (void) scm_throw (gnutls_error_key, scm_cons2 (err, func, args));
/* XXX: This is actually never reached, but since the Guile headers don't
declare `scm_throw ()' as `noreturn', we must add this to avoid GCC's
complaints. */
abort ();
}
+
+void
+scm_gnutls_error (int c_err, const char *c_func)
+{
+ scm_gnutls_error_with_args (c_err, c_func, SCM_EOL);
+}
+
\f
void
/* GnuTLS --- Guile bindings for GnuTLS.
- Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2010, 2011 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
#include "utils.h"
-SCM_API void
-scm_gnutls_error (int, const char *)
+SCM_API void scm_gnutls_error_with_args (int, const char *, SCM)
NO_RETURN;
- SCM_API void scm_init_gnutls_error (void);
-#endif
+SCM_API void scm_gnutls_error (int, const char *)
+ NO_RETURN;
-/* arch-tag: e7a92e44-b399-4c85-99d4-2dd3564600f7
- */
+SCM_API void scm_init_gnutls_error (void);
+
+#endif
# GnuTLS --- Guile bindings for GnuTLS.
-# Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+# Copyright (C) 2007, 2008, 2009, 2010, 2011 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 along with GnuTLS; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-TESTS = anonymous-auth.scm session-record-port.scm \
- pkcs-import-export.scm \
- errors.scm \
- x509-certificates.scm x509-auth.scm
+TESTS = anonymous-auth.scm session-record-port.scm \
+ pkcs-import-export.scm \
+ errors.scm \
+ x509-certificates.scm x509-auth.scm \
+ priorities.scm
if ENABLE_OPENPGP
TESTS += openpgp-keys.scm openpgp-keyring.scm openpgp-auth.scm
--- /dev/null
+;;; GnuTLS --- Guile bindings for GnuTLS
+;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;;
+;;; GnuTLS is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GnuTLS-EXTRA; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+;;; Written by Ludovic Courtès <ludo@gnu.org>.
+
+
+;;;
+;;; Exercise the priority API of GnuTLS.
+;;;
+
+(use-modules (gnutls)
+ (srfi srfi-26))
+
+(define %valid-priority-strings
+ ;; Valid priority strings (from the manual).
+ '("NONE:+VERS-TLS-ALL:+MAC-ALL:+RSA:+AES-128-CBC:+SIGN-ALL:+COMP-NULL"
+ "NORMAL:-ARCFOUR-128"
+ "SECURE:-VERS-SSL3.0:+COMP-DEFLATE"
+ "NONE:+VERS-TLS-ALL:+AES-128-CBC:+RSA:+SHA1:+COMP-NULL:+SIGN-RSA-SHA1"))
+
+(define %invalid-priority-strings
+ ;; Invalid strings: the prefix and the suffix that leads to a parse error.
+ '(("" . "THIS-DOES-NOT-WORK")
+ ("NORMAL:" . "FAIL-HERE")
+ ("SECURE:-VERS-SSL3.0:" . "+FAIL-HERE")
+ ("NONE:+VERS-TLS-ALL:+AES-128-CBC:"
+ . "+FAIL-HERE:+SHA1:+COMP-NULL:+SIGN-RSA-SHA1")))
+
+(dynamic-wind
+
+ (lambda ()
+ #t)
+
+ (lambda ()
+ (let ((s (make-session connection-end/client)))
+ ;; We shouldn't have any exception with the valid priority strings.
+ (for-each (cut set-session-priorities! s <>)
+ %valid-priority-strings)
+
+ (for-each (lambda (prefix+suffix)
+ (let* ((prefix (car prefix+suffix))
+ (suffix (cdr prefix+suffix))
+ (pos (string-length prefix))
+ (string (string-append prefix suffix)))
+ (catch 'gnutls-error
+ (lambda ()
+ (let ((s (make-session connection-end/client)))
+ (set-session-priorities! s string)))
+ (lambda (key err function error-location . unused)
+ (or (and (eq? key 'gnutls-error)
+ (eq? err error/invalid-request)
+ (eq? function 'set-session-priorities!)
+ (= error-location pos))
+ (exit 1))))))
+ %invalid-priority-strings)
+
+ (exit 0)))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
projects / thirdparty / gnutls.git / commitdiff
