remove FIXMEs:
* respect presence of threads - use locks for table accesses (*instance-table*, continuation-table, *plugin-table*) * return 404 Not found if servlet does not exist * neglect POST request (will do this later) * reload plugin if timestamp has changed
This commit is contained in:
interp
parent
be308133d2
commit
4d9f45c1bd
|
|
@ -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.<BR>
|
||||
(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.<BR>
|
||||
You can try starting at the <A HREF=~a>beginning</a>."
|
||||
(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 <A HREF=~a>beginning</a>."
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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 <A HREF=~a>beginning</a>."
|
|||
|
||||
(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 <A HREF=~a>beginning</a>."
|
|||
(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
|
||||
Loading…
Reference in New Issue