# 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
EXTRA_DIST = gnutls/build/enums.scm gnutls/build/smobs.scm \
gnutls/build/utils.scm gnutls/build/priorities.scm \
+ gnutls/build/tests.scm \
$(documentation_modules)
--- /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 Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+;;;
+;;; GnuTLS is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with GnuTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@gnu.org>.
+
+(define-module (gnutls build tests)
+ #:export (run-test))
+
+(define (run-test thunk)
+ "Call `(exit (THUNK))'. If THUNK raises an exception, then call `(exit 1)' and
+display a backtrace. Otherwise, return THUNK's return value."
+ (exit
+ (catch #t
+ thunk
+ (lambda (key . args)
+ ;; Never reached.
+ (exit 1))
+ (lambda (key . args)
+ (dynamic-wind ;; to be on the safe side
+ (lambda () #t)
+ (lambda ()
+ (format (current-error-port)
+ "~%throw to `~a' with args ~s~%" key args)
+ (display-backtrace (make-stack #t) (current-output-port)))
+ (lambda ()
+ (exit 1)))
+ (exit 1)))))
;;;
(use-modules (gnutls)
+ (gnutls build tests)
(srfi srfi-4))
;; (set-log-procedure! (lambda (level str)
;; (format #t "[~a|~a] ~a" (getpid) level str)))
-(dynamic-wind
- (lambda ()
- #t)
-
+(run-test
(lambda ()
(let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
(pid (primitive-fork)))
(record-send client %message)
(bye client close-request/rdwr)
- (exit))
+ (primitive-exit))
(let ((server (make-session connection-end/server)))
;; server-side
(let* ((buf (make-u8vector (u8vector-length %message)))
(amount (record-receive! server buf)))
(bye server close-request/rdwr)
- (exit (= amount (u8vector-length %message))
- (equal? buf %message)))))))
-
- (lambda ()
- ;; failure
- (exit 1)))
+ (and (= amount (u8vector-length %message))
+ (equal? buf %message))))))))
;;; arch-tag: 8c98de24-0a53-4290-974e-4b071ad162a0
;;; 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
;;; Test the error/exception mechanism.
;;;
-(use-modules (gnutls))
-
-(dynamic-wind
- (lambda ()
- #t)
+(use-modules (gnutls)
+ (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)
- (exit (and (eq? key 'gnutls-error)
- err
- (string? (error->string err))
- (eq? function 'handshake)))))))
-
- (lambda ()
- ;; failure
- (exit 1)))
+ (and (eq? key 'gnutls-error)
+ err
+ (string? (error->string err))
+ (eq? function 'handshake)))))))
;;; arch-tag: 73ed6229-378d-4a12-a5c6-4c2586c6e3a2
(use-modules (gnutls)
(gnutls extra)
+ (gnutls build tests)
(srfi srfi-4))
;; (set-log-procedure! (lambda (level str)
;; (format #t "[~a|~a] ~a" (getpid) level str)))
-(dynamic-wind
- (lambda ()
- #t)
-
+(run-test
(lambda ()
(let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
(pub (import-key import-openpgp-certificate
(write %message (session-record-port client))
(bye client close-request/rdwr)
- (exit))
+ (primitive-exit))
(let ((server (make-session connection-end/server))
(rsa (import-rsa-params "rsa-parameters.pem"))
(let ((msg (read (session-record-port server)))
(auth-type (session-authentication-type server)))
(bye server close-request/rdwr)
- (exit (and (eq? auth-type credentials/certificate)
- (equal? msg %message)))))))))
-
- (lambda ()
- ;; failure
- (exit 1)))
+ (and (eq? auth-type credentials/certificate)
+ (equal? msg %message)))))))))
;;; arch-tag: 1a973ed5-f45d-45a4-8160-900b6a8c27ff
;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
;;;
;;; GnuTLS-extra is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;;
(use-modules (gnutls extra) (gnutls)
+ (gnutls build tests)
(srfi srfi-1)
(srfi srfi-4))
(openpgp-keyring-contains-key-id? keyring id))
%ids-in-keyring)))))
-(dynamic-wind
-
- (lambda ()
- #t)
-
- (lambda ()
- (exit
- (every valid-keyring?
- (list %raw-keyring-file
- %ascii-keyring-file)
- (list openpgp-certificate-format/raw
- openpgp-certificate-format/base64))))
-
+(run-test
(lambda ()
- ;; failure
- (exit 1)))
+ (every valid-keyring?
+ (list %raw-keyring-file
+ %ascii-keyring-file)
+ (list openpgp-certificate-format/raw
+ openpgp-certificate-format/base64))))
;;; arch-tag: 516bf608-5c8b-4787-abe9-5f7b6e6d660b
;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
;;;
;;; GnuTLS-extra is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
(use-modules (gnutls)
(gnutls extra)
+ (gnutls build tests)
(srfi srfi-1)
(srfi srfi-4)
(srfi srfi-11))
(stat:size (stat file)))
-(dynamic-wind
-
- (lambda ()
- #t)
-
+(run-test
(lambda ()
(let ((raw-pubkey (make-u8vector (file-size %certificate-file)))
(raw-privkey (make-u8vector (file-size %private-key-file))))
(sec (import-openpgp-private-key raw-privkey
openpgp-certificate-format/base64)))
- (exit (and (openpgp-certificate? pub)
- (openpgp-private-key? sec)
- (equal? (openpgp-certificate-id pub) %key-id)
- (u8vector? (openpgp-certificate-fingerprint pub))
- (every string? (openpgp-certificate-names pub))
- (member (openpgp-certificate-version pub) '(3 4))
- (list? (openpgp-certificate-usage pub))
- (let-values (((pk bits)
- (openpgp-certificate-algorithm pub)))
- (and (string? (pk-algorithm->string pk))
- (number? bits))))))))
-
- (lambda ()
- ;; failure
- (exit 1)))
+ (and (openpgp-certificate? pub)
+ (openpgp-private-key? sec)
+ (equal? (openpgp-certificate-id pub) %key-id)
+ (u8vector? (openpgp-certificate-fingerprint pub))
+ (every string? (openpgp-certificate-names pub))
+ (member (openpgp-certificate-version pub) '(3 4))
+ (list? (openpgp-certificate-usage pub))
+ (let-values (((pk bits)
+ (openpgp-certificate-algorithm pub)))
+ (and (string? (pk-algorithm->string pk))
+ (number? bits))))))))
;;; arch-tag: 2ee2a377-7f4d-4031-92a8-275090e4f83d
;;; 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
;;;
(use-modules (gnutls)
+ (gnutls build tests)
(srfi srfi-4))
(define (import-something import-proc file fmt)
(import-something pkcs3-import-dh-parameters file
x509-certificate-format/pem))
-(dynamic-wind
-
- (lambda ()
- #t)
-
- (lambda ()
- (exit
- (let* ((dh-params (import-dh-params "dh-parameters.pem"))
- (export
- (pkcs3-export-dh-parameters dh-params
- x509-certificate-format/pem)))
- (and (u8vector? export)
- (let ((import
- (pkcs3-import-dh-parameters export
- x509-certificate-format/pem)))
- (dh-parameters? import))))))
-
+(run-test
(lambda ()
- ;; failure
- (exit 1)))
+ (let* ((dh-params (import-dh-params "dh-parameters.pem"))
+ (export
+ (pkcs3-export-dh-parameters dh-params
+ x509-certificate-format/pem)))
+ (and (u8vector? export)
+ (let ((import
+ (pkcs3-import-dh-parameters export
+ x509-certificate-format/pem)))
+ (dh-parameters? import))))))
;;; arch-tag: adff0f07-479e-421e-b47f-8956e06b9902
;;; 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
;;;
(use-modules (gnutls)
+ (gnutls build tests)
(srfi srfi-4))
;; (set-log-procedure! (lambda (level str)
;; (format #t "[~a|~a] ~a" (getpid) level str)))
-(dynamic-wind
- (lambda ()
- #t)
-
+(run-test
(lambda ()
;; Stress the GC. In 0.0, this triggered an abort due to
;; "scm_unprotect_object called during GC".
(uniform-vector-write %message (session-record-port client))
(bye client close-request/rdwr)
- (exit))
+ (primitive-exit))
(let ((server (make-session connection-end/server)))
;; server-side
(bye server close-request/rdwr)
;; Make sure we got everything right.
- (exit (eq? (session-record-port server)
- (session-record-port server))
- (= amount (u8vector-length %message))
- (equal? buf %message)
- (eof-object?
- (read-char (session-record-port server)))))))))
-
- (lambda ()
- ;; failure
- (exit 1)))
+ (and (eq? (session-record-port server)
+ (session-record-port server))
+ (= amount (u8vector-length %message))
+ (equal? buf %message)
+ (eof-object?
+ (read-char (session-record-port server))))))))))
;;; arch-tag: e873226a-d0b6-4a93-87ec-a1b5ad2ae8a2
;;; 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
;;; Test SRP base64 encoding and decoding.
;;;
-(use-modules (gnutls))
+(use-modules (gnutls)
+ (gnutls build tests))
(define %message
"GnuTLS is free software; you can redistribute it and/or
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.")
-(exit (let ((encoded (srp-base64-encode %message)))
- (and (string? encoded)
- (string=? (srp-base64-decode encoded)
- %message))))
+(run-test
+ (lambda ()
+ (let ((encoded (srp-base64-encode %message)))
+ (and (string? encoded)
+ (string=? (srp-base64-decode encoded)
+ %message)))))
;;; arch-tag: ea1534a5-d513-4208-9a75-54bd4710f915
;;; 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
;;;
(use-modules (gnutls)
+ (gnutls build tests)
(srfi srfi-4))
;; (set-log-procedure! (lambda (level str)
;; (format #t "[~a|~a] ~a" (getpid) level str)))
-(dynamic-wind
- (lambda ()
- #t)
-
+(run-test
(lambda ()
(let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
(pub (import-key import-x509-certificate
(write %message (session-record-port client))
(bye client close-request/rdwr)
- (exit))
+ (primitive-exit))
(let ((server (make-session connection-end/server))
(rsa (import-rsa-params "rsa-parameters.pem"))
(let ((msg (read (session-record-port server)))
(auth-type (session-authentication-type server)))
(bye server close-request/rdwr)
- (exit (and (eq? auth-type credentials/certificate)
- (equal? msg %message)))))))))
-
- (lambda ()
- ;; failure
- (exit 1)))
+ (and (eq? auth-type credentials/certificate)
+ (equal? msg %message)))))))))
;;; arch-tag: 1f88f835-a5c8-4fd6-94b6-5a13571ba03d
;;; 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
;;;
(use-modules (gnutls)
+ (gnutls build tests)
(srfi srfi-4)
(srfi srfi-11))
(stat:size (stat file)))
-(dynamic-wind
-
- (lambda ()
- #t)
-
+(run-test
(lambda ()
(let ((raw-certificate (make-u8vector (file-size %certificate-file)))
(raw-privkey (make-u8vector (file-size %private-key-file))))
(sec (import-x509-private-key raw-privkey
x509-certificate-format/pem)))
- (exit (and (x509-certificate? cert)
- (x509-private-key? sec)
- (string? (x509-certificate-dn cert))
- (string? (x509-certificate-issuer-dn cert))
- (string=? (x509-certificate-dn-oid cert 0) %first-oid)
- (eq? (x509-certificate-signature-algorithm cert)
- %signature-algorithm)
- (x509-certificate-matches-hostname? cert "localhost")
- (let-values (((type name)
- (x509-certificate-subject-alternative-name
- cert 0)))
- (and (string? name)
- (string?
- (x509-subject-alternative-name->string type)))))))))
-
- (lambda ()
- ;; failure
- (exit 1)))
+ (and (x509-certificate? cert)
+ (x509-private-key? sec)
+ (string? (x509-certificate-dn cert))
+ (string? (x509-certificate-issuer-dn cert))
+ (string=? (x509-certificate-dn-oid cert 0) %first-oid)
+ (eq? (x509-certificate-signature-algorithm cert)
+ %signature-algorithm)
+ (x509-certificate-matches-hostname? cert "localhost")
+ (let-values (((type name)
+ (x509-certificate-subject-alternative-name
+ cert 0)))
+ (and (string? name)
+ (string?
+ (x509-subject-alternative-name->string type)))))))))
;;; arch-tag: eef09b52-30e8-472a-8b93-cb636434f6eb
projects / thirdparty / gnutls.git / commitdiff
