From dlichteblau at common-lisp.net  Fri Mar  7 21:26:49 2008
From: dlichteblau at common-lisp.net (dlichteblau)
Date: Fri,  7 Mar 2008 16:26:49 -0500 (EST)
Subject: [cl-plus-ssl-cvs] CVS cl+ssl
Message-ID: <20080307212649.0E708610E7@common-lisp.net>

Update of /project/cl-plus-ssl/cvsroot/cl+ssl
In directory clnet:/tmp/cvs-serv24187

Modified Files:
	cl+ssl.asd ffi.lisp streams.lisp 
Log Message:
Implemented I/O deadline support for Clozure CL and SBCL.


--- /project/cl-plus-ssl/cvsroot/cl+ssl/cl+ssl.asd	2007/07/07 15:25:09	1.5
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/cl+ssl.asd	2008/03/07 21:26:48	1.6
@@ -13,7 +13,7 @@
 (in-package :cl+ssl-system)
 
 (defsystem :cl+ssl
-  :depends-on (:cffi :trivial-gray-streams :flexi-streams)
+  :depends-on (:cffi :trivial-gray-streams :flexi-streams #+sbcl :sb-posix)
   :serial t
   :components
    ((:file "package")
--- /project/cl-plus-ssl/cvsroot/cl+ssl/ffi.lisp	2007/12/21 13:36:15	1.6
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/ffi.lisp	2008/03/07 21:26:48	1.7
@@ -31,7 +31,9 @@
 (defconstant +ssl-filetype-default+ 3)
 
 (defconstant +SSL_CTRL_SET_SESS_CACHE_MODE+ 44)
+(defconstant +SSL_CTRL_MODE+ 33)
 
+(defconstant +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ 2)
 
 ;;; Misc
 ;;;
@@ -81,6 +83,9 @@
 (cffi:defcfun ("SSL_new" ssl-new)
     ssl-pointer
   (ctx ssl-ctx))
+(cffi:defcfun ("SSL_get_fd" ssl-get-fd)
+    :int
+  (ssl ssl-pointer))
 (cffi:defcfun ("SSL_set_fd" ssl-set-fd)
     :int
   (ssl ssl-pointer)
@@ -196,17 +201,105 @@
 (defvar *socket*)
 
 (declaim (inline ensure-ssl-funcall))
-(defun ensure-ssl-funcall (*socket* handle func sleep-time &rest args)
+(defun ensure-ssl-funcall (stream handle func &rest args)
   (loop
-    (handler-case
-	(let ((rc (apply func args)))
-	  (when (plusp rc)
-	    (return rc))
-	  (ssl-signal-error handle func (ssl-get-error handle rc) rc))
-      (ssl-error-want-something (condition)
-	(declare (ignore condition))
-	;; FIXME
-	(warn "busy waiting in ensure-ssl-funcall")))))
+     (let ((nbytes
+	    (let ((*socket* stream))	;for Lisp-BIO callbacks
+	      (apply func args))))
+       (when (plusp nbytes)
+	 (return nbytes))
+       (let ((error (ssl-get-error handle nbytes)))
+	 (case error
+	   (#.+ssl-error-want-read+
+	    (input-wait stream
+			(ssl-get-fd handle)
+			(ssl-stream-deadline stream)))
+	   (#.+ssl-error-want-write+
+	    (output-wait stream
+			 (ssl-get-fd handle)
+			 (ssl-stream-deadline stream)))
+	   (t
+	    (ssl-signal-error handle func error nbytes)))))))
+
+
+;;; Waiting for output to be possible
+
+#+clozure-common-lisp
+(defun milliseconds-until-deadline (deadline stream)
+  (let* ((now (get-internal-real-time)))
+    (if (> now deadline)
+	(error 'ccl::communication-deadline-expired :stream stream)
+	(values
+	 (round (- deadline now) (/ internal-time-units-per-second 1000))))))
+
+#+clozure-common-lisp
+(defun output-wait (stream fd deadline)
+  (unless deadline
+    (setf deadline (stream-deadline (ssl-stream-socket stream))))
+  (let* ((timeout
+	  (if deadline
+	      (milliseconds-until-deadline deadline stream)
+	      nil)))
+    (multiple-value-bind (win timedout error)
+	(ccl::process-output-wait fd timeout)
+      (unless win
+	(if timedout
+	    (error 'ccl::communication-deadline-expired :stream stream)
+	    (ccl::stream-io-error stream (- error) "write"))))))
+
+#+sbcl
+(defun output-wait (stream fd deadline)
+  (declare (ignore stream))
+  (let ((timeout
+	 ;; *deadline* is handled by wait-until-fd-usable automatically,
+	 ;; but we need to turn a user-specified deadline into a timeout
+	 (when deadline
+	   (/ (- deadline (get-internal-real-time))
+	      internal-time-units-per-second))))
+    (sb-sys:wait-until-fd-usable fd :output timeout)))
+
+#-(or clozure-common-lisp sbcl)
+(defun output-wait (stream fd deadline)
+  (declare (ignore stream fd deadline))
+  ;; This situation means that the lisp set our fd to non-blocking mode,
+  ;; and streams.lisp didn't know how to undo that.
+  (warn "non-blocking stream encountered unexpectedly"))
+
+
+;;; Waiting for input to be possible
+
+#+clozure-common-lisp
+(defun input-wait (stream fd deadline)
+  (unless deadline
+    (setf deadline (stream-deadline (ssl-stream-socket stream))))
+  (let* ((timeout
+	  (if deadline
+	      (milliseconds-until-deadline deadline stream)
+	      nil)))
+    (multiple-value-bind (win timedout error)
+	(ccl::process-input-wait fd timeout)
+      (unless win
+	(if timedout
+	    (error 'ccl::communication-deadline-expired :stream stream)
+	    (ccl::stream-io-error stream (- error) "read"))))))
+
+#+sbcl
+(defun input-wait (stream fd deadline)
+  (declare (ignore stream))
+  (let ((timeout
+	 ;; *deadline* is handled by wait-until-fd-usable automatically,
+	 ;; but we need to turn a user-specified deadline into a timeout
+	 (when deadline
+	   (/ (- deadline (get-internal-real-time))
+	      internal-time-units-per-second))))
+    (sb-sys:wait-until-fd-usable fd :input timeout)))
+
+#-(or clozure-common-lisp sbcl)
+(defun input-wait (stream fd deadline)
+  (declare (ignore stream fd deadline))
+  ;; This situation means that the lisp set our fd to non-blocking mode,
+  ;; and streams.lisp didn't know how to undo that.
+  (warn "non-blocking stream encountered unexpectedly"))
 
 
 ;;; Initialization
--- /project/cl-plus-ssl/cvsroot/cl+ssl/streams.lisp	2007/07/07 16:47:57	1.9
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/streams.lisp	2008/03/07 21:26:48	1.10
@@ -23,6 +23,10 @@
    (handle
     :initform nil
     :accessor ssl-stream-handle)
+   (deadline
+    :initform nil
+    :initarg :deadline
+    :accessor ssl-stream-deadline)
    (output-buffer
     :initform (make-buffer +initial-buffer-size+)
     :accessor ssl-stream-output-buffer)
@@ -52,14 +56,19 @@
   '(unsigned-byte 8))
 
 (defmethod close ((stream ssl-stream) &key abort)
-  (declare (ignore abort))
-  (force-output stream)
-  (ssl-free (ssl-stream-handle stream))
-  (setf (ssl-stream-handle stream) nil)
-  (when (streamp (ssl-stream-socket stream))
-    (close (ssl-stream-socket stream)))
-  (when (functionp (ssl-close-callback stream))
-    (funcall (ssl-close-callback stream))))
+  (cond
+    ((ssl-stream-handle stream)
+     (unless abort
+       (force-output stream))
+     (ssl-free (ssl-stream-handle stream))
+     (setf (ssl-stream-handle stream) nil)
+     (when (streamp (ssl-stream-socket stream))
+       (close (ssl-stream-socket stream)))
+     (when (functionp (ssl-close-callback stream))
+       (funcall (ssl-close-callback stream)))
+     t)
+    (t
+     nil)))
 
 (defmethod open-stream-p ((stream ssl-stream))
   (and (ssl-stream-handle stream) t))
@@ -76,10 +85,9 @@
       (let ((buf (ssl-stream-input-buffer stream)))
         (handler-case
             (with-pointer-to-vector-data (ptr buf)
-              (ensure-ssl-funcall (ssl-stream-socket stream)
+              (ensure-ssl-funcall stream
                                   (ssl-stream-handle stream)
                                   #'ssl-read
-                                  5.5
                                   (ssl-stream-handle stream)
                                   ptr
                                   1)
@@ -100,10 +108,9 @@
         do
           (handler-case
               (with-pointer-to-vector-data (ptr buf)
-                (ensure-ssl-funcall (ssl-stream-socket stream)
+                (ensure-ssl-funcall stream
                                     (ssl-stream-handle stream)
                                     #'ssl-read
-                                    5.5
                                     (ssl-stream-handle stream)
                                     ptr
                                     length)
@@ -111,6 +118,7 @@
                 (incf start length))
             (ssl-error-zero-return ()   ;SSL_read returns 0 on end-of-file
               (return))))
+    ;; fixme: kein out-of-file wenn (zerop start)?
     start))
 
 (defmethod stream-write-byte ((stream ssl-stream) b)
@@ -146,19 +154,73 @@
 (defmethod stream-force-output ((stream ssl-stream))
   (let ((buf (ssl-stream-output-buffer stream))
         (fill-ptr (ssl-stream-output-pointer stream))
-        (handle (ssl-stream-handle stream))
-	(socket (ssl-stream-socket stream)))
+        (handle (ssl-stream-handle stream)))
     (when (plusp fill-ptr)
+      (unless handle
+	(error "output operation on closed SSL stream"))
       (with-pointer-to-vector-data (ptr buf)
-        (ensure-ssl-funcall socket handle #'ssl-write 0.5 handle ptr fill-ptr))
+        (ensure-ssl-funcall stream handle #'ssl-write handle ptr fill-ptr))
       (setf (ssl-stream-output-pointer stream) 0))))
 
+#+clozure-common-lisp
+(defun install-nonblock-flag (fd)
+  (ccl::fd-set-flags fd (logior (ccl::fd-get-flags fd) #$O_NONBLOCK)))
+
+#+sbcl
+(defun install-nonblock-flag (fd)
+  (sb-posix:fcntl fd
+		  sb-posix::f-setfl
+		  (logior (sb-posix:fcntl fd sb-posix::f-getfl)
+			  sb-posix::o-nonblock)))
+
+#-(or clozure-common-lisp sbcl)
+(defun install-nonblock-flag (fd)
+  (declare (ignore fd)))
+
 
 ;;; interface functions
 ;;;
+
+(defun install-handle-and-bio (stream handle socket unwrap-stream-p)
+  (setf (ssl-stream-handle stream) handle)
+  (when unwrap-stream-p
+    (let ((fd (stream-fd socket)))
+      (when fd
+	(setf socket fd))))
+  (etypecase socket
+    (integer
+     (install-nonblock-flag socket)
+     (ssl-set-fd handle socket))
+    (stream
+     (ssl-set-bio handle (bio-new-lisp) (bio-new-lisp))))
+  (ssl-ctx-ctrl handle
+		+SSL_CTRL_MODE+
+		+SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+
+		0)
+  socket)
+
+(defun install-key-and-cert (handle key certificate)
+  (when key
+    (unless (eql 1 (ssl-use-rsa-privatekey-file handle
+						key
+						+ssl-filetype-pem+))
+      (error 'ssl-error-initialize :reason "Can't load RSA private key ~A")))
+  (when certificate
+    (unless (eql 1 (ssl-use-certificate-file handle
+					     certificate
+					     +ssl-filetype-pem+))
+      (error 'ssl-error-initialize
+	     :reason "Can't load certificate ~A" certificate))))
+
+(defun handle-external-format (stream ef)
+  (if ef
+      (flexi-streams:make-flexi-stream stream :external-format ef)
+      stream))
+
+;; fixme: free the context when errors happen in this function
 (defun make-ssl-client-stream
     (socket &key certificate key (method 'ssl-v23-method) external-format
-                 close-callback)
+                 close-callback (unwrap-stream-p t))
   "Returns an SSL stream for the client socket descriptor SOCKET.
 CERTIFICATE is the path to a file containing the PEM-encoded certificate for
  your client. KEY is the path to the PEM-encoded key for the client, which
@@ -168,31 +230,16 @@
 			       :socket socket
 			       :close-callback close-callback))
         (handle (ssl-new *ssl-global-context*)))
-    (setf (ssl-stream-handle stream) handle)
-    (etypecase socket
-      (integer (ssl-set-fd handle socket))
-      (stream (ssl-set-bio handle (bio-new-lisp) (bio-new-lisp))))
+    (setf socket (install-handle-and-bio stream handle socket unwrap-stream-p))
     (ssl-set-connect-state handle)
-    (when key
-      (unless (eql 1 (ssl-use-rsa-privatekey-file handle
-						  key
-						  +ssl-filetype-pem+))
-        (error 'ssl-error-initialize :reason "Can't load RSA private key ~A")))
-    (when certificate
-      (unless (eql 1 (ssl-use-certificate-file handle
-					       certificate
-					       +ssl-filetype-pem+))
-        (error 'ssl-error-initialize
-	       :reason "Can't load certificate ~A" certificate)))
-    (ensure-ssl-funcall socket handle #'ssl-connect 0.25 handle)
-    (if external-format
-        (flexi-streams:make-flexi-stream stream
-                                         :external-format external-format)
-        stream)))
+    (install-key-and-cert handle key certificate)
+    (ensure-ssl-funcall stream handle #'ssl-connect handle)
+    (handle-external-format stream external-format)))
 
+;; fixme: free the context when errors happen in this function
 (defun make-ssl-server-stream
     (socket &key certificate key (method 'ssl-v23-method) external-format
-                 close-callback)
+                 close-callback (unwrap-stream-p t))
   "Returns an SSL stream for the server socket descriptor SOCKET.
 CERTIFICATE is the path to a file containing the PEM-encoded certificate for
  your server. KEY is the path to the PEM-encoded key for the server, which
@@ -204,32 +251,21 @@
 		 :certificate certificate
 		 :key key))
         (handle (ssl-new *ssl-global-context*)))
-    (setf (ssl-stream-handle stream) handle)
-    (etypecase socket
-      (integer
-       (ssl-set-fd handle socket))
-      (stream
-       (let ((bio (bio-new-lisp)))
-	 (ssl-set-bio handle bio bio))))
+    (setf socket (install-handle-and-bio stream handle socket unwrap-stream-p))
     (ssl-set-accept-state handle)
     (when (zerop (ssl-set-cipher-list handle "ALL"))
       (error 'ssl-error-initialize :reason "Can't set SSL cipher list"))
-    (when key
-      (unless (eql 1 (ssl-use-rsa-privatekey-file handle
-						  key
-						  +ssl-filetype-pem+))
-        (error 'ssl-error-initialize :reason "Can't load RSA private key ~A")))
-    (when certificate
-      (unless (eql 1 (ssl-use-certificate-file handle
-					       certificate
-					       +ssl-filetype-pem+))
-        (error 'ssl-error-initialize
-	       :reason "Can't load certificate ~A" certificate)))
-    (ensure-ssl-funcall socket handle #'ssl-accept 0.25 handle)
-    (if external-format
-        (flexi-streams:make-flexi-stream stream
-                                         :external-format external-format)
-        stream)))
+    (install-key-and-cert handle key certificate)
+    (ensure-ssl-funcall stream handle #'ssl-accept handle)
+    (handle-external-format stream external-format)))
+
+#+openmcl
+(defmethod stream-deadline ((stream ccl::basic-stream))
+  (ccl::ioblock-deadline (ccl::stream-ioblock stream t)))
+#+openmcl
+(defmethod stream-deadline ((stream t))
+  nil)
+
 
 (defgeneric stream-fd (stream))
 (defmethod stream-fd (stream) stream)



From dlichteblau at common-lisp.net  Fri Mar  7 21:27:32 2008
From: dlichteblau at common-lisp.net (dlichteblau)
Date: Fri,  7 Mar 2008 16:27:32 -0500 (EST)
Subject: [cl-plus-ssl-cvs] CVS cl+ssl
Message-ID: <20080307212732.096DD610EE@common-lisp.net>

Update of /project/cl-plus-ssl/cvsroot/cl+ssl
In directory clnet:/tmp/cvs-serv24285

Added Files:
	example.lisp 
Log Message:
moved manual tests to example.lisp



--- /project/cl-plus-ssl/cvsroot/cl+ssl/example.lisp	2008/03/07 21:27:32	NONE
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/example.lisp	2008/03/07 21:27:32	1.1
;;; Copyright (C) 2001, 2003  Eric Marsden
;;; Copyright (C) 2005  David Lichteblau
;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt."
;;;
;;; See LICENSE for details.

#|
(load "example.lisp")
(ssl-test::test-https-client "www.google.com")
(ssl-test::test-https-server)
|#

(defpackage :ssl-test
  (:use :cl))
(in-package :ssl-test)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:operate 'asdf:load-op :trivial-sockets))

(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* ((deadline (+ (get-internal-real-time)
		      (* 3 internal-time-units-per-second)))
	 (socket (ccl:make-socket :address-family :internet
				  :connect :active
				  :type :stream
				  :remote-host host
				  :remote-port port
;;  				  :local-host (resolve-hostname local-host)
;; 				  :local-port local-port
				  :deadline deadline))
         (https
	  (progn
	    (cl+ssl:make-ssl-client-stream
	     socket
	     :unwrap-stream-p t
	     :external-format :iso-8859-1))))
    (unwind-protect
	(progn
	  (format https "GET / 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)))
	(unwind-protect
	    (progn
	      (loop :for line = (read-line-crlf client nil)
				:while (> (length line) 1) :do
				(format t "HTTPS> ~a~%" line))
	      (format client "HTTP/1.0 200 OK~%")
	      (format client "Server: SSL-CMUCL/1.1~%")
	      (format client "Content-Type: text/plain~%")
	      (terpri client)
	      (format client "G'day at ~A!~%"
		      (multiple-value-list (get-decoded-time)))
	      (format client "CL+SSL running in ~A ~A~%"
		      (lisp-implementation-type)
		      (lisp-implementation-version)))
	  (close socket)
	  (close client))))))


From dlichteblau at common-lisp.net  Fri Mar  7 21:27:44 2008
From: dlichteblau at common-lisp.net (dlichteblau)
Date: Fri,  7 Mar 2008 16:27:44 -0500 (EST)
Subject: [cl-plus-ssl-cvs] CVS cl+ssl
Message-ID: <20080307212744.E7CC5610EE@common-lisp.net>

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]



From dlichteblau at common-lisp.net  Fri Mar  7 21:28:49 2008
From: dlichteblau at common-lisp.net (dlichteblau)
Date: Fri,  7 Mar 2008 16:28:49 -0500 (EST)
Subject: [cl-plus-ssl-cvs] CVS cl+ssl
Message-ID: <20080307212849.BC8952400D@common-lisp.net>

Update of /project/cl-plus-ssl/cvsroot/cl+ssl
In directory clnet:/tmp/cvs-serv24392

Modified Files:
	index.css index.html 
Log Message:
updated documented for new argument UNWRAP-STREAM-P, mention deadline
in news.  removed ancient, irrelevant parts of the documentation.


--- /project/cl-plus-ssl/cvsroot/cl+ssl/index.css	2005/11/09 22:10:44	1.1.1.1
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/index.css	2008/03/07 21:28:49	1.2
@@ -21,11 +21,14 @@
 }
 
 h1,h2 {
-  background-color: darkred;
-  color: white;
   margin-left: -30px;
 }
 
+h3 {
+  margin-top: 2em;
+  margin-left: -20px;
+}
+
 th {
   background-color: darkred;
   color: white;
@@ -40,8 +43,11 @@
 }
 
 .def {
-  background-color: #ddddff;
+  background-color: #eeeeee;
+  width: 90%;
   font-weight: bold;
+  border: solid 1px #d0d0d0;
+  padding: 3px;
 }
 
 .nomargin {
--- /project/cl-plus-ssl/cvsroot/cl+ssl/index.html	2007/07/14 11:49:29	1.14
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/index.html	2008/03/07 21:28:49	1.15
@@ -6,54 +6,35 @@
     <link rel="stylesheet" type="text/css" href="index.css"/>
   </head>
   <body>
-    <h1>CL<em style="font-weight: normal">plus</em>SSL</h1>
+    <h1>CL+SSL</h1>
 
-    <h3>Subprojects</h3>
-    <ul>
-      <li><a href="#cl+ssl">CL+SSL</a></li>
-      <li><a href="#trivial-https">trivial-https</a></li>
-      <li><a href="#trivial-gray-streams">trivial-gray-streams</a></li>
-    </ul>
-
-    <h3>News</h3>
     <p>
-      2007-xx-yy
+      A Common Lisp interface to OpenSSL.
     </p>
-    <ul>
-      <li>
-	Fixed windows support, thanks to Matthew Kennedy and Vodonosov Anton.
-      </li>
-    </ul>
+
+    <h3>About</h3>
+
     <p>
-      2007-07-07
+      This library is a fork
+      of <a href="http://www.cliki.net/SSL-CMUCL">SSL-CMUCL</a>.  The
+      original SSL-CMUCL source code was written by Eric Marsden and
+      includes contributions by Jochen Schmidt. Development into CL+SSL
+      was done by David Lichteblau.  License: MIT-style.
     </p>
-    <ul>
-      <li>
-	Improved clisp support, thanks
-	to <a
-	      href="http://web.kepibu.org/code/lisp/cl+ssl/">Pixel
-	  // pinterface</a>, as well as client certificate support.
-      </li>
-      <li>
-	Re-introduced support for direct access to file descriptors as
-	an optimization.  New function <tt>stream-fd</tt>.  New keyword
-	argument <tt>close-callback</tt>.
-      </li>
-    </ul>
+
     <p>
-      2007-01-16: CL+SSL is now available under an MIT-style license.
+      Distinguishing features: CL+SSL is portable code based on CFFI and
+      gray streams.  It defines its own libssl BIO method, so that SSL
+      I/O can be written over portable Lisp streams instead of bypassing
+      the streams and sending data over Unix file descriptors directly.
+      (But the traditional approach is still used if possible.)
     </p>
 
     <h3>Download</h3>
     <p>
       Anonymous CVS (<a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=cl-plus-ssl">browse</a>):
     </p>
-    <pre>$ export CVSROOT=:pserver:anonymous at common-lisp.net:/project/cl-plus-ssl/cvsroot
-$ cvs login
-password: anonymous
-$ cvs co cl+ssl
-$ cvs co trivial-gray-streams
-$ cvs co trivial-https</pre>
+    <pre>$ cvs -d :pserver:anonymous:anonymous at common-lisp.net:/project/cl-plus-ssl/cvsroot cl+ssl</pre>
     <p>
       <a
       href="http://common-lisp.net/project/cl-plus-ssl/download/">Tarballs</a>
@@ -72,31 +53,7 @@
       information</a>).
     </p>
 
-    <a name="cl+ssl">
-    <h2>CL+SSL</h2>
-
-    <p>A simple Common Lisp interface to OpenSSL.</p>
-
-    <h3>About</h3>
-
-    <p>
-      This library is a fork of <a
-      href="http://www.cliki.net/SSL-CMUCL">SSL-CMUCL</a>.  The original
-      SSL-CMUCL source code was written by Eric Marsden and includes
-      contributions by Jochen Schmidt.  License: MIT-style.
-    </p>
-
-    <ul>
-      <li>
-        CL+SSL is portable code based on CFFI and gray streams.
-      </li>
-      <li>
-        It defines its own libssl BIO method, so that SSL I/O is
-        actually written over portable Lisp streams instead of bypassing
-	the streams and sending data over Unix file descriptors directly.
-      </li>
-    </ul>
-
+<!--
     <p>
       Comparison chart:
     </p>
@@ -133,32 +90,36 @@
       are provided
       using <a href="http://weitz.de/flexi-streams/">flexi-streams</a>.
     </p>
+-->
 
     <h3>API functions</h3>
     <p>
-      <div class="def">Function CL+SSL:STREAM-FD (stream)</div>
-      Return <tt>stream</tt>'s file descriptor as an integer, if
-      known.  Otherwise return <tt>stream</tt> itself.
-    </p>
-    <p>
-      Pass the
-      return value of this function to <tt>make-ssl-client-stream</tt>
-      or <tt>make-ssl-servre-stream</tt>, which are faster when
-      accessing file descriptors directly.
-    </p>
-    <p>
-      <div class="def">Function CL+SSL:MAKE-SSL-CLIENT-STREAM (fd-or-stream &amp;key external-format certificate key close-callback)</div>
-      Return an SSL stream for the client socket <tt>fd-or-stream</tt>.
-      All reads and writes to this SSL stream will be pushed through the
-      SSL connection.
+      <div class="def">Function CL+SSL:MAKE-SSL-CLIENT-STREAM (fd-or-stream &amp;key external-format certificate key close-callback (unwrap-streams-p t))<br/><br/>
+      Function CL+SSL:MAKE-SSL-SERVER-STREAM (fd-or-stream &amp;key external-format certificate key close-callback (unwrap-streams-p t))</div>
+      Return an SSL stream for the client (server)
+      socket <tt>fd-or-stream</tt>.  All reads and writes to this
+      stream will be pushed through the OpenSSL library.
+    </p>
+    <p>
+      Keyword arguments:
+    </p>
+    <p>
+      If <tt>fd-or-stream</tt> is a lisp stream, the SSL stream will
+      close it automatically.  File descriptors are not closed
+      automatically.  However, if <tt>close-callback</tt> is non-nil, it
+      will be called with zero arguments when the SSL stream is closed.
+    </p>
+    <p>
+      If <tt>unwrap-stream-p</tt> is true (the default), a stream for a
+      file descriptor will be replaced by that file descriptor
+      automatically.  This is similar to passing the result
+      of <tt>stream-fd</tt> as an argument, except that a deadline
+      associated with the stream object will be taken into account, and
+      that the stream will be closed automatically.  As with file
+      descriptor arguments, no I/O will actually be done on the stream
+      object.
     </p>
     <p>
-      If <tt>fd-or-stream</tt> is a lisp stream, it can
-      the SSL stream will close it automatically.  File descriptors are
-      not closed automatically.  However, if <tt>close-callback</tt> is
-      non-nil, it will be called with zero arguments when the SSL stream
-      is closed.
-      
       <tt>certificate</tt> is the path to a file containing the PEM-encoded
       certificate for your client. <tt>key</tt> is the path to the PEM-encoded
       key for the client, which must not be associated with a passphrase.
@@ -171,29 +132,18 @@
       as its initial external format.
     </p>
     <p>
-      <div class="def">Function CL+SSL:MAKE-SSL-SERVER-STREAM (fd-or-stream &amp;key external-format certificate key close-callback)</div>
-      Return an SSL stream for the server socket <tt>fd-or-stream</tt>.  All
-      reads and writes to this server stream will be pushed through the
-      OpenSSL library.
-    </p>
-    <p>
-      If <tt>fd-or-stream</tt> is a lisp stream, it can
-      the SSL stream will close it automatically.  File descriptors are
-      not closed automatically.  However, if <tt>close-callback</tt> is
-      non-nil, it will be called with zero arguments when the SSL stream
-      is closed.
-      
-      <tt>certificate</tt> is the path to a file containing the PEM-encoded
-      certificate for your server. <tt>key</tt> is the path to the PEM-encoded
-      key for the server, which must not be associated with a
-      passphrase.  See above for <tt>external-format</tt> handling.
-    </p>
-    <p>
       <div class="def">Function CL+SSL:RELOAD ()</div>
       Reload <tt>libssl</tt>.  Call this function after restarting a Lisp
       core with CL+SSL dumped into it on Lisp implementations that do
       not reload shared libraries automatically.
     </p>
+    <p>
+      <div class="def">Function CL+SSL:STREAM-FD (stream)</div>
+      Return <tt>stream</tt>'s file descriptor as an integer, if known.
+      Otherwise return <tt>stream</tt> itself.  The result of this
+      function can be passed to <tt>make-ssl-client-stream</tt>
+      and <tt>make-ssl-server-stream</tt>.
+    </p>
 
     <h3>Portability</h3>
     <p>
@@ -230,42 +180,47 @@
 
     <h3>TODO</h3>
     <ul>
-      <li>CNAME checking!</li>
+      <li>CNAME checking</li>
+      <li>session caching</li>
+      <li>The FFI code for all platforms except clisp needs to be
+      rewritten.</li>
     </ul>
 
-    <a name="trivial-https">
-    <h2>trivial-https</h2>
-
-    <p>
-      trivial-https is a fork of Brian
-      Mastenbrook's <a
-      href="http://www.cliki.net/trivial-http">trivial-http</a> adding
-      support for HTTPS using CL+SSL.  License: MIT-style.
-    </p>
-
+    <h3>News</h3>
     <p>
-      <b>
-	Note: The <a href="http://weitz.de/drakma/">Drakma</a> HTTP
-	client library by Weitz supports HTTPS using CL+SSL.
-	trivial-https will not be developed further; please use Drakma
-	instead.
-      </b>
+      2008-xx-yy
     </p>
-
+    <ul>
+      <li>
+	Support for I/O deadlines (Clozure CL and SBCL).
+      </li>
+    </ul>
     <p>
-      <a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/*checkout*/trivial-https/README?rev=HEAD&amp;cvsroot=cl-plus-ssl&amp;content-type=text/plain">README</a>
+      2007-xx-yy
     </p>
-
-    <a name="trivial-gray-streams">
-    <h2>trivial-gray-streams</h2>
-
+    <ul>
+      <li>
+	Fixed windows support, thanks to Matthew Kennedy and Vodonosov Anton.
+      </li>
+    </ul>
     <p>
-      trivial-gray-streams provides an extremely thin compatibility
-      layer for gray streams.  License: MIT-style.
+      2007-07-07
     </p>
-
+    <ul>
+      <li>
+	Improved clisp support, thanks
+	to <a
+	      href="http://web.kepibu.org/code/lisp/cl+ssl/">Pixel
+	  // pinterface</a>, as well as client certificate support.
+      </li>
+      <li>
+	Re-introduced support for direct access to file descriptors as
+	an optimization.  New function <tt>stream-fd</tt>.  New keyword
+	argument <tt>close-callback</tt>.
+      </li>
+    </ul>
     <p>
-      <a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/*checkout*/trivial-gray-streams/README?rev=HEAD&amp;cvsroot=cl-plus-ssl&amp;content-type=text/plain">README</a>
+      2007-01-16: CL+SSL is now available under an MIT-style license.
     </p>
   </body>
 </html>