diff options
author | Ludovic Courtès <ludo@gnu.org> | 2016-02-11 23:04:31 +0100 |
---|---|---|
committer | Nikos Mavrogiannopoulos <nmav@redhat.com> | 2016-02-15 10:05:01 +0100 |
commit | 53b7d41a26b3d61a62b2576e30d93f9f8c9aaef6 (patch) | |
tree | d274f92cb746736836b72fd31097aadee88812ec /guile | |
parent | e6dcb14dbbd3e9e40a1f193a7bf6657e82b88cb9 (diff) | |
download | gnutls-53b7d41a26b3d61a62b2576e30d93f9f8c9aaef6.tar.gz |
guile: tests: Add 'with-child-process'.
This makes sure that child processes always exit no matter what.
* guile/modules/gnutls/build/tests.scm (define-syntax-rule) [!guile-2]:
New macro.
(call-with-child-process): New procedure.
(with-child-process): New macro.
* guile/tests/anonymous-auth.scm, guile/tests/openpgp-auth.scm,
guile/tests/session-record-port.scm, guile/tests/x509-auth.scm: Use it
instead of an explicit 'primitive-fork' call.
* guile/.dir-locals.el: New file.
* guile/Makefile.am (EXTRA_DIST): New variable.
Diffstat (limited to 'guile')
-rw-r--r-- | guile/.dir-locals.el | 12 | ||||
-rw-r--r-- | guile/Makefile.am | 4 | ||||
-rw-r--r-- | guile/modules/gnutls/build/tests.scm | 41 | ||||
-rw-r--r-- | guile/tests/anonymous-auth.scm | 76 | ||||
-rw-r--r-- | guile/tests/openpgp-auth.scm | 92 | ||||
-rw-r--r-- | guile/tests/session-record-port.scm | 137 | ||||
-rw-r--r-- | guile/tests/x509-auth.scm | 103 |
7 files changed, 255 insertions, 210 deletions
diff --git a/guile/.dir-locals.el b/guile/.dir-locals.el new file mode 100644 index 0000000000..54091ccaa5 --- /dev/null +++ b/guile/.dir-locals.el @@ -0,0 +1,12 @@ +;; Per-directory local variables for GNU Emacs 23 and later. + +((nil + . ((fill-column . 78) + (tab-width . 8))) + (c-mode . ((c-file-style . "gnu"))) + (scheme-mode + . + ((indent-tabs-mode . nil) + (eval . (put 'with-child-process 'scheme-indent-function 1)))) + (texinfo-mode . ((indent-tabs-mode . nil) + (fill-column . 72)))) diff --git a/guile/Makefile.am b/guile/Makefile.am index a981ed5c21..ed9b8ba1d7 100644 --- a/guile/Makefile.am +++ b/guile/Makefile.am @@ -1,5 +1,5 @@ # GnuTLS --- Guile bindings for GnuTLS. -# Copyright (C) 2007-2012 Free Software Foundation, Inc. +# Copyright (C) 2007-2012, 2016 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 @@ -16,3 +16,5 @@ # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA SUBDIRS = modules src tests + +EXTRA_DIST = .dir-locals.el diff --git a/guile/modules/gnutls/build/tests.scm b/guile/modules/gnutls/build/tests.scm index f5e135b4f2..5a03ce7474 100644 --- a/guile/modules/gnutls/build/tests.scm +++ b/guile/modules/gnutls/build/tests.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2011-2012 Free Software Foundation, Inc. +;;; Copyright (C) 2011-2012, 2016 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 @@ -18,7 +18,8 @@ ;;; Written by Ludovic Courtès <ludo@gnu.org>. (define-module (gnutls build tests) - #:export (run-test)) + #:export (run-test + with-child-process)) (define (run-test thunk) "Call `(exit (THUNK))'. If THUNK raises an exception, then call `(exit 1)' and @@ -39,3 +40,39 @@ display a backtrace. Otherwise, return THUNK's return value." (lambda () (exit 1))) (exit 1))))) + +(define (call-with-child-process child parent) + "Run thunk CHILD in a child process and invoke PARENT from the parent +process, passing it the PID of the child process. Make sure the child +process exits upon failure." + (let ((pid (primitive-fork))) + (if (zero? pid) + (dynamic-wind + (const #t) + (lambda () + (primitive-exit (if (child) 0 1))) + (lambda () + (primitive-exit 2))) + (parent pid)))) + +(cond-expand + ((not guile-2) ;1.8, yay! + (use-modules (ice-9 syncase)) + + (define-syntax define-syntax-rule + (syntax-rules () + ((_ (name args ...) docstring body) + (define-syntax name + (syntax-rules () + ((_ args ...) body)))))) + + (export define-syntax-rule)) + (else + #t)) + +(define-syntax-rule (with-child-process pid parent child) + "Fork and evaluate expression PARENT in the current process, with PID bound +to the PID of its child process; the child process evaluated CHILD." + (call-with-child-process + (lambda () child) + (lambda (pid) parent))) diff --git a/guile/tests/anonymous-auth.scm b/guile/tests/anonymous-auth.scm index 585b3a5cca..d01884d749 100644 --- a/guile/tests/anonymous-auth.scm +++ b/guile/tests/anonymous-auth.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;;; Copyright (C) 2007-2013, 2016 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,43 +52,41 @@ ;; (format #t "[~a|~a] ~a" (getpid) level str))) (run-test - (lambda () - (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)) - (pid (primitive-fork))) - (if (= 0 pid) - - (let ((client (make-session connection-end/client))) - ;; client-side (child process) - (set-session-priorities! client priorities) - (set-session-server-name! client - server-name-type/dns (gethostname)) - (set-session-transport-fd! client (port->fdes (car socket-pair))) - (set-session-credentials! client (make-anonymous-client-credentials)) - (set-session-dh-prime-bits! client 1024) - - (handshake client) - (record-send client %message) - (bye client close-request/rdwr) - - (primitive-exit)) - - (let ((server (make-session connection-end/server))) - ;; server-side - (set-session-priorities! server priorities) - - (set-session-transport-fd! server (port->fdes (cdr socket-pair))) - (let ((cred (make-anonymous-server-credentials)) - (dh-params (import-dh-params "dh-parameters.pem"))) - ;; Note: DH parameter generation can take some time. - (set-anonymous-server-dh-parameters! cred dh-params) - (set-session-credentials! server cred)) - (set-session-dh-prime-bits! server 1024) - - (handshake server) - (let* ((buf (make-u8vector (u8vector-length %message))) - (amount (record-receive! server buf))) - (bye server close-request/rdwr) - (and (= amount (u8vector-length %message)) - (equal? buf %message)))))))) + (lambda () + (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))) + (with-child-process pid + ;; server-side + (let ((server (make-session connection-end/server))) + (set-session-priorities! server priorities) + + (set-session-transport-fd! server (port->fdes (cdr socket-pair))) + (let ((cred (make-anonymous-server-credentials)) + (dh-params (import-dh-params "dh-parameters.pem"))) + ;; Note: DH parameter generation can take some time. + (set-anonymous-server-dh-parameters! cred dh-params) + (set-session-credentials! server cred)) + (set-session-dh-prime-bits! server 1024) + + (handshake server) + (let* ((buf (make-u8vector (u8vector-length %message))) + (amount (record-receive! server buf))) + (bye server close-request/rdwr) + (and (= amount (u8vector-length %message)) + (equal? buf %message)))) + + ;; client-side (child process) + (let ((client (make-session connection-end/client))) + (set-session-priorities! client priorities) + (set-session-server-name! client + server-name-type/dns (gethostname)) + (set-session-transport-fd! client (port->fdes (car socket-pair))) + (set-session-credentials! client (make-anonymous-client-credentials)) + (set-session-dh-prime-bits! client 1024) + + (handshake client) + (record-send client %message) + (bye client close-request/rdwr) + + (primitive-exit)))))) ;;; arch-tag: 8c98de24-0a53-4290-974e-4b071ad162a0 diff --git a/guile/tests/openpgp-auth.scm b/guile/tests/openpgp-auth.scm index a60f8856ae..49b4817435 100644 --- a/guile/tests/openpgp-auth.scm +++ b/guile/tests/openpgp-auth.scm @@ -1,5 +1,5 @@ ;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA. -;;; Copyright (C) 2007-2014 Free Software Foundation, Inc. +;;; Copyright (C) 2007-2014, 2016 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 @@ -56,51 +56,49 @@ ;; (format #t "[~a|~a] ~a" (getpid) level str))) (run-test - (lambda () - (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)) - (pub (import-key import-openpgp-certificate - "openpgp-pub.asc")) - (sec (import-key import-openpgp-private-key - "openpgp-sec.asc"))) - (let ((pid (primitive-fork))) - (if (= 0 pid) - - (let ((client (make-session connection-end/client)) - (cred (make-certificate-credentials))) - ;; client-side (child process) - (set-session-priorities! client priorities) - - (set-certificate-credentials-openpgp-keys! cred pub sec) - (set-session-credentials! client cred) - (set-session-dh-prime-bits! client 1024) - - (set-session-transport-fd! client (port->fdes (car socket-pair))) - - (handshake client) - (write %message (session-record-port client)) - (bye client close-request/rdwr) - - (primitive-exit)) - - (let ((server (make-session connection-end/server)) - (dh (import-dh-params "dh-parameters.pem"))) - ;; server-side - (set-session-priorities! server priorities) - (set-server-session-certificate-request! server - certificate-request/require) - - (set-session-transport-fd! server (port->fdes (cdr socket-pair))) - (let ((cred (make-certificate-credentials))) - (set-certificate-credentials-dh-parameters! cred dh) - (set-certificate-credentials-openpgp-keys! cred pub sec) - (set-session-credentials! server cred)) - (set-session-dh-prime-bits! server 1024) - - (handshake server) - (let ((msg (read (session-record-port server))) - (auth-type (session-authentication-type server))) - (bye server close-request/rdwr) - (and (eq? auth-type credentials/certificate) - (equal? msg %message))))))))) + (lambda () + (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)) + (pub (import-key import-openpgp-certificate + "openpgp-pub.asc")) + (sec (import-key import-openpgp-private-key + "openpgp-sec.asc"))) + (with-child-process pid + ;; server-side + (let ((server (make-session connection-end/server)) + (dh (import-dh-params "dh-parameters.pem"))) + (set-session-priorities! server priorities) + (set-server-session-certificate-request! server + certificate-request/require) + + (set-session-transport-fd! server (port->fdes (cdr socket-pair))) + (let ((cred (make-certificate-credentials))) + (set-certificate-credentials-dh-parameters! cred dh) + (set-certificate-credentials-openpgp-keys! cred pub sec) + (set-session-credentials! server cred)) + (set-session-dh-prime-bits! server 1024) + + (handshake server) + (let ((msg (read (session-record-port server))) + (auth-type (session-authentication-type server))) + (bye server close-request/rdwr) + (and (eq? auth-type credentials/certificate) + (equal? msg %message)))) + + ;; client-side (child process) + (let ((client (make-session connection-end/client)) + (cred (make-certificate-credentials))) + (set-session-priorities! client priorities) + + (set-certificate-credentials-openpgp-keys! cred pub sec) + (set-session-credentials! client cred) + (set-session-dh-prime-bits! client 1024) + + (set-session-transport-fd! client (port->fdes (car socket-pair))) + + (handshake client) + (write %message (session-record-port client)) + (bye client close-request/rdwr) + + (primitive-exit)))))) ;;; arch-tag: 1a973ed5-f45d-45a4-8160-900b6a8c27ff diff --git a/guile/tests/session-record-port.scm b/guile/tests/session-record-port.scm index bb3f25f844..8291880e27 100644 --- a/guile/tests/session-record-port.scm +++ b/guile/tests/session-record-port.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012, 2014 Free Software Foundation, Inc. +;;; Copyright (C) 2007-2012, 2014, 2016 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 @@ -51,73 +51,72 @@ ;; (format #t "[~a|~a] ~a" (getpid) level str))) (run-test - (lambda () - ;; Stress the GC. In 0.0, this triggered an abort due to - ;; "scm_unprotect_object called during GC". - (let ((sessions (map (lambda (i) - (make-session connection-end/server)) - (iota 123)))) - (for-each session-record-port sessions) - (gc)(gc)(gc)) - - ;; Stress the GC. The session associated to each port in PORTS should - ;; remain reachable. - (let ((ports (map session-record-port - (map (lambda (i) - (make-session connection-end/server)) - (iota 123))))) - (gc)(gc)(gc) - (for-each (lambda (p) - (catch 'gnutls-error - (lambda () - (read p)) - (lambda (key . args) - #t))) - ports)) - - ;; Try using the record port for I/O. - (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)) - (pid (primitive-fork))) - (if (= 0 pid) - - (let ((client (make-session connection-end/client))) - ;; client-side (child process) - (set-session-priorities! client priorities) - - (set-session-transport-port! client (car socket-pair)) - (set-session-credentials! client (make-anonymous-client-credentials)) - (set-session-dh-prime-bits! client 1024) - - (handshake client) - (uniform-vector-write %message (session-record-port client)) - (bye client close-request/rdwr) - - (primitive-exit)) - - (let ((server (make-session connection-end/server))) - ;; server-side - (set-session-priorities! server priorities) - - (set-session-transport-port! server (cdr socket-pair)) - (let ((cred (make-anonymous-server-credentials)) - (dh-params (import-dh-params "dh-parameters.pem"))) - ;; Note: DH parameter generation can take some time. - (set-anonymous-server-dh-parameters! cred dh-params) - (set-session-credentials! server cred)) - (set-session-dh-prime-bits! server 1024) - - (handshake server) - (let* ((buf (make-u8vector (u8vector-length %message))) - (amount - (uniform-vector-read! buf (session-record-port server)))) - (bye server close-request/rdwr) - - ;; Make sure we got everything right. - (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)))))))))) + (lambda () + ;; Stress the GC. In 0.0, this triggered an abort due to + ;; "scm_unprotect_object called during GC". + (let ((sessions (map (lambda (i) + (make-session connection-end/server)) + (iota 123)))) + (for-each session-record-port sessions) + (gc)(gc)(gc)) + + ;; Stress the GC. The session associated to each port in PORTS should + ;; remain reachable. + (let ((ports (map session-record-port + (map (lambda (i) + (make-session connection-end/server)) + (iota 123))))) + (gc)(gc)(gc) + (for-each (lambda (p) + (catch 'gnutls-error + (lambda () + (read p)) + (lambda (key . args) + #t))) + ports)) + + ;; Try using the record port for I/O. + (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))) + (with-child-process pid + + ;; server-side + (let ((server (make-session connection-end/server))) + (set-session-priorities! server priorities) + + (set-session-transport-port! server (cdr socket-pair)) + (let ((cred (make-anonymous-server-credentials)) + (dh-params (import-dh-params "dh-parameters.pem"))) + ;; Note: DH parameter generation can take some time. + (set-anonymous-server-dh-parameters! cred dh-params) + (set-session-credentials! server cred)) + (set-session-dh-prime-bits! server 1024) + + (handshake server) + (let* ((buf (make-u8vector (u8vector-length %message))) + (amount + (uniform-vector-read! buf (session-record-port server)))) + (bye server close-request/rdwr) + + ;; Make sure we got everything right. + (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)))))) + + ;; client-side (child process) + (let ((client (make-session connection-end/client))) + (set-session-priorities! client priorities) + + (set-session-transport-port! client (car socket-pair)) + (set-session-credentials! client (make-anonymous-client-credentials)) + (set-session-dh-prime-bits! client 1024) + + (handshake client) + (uniform-vector-write %message (session-record-port client)) + (bye client close-request/rdwr) + + (primitive-exit)))))) ;;; arch-tag: e873226a-d0b6-4a93-87ec-a1b5ad2ae8a2 diff --git a/guile/tests/x509-auth.scm b/guile/tests/x509-auth.scm index 71c8d1500a..609251d473 100644 --- a/guile/tests/x509-auth.scm +++ b/guile/tests/x509-auth.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2014 Free Software Foundation, Inc. +;;; Copyright (C) 2007-2014, 2016 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 @@ -55,56 +55,55 @@ ;; (format #t "[~a|~a] ~a" (getpid) level str))) (run-test - (lambda () - (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)) - (pub (import-key import-x509-certificate - "x509-certificate.pem")) - (sec (import-key import-x509-private-key - "x509-key.pem"))) - (let ((pid (primitive-fork))) - (if (= 0 pid) - - (let ((client (make-session connection-end/client)) - (cred (make-certificate-credentials))) - ;; client-side (child process) - (set-session-priorities! client priorities) - (set-certificate-credentials-x509-keys! cred (list pub) sec) - (set-session-credentials! client cred) - (set-session-dh-prime-bits! client 1024) - - (set-session-transport-fd! client (port->fdes (car socket-pair))) - - (handshake client) - (write %message (session-record-port client)) - (bye client close-request/rdwr) - - (primitive-exit)) - - (let ((server (make-session connection-end/server)) - (dh (import-dh-params "dh-parameters.pem"))) - ;; server-side - (set-session-priorities! server priorities) - (set-server-session-certificate-request! server - certificate-request/require) - - (set-session-transport-fd! server (port->fdes (cdr socket-pair))) - (let ((cred (make-certificate-credentials)) - (trust-file (search-path %load-path - "x509-certificate.pem")) - (trust-fmt x509-certificate-format/pem)) - (set-certificate-credentials-dh-parameters! cred dh) - (set-certificate-credentials-x509-keys! cred (list pub) sec) - (set-certificate-credentials-x509-trust-file! cred - trust-file - trust-fmt) - (set-session-credentials! server cred)) - (set-session-dh-prime-bits! server 1024) - - (handshake server) - (let ((msg (read (session-record-port server))) - (auth-type (session-authentication-type server))) - (bye server close-request/rdwr) - (and (eq? auth-type credentials/certificate) - (equal? msg %message))))))))) + (lambda () + (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)) + (pub (import-key import-x509-certificate + "x509-certificate.pem")) + (sec (import-key import-x509-private-key + "x509-key.pem"))) + (with-child-process pid + + ;; server-side + (let ((server (make-session connection-end/server)) + (dh (import-dh-params "dh-parameters.pem"))) + (set-session-priorities! server priorities) + (set-server-session-certificate-request! server + certificate-request/require) + + (set-session-transport-fd! server (port->fdes (cdr socket-pair))) + (let ((cred (make-certificate-credentials)) + (trust-file (search-path %load-path + "x509-certificate.pem")) + (trust-fmt x509-certificate-format/pem)) + (set-certificate-credentials-dh-parameters! cred dh) + (set-certificate-credentials-x509-keys! cred (list pub) sec) + (set-certificate-credentials-x509-trust-file! cred + trust-file + trust-fmt) + (set-session-credentials! server cred)) + (set-session-dh-prime-bits! server 1024) + + (handshake server) + (let ((msg (read (session-record-port server))) + (auth-type (session-authentication-type server))) + (bye server close-request/rdwr) + (and (eq? auth-type credentials/certificate) + (equal? msg %message)))) + + ;; client-side (child process) + (let ((client (make-session connection-end/client)) + (cred (make-certificate-credentials))) + (set-session-priorities! client priorities) + (set-certificate-credentials-x509-keys! cred (list pub) sec) + (set-session-credentials! client cred) + (set-session-dh-prime-bits! client 1024) + + (set-session-transport-fd! client (port->fdes (car socket-pair))) + + (handshake client) + (write %message (session-record-port client)) + (bye client close-request/rdwr) + + (primitive-exit)))))) ;;; arch-tag: 1f88f835-a5c8-4fd6-94b6-5a13571ba03d |