[gnutls-devel] [PATCH 1/8] guile: tests: Add 'with-child-process'.
Ludovic Courtès
ludo at gnu.org
Thu Feb 11 23:04:31 CET 2016
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.
---
guile/.dir-locals.el | 12 +++
guile/Makefile.am | 4 +-
guile/modules/gnutls/build/tests.scm | 41 ++++++++++-
guile/tests/anonymous-auth.scm | 76 ++++++++++---------
guile/tests/openpgp-auth.scm | 92 ++++++++++++-----------
guile/tests/session-record-port.scm | 137 +++++++++++++++++------------------
guile/tests/x509-auth.scm | 103 +++++++++++++-------------
7 files changed, 255 insertions(+), 210 deletions(-)
create mode 100644 guile/.dir-locals.el
diff --git a/guile/.dir-locals.el b/guile/.dir-locals.el
new file mode 100644
index 0000000..54091cc
--- /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 a981ed5..ed9b8ba 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 f5e135b..5a03ce7 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 at 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 585b3a5..d01884d 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 a60f885..49b4817 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 bb3f25f..8291880 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 71c8d15..609251d 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
--
2.6.3
More information about the Gnutls-devel
mailing list