[Portableaserve-cvslog] CVS: portableaserve/acl-compat/lispworks acl-socket.lisp, 1.6, 1.7

[Kevin R. <kev...@us...>]

Update of /cvsroot/portableaserve/portableaserve/acl-compat/lispworks
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21037/acl-compat/lispworks

Modified Files:
	acl-socket.lisp 
Log Message:
Patch from Lispworks Inc to add SSL support

Index: acl-socket.lisp
===================================================================
RCS file: /cvsroot/portableaserve/portableaserve/acl-compat/lispworks/acl-socket.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -w -r1.6 -r1.7
--- acl-socket.lisp	20 Oct 2005 07:54:06 -0000	1.6
+++ acl-socket.lisp	15 Aug 2008 00:35:05 -0000	1.7
@@ -308,4 +308,50 @@
 		     :ssl-configure-callback #'ssl-configure-callback))
   socket-stream)
 
+
+;; SSL support using built-in LispWorks OpenSSL interface
+
+(defvar *certificate-ctx-map* (make-hash-table :test 'equal))
+(defvar *certificate-ctx-map-lock* (mp:make-lock))
+(defvar *share-ssl-ctx-p* nil) ; needs to remain as NIL for ACL compatibility?
+
+(defun ensure-ssl-ctx-for-certificate (certificate-file
+                                       key
+                                       certificate-password)
+  (if *share-ssl-ctx-p*
+      (mp:with-lock (*certificate-ctx-map-lock*)
+        (or (gethash certificate-file *certificate-ctx-map*)
+            (setf (gethash certificate-file *certificate-ctx-map*)
+                  (make-ssl-ctx-for-certificate certificate-file
+                                                key
+                                                certificate-password))))
+    (make-ssl-ctx-for-certificate certificate-file
+                                  key
+                                  certificate-password)))
+
+(defun make-ssl-ctx-for-certificate (certificate-file
+                                     key
+                                     certificate-password)
+  (let ((ssl-ctx (comm:make-ssl-ctx :ssl-side :server)))
+    (when certificate-password
+      (comm:set-ssl-ctx-password-callback ssl-ctx :password certificate-password))
+    (comm:ssl-ctx-use-certificate-chain-file ssl-ctx (namestring certificate-file))
+    (comm:ssl-ctx-use-rsaprivatekey-file ssl-ctx
+                                         (namestring (or key certificate-file))
+                                         comm:ssl_filetype_pem)
+    ;; (comm:set-ssl-ctx-dh ssl-ctx :filename dh-file)
+    ssl-ctx))
+
+(defmethod make-ssl-server-stream ((stream comm:socket-stream) &key
+                                   certificate key certificate-password
+                                   ;; method verify max-depth   ; client cert options
+                                   ;; ca-file ca-directory      ;   not implemented yet
+                                   )
+  (let ((ctx (ensure-ssl-ctx-for-certificate certificate
+                                             key
+                                             certificate-password)))
+    (comm:attach-ssl stream :ssl-side :server :ssl-ctx ctx)
+    ;; Return the same stream -- is this allowed?
+    stream))
+
 (provide 'acl-socket)