;; The SUrflet handler
;; Copyright Andreas Bernauer, 2002
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GLOBALS
;;; DEBUGging
(define *debug* #t)
;;; OPTIONS for the SUrflet handler.
;; Preserved thread fluid because between different calls to
;; surflet-handler the options shall remain the same. SURFLET-HANDLER
;; sets the value (an option record, see end of file)
(define *options* (make-preserved-thread-fluid #f))
;;; TABLES are thread safe as they all use the same lock and different
;;; keys for the hash (There may be performance reasons to change
;;; this, though).
;;; SURFLET-TABLE cache
(define *surflet-table* (make-string-table)) ; path-string is index
(define *surflet-table-lock* (make-lock))
;;; SESSION-TABLE
;; Every session gets an entry in the hash table. Entries are session
;; records.
(define *session-table* (make-integer-table)) ; session-id is index
(define *session-table-lock* (make-lock))
;; INSTANCE is the session that is currently handled.
(define *instance* (make-thread-cell #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SURFLET-HANDLER
;;; SURFLET-HANDLER
;; Loads a new or resumes a suspended SUrflet; returns a
;; (HTTP-)RESPONSE. SURFLET-PATH is a string pointing to the real
;; directory where the SUrflets are searched.
(define (surflet-handler surflet-path)
(set-thread-fluid! *options* (make-default-options surflet-path))
(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 surflet-path req)
(launch-new-session path-string surflet-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)))))
;;; LAUNCH-NEW-SESSION
;; Loads and runs a new session of a SUrflet installing the RESET
;; boundary; returns a (HTTP-)RESPONSE. PATH-STRING is the virtual
;; path of the request, SURFLET-PATH is a string pointing to the real
;; directory of the SUrflets, and REQ the request of the browser.
(define (launch-new-session path-string surflet-path req)
(cond
((file-not-exists? (absolute-file-name path-string surflet-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)) ; surflet-data
(release-lock *session-table-lock*)
(register-instance! session-id)
(with-fatal-handler
;; Catch conditions from get-surflet-rt-structure.
(lambda (condition decline)
(delete-session! session-id)
(bad-gateway-error-response req path-string condition))
(let ((surflet (get-surflet-rt-structure path-string surflet-path)))
(fork-thread
(session-surveillance session-id
(+ (time) (options-session-lifetime))
memo))
(reset
(with-fatal-handler
;; Catch conditions that occur while running the surflet.
(lambda (condition decline)
(delete-session! session-id)
;; Restore correct continuation with shift.
(shift unused
(bad-gateway-error-response req path-string condition)))
(with-cwd surflet-path
(with-names-from-rt-structure
surflet surflet-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 surflet-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))
))
;;; SESSION-SURVEILLANCE
;; Returns surveillance procedure to be fork-threaded, that kills a
;; session after TIME-TO-DIE (seconds) has expired. MEMO contains
;; current status of session.
(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)))))))
;;; RESUME-URL
;; Resumes a suspended URL and returns a (HTTP-)RESPONSE. PATH-STRING
;; is the virtual path, SURFLET-PATH a string pointing to the real
;; directory of the SUrflets and REQ the request of the browser.
(define resume-url
(let ((bad-request
(lambda (path-string req)
(make-error-response
(status-code bad-request) req
(format #f
"
There may be several reasons, why your request for a SUrflet was denied:
In any case, you may try to restart the SUrflet from the beginning. Your browser may also have cached an old session of this SUrflet. In this case, try to reload the page.
" (resume-url-surflet-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 surflet-path req) (receive (session-id continuation-id) ;; Searches ids only in file-name. (resume-url-ids (file-name-nondirectory path-string)) ;; Try to get continuation-table and then the continuation. (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 surflet-path (reset (begin (register-instance! session-id) (resume req)))) (bad-request path-string req))) (bad-request path-string req))) )))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; SURFLET-INTERFACE ;;; SEND/SUSPEND ;; Suspends current computation, saves current continuation, and ;; leaves current continuation via SHIFT with a (HTTP-)RESPONSE. ;; RESPONSE-MAKER is a procedure returnig a SURFLET-RESPONSE (that is, ;; eventually converted to a HTTP-RESPONSE). (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-surflet-name session) session-id continuation-counter continuation-id))) (make-http-response (response-maker new-url)))))) (make-error-response (status-code not-found) #f "The URL refers to a SUrflet, whose session is no longer alive."))))) ;;; SEND/FINISH ;; Kills current session, and leaves current continuation returning ;; via SHIFT with a (HTTP-)RESPONSE. RESPONSE is a SURFLET-RESPONSE. (define (send/finish response) (delete-session! (instance-session-id)) (shift unused (make-http-response response))) ;;; SEND ;; Leaves current continuation via SHIFT with a ;; (HTTP-)RESPONSE. RESPONSE is a SURFLET-RESPONSE. (define (send response) (shift unused (make-http-response response))) ;;; SEND-ERROR ;; Stops current computation, and leaves current continuation via ;; SHIFT with a (HTTP-)(ERROR-)RESPONSE. STATUS-CODE is a status code ;; from HTTP-RESPONSES, REQ a request (may be #f) and MESSAGES ;; contains further informations (arbitrary types). (define (send-error status-code req . messages) (shift unused (apply make-error-response (cons status-code (cons #f messages))))) ;;; MAKE-HTTP-RESPONSE ;; Converts a SURFLET-RESPONSE to a (HTTP-)RESPONSE. Returns a ;; (HTTP-)RESPONSE. (define (make-http-response response) (cond ((surflet-response? response) (let ((data (surflet-response-data response))) (if (valid-surflet-response-data? data) (make-response (surflet-response-status response) #f (time) (surflet-response-content-type response) (surflet-response-headers response) (make-writer-body (lambda (out options) (cond ((string? data) (display data out)) ((list? data) (for-each (lambda (data) (display data out)) data)) (else ;; We lose. (display "Error in SUrflet output.\n" out)) )))) (make-error-response (status-code bad-gateway) #f "The SUrflet returned an invalid response object (no surflet-response).")))) ((and (response? response) ;; RESPONSE? refers to a HTTP-RESPONSE. (redirect-body? (response-body response))) response) (else (make-error-response (status-code bad-gateway) #f "The SUrflet returned an invalid response object (no surflet-response).")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; SESSIONS ;;; SESSION-LOOKUP ;; Looks up SESSION-ID in the *SESSION-TABLE* (locking) and returns ;; the SESSION record, if anby (#f otherwise). (define (session-lookup session-id) (obtain-lock *session-table-lock*) (let ((result (table-ref *session-table* session-id))) (release-lock *session-table-lock*) result)) ;;; SESSION-NEXT-CONTINUATION-COUNTER ;; Increases the SESSION-CONTINUATION-COUNTER in the SESSION record by ;; one. (define (session-next-continuation-counter session) (thread-safe-counter-next! (session-continuation-counter session))) ;;; DELETE-SESSION! ;; Deletes the session indicated by its number SESSION-ID from the ;; *SESSION-TABLE* (locking). (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*)) ;;; SESSION-ADJUST-TIMEOUT! ;; Resets time-to-die of session indicated by its SESSION-ID number. (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*)) ;;; ADJUST-TIMEOUT ;; Resets time-to-die of current session. (define (adjust-timeout) (session-adjust-timeout! (instance-session-id))) ;;; RESET-SESSION-TABLE! ;; Clears the *SESSION-TABLE* (locking) (define (reset-session-table!) (with-fatal-handler (lambda (condtion decline) (release-lock *session-table-lock*) (decline)) (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*))) ;;; GET-SESSIONS ;; Returns a list of all active sessions in *SESSION-TABLE* ;; (locking). The list elements are pairs of session-id and session ;; record. (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)) ;;; GET-CONTINUATIONS ;; Returns a list of all continuations of the session indicated by the ;; SESSION-ID number (locking). The list elements are pairs of ;; continuation id and continuation. (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) '()))) ;;; DELETE-CONTINUATION ;; Deletes continuation SESSION-ID, CONTINUATION-ID (locking). (define (delete-continuation! session-id continuation-id) (let ((session (session-lookup session-id))) (if session (let ((continuation-table-lock (session-continuation-table-lock session))) (obtain-lock continuation-table-lock) (let ((continuation-table (session-continuation-table session)) (continuations '())) (if (table-ref continuation-table continuation-id) (table-set! continuation-table continuation-id #f))) (release-lock continuation-table-lock))))) ;;; SET-SURFLET-DATA!, GET-SURFLET-DATA ;; Access to arbitrary data stored along with current session (no ;; locking!). (define (set-surflet-data! new-data) (let ((session (session-lookup (instance-session-id)))) (if session (begin (set-session-surflet-data! session new-data) #t) #f))) (define (get-surflet-data) (let ((session (session-lookup (instance-session-id)))) (if session (session-surflet-data session) (error "Instance no longer alive.")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ID generation ;;; GENERATE-NEW-TABLE-ID ;; Returns a random integer not used in the hash TABLE (no ;; locking!). The locking has to happe elsewhere. (define (generate-new-table-id table) (let loop ((id (random))) (if (table-ref table id) ;; FIXME?: this may loop forever, if the table is full (can ;; this ever happen?) (loop (random)) id))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SURFLETs CACHE ;;; GET-SURFLET-RT-STRUCTURE ;; Returns SUrflet's RT-STRUCTURE indicated by SURFLET-NAME (a virtual ;; path string) while managing the SUrflet cache *SURFLET-TABLE* ;; (locking). (define get-surflet-rt-structure (let ((load-surflet (lambda (full-surflet-name cached?) (with-fatal-handler* (lambda (condition decline) (if cached? (release-lock *surflet-table-lock*)) (decline)) (lambda () ;; load-config-file does not care about cwd(?) ;; --> absolute file name needed (load-config-file full-surflet-name) ;; surflet-structure to load must be named "surflet" (let ((surflet-structure (reify-structure 'surflet))) (load-structure surflet-structure) (if cached? (begin (table-set! *surflet-table* full-surflet-name (cons surflet-structure (file-last-mod full-surflet-name))) ;; only now the lock may be released (release-lock *surflet-table-lock*))) surflet-structure)))))) (lambda (surflet-name directory) (let ((full-surflet-name (absolute-file-name surflet-name directory))) (if (options-cache-surflets?) (begin ;; The lock is only obtained and released, if surflets are ;; cached. LOAD-SURFLET gets the CACHED? parameter, so ;; nothing may happen, if in the meanwhile caching is turned ;; off. (obtain-lock *surflet-table-lock*) (let ((surflet (table-ref *surflet-table* full-surflet-name))) (if surflet (if (equal? (file-last-mod full-surflet-name) (cdr surflet)) (begin (release-lock *surflet-table-lock*) (car surflet)) (load-surflet full-surflet-name #t)) (load-surflet full-surflet-name #t)))) (load-surflet full-surflet-name #f)))))) ;;; GET-LOADED-SURFLETS ;; Returns list of all loaded surflets (real path strings). (define (get-loaded-surflets) (obtain-lock *surflet-table-lock*) (let ((loaded-surflets '())) (table-walk (lambda (surflet-path rt-structure) (set! loaded-surflets (cons surflet-path loaded-surflets))) *surflet-table*) (release-lock *surflet-table-lock*) loaded-surflets)) ;;; UNLOAD-SURFLET ;; Removes SURFLET-NAME from the *SURFLET-TABLE* cache (locking). (define (unload-surflet surflet-name) (obtain-lock *surflet-table-lock*) (if (table-ref *surflet-table* surflet-name) (table-set! *surflet-table* surflet-name #f)) (release-lock *surflet-table-lock*)) ;;; RESET-SURFLET-CACHE! ;; Clears *SURFLET-TABLE* (locking). (define (reset-surflet-cache!) (with-fatal-handler (lambda (condition decline) (release-lock *surflet-table-lock*) (decline)) (obtain-lock *surflet-table-lock*) (set! *surflet-table* (make-string-table)) (release-lock *surflet-table-lock*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; INSTANCE ;;; REGISTER-INSTANCE! ;; Saves values for current session (in a record). (define (register-instance! session-id) (thread-cell-set! *instance* (make-instance session-id))) ;;; INSTANCE-SESSION-ID ;; Returns session-id of current *INSTANCE*. (define (instance-session-id) (really-instance-session-id (thread-cell-ref *instance*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; RESUME-URL ;; Functions and constants for generating and parsing Continuation ;; URLs (= resume URLs). Resume URLs look like ;; http://localhost:8088/surflet/admin-handler.scm;k757033335;c1-684902143?return54= (define *resume-url-regexp* (rx (submatch (* (- printing ";"))) ";k" (submatch (* digit)) ; Instance-ID ";c" (+ digit) ; Continuation Counter "-" (submatch (* digit)))) ; Continuation-ID ;; All arguments are numbers except PATH-STRING, which is a string. (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))) ;; Return various parts of RESUME-URL (define (resume-url-session-id resume-url) (receive (session-id continuation-id) (resume-url-ids resume-url) session-id)) (define (resume-url-continuation-id resume-url) (receive (session-id continuation-id) (resume-url-ids resume-url) continuation-id)) (define (resume-url-ids resume-url) (let ((match (regexp-search *resume-url-regexp* (file-name-nondirectory resume-url)))) (if match (values (string->number (match:substring match 2)) (string->number (match:substring match 3))) (values #f #f)))) (define (resume-url-surflet-name resume-url) (let ((match (regexp-search *resume-url-regexp* resume-url))) (if match (match:substring match 1) (values #f #f)))) (define (resume-url? resume-url) (regexp-search? *resume-url-regexp* resume-url)) (define (bad-gateway-error-response req path-string condition) (make-error-response (status-code bad-gateway) req (format #f "Error in SUrflet ~s." path-string) condition)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Record types ;;; SESSION: session-table entry for every new request on a surflet page (define-record-type session :session (make-session surflet-name memo continuation-table continuation-table-lock continuation-counter surflet-data) session? (surflet-name session-surflet-name) (memo session-memo set-session-memo!) (continuation-table session-continuation-table) (continuation-table-lock session-continuation-table-lock) (continuation-counter session-continuation-counter) (surflet-data session-surflet-data set-session-surflet-data!)) ;;; MEMO: Information for session surveiller about session status (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)) ;;; INSTANCE: Every request corresponds to an instance. (define-record-type instance :instance (make-instance session-id) instance? (session-id really-instance-session-id set-instance-session-id!)) ;;; OPTIONS: options for the surflet-handler (define-record-type options :options (make-options surflet-path cache-surflets? session-lifetime) options? (surflet-path options:surflet-path set-options:surflet-path) (cache-surflets? options:cache-surflets? set-options:cache-surflets?) ;; session lifetime is in seconds (session-lifetime options:session-lifetime set-options:session-lifetime)) ;; Constructor with defaults. (define (make-default-options surflet-path) (make-options surflet-path #t 600)) ;; Selectors for *options* (preserved-thread-fluid) (define (make-fluid-selector selector) (lambda () (selector (thread-fluid *options*)))) (define (make-fluid-setter setter) (lambda (value) (setter (thread-fluid *options*) value))) (define options-surflet-path (make-fluid-selector options:surflet-path)) (define options-cache-surflets? (make-fluid-selector options:cache-surflets?)) (define options-session-lifetime (make-fluid-selector options:session-lifetime)) (define set-options-cache-surflets? (make-fluid-setter set-options:cache-surflets?)) (define set-options-session-lifetime (make-fluid-setter set-options:session-lifetime)) ;;; SURFLET-RESPONSE: Surflets are expected to return this object type. ;;; STATUS is the status code, an exact integer. See httpd/response.scm ;;; e.g. (status-code ok) ;;; CONTENT-TYPE is a string, most probably "text/html". ;;; HEADERS is a (maybe empty) list of pairs of (string or symbol); ;;; Additional headers to send, e.g. '(("Cache-Control" . "no-cache")) or ;;; '((Cache-Control . "no-cache")) etc. ;;; DATA is either ;;; * a string ;;; * a list of strings ;;; This list maybe extended to vectors later. (define-record-type surflet-response :surflet-response (make-surflet-response status content-type headers data) surflet-response? (status surflet-response-status) (content-type surflet-response-content-type) (headers surflet-response-headers) (data surflet-response-data)) ;; Allowed type for the data field. (define (valid-surflet-response-data? data) (or (string? data) (list? data))) ;; For debug purposes (define (surflet-response->string surflet-response) (format #f "#{SUrflet-response Status: ~a Content-Type: ~s Headers: ~s~%~s~%" (surflet-response-status surflet-response) (surflet-response-content-type surflet-response) (surflet-response-headers surflet-response) (surflet-response-data surflet-response))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; RANDOM SOURCE (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.... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; DEBUGGING (define (debug fmt . args) (if *debug* (format #t "DEBUG: ~?~%" fmt args) (force-output)))