;; 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
servlet-data)
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)
(servlet-data instance-servlet-data set-instance-servlet-data!))
(define-record-type memo :memo
(make-memo message value new-memo)
memo?
(message memo:message set-memo:message) ;kill, killed, adjust-timeout
(value memo:value set-memo:value)
(new-memo memo:new-memo set-memo:new-memo))
(define (make-default-memo)
(make-memo 'kill #f #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-type options :options
(make-options servlet-path servlet-prefix cache-servlets? instance-lifetime)
options?
(servlet-path options:servlet-path set-options:servlet-path)
(servlet-prefix options:servlet-prefix set-options:servlet-prefix)
(cache-servlets? options:cache-servlets? set-options:cache-servlets?)
;; instance lifetime is in seconds
(instance-lifetime options:instance-lifetime set-options:instance-lifetime))
(define (make-default-options servlet-path servlet-prefix)
(make-options servlet-path servlet-prefix #t 600))
(define *options* (make-preserved-thread-fluid #f))
;; preserved thread fluid because between different calls to
;; servlet-handler the options shall remain the same.
(define (make-fluid-selector selector)
(lambda () (selector (thread-fluid *options*))))
(define (make-fluid-setter setter)
(lambda (value)
(setter (thread-fluid *options*) value)))
(define options-servlet-path (make-fluid-selector options:servlet-path))
(define options-servlet-prefix (make-fluid-selector options:servlet-prefix))
(define options-cache-servlets? (make-fluid-selector options:cache-servlets?))
(define options-instance-lifetime (make-fluid-selector options:instance-lifetime))
(define set-options-cache-servlets? (make-fluid-setter set-options:cache-servlets?))
(define set-options-instance-lifetime (make-fluid-setter set-options:instance-lifetime))
(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. Currently,
;; it is ignored.
(define (servlet-handler servlet-path . servlet-prefix)
(set-thread-fluid! *options* (make-default-options 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)))
(if (or (string=? request-method "GET")
(string=? request-method "POST"))
(if (resume-url? path-string)
(resume-url path-string servlet-path req)
(launch-new-instance path-string servlet-path req))
(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)
(cond
((file-not-exists? (absolute-file-name path-string servlet-path))
(make-http-error-response http-status/not-found req path-string))
((string=? (file-name-extension path-string) ".scm")
(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-default-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
#f)) ; servlet-data
(release-lock *instance-table-lock*)
(register-session! instance-id 'no-return)
(with-fatal-handler
;; Catch conditions from get-servlet-rt-structure.
(lambda (condition decline)
(delete-instance! instance-id)
(bad-gateway-error-response req path-string condition))
(let ((servlet (get-servlet-rt-structure path-string servlet-path)))
(fork-thread
(instance-surveillance instance-id
(+ (time) (options-instance-lifetime))
memo))
(reset
(with-fatal-handler
;; Catch conditions that occur while running the servlet.
(lambda (condition decline)
(delete-instance! instance-id)
;; Restore correct continuation with shift.
(shift unused
(bad-gateway-error-response req path-string condition)))
(with-cwd servlet-path
(with-names-from-rt-structure
servlet servlet-interface
(main req)))))))))
(else ; We'll serve every non-scm file.
;; We need access to SEND-FILE-RESPONSE of
;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we
;; don't have it, so we disable this feature here.
; (let ((full-file-name (absolute-file-name path-string servlet-path)))
; (send-file-response full-file-name
; (file-info full-file-name)
; req))
(make-http-error-response http-status/forbidden req
"Can't serve other than Scheme files."
path-string))
))
(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
"
There may be several reasons, why your request for a servlet was denied:
In any case, you may try to restart the servlet from the beginning. Your browser may also have cached an old instance of this servlet. In this case, try to reload the page.
" (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) (delete-instance! (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 (delete-instance! 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-default-memo))) ;; Do it this way: new values and then new message (set-memo:value memo (+ (time) (options-instance-lifetime))) (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*)) ;; adjusts the timeout of the current instance (define (adjust-timeout) (instance-adjust-timeout! (session-instance-id))) (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)) (define (get-continuations instance-id) (let ((instance (instance-lookup instance-id))) (if instance (let ((continuation-table-lock (instance-continuation-table-lock instance)) (continuation-table (instance-continuation-table instance)) (continuations '())) (obtain-lock continuation-table-lock) (table-walk (lambda (continuation-id continuation-entry) (set! continuations (cons (cons continuation-id continuation-entry) continuations))) continuation-table) (release-lock continuation-table-lock) continuations) '()))) (define (delete-continuation! instance-id continuation-id) (let ((instance (instance-lookup instance-id))) (if instance (let ((continuation-table-lock (instance-continuation-table-lock instance)) (continuation-table (instance-continuation-table instance)) (continuations '())) (obtain-lock continuation-table-lock) (if (table-ref continuation-table continuation-id) (table-set! continuation-table continuation-id #f)) (release-lock continuation-table-lock))))) (define (set-servlet-data! new-data) (let ((instance (instance-lookup (session-instance-id)))) (if instance (begin (set-instance-servlet-data! instance new-data) #t) #f))) (define (get-servlet-data) (let ((instance (instance-lookup (session-instance-id)))) (if instance (instance-servlet-data instance) (error "Instance no longer alive.")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SERVLETs CACHE (define *servlet-table* (make-string-table)) ; path-string is index (define *servlet-table-lock* (make-lock)) ;; SERVLET-NAME is like "news-dir/latest-news.scm" (define (get-servlet-rt-structure servlet-name directory) (let* ((full-servlet-name (absolute-file-name servlet-name directory)) (load-servlet (lambda (cached?) (with-fatal-handler* (lambda (condition decline) (if cached? (release-lock *servlet-table-lock*)) (decline)) (lambda () ;; load-config-file does not care about cwd(?) ;; --> absolute file name needed (load-config-file full-servlet-name) ;; servlet-structure to load must be named "servlet" (let ((servlet-structure (reify-structure 'servlet))) (load-structure servlet-structure) (if cached? (begin (table-set! *servlet-table* full-servlet-name (cons servlet-structure (file-last-mod full-servlet-name))) ;; only now the lock may be released (release-lock *servlet-table-lock*))) servlet-structure)))))) (if (options-cache-servlets?) (begin ;; The lock is only obtained and released, if servlets are ;; cached. LOAD-SERVLET gets the CACHED? parameter, so ;; nothing may happen, if in the meanwhile caching is turned ;; off. (obtain-lock *servlet-table-lock*) (let ((servlet (table-ref *servlet-table* full-servlet-name))) (if servlet (if (equal? (file-last-mod full-servlet-name) (cdr servlet)) (begin (release-lock *servlet-table-lock*) (car servlet)) (load-servlet #t)) (load-servlet #t)))) (load-servlet #f)))) (define (get-loaded-servlets) (obtain-lock *servlet-table-lock*) (let ((loaded-servlets '())) (table-walk (lambda (servlet-path rt-structure) (set! loaded-servlets (cons servlet-path loaded-servlets))) *servlet-table*) (release-lock *servlet-table-lock*) loaded-servlets)) (define (unload-servlet servlet-name) (obtain-lock *servlet-table-lock*) (if (table-ref *servlet-table* servlet-name) (table-set! *servlet-table* servlet-name #f)) (release-lock *servlet-table-lock*)) (define (reset-servlet-cache!) (with-fatal-error-handler* (lambda (condition decline) (release-lock *servlet-table-lock*) (decline)) (lambda () (obtain-lock *servlet-table-lock*) (set! *servlet-table* (make-string-table)) (release-lock *servlet-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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Error-Handler ;; ;; Adopted from WITH-FATAL-ERROR-HANDLER, but handles everything that ;; is catchable. We must catch everything because we also want ;; exceptions (and warnings) to be catched (e.g. when the servlet is ;; loaded.) (define (with-fatal-handler* handler thunk) (call-with-current-continuation (lambda (accept) ((call-with-current-continuation (lambda (k) (with-handler (lambda (condition more) (call-with-current-continuation (lambda (decline) (k (lambda () (handler condition decline))))) (more)) ; Keep looking for a handler. (lambda () (call-with-values thunk accept))))))))) (define-syntax with-fatal-handler (syntax-rules () ((with-fatal-handler handler body ...) (with-fatal-handler* handler (lambda () body ...))))) (define (bad-gateway-error-response req path-string condition) (make-http-error-response http-status/bad-gateway req (format #f "Error in servlet ~s." path-string) condition)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; DEBUGGING (define (debug fmt . args) (if *debug* (format #t "DEBUG: ~?~%" fmt args) (force-output)))