On Tue, Dec 21, 2010 at 4:19 AM, Leslie P. Polzer <[email protected]> wrote:
> We've discussed this in the context of the upcoming Postmodern store
> and think it's the right thing to do (provided we abstract it properly
> so it works with multiple stores).
>
> But we need to test and think a bit more about it. It'd be great if
> you could try this approach in parallel for CLSQL.
Okay, I took a shot at it. I quickly discovered the complication
posed by multiple stores. But I think I found a reasonably elegant
solution. It cheats just a tiny bit, by calling the internal accessor
CLSQL-SYS::CONNECTION-SPEC, but that's all. It seems to work, though
all I've done with it so far is run the demo.
The patch is below. Basically there's a new generic function
THREAD-PREPARE-STORE by which each store gets to do setup and teardown
for each thread. PROCESS-CONNECTION (not ACCEPT-CONNECTIONS, as I
originally thought) is made to call this.
I added an (OPEN-STORES) call in START-WEBLOCKS, and a (CLOSE-STORES)
call in STOP-WEBLOCKS. The former is necessary, because the stores
have to be opened before the server threads get created in order for
THREAD-PREPARE-STORE to do its thing. The latter isn't strictly
necessary, but I noticed that STOP-WEBLOCKS wasn't closing stores as
its doc string promises.
To convince yourself it's working, trace CLSQL:CONNECT and
CLSQL:DISCONNECT. (You probably know, but I didn't: if you're using
slime-repl, trace output from background threads appears in
*inferior-lisp*.)
-- Scott
diff -r 5659d7f4ca80 src/acceptor.lisp
--- a/src/acceptor.lisp Wed Dec 15 12:56:55 2010 +0100
+++ b/src/acceptor.lisp Wed Dec 22 12:04:33 2010 -0800
@@ -20,3 +20,7 @@
(let ((*print-readably* nil))
(call-next-method)))
+(defmethod process-connection :around ((acceptor weblocks-acceptor) socket)
+ (with-stores-thread-prepared
+ (call-next-method)))
+
diff -r 5659d7f4ca80 src/server.lisp
--- a/src/server.lisp Wed Dec 15 12:56:55 2010 +0100
+++ b/src/server.lisp Wed Dec 22 12:04:33 2010 -0800
@@ -56,6 +56,7 @@
(if debug
(enable-global-debugging)
(disable-global-debugging))
+ (open-stores)
(when (null *weblocks-server*)
(values
(start (setf *weblocks-server*
@@ -75,6 +76,7 @@
(reset-sessions)
(when *weblocks-server*
(stop *weblocks-server*))
+ (close-stores)
(setf *weblocks-server* nil)))
diff -r 5659d7f4ca80 src/store/clsql/clsql.lisp
--- a/src/store/clsql/clsql.lisp Wed Dec 15 12:56:55 2010 +0100
+++ b/src/store/clsql/clsql.lisp Wed Dec 22 12:04:33 2010 -0800
@@ -10,13 +10,18 @@
(export '(order-by-expression range-to-offset range-to-limit))
+(defmethod thread-prepare-store ((store database) thunk)
+ (with-database (*default-database* (clsql-sys::connection-spec store)
+ :database-type (database-type store)
+ :pool t :if-exists :new)
+ (funcall thunk)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Initialization/finalization ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod open-store ((store-type (eql :clsql)) &rest args)
(setf *default-caching* nil)
- (setf *default-store* (apply #'make-instance 'fluid-database
- :connection-spec args)))
+ (setf *default-store* (apply #'connect args)))
(defmethod close-store ((store database))
(when (eq *default-store* store)
diff -r 5659d7f4ca80 src/store/clsql/weblocks-clsql.asd
--- a/src/store/clsql/weblocks-clsql.asd Wed Dec 15 12:56:55 2010 +0100
+++ b/src/store/clsql/weblocks-clsql.asd Wed Dec 22 12:04:33 2010 -0800
@@ -11,6 +11,6 @@
:author "Slava Akhmechet"
:licence "LLGPL"
:description "A weblocks backend for clsql."
- :depends-on (:closer-mop :metatilities :clsql :clsql-fluid :weblocks)
+ :depends-on (:closer-mop :metatilities :clsql :weblocks)
:components ((:file "clsql")))
diff -r 5659d7f4ca80 src/store/store-api.lisp
--- a/src/store/store-api.lisp Wed Dec 15 12:56:55 2010 +0100
+++ b/src/store/store-api.lisp Wed Dec 22 12:04:33 2010 -0800
@@ -1,7 +1,7 @@
(in-package :weblocks)
-(export '(open-store close-store clean-store *default-store*
+(export '(open-store close-store clean-store thread-prepare-store
*default-store*
begin-transaction commit-transaction rollback-transaction
dynamic-transaction use-dynamic-transaction-p
persist-object delete-persistent-object
@@ -26,6 +26,10 @@
should erase data, but not necessarily any schema information (like
tables, etc.)"))
+(defgeneric thread-prepare-store (store thunk)
+ (:documentation "Some stores need per-thread setup/teardown. This
function does
+ the setup, calls THUNK (a function of no arguments), and does the
teardown."))
+
(defvar *default-store* nil
"The default store to which objects are persisted. Bound while a
webapp is handling a request to the value of its
diff -r 5659d7f4ca80 src/store/store-utils.lisp
--- a/src/store/store-utils.lisp Wed Dec 15 12:56:55 2010 +0100
+++ b/src/store/store-utils.lisp Wed Dec 22 12:04:33 2010 -0800
@@ -158,3 +158,21 @@
(dolist (obj objects)
(apply #'persist-object store obj keys)))
+;;; Default method.
+(defmethod thread-prepare-store ((store t) thunk)
+ (funcall thunk))
+
+(defun thread-prepare-stores (thunk)
+ (labels ((rec (store-names)
+ (if store-names
+ (if (symbol-value (car store-names))
+ (thread-prepare-store (symbol-value (car store-names))
+ #'(lambda ()
+ (rec (cdr store-names))))
+ (rec (cdr store-names)))
+ (funcall thunk))))
+ (rec *store-names*)))
+
+(defmacro with-stores-thread-prepared (&body body)
+ `(thread-prepare-stores #'(lambda () . ,body)))
+
--
You received this message because you are subscribed to the Google Groups
"weblocks" group.
To post to this group, send email to [email protected].
To unsubscribe from this group, send email to
[email protected].
For more options, visit this group at
http://groups.google.com/group/weblocks?hl=en.
