diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm
index f6223c5..1e5dd9d 100644
--- a/scheme/httpd/surflets/surflet-handler.scm
+++ b/scheme/httpd/surflets/surflet-handler.scm
@@ -4,25 +4,24 @@
;;; instance-table: entry for every new request on a servlet page
(define-record-type instance :instance
- (make-instance servlet-name continuation-table continuation-counter)
+ (make-instance servlet-name continuation-table continuation-table-lock
+ continuation-counter)
instance?
- (servlet-name really-instance-servlet-name
- set-instance-servlet-name!)
- (continuation-table really-instance-continuation-table
- set-instance-continuation-table!)
- (continuation-counter really-instance-continuation-counter
- set-instance-continuation-counter!))
+ (servlet-name instance-servlet-name)
+ (continuation-table instance-continuation-table)
+ (continuation-table-lock instance-continuation-table-lock)
+ (continuation-counter instance-continuation-counter))
(define-record-type session :session
- (really-make-session instance-id return-continuation)
+ (make-session instance-id return-continuation)
session?
(instance-id really-session-instance-id
set-session-instance-id!)
(return-continuation really-session-return-continuation
set-session-return-continuation!))
-;; FIXME: Make this thread-safe
(define *instance-table* (make-integer-table)) ; instance-id is index
+(define *instance-table-lock* (make-lock))
(define random
(let* ((source (make-random-source))
(random-integer (begin
@@ -48,7 +47,8 @@
(reset-plugin-cache!)
(make-http-error-response http-status/accepted req "plugin cache cleared"))
((or (string=? request-method "GET")
- (string=? request-method "PUT"))
+; (string=? request-method "POST")) ; do this at later time
+ )
(with-cwd
servlet-path
(if (resume-url? full-path)
@@ -60,65 +60,95 @@
(make-http-error-response http-status/bad-request req
(format #f "Bad path: ~s" path)))))
-;; FIXME: test for file existance
(define (launch-new-instance full-path req)
- (let ((instance-id (generate-new-instance-id))
- (plugin (get-plugin-rt-structure full-path)))
- (save-instance! full-path instance-id) ; make entry in instance-table
- (reset
- (begin
- (register-session! instance-id 'no-return)
- (with-names-from-rt-structure
- plugin plugin-interface
- (main req))))))
+ (if (file-not-exists? full-path)
+ (make-http-error-response http-status/not-found req full-path)
+ (begin
+ (obtain-lock *instance-table-lock*)
+ ;; no access to instance table until new instance-id is saved
+ (let ((instance-id (generate-new-table-id *instance-table*)))
+ (table-set! *instance-table* instance-id
+ (make-instance full-path ; used to make
+ ; redirections to origin
+ (make-integer-table) ; continuation table
+ (make-lock) ; continuation table lock
+ (make-thread-safe-counter))) ; continuation counter
+ (release-lock *instance-table-lock*)
+ (let ((plugin (with-fatal-error-handler*
+ (lambda (condition decline)
+ (instance-delete! instance-id)
+ (decline))
+ (lambda ()
+ (get-plugin-rt-structure full-path)))))
+ (reset
+ (begin
+ (register-session! instance-id 'no-return)
+ (with-names-from-rt-structure
+ plugin plugin-interface
+ (main req)))))))))
;; try to get continuation-table and then the continuation
-(define (resume-url full-path req)
- (call-with-current-continuation
- (lambda (return)
- (with-fatal-error-handler*
- (lambda (condition decline)
- (return (make-http-error-response
- http-status/bad-request req
- (format #f "The servlet does not accept any requests any more or your URL is illformed.
+(define resume-url
+ (let ((bad-request
+ (lambda (full-path req)
+ (make-http-error-response
+ http-status/bad-request req
+ (format #f "The servlet does not accept any requests any more or your URL is illformed.
You can try starting at the beginning."
- (resume-url-servlet-name full-path)))))
- (lambda ()
- (receive (instance-id continuation-id)
- (resume-url-ids full-path)
+ (resume-url-servlet-name full-path)))))
+ (lookup-continuation-table
+ (lambda (instance continuation-table continuation-id)
+ (let ((continuation-table-lock (instance-continuation-table-lock instance)))
+ (obtain-lock continuation-table-lock)
+ (let ((result (table-ref continuation-table continuation-id)))
+ (release-lock continuation-table-lock)
+ result)))))
+
+ (lambda (full-path req)
+ (receive (instance-id continuation-id)
+ (resume-url-ids full-path)
+ (let ((instance (instance-lookup instance-id)))
+ (if instance
+ (let* ((continuation-table (instance-continuation-table instance))
+ (resume (lookup-continuation-table instance continuation-table
+ continuation-id)))
+ (if resume
+ (reset
+ (begin
+ (register-session! instance-id 'no-return)
+; (error "This may never return." ; for debugging
+ (resume req)))
+ (bad-request full-path req)))
+ (bad-request full-path req)))
+ ))))
+
- (let* ((continuation-table (instance-continuation-table instance-id))
- (resume (table-ref continuation-table continuation-id)))
- (if resume
- (reset
- (begin
- (register-session! instance-id 'no-return)
-; (error "This may never return." ; for debugging
- (resume req)))))))))))
-
-
(define (send-html/suspend html-tree-maker)
(shift return
(let* ((instance-id (session-instance-id))
- (continuations-table (instance-continuation-table instance-id))
- (continuation-counter (instance-next-continuation-counter instance-id))
- (continuation-id (generate-new-continuation-id instance-id)))
- (table-set! continuations-table continuation-id return)
- (let ((new-url (make-resume-url (instance-servlet-name instance-id)
- instance-id
- continuation-counter
- continuation-id)))
- (make-usual-html-response
- (lambda (out options)
- (with-current-output-port*
- out
- (lambda () (SXML->HTML (html-tree-maker new-url))))))))))
+ (instance (instance-lookup instance-id))
+ (continuations-table (instance-continuation-table instance))
+ (continuation-table-lock (instance-continuation-table-lock instance))
+ (continuation-counter (instance-next-continuation-counter instance)))
+ (obtain-lock continuation-table-lock)
+ (let ((continuation-id (generate-new-table-id continuations-table)))
+ (table-set! continuations-table continuation-id return)
+ (release-lock continuation-table-lock)
+ (let ((new-url (make-resume-url (instance-servlet-name instance)
+ instance-id
+ continuation-counter
+ continuation-id)))
+ (make-usual-html-response
+ (lambda (out options)
+ (with-current-output-port*
+ out
+ (lambda () (SXML->HTML (html-tree-maker new-url)))))))))))
(define (send-html/finish html-tree)
- (instance-delete (session-instance-id))
+ (instance-delete! (session-instance-id))
(make-usual-html-response
(lambda (out options)
- (with-current-output-port* ; don't want to blame Oleg, but...
+ (with-current-output-port* ; FIXME: will change in further revision
out
(lambda () (SXML->HTML html-tree))))))
@@ -133,92 +163,80 @@ You can try starting at the beginning."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; access to instance-table
-(define (save-instance! servlet-name instance-id)
- (table-set! *instance-table* instance-id
- (make-instance servlet-name (make-integer-table) 0)))
-;; FIXME: make continuation-table thread-safe
+(define (instance-lookup instance-id)
+ (obtain-lock *instance-table-lock*)
+ (let ((result (table-ref *instance-table* instance-id)))
+ (release-lock *instance-table-lock*)
+ result))
-(define (instance instance-id)
- (table-ref *instance-table* instance-id))
-
-(define (instance-servlet-name instance-id)
- (really-instance-servlet-name (instance instance-id)))
-
-(define (instance-continuation-table instance-id)
- (really-instance-continuation-table (instance instance-id)))
-
-(define (instance-continuation-counter instance-id)
- (really-instance-continuation-counter (instance instance-id)))
-
-(define (instance-next-continuation-counter instance-id)
- (let ((instance (instance instance-id)))
- (set-instance-continuation-counter!
- instance
- (+ 1 (really-instance-continuation-counter instance)))
- (really-instance-continuation-counter instance)))
-
-(define (instance-delete instance-id)
- (table-set! *instance-table* instance-id #f))
+(define (instance-next-continuation-counter instance)
+ (thread-safe-counter-next!
+ (instance-continuation-counter instance)))
+(define (instance-delete! instance-id)
+ (obtain-lock *instance-table-lock*)
+ ;; why can't table entries be deleted correctly?
+ (table-set! *instance-table* instance-id #f)
+ (release-lock *instance-table-lock*))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ID generation
-;; FIXME: make this thread safe
-;; FIXME: this may loop forever, if the table is full (can this happen?)
-(define (generate-new-instance-id)
- (let loop ((instance-id (random)))
- (if (instance instance-id)
+;; locking must be done by caller
+;; FIXME?: this may loop forever, if the table is full (can this happen?)
+(define (generate-new-table-id table)
+ (let loop ((id (random)))
+ (if (table-ref table id)
(loop (random))
- instance-id)))
-
-
-;; FIXME make this thread-safe (locks)
-;; FIXME this may loop forever, if the table is full (can this happen?)
-(define (generate-new-continuation-id instance-id)
- (let ((continuation-table (instance-continuation-table instance-id)))
- (let loop ((continuation-id (random)))
- (if (table-ref continuation-table continuation-id)
- (loop (random))
- continuation-id))))
-
+ id)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PLUGINs CACHE
-;; FIXME: make this thread-safe
(define *plugin-table* (make-string-table)) ; full-path is index
-(define plugin-table-lock (make-lock))
+(define *plugin-table-lock* (make-lock))
-;; FIXME: reload plugin if timestamp has changed
;; PLUGIN-NAME is like "news-dir/latest-news.scm"
(define (get-plugin-rt-structure plugin-name)
+ (let ((load-plugin
+ (lambda ()
+ (with-fatal-error-handler*
+ (lambda (condition decline)
+ (release-lock *plugin-table-lock*)
+ (decline))
+ (lambda ()
+ ;; load-config-file does not care about cwd(?)
+ ;; --> absolute file name needed
+ (load-config-file (absolute-file-name plugin-name))
+ ;; plugin-structure to load must be named "plugin"
+ (let ((plugin-structure (reify-structure 'plugin)))
+ (load-structure plugin-structure)
+ (table-set! *plugin-table* plugin-name
+ (cons plugin-structure
+ (file-last-mod plugin-name)))
+ ;; only now the lock may be released
+ (release-lock *plugin-table-lock*)
+ plugin-structure))))))
+
+ (obtain-lock *plugin-table-lock*)
(let ((plugin (table-ref *plugin-table* plugin-name)))
(if plugin
- plugin
- (with-fatal-error-handler*
- (lambda (condition decline)
- (release-lock plugin-table-lock)
- (decline))
- (lambda ()
- (obtain-lock plugin-table-lock)
- ;; load-config-file does not care about cwd(?)
- ;; --> absolute file name needed
- (load-config-file (absolute-file-name plugin-name))
- ;; plugin-structure to load must be named "plugin"
- (let ((plugin-structure (reify-structure 'plugin)))
- (load-structure plugin-structure)
- (table-set! *plugin-table* plugin-name plugin-structure)
- (release-lock plugin-table-lock)
- plugin-structure))))))
+ (if (equal? (file-last-mod plugin-name)
+ (cdr plugin))
+ (begin
+ (release-lock *plugin-table-lock*)
+ (car plugin))
+ (load-plugin))
+ (load-plugin)))))
(define (reset-plugin-cache!)
(with-fatal-error-handler*
(lambda (condition decline)
- (release-lock plugin-table-lock)
+ (release-lock *plugin-table-lock*)
(decline))
(lambda ()
- (obtain-lock plugin-table-lock)
+ (obtain-lock *plugin-table-lock*)
(set! *plugin-table* (make-string-table))
- (release-lock plugin-table-lock))))
+ (release-lock *plugin-table-lock*))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SESSION
@@ -226,7 +244,7 @@ You can try starting at the beginning."
(define (register-session! instance-id return-continuation)
(thread-cell-set! *session*
- (really-make-session instance-id return-continuation)))
+ (make-session instance-id return-continuation)))
;(define (save-session-return-continuation! return-continuation)
@@ -278,3 +296,38 @@ You can try starting at the beginning."
(regexp-search? *resume-url-regexp* id-url))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; thread-safe counter
+
+(define-record-type counter :counter
+ (really-make-counter counter lock)
+ (counter counter-counter set-counter-counter!)
+ (lock counter-lock))
+
+(define (make-thread-safe-counter)
+ (really-make-counter 0 (make-lock)))
+
+;;; read current value
+(define (thread-safe-counter counter)
+ (obtain-lock (counter-lock counter))
+ (let ((result (counter-counter counter)))
+ (release-lock (counter-lock counter))
+ result))
+
+;;; make next value and return it
+(define (thread-safe-counter-next! counter)
+ (obtain-lock (counter-lock counter))
+ (let ((result (+ 1 (counter-counter counter))))
+ (set-counter-counter! counter result)
+ (release-lock (counter-lock counter))
+ result))
+
+
+
+
+
+; instance-table thread safe
+; continuation-table thread safe
+; generate-new-instance-id only called if thread safe
+; generate-new-continuation-id only called if thread safe
+; respect plugin timestamp
\ No newline at end of file