sunet/scheme/httpd/surflets/surflet-handler.scm

598 lines
21 KiB
Scheme

;; the servlet handler
;; Copyright Andreas Bernauer, 2002
(define *debug* #t)
;;; session-table: entry for every new request on a servlet page
(define-record-type session :session
(make-session servlet-name memo
continuation-table continuation-table-lock
continuation-counter
servlet-data)
session?
(servlet-name session-servlet-name)
(memo session-memo set-session-memo!)
(continuation-table session-continuation-table)
(continuation-table-lock session-continuation-table-lock)
(continuation-counter session-continuation-counter)
(servlet-data session-servlet-data set-session-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 instance :instance
(make-instance session-id return-continuation)
instance?
(session-id really-instance-session-id
set-instance-session-id!)
(return-continuation really-instance-return-continuation
set-instance-return-continuation!))
(define-record-type options :options
(make-options servlet-path servlet-prefix cache-servlets? session-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?)
;; session lifetime is in seconds
(session-lifetime options:session-lifetime set-options:session-lifetime))
;; Servlet-prefix is unused now. Formerly, it contained the virtual
;; path prefix for the handler.
(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-session-lifetime (make-fluid-selector options:session-lifetime))
(define set-options-cache-servlets? (make-fluid-setter set-options:cache-servlets?))
(define set-options-session-lifetime (make-fluid-setter set-options:session-lifetime))
(define *session-table* (make-integer-table)) ; session-id is index
(define *session-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....
(define (servlet-handler servlet-path)
(set-thread-fluid! *options* (make-default-options servlet-path #f))
(lambda (path req)
(if (pair? path) ; need at least one element
(let ((request-method (request-method req))
(path-string (uri-path->uri 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-session path-string servlet-path req))
(make-error-response (status-code method-not-allowed) req
request-method)))
(make-error-response (status-code bad-request) req
(format #f "Bad path: ~s" path)))))
(define (launch-new-session path-string servlet-path req)
(cond
((file-not-exists? (absolute-file-name path-string servlet-path))
(make-error-response (status-code not-found) req path-string))
((string=? (file-name-extension path-string) ".scm")
(obtain-lock *session-table-lock*)
;; no access to session table until new session-id is saved
(let ((session-id (generate-new-table-id *session-table*))
(memo (make-default-memo)))
(table-set! *session-table* session-id
(make-session 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 *session-table-lock*)
(register-instance! session-id 'no-return)
(with-fatal-handler
;; Catch conditions from get-servlet-rt-structure.
(lambda (condition decline)
(delete-session! session-id)
(bad-gateway-error-response req path-string condition))
(let ((servlet (get-servlet-rt-structure path-string servlet-path)))
(fork-thread
(session-surveillance session-id
(+ (time) (options-session-lifetime))
memo))
(reset
(with-fatal-handler
;; Catch conditions that occur while running the servlet.
(lambda (condition decline)
(delete-session! session-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))))))))) ; Launch serlvet's main procedure.
(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-error-response (status-code forbidden) req
"Can't serve other than Scheme files."
path-string))
))
(define (session-surveillance session-id time-to-die memo)
(lambda ()
(let loop ((time-to-die time-to-die)
(memo memo))
(debug "session-surveillance[~s]: going to sleep until ~a"
session-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 "session-surveillance[~s]: session already killed, dieing"
session-id)
)
((adjust-timeout) ; new timeout
(debug "session-surveillance[~s]: adjusting timeout" session-id)
(loop (memo:value memo)
(memo:new-memo memo)))
((kill) ; kill session
(debug "session-surveillance[~s]: killing"
session-id)
(obtain-lock *session-table-lock*)
(table-set! *session-table* session-id #f)
(release-lock *session-table-lock*))
(else
(format (current-error-port)
"session-surveillance[~s]: unknown message ~s; dieing"
session-id (memo:message memo)))))))
;; try to get continuation-table and then the continuation
(define resume-url
(let ((bad-request
(lambda (path-string req)
(make-error-response
(status-code bad-request) req
(format #f
"<br>
<p>There may be several reasons, why your request for a servlet 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>. Your browser may also have cached an old session of this servlet. In this case, try to reload the page.</p>"
(resume-url-servlet-name path-string)))))
(lookup-continuation-table
(lambda (session continuation-table continuation-id)
(let ((continuation-table-lock (session-continuation-table-lock session)))
(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 (session-id continuation-id)
(resume-url-ids path-string)
(let ((session (session-lookup session-id)))
(if session
(let* ((continuation-table (session-continuation-table session))
(resume (lookup-continuation-table session continuation-table
continuation-id)))
(if resume
(with-cwd servlet-path
(reset
(begin
(register-instance! session-id 'no-return)
(resume req))))
(bad-request path-string req)))
(bad-request path-string req)))
))))
(define (send/suspend response-maker)
(shift return
(let* ((session-id (instance-session-id))
(session (session-lookup session-id)))
;; the instance might be deleted in the meanwhile
(if session
(begin
(session-adjust-timeout! session-id)
(let ((continuations-table (session-continuation-table session))
(continuation-table-lock (session-continuation-table-lock session))
(continuation-counter (session-next-continuation-counter session)))
(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 (session-servlet-name session)
session-id
continuation-counter
continuation-id)))
(make-servlet-response (response-maker new-url))))))
(make-error-response (status-code not-found) #f
"The URL refers to a servlet, whose session is no longer alive.")))))
(define (send/finish response)
(delete-session! (instance-session-id))
(shift unused response))
(define (send response)
(shift unsused response))
(define (make-servlet-response response)
(let ((servlet-out-port (open-output-string))
(servlet-in-port #f) ;; FIXME: no input-port available
(options #f)) ;; FIXME: No access to httpd-options :-(
(if (writer-body? (response-body response))
(begin
;; Error-handler is already installed.
;; Force string-output to resolve all send/... calls.
(display-http-body (response-body response)
servlet-in-port servlet-out-port
options)
;; Create write-out-response for webserver.
(make-response
(response-code response)
(response-message response)
(response-seconds response)
(response-mime response)
(response-extras response)
(make-writer-body
(lambda (out options)
(display (get-output-string servlet-out-port) out)))))
(make-error-response (status-code bad-gateway) #f
"The servlet returned an invalid response object (no writer-body)."))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; access to session-table
(define (session-lookup session-id)
(obtain-lock *session-table-lock*)
(let ((result (table-ref *session-table* session-id)))
(release-lock *session-table-lock*)
result))
(define (session-next-continuation-counter session)
(thread-safe-counter-next!
(session-continuation-counter session)))
(define (delete-session! session-id)
(obtain-lock *session-table-lock*)
;; notify surveillance of session being alread killed (prevents
;; surveillance of killing new session that has the same number by
;; accident)
(let ((session (table-ref *session-table* session-id)))
(memo-killed! (session-memo session)))
;; why can't table entries be deleted correctly?
(table-set! *session-table* session-id #f)
(release-lock *session-table-lock*))
(define (session-adjust-timeout! session-id)
(obtain-lock *session-table-lock*)
(let* ((session (table-ref *session-table* session-id))
(memo (session-memo session))
(new-memo (make-default-memo)))
;; Do it this way: new values and then new message
(set-memo:value memo
(+ (time)
(options-session-lifetime)))
(set-memo:new-memo memo new-memo)
;; I don't think we need locking here. Do you agree?
(set-session-memo! session new-memo)
(set-memo:message memo 'adjust-timeout))
(release-lock *session-table-lock*))
;; adjusts the timeout of the current session
(define (adjust-timeout)
(session-adjust-timeout! (instance-session-id)))
(define (reset-session-table!)
(with-fatal-error-handler
(lambda (condtion decline)
(release-lock *session-table-lock*)
(decline))
(lambda ()
(obtain-lock *session-table-lock*)
;; notify session killing
(table-walk
(lambda (session-id session)
(memo-killed! (session-memo session)))
*session-table*)
(set! *session-table* (make-integer-table))
(release-lock *session-table*))))
(define (get-sessions)
(obtain-lock *session-table-lock*)
(let ((sessions '()))
(table-walk
(lambda (session-id session-entry)
(set! sessions (cons (cons session-id session-entry) sessions)))
*session-table*)
(release-lock *session-table-lock*)
sessions))
(define (get-continuations session-id)
(let ((session (session-lookup session-id)))
(if session
(let ((continuation-table-lock (session-continuation-table-lock session))
(continuation-table (session-continuation-table session))
(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! session-id continuation-id)
(let ((session (session-lookup session-id)))
(if session
(let ((continuation-table-lock (session-continuation-table-lock session))
(continuation-table (session-continuation-table session))
(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 ((session (session-lookup (instance-session-id))))
(if session
(begin
(set-session-servlet-data! session new-data)
#t)
#f)))
(define (get-servlet-data)
(let ((session (session-lookup (instance-session-id))))
(if session
(session-servlet-data session)
(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*))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INSTANCE
(define *instance* (make-thread-cell #f))
(define (register-instance! session-id return-continuation)
(thread-cell-set! *instance*
(make-instance session-id return-continuation)))
;(define (save-instance-return-continuation! return-continuation)
; (set-instance-session-id! (thread-cell-ref *instance*)
; return-continuation))
(define (instance-session-id)
(really-instance-session-id (thread-cell-ref *instance*)))
(define (instance-return-continuation)
(really-instance-return-continuation (thread-cell-ref *instance*)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 session-id continuation-counter continuation-id)
(string-append path-string
";k" (number->string (instance-session-id))
";c" (number->string continuation-counter)
"-" (number->string continuation-id)))
(define (resume-url-session-id id-url)
(receive (session-id continuation-id)
(resume-url-ids id-url)
session-id))
(define (resume-url-continuation-id id-url)
(receive (session-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 session/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-error-response
(status-code 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)))