[cl-plus-ssl-cvs] CVS cl+ssl
dlichteblau
dlichteblau at common-lisp.net
Fri Mar 7 21:27:44 UTC 2008
Update of /project/cl-plus-ssl/cvsroot/cl+ssl
In directory clnet:/tmp/cvs-serv24325
Modified Files:
test.lisp
Log Message:
new file: automatic tests
--- /project/cl-plus-ssl/cvsroot/cl+ssl/test.lisp 2007/07/07 16:26:11 1.3
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/test.lisp 2008/03/07 21:27:44 1.4
@@ -1,103 +1,371 @@
-;;; Copyright (C) 2001, 2003 Eric Marsden
-;;; Copyright (C) 2005 David Lichteblau
-;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt."
-;;;
+;;; Copyright (C) 2008 David Lichteblau
;;; See LICENSE for details.
#|
(load "test.lisp")
-(ssl-test::test-https-client "www.google.com")
-(ssl-test::test-https-server)
|#
(defpackage :ssl-test
(:use :cl))
(in-package :ssl-test)
+(defvar *port* 8080)
+(defvar *cert* "/home/david/newcert.pem")
+(defvar *key* "/home/david/newkey.pem")
+
(eval-when (:compile-toplevel :load-toplevel :execute)
- (asdf:operate 'asdf:load-op :trivial-sockets))
+ (asdf:operate 'asdf:load-op :trivial-sockets)
+ (asdf:operate 'asdf:load-op :bordeaux-threads))
+
+(defparameter *tests* '())
+
+(defvar *sockets* '())
+(defvar *sockets-lock* (bordeaux-threads:make-lock))
+
+(defun record-socket (socket)
+ (unless (integerp socket)
+ (bordeaux-threads:with-lock-held (*sockets-lock*)
+ (push socket *sockets*)))
+ socket)
+
+(defun close-socket (socket &key abort)
+ (if (streamp socket)
+ (close socket :abort abort)
+ (trivial-sockets:close-server socket)))
+
+(defun check-sockets ()
+ (let ((failures nil))
+ (bordeaux-threads:with-lock-held (*sockets-lock*)
+ (dolist (socket *sockets*)
+ (when (close-socket socket :abort t)
+ (push socket failures)))
+ (setf *sockets* nil))
+ #-sbcl ;fixme
+ (when failures
+ (error "failed to close sockets properly:~{ ~A~%~}" failures))))
+
+(defmacro deftest (name &body body)
+ `(progn
+ (defun ,name ()
+ (format t "~%----- ~A ----------------------------~%" ',name)
+ (handler-case
+ (progn
+ , at body
+ (check-sockets)
+ (format t "===== [OK] ~A ====================~%" ',name)
+ t)
+ (error (c)
+ (when (typep c 'trivial-sockets:socket-error)
+ (setf c (trivial-sockets:socket-nested-error c)))
+ (format t "~%===== [FAIL] ~A: ~A~%" ',name c)
+ (handler-case
+ (check-sockets)
+ (error (c)
+ (format t "muffling follow-up error ~A~%" c)))
+ nil)))
+ (push ',name *tests*)))
+
+(defun run-all-tests ()
+ (unless (probe-file *cert*) (error "~A not found" *cert*))
+ (unless (probe-file *key*) (error "~A not found" *key*))
+ (let ((n 0)
+ (nok 0))
+ (dolist (test (reverse *tests*))
+ (when (funcall test)
+ (incf nok))
+ (incf n))
+ (format t "~&passed ~D/~D tests~%" nok n)))
+
+(define-condition quit (condition)
+ ())
+
+(defparameter *please-quit* t)
+
+(defun make-test-thread (name init main &rest args)
+ "Start a thread named NAME, wait until it has funcalled INIT with ARGS
+ as arguments, then continue while the thread concurrently funcalls MAIN
+ with INIT's return values as arguments."
+ (let ((cv (bordeaux-threads:make-condition-variable))
+ (lock (bordeaux-threads:make-lock name))
+ ;; redirect io manually, because swan's global redirection isn't as
+ ;; global as one might hope
+ (out *terminal-io*)
+ (init-ok nil))
+ (bordeaux-threads:with-lock-held (lock)
+ (setf *please-quit* nil)
+ (prog1
+ (bordeaux-threads:make-thread
+ (lambda ()
+ (flet ((notify ()
+ (bordeaux-threads:with-lock-held (lock)
+ (bordeaux-threads:condition-notify cv))))
+ (let ((*terminal-io* out)
+ (*standard-output* out)
+ (*trace-output* out)
+ (*error-output* out))
+ (handler-case
+ (let ((values (multiple-value-list (apply init args))))
+ (setf init-ok t)
+ (notify)
+ (apply main values))
+ (quit ()
+ (notify)
+ t)
+ (error (c)
+ (when (typep c 'trivial-sockets:socket-error)
+ (setf c (trivial-sockets:socket-nested-error c)))
+ (format t "aborting test thread ~A: ~A" name c)
+ (notify)
+ nil)))))
+ :name name)
+ (bordeaux-threads:condition-wait cv lock)
+ (unless init-ok
+ (error "failed to start background thread"))))))
+
+(defmacro with-thread ((name init main &rest args) &body body)
+ `(invoke-with-thread (lambda () , at body)
+ ,name
+ ,init
+ ,main
+ , at args))
-(defun read-line-crlf (stream &optional eof-error-p)
- (let ((s (make-string-output-stream)))
- (loop
- for empty = t then nil
- for c = (read-char stream eof-error-p nil)
- while (and c (not (eql c #\return)))
- do
- (unless (eql c #\newline)
- (write-char c s))
- finally
- (return
- (if empty nil (get-output-stream-string s))))))
-
-(defun test-nntps-client (&optional (host "snews.gmane.org") (port 563))
- (let* ((fd (trivial-sockets:open-stream host port
- :element-type '(unsigned-byte 8)))
- (nntps (cl+ssl:make-ssl-client-stream fd :external-format :iso-8859-1)))
- (format t "NNTPS> ~A~%" (read-line-crlf nntps))
- (write-line "HELP" nntps)
- (force-output nntps)
- (loop :for line = (read-line-crlf nntps nil)
- :until (string-equal "." line)
- :do (format t "NNTPS> ~A~%" line))))
-
-
-;; open an HTTPS connection to a secure web server and make a
-;; HEAD request
-(defun test-https-client (host &optional (port 443))
- (let* ((socket (trivial-sockets:open-stream
- host
- port
- :element-type '(unsigned-byte 8)))
- (https (cl+ssl:make-ssl-client-stream
- (cl+ssl:stream-fd socket)
- :external-format :iso-8859-1)))
+(defun invoke-with-thread (body name init main &rest args)
+ (let ((thread (apply #'make-test-thread name init main args)))
(unwind-protect
- (progn
- (format https "HEAD / HTTP/1.0~%Host: ~a~%~%" host)
- (force-output https)
- (loop :for line = (read-line-crlf https nil)
- :while line :do
- (format t "HTTPS> ~a~%" line)))
- (close socket)
- (close https))))
-
-;; start a simple HTTPS server. See the mod_ssl documentation at
-;; <URL:http://www.modssl.org/> for information on generating the
-;; server certificate and key
-;;
-;; You can stress-test the server with
-;;
-;; siege -c 10 -u https://host:8080/foobar
-;;
-(defun test-https-server
- (&key (port 8080)
- (cert "/home/david/newcert.pem")
- (key "/home/david/newkey.pem"))
- (format t "~&SSL server listening on port ~d~%" port)
- (trivial-sockets:with-server (server (:port port))
- (loop
- (let* ((socket (trivial-sockets:accept-connection
- server
- :element-type '(unsigned-byte 8)))
- (client (cl+ssl:make-ssl-server-stream
- (cl+ssl:stream-fd socket)
- :external-format :iso-8859-1
- :certificate cert
- :key key)))
+ (funcall body)
+ (setf *please-quit* t)
+ (loop
+ for delay = 0.0001 then (* delay 2)
+ while (and (< delay 0.5) (bordeaux-threads:thread-alive-p thread))
+ do
+ (sleep delay))
+ (when (bordeaux-threads:thread-alive-p thread)
+ (format t "~&thread doesn't want to quit, killing it~%")
+ (force-output)
+ (bordeaux-threads:interrupt-thread thread (lambda () (error 'quit)))
+ (loop
+ for delay = 0.0001 then (* delay 2)
+ while (bordeaux-threads:thread-alive-p thread)
+ do
+ (sleep delay))))))
+
+(defun init-server (&key (unwrap-stream-p t))
+ (format t "~&SSL server listening on port ~d~%" *port*)
+ (values (record-socket (trivial-sockets:open-server :port *port*))
+ unwrap-stream-p))
+
+(defun test-server (listening-socket unwrap-stream-p)
+ (format t "~&SSL server accepting...~%")
+ (unwind-protect
+ (let* ((socket (record-socket
+ (trivial-sockets:accept-connection
+ listening-socket
+ :element-type '(unsigned-byte 8))))
+ (callback nil))
+ (when (eq unwrap-stream-p :caller)
+ (setf callback (let ((s socket)) (lambda () (close-socket s))))
+ (setf socket (cl+ssl:stream-fd socket))
+ (setf unwrap-stream-p nil))
+ (let ((client (record-socket
+ (cl+ssl:make-ssl-server-stream
+ socket
+ :unwrap-stream-p unwrap-stream-p
+ :close-callback callback
+ :external-format :iso-8859-1
+ :certificate *cert*
+ :key *key*))))
+ (unwind-protect
+ (loop
+ for line = (prog2
+ (when *please-quit* (return))
+ (read-line client nil)
+ (when *please-quit* (return)))
+ while line
+ do
+ (cond
+ ((equal line "freeze")
+ (format t "~&Freezing on client request~%")
+ (loop
+ (sleep 1)
+ (when *please-quit* (return))))
+ (t
+ (format t "~&Responding to query ~A...~%" line)
+ (format client "(echo ~A)~%" line)
+ (force-output client))))
+ (close-socket client))))
+ (close-socket listening-socket)))
+
+(defun init-client (&key (unwrap-stream-p t))
+ (let ((socket (record-socket
+ (trivial-sockets:open-stream
+ "127.0.0.1"
+ *port*
+ :element-type '(unsigned-byte 8))))
+ (callback nil))
+ (when (eq unwrap-stream-p :caller)
+ (setf callback (let ((s socket)) (lambda () (close-socket s))))
+ (setf socket (cl+ssl:stream-fd socket))
+ (setf unwrap-stream-p nil))
+ (cl+ssl:make-ssl-client-stream
+ socket
+ :unwrap-stream-p unwrap-stream-p
+ :close-callback callback
+ :external-format :iso-8859-1)))
+
+;;; Simple echo-server test. Write a line and check that the result
+;;; watches, three times in a row.
+(deftest echo
+ (with-thread ("simple server" #'init-server #'test-server)
+ (with-open-stream (socket (init-client))
+ (write-line "test" socket)
+ (force-output socket)
+ (assert (equal (read-line socket) "(echo test)"))
+ (write-line "test2" socket)
+ (force-output socket)
+ (assert (equal (read-line socket) "(echo test2)"))
+ (write-line "test3" socket)
+ (force-output socket)
+ (assert (equal (read-line socket) "(echo test3)")))))
+
+;;; Run tests with different BIO setup strategies:
+;;; - :UNWRAP-STREAMS T
+;;; In this case, CL+SSL will convert the socket to a file descriptor.
+;;; - :UNWRAP-STREAMS :CLIENT
+;;; Convert the socket to a file descriptor manually, and give that
+;;; to CL+SSL.
+;;; - :UNWRAP-STREAMS NIL
+;;; Let CL+SSL write to the stream directly, using the Lisp BIO.
+(macrolet ((deftests (name (var &rest values) &body body)
+ `(progn
+ ,@(loop
+ for value in values
+ collect
+ `(deftest ,(intern (format nil "~A-~A" name value))
+ (let ((,var ',value))
+ , at body))))))
+
+ (deftests unwrap-strategy (usp nil t :caller)
+ (with-thread ("echo server for strategy test"
+ (lambda () (init-server :unwrap-stream-p usp))
+ #'test-server)
+ (with-open-stream (socket (init-client :unwrap-stream-p usp))
+ (write-line "test" socket)
+ (force-output socket)
+ (assert (equal (read-line socket) "(echo test)")))))
+
+ #+clozure-common-lisp
+ (deftests read-deadline (usp nil t)
+ (with-thread ("echo server for deadline test"
+ (lambda () (init-server :unwrap-stream-p usp))
+ #'test-server)
+ (let* ((deadline
+ (+ (get-internal-real-time)
+ (* 3 internal-time-units-per-second)))
+ (low
+ (record-socket
+ (ccl:make-socket
+ :address-family :internet
+ :connect :active
+ :type :stream
+ :remote-host "127.0.0.1"
+ :remote-port *port*
+ :deadline deadline))))
+ (with-open-stream
+ (socket
+ (cl+ssl:make-ssl-client-stream
+ low
+ :unwrap-stream-p usp
+ :external-format :iso-8859-1))
+ (write-line "test" socket)
+ (force-output socket)
+ (assert (equal (read-line socket) "(echo test)"))
+ (handler-case
+ (progn
+ (read-char socket)
+ (error "unexpected data"))
+ (ccl::communication-deadline-expired ()))))))
+
+ #+sbcl
+ (deftests read-deadline (usp nil t :caller)
+ (with-thread ("echo server for deadline test"
+ (lambda () (init-server :unwrap-stream-p usp))
+ #'test-server)
+ (sb-sys:with-deadline (:seconds 3)
+ (with-open-stream (socket (init-client :unwrap-stream-p usp))
+ (write-line "test" socket)
+ (force-output socket)
+ (assert (equal (read-line socket) "(echo test)"))
+ (handler-case
+ (progn
+ (read-char socket)
+ (error "unexpected data"))
+ (sb-sys:deadline-timeout ()))))))
+
+ #+clozure-common-lisp
+ (deftests write-deadline (usp nil t)
+ (with-thread ("echo server for deadline test"
+ (lambda () (init-server :unwrap-stream-p usp))
+ #'test-server)
+ (let* ((deadline
+ (+ (get-internal-real-time)
+ (* 3 internal-time-units-per-second)))
+ (low
+ (record-socket
+ (ccl:make-socket
+ :address-family :internet
+ :connect :active
+ :type :stream
+ :remote-host "127.0.0.1"
+ :remote-port *port*
+ :deadline deadline)))
+ (socket
+ (cl+ssl:make-ssl-client-stream
+ low
[62 lines skipped]
More information about the cl-plus-ssl-cvs
mailing list