From d762aa6b6d90c473366fc45ae08518a56af69b93 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 7 Jun 2019 11:06:18 +0200 Subject: guile: Add bindings for 'gnutls_error_is_fatal'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guile/src/errors.c (scm_gnutls_fatal_error_p): New function. * guile/modules/gnutls.in: Export 'fatal-error?'. * guile/tests/errors.scm: test 'fatal-error?'. Signed-off-by: Ludovic Courtès --- guile/modules/gnutls.in | 2 ++ guile/src/errors.c | 12 +++++++++++- guile/tests/errors.scm | 26 +++++++++++++++----------- 3 files changed, 28 insertions(+), 12 deletions(-) diff --git a/guile/modules/gnutls.in b/guile/modules/gnutls.in index 98eda3fdc9..e935d96270 100644 --- a/guile/modules/gnutls.in +++ b/guile/modules/gnutls.in @@ -453,6 +453,8 @@ error/application-error-max error/application-error-min + fatal-error? + ;; OpenPGP keys (formerly in GnuTLS-extra) openpgp-certificate? openpgp-private-key? import-openpgp-certificate import-openpgp-private-key diff --git a/guile/src/errors.c b/guile/src/errors.c index 102be5180b..a78f2ffef8 100644 --- a/guile/src/errors.c +++ b/guile/src/errors.c @@ -1,5 +1,5 @@ /* GnuTLS --- Guile bindings for GnuTLS. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2012, 2019 Free Software Foundation, Inc. GnuTLS is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -52,6 +52,16 @@ scm_gnutls_error (int c_err, const char *c_func) scm_gnutls_error_with_args (c_err, c_func, SCM_EOL); } +SCM_DEFINE (scm_gnutls_fatal_error_p, "fatal-error?", 1, 0, 0, + (SCM err), + "Return true if @var{error} is fatal.") +#define FUNC_NAME s_scm_gnutls_fatal_error_p +{ + int c_err = scm_to_gnutls_error (err, 1, FUNC_NAME); + return scm_from_bool (gnutls_error_is_fatal (c_err)); +} +#undef FUNC_NAME + void diff --git a/guile/tests/errors.scm b/guile/tests/errors.scm index 4d4d958f85..b8d46234ab 100644 --- a/guile/tests/errors.scm +++ b/guile/tests/errors.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012 Free Software Foundation, Inc. +;;; Copyright (C) 2007-2012, 2019 Free Software Foundation, Inc. ;;; ;;; GnuTLS is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -26,15 +26,19 @@ (gnutls build tests)) (run-test - (lambda () - (let ((s (make-session connection-end/server))) - (catch 'gnutls-error - (lambda () - (handshake s)) - (lambda (key err function . currently-unused) - (and (eq? key 'gnutls-error) - err - (string? (error->string err)) - (eq? function 'handshake))))))) + (lambda () + (and (fatal-error? error/hash-failed) + (not (fatal-error? error/reauth-request)) + + (let ((s (make-session connection-end/server))) + (catch 'gnutls-error + (lambda () + (handshake s)) + (lambda (key err function . currently-unused) + (and (eq? key 'gnutls-error) + err + (fatal-error? err) + (string? (error->string err)) + (eq? function 'handshake)))))))) ;;; arch-tag: 73ed6229-378d-4a12-a5c6-4c2586c6e3a2 -- cgit v1.2.1