480 lines
16 KiB
Scheme
480 lines
16 KiB
Scheme
;; the servlet handler
|
|
;; Copyright Andreas Bernauer, 2002
|
|
|
|
|
|
(define *debug* #t)
|
|
|
|
;;; instance-table: entry for every new request on a servlet page
|
|
(define-record-type instance :instance
|
|
(make-instance servlet-name memo
|
|
continuation-table continuation-table-lock
|
|
continuation-counter)
|
|
instance?
|
|
(servlet-name instance-servlet-name)
|
|
(memo instance-memo set-instance-memo!)
|
|
(continuation-table instance-continuation-table)
|
|
(continuation-table-lock instance-continuation-table-lock)
|
|
(continuation-counter instance-continuation-counter))
|
|
|
|
(define-record memo
|
|
(message 'kill) ;kill, killed, adjust-timeout
|
|
(value #f)
|
|
(new-memo #f))
|
|
|
|
;; caller must do locking stuff
|
|
(define (memo-killed! memo)
|
|
(set-memo:message memo 'killed))
|
|
|
|
(define-record-type session :session
|
|
(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!))
|
|
|
|
(define-record options
|
|
(cache-plugins? #t)
|
|
(instance-lifetime 600)) ; in seconds
|
|
|
|
(define *options* (make-options))
|
|
;(define *options-lock* (make-lock)) ; currently unused
|
|
|
|
(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
|
|
(random-source-randomize! source)
|
|
(random-source-make-integers source))))
|
|
(lambda ()
|
|
(random-integer 1073741824)))) ; I hope, 1+ billion is enough....
|
|
|
|
;; servlet-prefix gives virtual prefixed path to servlets
|
|
(define (servlet-handler servlet-path servlet-prefix)
|
|
(lambda (path req)
|
|
(if (pair? path) ; need at least one element
|
|
(let ((request-method (request:method req))
|
|
(path-string (uri-path-list->path path)))
|
|
(cond
|
|
; ((string=? path-string "profile") ; triggers profiling
|
|
; (http-syslog (syslog-level debug)
|
|
; "profiling: triggered in servlet-handler [~a]"
|
|
; (profile-space)) ; PROFILE
|
|
; (make-http-error-response http-status/accepted req "profiled"))
|
|
; ((string=? path-string "reset") ; triggers cache clearing
|
|
; (http-syslog (syslog-level debug)
|
|
; "servlet-handler: clearing plugin cache")
|
|
; (reset-plugin-cache!)
|
|
; (http-syslog (syslog-level debug)
|
|
; "servlet-handler: clearing instance table")
|
|
; (reset-instance-table!)
|
|
; (make-http-error-response http-status/accepted req "plugin cache cleared"))
|
|
((or (string=? request-method "GET")
|
|
; (string=? request-method "POST")) ; do this at later time
|
|
)
|
|
(let ((response
|
|
(if (resume-url? path-string)
|
|
(resume-url path-string servlet-path req)
|
|
(launch-new-instance path-string servlet-path req))))
|
|
(if (redirect-body? (response-body response))
|
|
;; prefix with servlet-path
|
|
(make-redirect-response
|
|
(string-join (file-name-as-directory servlet-prefix)
|
|
(redirect-body-location (response-body response))))
|
|
response)))
|
|
(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 path-string servlet-path req)
|
|
(if (file-not-exists? (absolute-file-name path-string servlet-path))
|
|
(make-http-error-response http-status/not-found req path-string)
|
|
(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*))
|
|
(memo (make-memo)))
|
|
(table-set! *instance-table* instance-id
|
|
(make-instance path-string ; used to make
|
|
; redirections to origin
|
|
memo
|
|
(make-integer-table) ; continuation table
|
|
(make-lock) ; continuation table lock
|
|
(make-thread-safe-counter))) ; continuation counter
|
|
(release-lock *instance-table-lock*)
|
|
(register-session! instance-id 'no-return)
|
|
(let ((plugin (with-fatal-error-handler*
|
|
(lambda (condition decline)
|
|
(instance-delete! instance-id)
|
|
(decline))
|
|
(lambda ()
|
|
(get-plugin-rt-structure path-string servlet-path)))))
|
|
(fork-thread (instance-surveillance instance-id
|
|
(+ (time)
|
|
(options:instance-lifetime *options*))
|
|
memo))
|
|
(reset
|
|
(begin
|
|
(with-cwd
|
|
servlet-path
|
|
(with-names-from-rt-structure
|
|
plugin plugin-interface
|
|
(main req))))))))))
|
|
|
|
(define (instance-surveillance instance-id time-to-die memo)
|
|
(lambda ()
|
|
(let loop ((time-to-die time-to-die)
|
|
(memo memo))
|
|
(debug "instance-surveillance[~s]: going to sleep until ~a"
|
|
instance-id (format-date "~c" (date time-to-die)))
|
|
(let ((seconds-to-sleep (- time-to-die (time))))
|
|
(if (positive? seconds-to-sleep)
|
|
(sleep (* 1000 seconds-to-sleep))))
|
|
;; check state of the world
|
|
(case (memo:message memo)
|
|
((killed) ; too late
|
|
(debug "instance-surveillance[~s]: instance already killed, dieing"
|
|
instance-id)
|
|
)
|
|
((adjust-timeout) ; new timeout
|
|
(debug "instance-surveillance[~s]: adjusting timeout" instance-id)
|
|
(loop (memo:value memo)
|
|
(memo:new-memo memo)))
|
|
((kill) ; kill instance
|
|
(debug "instance-surveillance[~s]: killing"
|
|
instance-id)
|
|
(obtain-lock *instance-table-lock*)
|
|
(table-set! *instance-table* instance-id #f)
|
|
(release-lock *instance-table-lock*))
|
|
(else
|
|
(format (current-error-port)
|
|
"instance-surveillance[~s]: unknown message ~s; dieing"
|
|
instance-id (memo:message memo)))))))
|
|
|
|
|
|
;; try to get continuation-table and then the continuation
|
|
(define resume-url
|
|
(let ((bad-request
|
|
(lambda (path-string req)
|
|
(make-http-error-response
|
|
http-status/bad-request req
|
|
(format #f
|
|
"<br>
|
|
<p>There may be several reasons, why your request was denied:
|
|
<ul>
|
|
<li>The servlet does not accept any requests any more.</li>
|
|
<li>The servlet URL has timed out.</li>
|
|
<li>You URL is illformed.</li>
|
|
</ul>
|
|
</p>
|
|
<p>In any case, you may try to restart the servlet from the <a href=\"~a\">beginning</a></p>"
|
|
(resume-url-servlet-name path-string)))))
|
|
(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 (path-string servlet-path req)
|
|
(receive (instance-id continuation-id)
|
|
(resume-url-ids path-string)
|
|
(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
|
|
(with-cwd
|
|
servlet-path
|
|
(reset
|
|
(begin
|
|
(register-session! instance-id 'no-return)
|
|
(resume req))))
|
|
(bad-request path-string req)))
|
|
(bad-request path-string req)))
|
|
))))
|
|
|
|
|
|
(define (send/suspend response-maker)
|
|
(shift return
|
|
(let* ((instance-id (session-instance-id))
|
|
(instance (instance-lookup instance-id)))
|
|
;; the session might be deleted in the meanwhile
|
|
(if instance
|
|
(begin
|
|
(instance-adjust-timeout! instance-id)
|
|
(let ((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)))
|
|
(response-maker new-url)))))
|
|
(make-http-error-response http-status/not-found #f
|
|
"The URL refers to a servlet, whose instance is no longer alive.")))))
|
|
|
|
(define (send/finish response)
|
|
(instance-delete! (session-instance-id))
|
|
(shift unused response))
|
|
|
|
(define (send response)
|
|
(shift unsused response))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; access to instance-table
|
|
(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-next-continuation-counter instance)
|
|
(thread-safe-counter-next!
|
|
(instance-continuation-counter instance)))
|
|
|
|
(define (instance-delete! instance-id)
|
|
(obtain-lock *instance-table-lock*)
|
|
;; notify surveillance of instance being alread killed (prevents
|
|
;; surveillance of killing new instance that has the same number by
|
|
;; accident)
|
|
(let ((instance (table-ref *instance-table* instance-id)))
|
|
(memo-killed! (instance-memo instance)))
|
|
;; why can't table entries be deleted correctly?
|
|
(table-set! *instance-table* instance-id #f)
|
|
(release-lock *instance-table-lock*))
|
|
|
|
(define (instance-adjust-timeout! instance-id)
|
|
(obtain-lock *instance-table-lock*)
|
|
(let* ((instance (table-ref *instance-table* instance-id))
|
|
(memo (instance-memo instance))
|
|
(new-memo (make-memo)))
|
|
;; Do it this way: new values and then new message
|
|
(set-memo:value memo
|
|
(+ (time)
|
|
(options:instance-lifetime *options*)))
|
|
(set-memo:new-memo memo new-memo)
|
|
;; I don't think we need locking here. Do you agree?
|
|
(set-instance-memo! instance new-memo)
|
|
(set-memo:message memo 'adjust-timeout))
|
|
(release-lock *instance-table-lock*))
|
|
|
|
(define (reset-instance-table!)
|
|
(with-fatal-error-handler
|
|
(lambda (condtion decline)
|
|
(release-lock *instance-table-lock*)
|
|
(decline))
|
|
(lambda ()
|
|
(obtain-lock *instance-table-lock*)
|
|
;; notify instance killing
|
|
(table-walk
|
|
(lambda (instance-id instance)
|
|
(memo-killed! (instance-memo instance)))
|
|
*instance-table*)
|
|
(set! *instance-table* (make-integer-table))
|
|
(release-lock *instance-table*))))
|
|
|
|
(define (get-instances)
|
|
(obtain-lock *instance-table-lock*)
|
|
(let ((instances '()))
|
|
(table-walk
|
|
(lambda (instance-id instance-entry)
|
|
(set! instances (cons (cons instance-id instance-entry) instances)))
|
|
*instance-table*)
|
|
(release-lock *instance-table-lock*)
|
|
instances))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; ID generation
|
|
;; 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))
|
|
id)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; PLUGINs CACHE
|
|
(define *plugin-table* (make-string-table)) ; path-string is index
|
|
(define *plugin-table-lock* (make-lock))
|
|
|
|
;; PLUGIN-NAME is like "news-dir/latest-news.scm"
|
|
(define (get-plugin-rt-structure plugin-name directory)
|
|
(let* ((full-plugin-name (absolute-file-name plugin-name directory))
|
|
(load-plugin
|
|
(lambda (cached?)
|
|
(with-fatal-error-handler*
|
|
(lambda (condition decline)
|
|
(if cached? (release-lock *plugin-table-lock*))
|
|
(decline))
|
|
(lambda ()
|
|
;; load-config-file does not care about cwd(?)
|
|
;; --> absolute file name needed
|
|
(load-config-file full-plugin-name)
|
|
;; plugin-structure to load must be named "plugin"
|
|
(let ((plugin-structure (reify-structure 'plugin)))
|
|
(load-structure plugin-structure)
|
|
(if cached?
|
|
(begin
|
|
(table-set! *plugin-table* full-plugin-name
|
|
(cons plugin-structure
|
|
(file-last-mod full-plugin-name)))
|
|
;; only now the lock may be released
|
|
(release-lock *plugin-table-lock*)))
|
|
plugin-structure))))))
|
|
(if (options:cache-plugins? *options*)
|
|
(begin
|
|
;; The lock is only obtained and released, if plugins are
|
|
;; cached. LOAD-PLUGIN gets the CACHED? parameter, so
|
|
;; nothing may happen, if in the meanwhile caching is turned
|
|
;; off.
|
|
(obtain-lock *plugin-table-lock*)
|
|
(let ((plugin (table-ref *plugin-table* full-plugin-name)))
|
|
(if plugin
|
|
(if (equal? (file-last-mod full-plugin-name)
|
|
(cdr plugin))
|
|
(begin
|
|
(release-lock *plugin-table-lock*)
|
|
(car plugin))
|
|
(load-plugin #t))
|
|
(load-plugin #t))))
|
|
(load-plugin #f))))
|
|
|
|
(define (get-loaded-plugins)
|
|
(obtain-lock *plugin-table-lock*)
|
|
(let ((loaded-plugins '()))
|
|
(table-walk
|
|
(lambda (plugin-path rt-structure)
|
|
(set! loaded-plugins (cons plugin-path loaded-plugins)))
|
|
*plugin-table*)
|
|
(release-lock *plugin-table-lock*)
|
|
loaded-plugins))
|
|
|
|
(define (unload-plugin plugin-name)
|
|
(obtain-lock *plugin-table-lock*)
|
|
(if (table-ref *plugin-table* plugin-name)
|
|
(table-set! *plugin-table* plugin-name #f))
|
|
(release-lock *plugin-table-lock*))
|
|
|
|
(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*
|
|
(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" (+ digit) "-" (submatch (* digit)))) ; Continuation-ID
|
|
|
|
(define (make-resume-url path-string instance-id continuation-counter continuation-id)
|
|
(string-append path-string
|
|
";k" (number->string (session-instance-id))
|
|
";c" (number->string continuation-counter)
|
|
"-" (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))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; access to options
|
|
|
|
(define (set-instance-lifetime! new-lifetime)
|
|
(set-options:instance-lifetime *options* new-lifetime))
|
|
|
|
(define (get-instance-lifetime)
|
|
(options:instance-lifetime *options*))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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))
|
|
|
|
|
|
|
|
|
|
(define (debug fmt . args)
|
|
(if *debug*
|
|
(format #t "DEBUG: ~?~%" fmt args)
|
|
(force-output)))
|