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

330 lines
11 KiB
Scheme
Raw Normal View History

2002-09-13 03:21:19 -04:00
;; the servlet handler
;; Copyright Andreas Bernauer, 2002
;;; instance-table: entry for every new request on a servlet page
(define-record-type instance :instance
(make-instance servlet-name continuation-table continuation-table-lock
continuation-counter)
2002-09-13 03:21:19 -04:00
instance?
(servlet-name instance-servlet-name)
(continuation-table instance-continuation-table)
(continuation-table-lock instance-continuation-table-lock)
(continuation-counter instance-continuation-counter))
2002-09-13 03:21:19 -04:00
(define-record-type session :session
(make-session instance-id return-continuation)
2002-09-13 03:21:19 -04:00
session?
(instance-id really-session-instance-id
set-session-instance-id!)
(return-continuation really-session-return-continuation
set-session-return-continuation!))
(define *instance-table* (make-integer-table)) ; instance-id is index
(define *instance-table-lock* (make-lock))
2002-09-18 11:32:41 -04:00
(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....
2002-09-13 03:21:19 -04:00
(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
((string=? full-path "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=? full-path "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"))
2002-09-13 03:21:19 -04:00
((or (string=? request-method "GET")
; (string=? request-method "POST")) ; do this at later time
)
2002-09-13 03:21:19 -04:00
(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)
(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)))))))))
2002-09-13 03:21:19 -04:00
;; try to get continuation-table and then the continuation
(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.<BR>
2002-09-13 03:21:19 -04:00
You can try starting at the <A HREF=~a>beginning</a>."
(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)))
))))
(define (send/suspend response-maker)
2002-09-14 12:42:24 -04:00
(shift return
(let* ((instance-id (session-instance-id))
(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)))
(response-maker new-url))))))
2002-09-13 03:21:19 -04:00
(define (send/finish response)
(instance-delete! (session-instance-id))
response)
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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*)
;; why can't table entries be deleted correctly?
(table-set! *instance-table* instance-id #f)
(release-lock *instance-table-lock*))
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)
2002-09-13 03:21:19 -04:00
(loop (random))
id)))
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PLUGINs CACHE
(define *plugin-table* (make-string-table)) ; full-path is index
(define *plugin-table-lock* (make-lock))
2002-09-13 03:21:19 -04:00
;; 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*)
2002-09-13 03:21:19 -04:00
(let ((plugin (table-ref *plugin-table* plugin-name)))
(if plugin
(if (equal? (file-last-mod plugin-name)
(cdr plugin))
(begin
(release-lock *plugin-table-lock*)
(car plugin))
(load-plugin))
(load-plugin)))))
2002-09-13 03:21:19 -04:00
(define (reset-plugin-cache!)
(with-fatal-error-handler*
(lambda (condition decline)
(release-lock *plugin-table-lock*)
2002-09-13 03:21:19 -04:00
(decline))
(lambda ()
(obtain-lock *plugin-table-lock*)
2002-09-13 03:21:19 -04:00
(set! *plugin-table* (make-string-table))
(release-lock *plugin-table-lock*))))
2002-09-13 03:21:19 -04:00
(define (reset-instance-table!)
(with-fatal-error-handler
(lambda (condtion decline)
(release-lock *instance-table-lock*)
(decline))
(lambda ()
(obtain-lock *instance-table-lock*)
(set! *instance-table* (make-integer-table))
(release-lock *instance-table*))))
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SESSION
(define *session* (make-thread-cell #f))
(define (register-session! instance-id return-continuation)
(thread-cell-set! *session*
(make-session instance-id return-continuation)))
2002-09-13 03:21:19 -04:00
;(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
2002-09-13 03:21:19 -04:00
(define (make-resume-url full-path instance-id continuation-counter continuation-id)
2002-09-13 03:21:19 -04:00
(string-append full-path
";k" (number->string (session-instance-id))
";c" (number->string continuation-counter)
"-" (number->string continuation-id)))
2002-09-13 03:21:19 -04:00
(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))
; 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