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

755 lines
27 KiB
Scheme
Raw Normal View History

;; The SUrflet handler
2002-09-13 03:21:19 -04:00
;; Copyright Andreas Bernauer, 2002
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GLOBALS
2002-09-13 03:21:19 -04:00
;;; 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))
2002-09-29 09:43:39 -04:00
2003-01-25 11:33:50 -05:00
;;; 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))
2002-09-29 09:43:39 -04:00
2003-01-25 11:30:09 -05:00
;; INSTANCE is the session that is currently handled.
(define *instance* (make-thread-cell #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SURFLET-HANDLER
2002-09-13 03:21:19 -04:00
;;; 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.
2003-03-17 05:17:55 -05:00
(define (surflet-handler surflet-path . maybe-options)
(let-optionals maybe-options
((options (with-surflet-path surflet-path (make-default-surflet-options))))
2003-03-17 05:17:55 -05:00
(set-thread-fluid! *options* options)
(spawn surveillance-thread)
2003-03-17 05:17:55 -05:00
(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"))
(make-input-response
(lambda (input-port)
(let ((s-req (make-surflet-request req input-port)))
(if (resume-url? path-string)
(resume-url path-string (options-surflet-path) s-req)
(launch-new-session path-string (options-surflet-path) s-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))))))
2002-09-13 03:21:19 -04:00
;;; 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 S-REQ the request of the browser.
(define (launch-new-session path-string surflet-path s-req)
(cond
2003-01-19 11:57:27 -05:00
((file-not-exists? (absolute-file-name path-string surflet-path))
(make-error-response (status-code not-found)
(surflet-request-request s-req) path-string))
((string=? (file-name-extension path-string) ".scm")
(receive (session-id lifetime)
(with-lock *session-table-lock*
(let ((session-id (generate-new-table-id *session-table*))
(lifetime (options-session-lifetime)))
(table-set! *session-table* session-id
(make-session path-string ; used for redirections
(make-integer-table) ; continuation table
(make-lock) ; continuation table lock
(make-thread-safe-counter) ; continuation counter
#f ; session-data
lifetime))
(values session-id lifetime)))
;; no access to session table until new session-id is saved
(register-instance! session-id)
(with-fatal-error-handler
2003-01-19 11:57:27 -05:00
;; Catch conditions from get-surflet-rt-structure.
(lambda (condition decline)
(delete-session! session-id)
(bad-gateway-error-response s-req path-string condition))
2003-01-19 11:57:27 -05:00
(let ((surflet (get-surflet-rt-structure path-string surflet-path)))
(timeout-queue-register-session! session-id (+ (time) lifetime))
(reset
(with-fatal-error-handler
2003-01-19 11:57:27 -05:00
;; 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 s-req path-string condition)))
2003-01-19 11:57:27 -05:00
(with-cwd surflet-path
(with-names-from-rt-structure
2003-01-19 11:57:27 -05:00
surflet surflet-interface
(main s-req))))))))) ; Launch serlvet's main procedure.
(else ; We'll serve every non-scm file.
(make-error-response (status-code forbidden)
(surflet-request-request s-req)
"Can't serve other than Scheme files."
path-string))
))
2002-09-13 03:21:19 -04:00
;;; SESSION-SURVEILLANCE
(define *timeout-queue*)
(define (timeout-queue-register-session! session-id timeout)
(search-tree-set! *timeout-queue* (cons session-id timeout) 'ignore))
(define (timeout-queue-remove-session! session-id)
(search-tree-set! *timeout-queue* (cons session-id 0) #f))
(define (timeout-queue-adjust-session-timeout! session-id new-timeout)
(search-tree-set! *timeout-queue* (cons session-id new-timeout) 'ignore))
(define (surveillance-thread)
(set! *timeout-queue* (make-search-tree (lambda (p q) (eq? (car p) (car q)))
(lambda (p q)
(< (cdr p) (cdr q)))))
(let lp ()
(with-lock *session-table-lock*
(let ((now (time)))
(let lp2 ()
(receive (session-id.time ignore) (search-tree-min *timeout-queue*)
(if session-id.time
(if (<= (cdr session-id.time) now)
(let ((session-id (car session-id.time)))
(table-set! *session-table* session-id #f)
(pop-search-tree-min! *timeout-queue*)
(lp2))))))))
(sleep 1000)
(lp)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 S-REQ the request of the browser.
(define resume-url
(let ((bad-request
(lambda (path-string s-req)
(make-error-response
(status-code bad-request)
(surflet-request-request s-req)
((options-make-session-timeout-text)
(resume-url-surflet-name path-string)))))
(lookup-continuation-table
(lambda (session continuation-table continuation-id)
(let ((continuation-table-lock (session-continuation-table-lock session)))
(with-lock continuation-table-lock
(table-ref continuation-table continuation-id))))))
(lambda (path-string surflet-path s-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
2003-01-19 11:57:27 -05:00
(with-cwd surflet-path
(reset
(begin
(register-instance! session-id)
(resume s-req))))
(bad-request path-string s-req)))
(bad-request path-string s-req)))
2002-09-24 04:47:33 -04:00
))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)
2002-09-14 12:42:24 -04:00
(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)))
(let ((continuation-id
(with-lock continuation-table-lock
(let ((c-id (generate-new-table-id continuations-table)))
(table-set! continuations-table c-id return)
c-id))))
2003-01-19 11:57:27 -05:00
(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.")))))
2002-09-13 03:21:19 -04:00
;;; 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)))
2002-09-13 03:21:19 -04:00
;;; 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, S-REQ a surflet-request (may be #f) and
;; MESSAGES contains further informations (arbitrary types).
(define (send-error status-code s-req . messages)
2003-01-24 11:02:29 -05:00
(shift unused (apply make-error-response
(cons status-code
(cons (and (surflet-request? s-req)
(surflet-request-request s-req))
messages)))))
2003-01-24 11:02:29 -05:00
;;; 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)."))))
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)
(with-lock *session-table-lock*
(table-ref *session-table* session-id)))
;;; 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)
(with-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)))
(if session
(begin
(timeout-queue-remove-session! session-id)
(table-set! *session-table* session-id #f))
;; else: somebody was faster than we
))))
;;; SESSION-ADJUST-TIMEOUT!
;; Resets time-to-die of session indicated by its SESSION-ID number.
(define (session-adjust-timeout! session-id . maybe-time-to-live)
2003-03-31 05:56:28 -05:00
(really-session-adjust-timeout!
session-id
2003-03-31 05:56:28 -05:00
(:optional maybe-time-to-live (session-lifetime session-id))))
(define (really-session-adjust-timeout! session-id time-to-live)
(with-lock *session-table-lock*
(let ((session (table-ref *session-table* session-id)))
(if session
(timeout-queue-adjust-session-timeout!
session-id
(+ (time) time-to-live))
(error "There is no session with this ID" session-id)))))
;;; ADJUST-TIMEOUT!
;; Resets time-to-die of current session. The argument must be
;; optional as PLT does not have it.
(define (adjust-timeout! . maybe-time-to-live)
2003-03-31 05:56:28 -05:00
(let ((session-id (instance-session-id)))
(really-session-adjust-timeout!
session-id
(:optional maybe-time-to-live
(session-lifetime session-id)))))
(define (session-lifetime session-id)
(let ((maybe-session (session-lookup session-id)))
(and maybe-session
(really-session-lifetime maybe-session))))
(define (set-session-lifetime! session-id new-lifetime)
(let ((maybe-session (session-lookup session-id)))
(and maybe-session
(begin
(really-set-session-lifetime! maybe-session new-lifetime)
(session-adjust-timeout! session-id new-lifetime)))))
;;; RESET-SESSION-TABLE!
;; Clears the *SESSION-TABLE* (locking)
(define (reset-session-table!)
(with-fatal-error-handler
(lambda (condtion decline)
(release-lock *session-table-lock*)
(decline))
(with-lock *session-table-lock*
;; notify session killing
(table-walk
(lambda (session-id session)
(timeout-queue-remove-session! session-id))
*session-table*)
(set! *session-table* (make-integer-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)
(with-lock *session-table-lock*
(let ((sessions '()))
(table-walk
(lambda (session-id session-entry)
(set! sessions (cons (cons session-id session-entry) sessions)))
*session-table*)
sessions)))
2003-03-13 06:32:59 -05:00
(define get-session session-lookup)
2003-03-10 11:37:22 -05:00
;; SESSION-ALIVE? returns #t if there is a session with this id, #f
;; otherwise.
(define (session-alive? session-id)
(if (session-lookup session-id) #t #f))
;;; 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 '()))
(with-lock continuation-table-lock
(table-walk
(lambda (continuation-id continuation-entry)
(set! continuations (cons (cons continuation-id continuation-entry)
continuations)))
continuation-table)
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)))
(with-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))))))))
;;; SET-SESSION-DATA!, GET-SESSION-DATA
;; Access to arbitrary data stored along with current session (no
;; locking!).
(define (set-session-data! new-data)
(let ((session (session-lookup (instance-session-id))))
(if session
2002-10-02 20:15:44 -04:00
(begin
(set-session-session-data! session new-data)
2002-10-02 20:15:44 -04:00
#t)
#f)))
2002-09-13 03:21:19 -04:00
(define (get-session-data)
(let ((session (session-lookup (instance-session-id))))
(if session
(session-session-data session)
2002-10-02 20:15:44 -04:00
(error "Instance no longer alive."))))
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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?)
2002-09-13 03:21:19 -04:00
(loop (random))
id)))
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2003-01-19 11:57:27 -05:00
;; 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?)
;; 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?
(table-set! *surflet-table* full-surflet-name
(cons surflet-structure
(file-last-mod full-surflet-name))))
surflet-structure))))
(lambda (surflet-name directory)
(let ((full-surflet-name (absolute-file-name surflet-name directory)))
(if (options-cache-surflets?)
(with-lock *surflet-table-lock*
(cond
((table-ref *surflet-table* full-surflet-name) =>
(lambda (surflet)
(if (equal? (file-last-mod full-surflet-name)
(cdr surflet))
(car surflet)
(load-surflet full-surflet-name #t))))
(else
(load-surflet full-surflet-name #t))))
(load-surflet full-surflet-name #f))))))
2003-01-19 11:57:27 -05:00
;;; GET-LOADED-SURFLETS
;; Returns list of all loaded surflets (real path strings).
2003-01-19 11:57:27 -05:00
(define (get-loaded-surflets)
(with-lock *surflet-table-lock*
(let ((loaded-surflets '()))
(table-walk
(lambda (surflet-path rt-structure)
(set! loaded-surflets (cons surflet-path loaded-surflets)))
*surflet-table*)
loaded-surflets)))
2003-01-19 11:57:27 -05:00
;;; UNLOAD-SURFLET
;; Removes SURFLET-NAME from the *SURFLET-TABLE* cache (locking).
2003-01-19 11:57:27 -05:00
(define (unload-surflet surflet-name)
(with-lock *surflet-table-lock*
(if (table-ref *surflet-table* surflet-name)
(table-set! *surflet-table* surflet-name #f))))
2003-01-19 11:57:27 -05:00
;;; RESET-SURFLET-CACHE!
;; Clears *SURFLET-TABLE* (locking).
2003-01-19 11:57:27 -05:00
(define (reset-surflet-cache!)
(with-lock *surflet-table-lock*
(set! *surflet-table* (make-string-table))))
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; INSTANCE
2002-09-13 03:21:19 -04:00
;;; REGISTER-INSTANCE!
;; Saves values for current session (in a record).
(define (register-instance! session-id)
(thread-cell-set! *instance*
(make-instance session-id)))
2002-09-13 03:21:19 -04:00
;;; INSTANCE-SESSION-ID
;; Returns session-id of current *INSTANCE*.
(define (instance-session-id)
(really-instance-session-id (thread-cell-ref *instance*)))
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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=
2002-09-13 03:21:19 -04:00
(define *resume-url-regexp* (rx (submatch (* (- printing ";")))
";k" (submatch (* digit)) ; Instance-ID
";c" (+ digit) ; Continuation Counter
"-" (submatch (* digit)))) ; Continuation-ID
2002-09-13 03:21:19 -04:00
;; 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)))
2002-09-13 03:21:19 -04:00
;; 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))
2002-09-13 03:21:19 -04:00
(define (resume-url-continuation-id resume-url)
(receive (session-id continuation-id)
(resume-url-ids resume-url)
2002-09-13 03:21:19 -04:00
continuation-id))
(define (resume-url-ids resume-url)
(let ((match (regexp-search *resume-url-regexp*
(file-name-nondirectory resume-url))))
2002-09-13 03:21:19 -04:00
(if match
(values (string->number (match:substring match 2))
(string->number (match:substring match 3)))
(values #f #f))))
2002-09-13 03:21:19 -04:00
(define (resume-url-surflet-name resume-url)
(let ((match (regexp-search *resume-url-regexp* resume-url)))
2002-09-13 03:21:19 -04:00
(if match
(match:substring match 1)
(values #f #f))))
2002-09-13 03:21:19 -04:00
(define (resume-url? resume-url)
(regexp-search? *resume-url-regexp* resume-url))
(define (bad-gateway-error-response s-req path-string condition)
(make-error-response
(status-code bad-gateway)
(surflet-request-request s-req)
2003-01-25 11:28:16 -05:00
(format #f "Error in SUrflet ~s." path-string)
condition))
2002-09-13 03:21:19 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Record types
;;; SESSION: session-table entry for every new request on a surflet page
(define-record-type session :session
(make-session surflet-name
2003-03-31 05:56:28 -05:00
continuation-table continuation-table-lock
continuation-counter
session-data
lifetime)
session?
(surflet-name session-surflet-name)
(continuation-table session-continuation-table)
(continuation-table-lock session-continuation-table-lock)
(continuation-counter session-continuation-counter)
2003-03-31 05:56:28 -05:00
(session-data session-session-data set-session-session-data!)
(lifetime really-session-lifetime really-set-session-lifetime!))
;;; 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
2003-03-17 05:17:55 -05:00
(define-record-type surflet-options :suflet-options
(really-make-surflet-options surflet-path cache-surflets?
session-lifetime make-session-timeout-text)
2003-03-17 05:17:55 -05:00
surflet-options?
(surflet-path surflet-options-surflet-path set-surflet-options-surflet-path!)
2003-03-17 05:17:55 -05:00
(cache-surflets? surflet-options-cache-surflets? set-surflet-options-cache-surflets?!)
;; session lifetime is in seconds
(session-lifetime surflet-options-session-lifetime set-surflet-options-session-lifetime!)
(make-session-timeout-text surflet-options-make-session-timeout-text
set-surflet-options-make-session-timeout-text!))
(define (default-make-session-timeout-text start-url)
(format #f
"<br>
<p>There may be several reasons, why your request for a SUrflet was denied:
<ul>
<li>The SUrflet does not accept any requests any more.</li>
<li>The SUrflet URL has timed out.</li>
<li>You URL is illformed.</li>
</ul>
</p>
<p>In any case, you may try to restart the SUrflet from the <a href=\"~a\">beginning</a>. Your browser may also have cached an old session of this SUrflet. In this case, try to reload the page.</p>" start-url))
;; Constructor with defaults.
2003-03-17 05:17:55 -05:00
(define (make-default-surflet-options)
(really-make-surflet-options #f #t 600 default-make-session-timeout-text))
2003-03-17 05:17:55 -05:00
(define (copy-surflet-options options)
(let ((new-options (make-default-surflet-options)))
(set-surflet-options-surflet-path!
new-options
(surflet-options-surflet-path options))
2003-03-17 05:17:55 -05:00
(set-surflet-options-cache-surflets?!
new-options
(surflet-options-cache-surflets? options))
(set-surflet-options-session-lifetime!
new-options
(surflet-options-session-lifetime options))
(set-surflet-options-make-session-timeout-text!
new-options
2003-03-17 14:29:45 -05:00
(surflet-options-make-session-timeout-text options))
new-options))
2003-03-17 05:17:55 -05:00
(define (make-surflet-options-transformer set-option!)
(lambda (new-value . stuff)
(let ((new-options (if (not (null? stuff))
(copy-surflet-options (car stuff))
(make-default-surflet-options))))
(set-option! new-options new-value)
new-options)))
(define (make-surflet-options . stuff)
(let loop ((options (make-default-surflet-options))
(stuff stuff))
(if (null? stuff)
options
(let* ((transformer (car stuff))
(value (cadr stuff)))
(loop (transformer value options)
(cddr stuff))))))
(define with-surflet-path
(make-surflet-options-transformer
set-surflet-options-surflet-path!))
2003-03-17 05:17:55 -05:00
(define with-cache-surflets?
(make-surflet-options-transformer
set-surflet-options-cache-surflets?!))
(define with-session-lifetime
(make-surflet-options-transformer
set-surflet-options-session-lifetime!))
(define with-make-session-timeout-text
(make-surflet-options-transformer
set-surflet-options-make-session-timeout-text!))
;; 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 surflet-options-surflet-path))
2003-03-17 05:17:55 -05:00
(define options-cache-surflets?
(make-fluid-selector surflet-options-cache-surflets?))
(define options-session-lifetime
(make-fluid-selector surflet-options-session-lifetime))
(define options-make-session-timeout-text
(make-fluid-selector surflet-options-make-session-timeout-text))
(define set-options-surflet-path!
(make-fluid-setter set-surflet-options-surflet-path!))
2003-03-17 05:17:55 -05:00
(define set-options-cache-surflets?!
(make-fluid-setter set-surflet-options-cache-surflets?!))
(define set-options-session-lifetime!
(make-fluid-setter set-surflet-options-session-lifetime!))
(define set-options-make-session-timeout-text
(make-fluid-setter set-surflet-options-make-session-timeout-text!))
;;; 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)
2003-01-25 11:28:16 -05:00
(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....
2002-11-05 17:20:47 -05:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEBUGGING
(define (debug fmt . args)
(if *debug*
(format #t "DEBUG: ~?~%" fmt args)
(force-output)))