From dlichteblau at common-lisp.net  Sun Apr  3 13:20:29 2011
From: dlichteblau at common-lisp.net (dlichteblau)
Date: Sun, 03 Apr 2011 09:20:29 -0400
Subject: [cl-plus-ssl-cvs] CVS cl+ssl
Message-ID: <E1Q6NED-0008Jo-No@common-lisp.net>

Update of /project/cl-plus-ssl/cvsroot/cl+ssl
In directory cl-net:/tmp/cvs-serv31882

Modified Files:
	cl+ssl.asd ffi.lisp 
Log Message:
Implement locking and thread ID callbacks using bxthreads; lock around initialization


--- /project/cl-plus-ssl/cvsroot/cl+ssl/cl+ssl.asd	2008/03/07 21:26:48	1.6
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/cl+ssl.asd	2011/04/03 13:20:29	1.7
@@ -13,7 +13,8 @@
 (in-package :cl+ssl-system)
 
 (defsystem :cl+ssl
-  :depends-on (:cffi :trivial-gray-streams :flexi-streams #+sbcl :sb-posix)
+  :depends-on (:cffi :trivial-gray-streams :flexi-streams #+sbcl :sb-posix
+		     :bordeaux-threads :trivial-garbage)
   :serial t
   :components
    ((:file "package")
--- /project/cl-plus-ssl/cvsroot/cl+ssl/ffi.lisp	2010/05/23 23:24:38	1.14
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/ffi.lisp	2011/04/03 13:20:29	1.15
@@ -205,6 +205,14 @@
   (ctx ssl-ctx)
   (pem_passwd_cb :pointer))
 
+(cffi:defcfun ("CRYPTO_num_locks" crypto-num-locks) :int)
+(cffi:defcfun ("CRYPTO_set_locking_callback" crypto-set-locking-callback)
+    :void
+  (fun :pointer))
+(cffi:defcfun ("CRYPTO_set_id_callback" crypto-set-id-callback)
+    :void
+  (fun :pointer))
+
 ;;; Funcall wrapper
 ;;;
 (defvar *socket*)
@@ -369,7 +377,54 @@
 (defun ssl-ctx-set-session-cache-mode (ctx mode)
   (ssl-ctx-ctrl ctx +SSL_CTRL_SET_SESS_CACHE_MODE+ mode 0))
 
+(defvar *locks*)
+(defconstant +CRYPTO-LOCK+ 1)
+(defconstant +CRYPTO-UNLOCK+ 2)
+(defconstant +CRYPTO-READ+ 4)
+(defconstant +CRYPTO-WRITE+ 8)
+
+;; zzz as of early 2011, bxthreads is totally broken on SBCL wrt. explicit
+;; locking of recursive locks.  with-recursive-lock works, but acquire/release
+;; don't.  Hence we use non-recursize locks here (but can use a recursive
+;; lock for the global lock).
+
+(cffi:defcallback locking-callback :void
+    ((mode :int)
+     (n :int)
+     (file :string)
+     (line :int))
+  (declare (ignore file line))
+  ;; (assert (logtest mode (logior +CRYPTO-READ+ +CRYPTO-WRITE+)))
+  (let ((lock (elt *locks* n)))
+    (cond
+      ((logtest mode +CRYPTO-LOCK+)
+       (bt:acquire-lock lock))
+      ((logtest mode +CRYPTO-UNLOCK+)
+       (bt:release-lock lock))
+      (t
+       (error "fell through")))))
+
+(defvar *threads* (trivial-garbage:make-weak-hash-table :weakness :key))
+(defvar *thread-counter* 0)
+
+(defparameter *global-lock*
+  (bordeaux-threads:make-recursive-lock "SSL initialization"))
+
+;; zzz BUG: On a 32-bit system and under non-trivial load, this counter
+;; is likely to wrap in less than a year.
+(cffi:defcallback threadid-callback :unsigned-long ()
+  (bordeaux-threads:with-recursive-lock-held (*global-lock*)
+    (let ((self (bt:current-thread)))
+      (or (gethash self *threads*)
+	  (setf (gethash self *threads*)
+		(incf *thread-counter*))))))
+
 (defun initialize (&key (method 'ssl-v23-method) rand-seed)
+  (setf *locks* (loop
+		   repeat (crypto-num-locks)
+		   collect (bt:make-lock)))
+  (crypto-set-locking-callback (cffi:callback locking-callback))
+  (crypto-set-id-callback (cffi:callback threadid-callback))
   (setf *bio-lisp-method* (make-bio-lisp-method))
   (ssl-load-error-strings)
   (ssl-library-init)
@@ -398,10 +453,11 @@
 
 Hint: do not use Common Lisp RANDOM function to generate the RAND-SEED, 
 because the function usually returns predictable values."
-  (unless (ssl-initialized-p)
-    (initialize :method method :rand-seed rand-seed))
-  (unless *bio-lisp-method*
-    (setf *bio-lisp-method* (make-bio-lisp-method))))
+  (bordeaux-threads:with-recursive-lock-held (*global-lock*)
+    (unless (ssl-initialized-p)
+      (initialize :method method :rand-seed rand-seed))
+    (unless *bio-lisp-method*
+      (setf *bio-lisp-method* (make-bio-lisp-method)))))
 
 (defun use-certificate-chain-file (certificate-chain-file)
   "Loads a PEM encoded certificate chain file CERTIFICATE-CHAIN-FILE




From avodonosov at common-lisp.net  Thu Apr  7 00:20:11 2011
From: avodonosov at common-lisp.net (avodonosov)
Date: Wed, 06 Apr 2011 20:20:11 -0400
Subject: [cl-plus-ssl-cvs] CVS cl+ssl
Message-ID: <E1Q7cxH-0007XV-2F@common-lisp.net>

Update of /project/cl-plus-ssl/cvsroot/cl+ssl
In directory cl-net:/tmp/cvs-serv28892

Modified Files:
	ffi.lisp 
Log Message:
Fix typo: missed parameter in the FFI wrapper for SSL_CTX_use_RSAPrivateKey_file.

--- /project/cl-plus-ssl/cvsroot/cl+ssl/ffi.lisp	2011/04/03 13:20:29	1.15
+++ /project/cl-plus-ssl/cvsroot/cl+ssl/ffi.lisp	2011/04/07 00:20:10	1.16
@@ -170,6 +170,7 @@
     ("SSL_CTX_use_RSAPrivateKey_file" ssl-ctx-use-rsa-privatekey-file)
     :int
   (ctx ssl-ctx)
+  (file :string)
   (type :int))
 (cffi:defcfun ("SSL_use_certificate_file" ssl-use-certificate-file)
     :int
@@ -394,6 +395,7 @@
      (file :string)
      (line :int))
   (declare (ignore file line))
+
   ;; (assert (logtest mode (logior +CRYPTO-READ+ +CRYPTO-WRITE+)))
   (let ((lock (elt *locks* n)))
     (cond