246 lines
8.3 KiB
Scheme
246 lines
8.3 KiB
Scheme
|
;; the servlet handler
|
||
|
|
;; Copyright Andreas Bernauer, 2002
|
||
|
|
|
||
|
|
|
||
|
|
;(define-record-type continuation-table-entry :continuation-table-entry
|
||
|
|
; (make-continuation-table-entry continuation)
|
||
|
|
; continuation-table-entry?
|
||
|
|
; (id continuation-table-entry-id set-continuation-table-entry-id!)
|
||
|
|
; (continuation continuation-table-entry-continuation
|
||
|
|
; set-continuation-table-entry-continuation!))
|
||
|
|
|
||
|
|
|
||
|
|
;;; instance-table: entry for every new request on a servlet page
|
||
|
|
(define-record-type instance :instance
|
||
|
|
(make-instance servlet-name continuation-table)
|
||
|
|
instance?
|
||
|
|
(servlet-name really-instance-servlet-name
|
||
|
|
set-instance-servlet-name!)
|
||
|
|
(continuation-table really-instance-continuation-table
|
||
|
|
set-instance-continuation-table!))
|
||
|
|
|
||
|
|
(define-record-type session :session
|
||
|
|
(really-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 random (make-random (modulo (time)268435455))) ; not really random
|
||
|
|
; generator
|
||
|
|
|
||
|
|
(define (servlet-handler servlet-path)
|
||
|
|
(lambda (path req)
|
||
|
|
(if (pair? path) ; need at least one element
|
||
|
|
(let ((request-method (request:method req))
|
||
|
|
(full-path (uri-path-list->path path)))
|
||
|
|
(cond
|
||
|
|
((or (string=? request-method "GET")
|
||
|
|
(string=? request-method "PUT"))
|
||
|
|
(with-cwd
|
||
|
|
servlet-path
|
||
|
|
(if (resume-url? full-path)
|
||
|
|
(resume-url full-path req)
|
||
|
|
(launch-new-instance full-path req))))
|
||
|
|
(else
|
||
|
|
(make-http-error-response http-status/method-not-allowed req
|
||
|
|
request-method))))
|
||
|
|
(make-http-error-response http-status/bad-request req
|
||
|
|
(format #f "Bad path: ~s" path)))))
|
||
|
|
|
||
|
|
(define (launch-new-instance full-path req)
|
||
|
|
(let ((instance-id (generate-new-instance-id))
|
||
|
|
(plugin (get-plugin-rt-structure full-path)))
|
||
|
|
(call-with-current-continuation
|
||
|
|
(lambda (return)
|
||
|
|
(save-instance! full-path instance-id) ; make entry in instance-table
|
||
|
|
(register-session! instance-id return)
|
||
|
|
(with-names-from-rt-structure
|
||
|
|
plugin plugin-interface
|
||
|
|
;; MAIN may return in another thread, so we have to lookup
|
||
|
|
;; return continuation explicitly
|
||
|
|
((session-return-continuation) (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>
|
||
|
|
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)
|
||
|
|
|
||
|
|
(let* ((continuation-table (instance-continuation-table instance-id))
|
||
|
|
(resume (table-ref continuation-table continuation-id)))
|
||
|
|
(if resume
|
||
|
|
(call-with-current-continuation
|
||
|
|
(lambda (return)
|
||
|
|
(register-session! instance-id return)
|
||
|
|
(error "This may never return." ; for debugging
|
||
|
|
(resume req))))))))))))
|
||
|
|
|
||
|
|
|
||
|
|
(define (send/suspend response-maker)
|
||
|
|
(call-with-current-continuation
|
||
|
|
(lambda (return)
|
||
|
|
(let* ((instance-id (session-instance-id))
|
||
|
|
(continuations-table (instance-continuation-table 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-id)))
|
||
|
|
((session-return-continuation) (response-maker new-url)))))))
|
||
|
|
|
||
|
|
(define (send/finish response)
|
||
|
|
(instance-delete (session-instance-id))
|
||
|
|
((session-return-continuation) response))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; access to instance-table
|
||
|
|
(define (save-instance! servlet-name instance-id)
|
||
|
|
(table-set! *instance-table* instance-id
|
||
|
|
(make-instance servlet-name (make-integer-table))))
|
||
|
|
;; FIXME: make continuation-table thread-safe
|
||
|
|
|
||
|
|
(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-delete instance-id)
|
||
|
|
(table-set! *instance-table* instance-id #f))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; ID generation
|
||
|
|
;; FIXME: make this thread safe
|
||
|
|
;; FIXME: this may loop forever, if the table is full
|
||
|
|
;;(max. 2**28-1 instances)
|
||
|
|
(define (generate-new-instance-id)
|
||
|
|
(let loop ((instance-id (random)))
|
||
|
|
(if (instance instance-id)
|
||
|
|
(loop (random))
|
||
|
|
instance-id)))
|
||
|
|
|
||
|
|
|
||
|
|
;; FIXME make this thread-safe (locks)
|
||
|
|
;; FIXME this may loop forever, if the table is full
|
||
|
|
;; (max. 2**28-1 continuations)
|
||
|
|
(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))))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; PLUGINs CACHE
|
||
|
|
;; FIXME: make this thread-safe
|
||
|
|
(define *plugin-table* (make-string-table)) ; full-path is index
|
||
|
|
(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 ((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))))))
|
||
|
|
|
||
|
|
(define (reset-plugin-cache!)
|
||
|
|
(with-fatal-error-handler*
|
||
|
|
(lambda (condition decline)
|
||
|
|
(release-lock plugin-table-lock)
|
||
|
|
(decline))
|
||
|
|
(lambda ()
|
||
|
|
(obtain-lock plugin-table-lock)
|
||
|
|
(set! *plugin-table* (make-string-table))
|
||
|
|
(release-lock plugin-table-lock))))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; SESSION
|
||
|
|
(define *session* (make-thread-cell #f))
|
||
|
|
|
||
|
|
(define (register-session! instance-id return-continuation)
|
||
|
|
(thread-cell-set! *session*
|
||
|
|
(really-make-session instance-id return-continuation)))
|
||
|
|
|
||
|
|
|
||
|
|
;(define (save-session-return-continuation! return-continuation)
|
||
|
|
; (set-session-instance-id! (thread-cell-ref *session*)
|
||
|
|
; return-continuation))
|
||
|
|
|
||
|
|
(define (session-instance-id)
|
||
|
|
(really-session-instance-id (thread-cell-ref *session*)))
|
||
|
|
|
||
|
|
(define (session-return-continuation)
|
||
|
|
(really-session-return-continuation (thread-cell-ref *session*)))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; RESUME-URL
|
||
|
|
(define *resume-url-regexp* (rx (submatch (* (- printing ";")))
|
||
|
|
";k" (submatch (* digit)) ; Instance-ID
|
||
|
|
";c" (submatch (* digit)))) ; Continuation-ID
|
||
|
|
|
||
|
|
(define (make-resume-url full-path instance-id continuation-id)
|
||
|
|
(string-append full-path
|
||
|
|
";k" (number->string instance-id)
|
||
|
|
";c" (number->string continuation-id)))
|
||
|
|
|
||
|
|
(define (resume-url-instance-id id-url)
|
||
|
|
(receive (instance-id continuation-id)
|
||
|
|
(resume-url-ids id-url)
|
||
|
|
instance-id))
|
||
|
|
|
||
|
|
(define (resume-url-continuation-id id-url)
|
||
|
|
(receive (instance-id continuation-id)
|
||
|
|
(resume-url-ids id-url)
|
||
|
|
continuation-id))
|
||
|
|
|
||
|
|
(define (resume-url-ids id-url)
|
||
|
|
(let ((match (regexp-search *resume-url-regexp* id-url)))
|
||
|
|
(if match
|
||
|
|
(values (string->number (match:substring match 2))
|
||
|
|
(string->number (match:substring match 3)))
|
||
|
|
(error "resume-url-ids: no instance/continuation id" id-url))))
|
||
|
|
|
||
|
|
(define (resume-url-servlet-name id-url)
|
||
|
|
(let ((match (regexp-search *resume-url-regexp* id-url)))
|
||
|
|
(if match
|
||
|
|
(match:substring match 1)
|
||
|
|
(error "resume-url-servlet-name: no servlet-name found"))))
|
||
|
|
|
||
|
|
(define (resume-url? id-url)
|
||
|
|
(regexp-search? *resume-url-regexp* id-url))
|
||
|
|
|
||
|
|
|