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