guile: Wrap `gnutls_priority_set_direct'; deprecate the old method.

8 files changed, 152 insertions, 19 deletions

diff --git a/guile/modules/gnutls.scm b/guile/modules/gnutls.scm
index ed5efd893c..0f4aa62db0 100644
--- a/guile/modules/gnutls.scm
+++ b/guile/modules/gnutls.scm
@@ -1,5 +1,5 @@
 ;;; 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
@@ -70,7 +70,10 @@
            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!
diff --git a/guile/modules/gnutls/build/enums.scm b/guile/modules/gnutls/build/enums.scm
index 91b61614e5..8f53d8e0dd 100644
--- a/guile/modules/gnutls/build/enums.scm
+++ b/guile/modules/gnutls/build/enums.scm
@@ -485,6 +485,7 @@ insufficient-credentials
 insuficient-credentials
 insufficient-cred
 insuficient-cred
+invalid-request
 hash-failed
 base64-decoding-error
 mpi-print-failed
diff --git a/guile/modules/gnutls/build/priorities.scm b/guile/modules/gnutls/build/priorities.scm
index 3cd733a65f..479e601fd7 100644
--- a/guile/modules/gnutls/build/priorities.scm
+++ b/guile/modules/gnutls/build/priorities.scm
@@ -1,5 +1,5 @@
 ;;; 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
@@ -64,6 +64,9 @@
     (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);~%"
diff --git a/guile/src/core.c b/guile/src/core.c
index dfe0fc33dd..e0b264bf88 100644
--- a/guile/src/core.c
+++ b/guile/src/core.c
@@ -1,5 +1,5 @@
 /* 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
@@ -532,7 +532,49 @@ SCM_DEFINE (scm_gnutls_set_default_export_priority_x,
 
   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",
diff --git a/guile/src/errors.c b/guile/src/errors.c
index b2bbd8f826..987dd42113 100644
--- a/guile/src/errors.c
+++ b/guile/src/errors.c
@@ -1,5 +1,5 @@
 /* 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
@@ -30,7 +30,7 @@
 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;
 
@@ -38,13 +38,20 @@ scm_gnutls_error (int c_err, const char *c_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);
+}
+
 
 
 void
diff --git a/guile/src/errors.h b/guile/src/errors.h
index 337cdb6ed0..341807d04e 100644
--- a/guile/src/errors.h
+++ b/guile/src/errors.h
@@ -1,5 +1,5 @@
 /* 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
@@ -22,12 +22,12 @@
 
 #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
diff --git a/guile/tests/Makefile.am b/guile/tests/Makefile.am
index 0832b1e806..49aaf54660 100644
--- a/guile/tests/Makefile.am
+++ b/guile/tests/Makefile.am
@@ -1,5 +1,5 @@
 #  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
@@ -15,10 +15,11 @@
 #  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
diff --git a/guile/tests/priorities.scm b/guile/tests/priorities.scm
new file mode 100644
index 0000000000..1ee072be5e
--- /dev/null
+++ b/guile/tests/priorities.scm
@@ -0,0 +1,76 @@
+;;; 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)))