+ Outhouse some components of surflet-handler.
+ Textual restructuring of surflet-handler. + Comments added.
This commit is contained in:
interp
parent
7747dd4ac6
commit
3d3655960b
|
|
@ -0,0 +1,24 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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 surflet 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 ...)))))
|
||||
|
|
@ -128,22 +128,19 @@
|
|||
rt-module-language ;get structures dynamically
|
||||
; srfi-13 ;string
|
||||
srfi-14 ;CHAR-SET:DIGIT
|
||||
handle-fatal-error ;WITH-FATAL-ERROR-HANDLER* et al.
|
||||
handle-fatal ;WITH-FATAL-ERROR-HANDLER* et al.
|
||||
srfi-27 ;random numbers
|
||||
locks ;MAKE-LOCK et al.
|
||||
thread-cells ;THREAD-CELL et al.
|
||||
profiling ;PROFILE-SPACE
|
||||
httpd-logging ;HTTP-SYSLOG
|
||||
shift-reset ;SHIFT and RESET
|
||||
conditions ;exception
|
||||
threads ;SLEEP
|
||||
thread-fluids ;FORK-THREAD
|
||||
sxml-to-html ;SXML->HTML
|
||||
scsh ;regexp et al.
|
||||
; httpd-file-directory-handlers ;send-file-response
|
||||
scheme-with-scsh ;regexp et al.
|
||||
srfi-6 ;string-ports
|
||||
handle
|
||||
scheme
|
||||
thread-safe-counter
|
||||
)
|
||||
(files surflet-handler))
|
||||
|
||||
|
|
@ -297,3 +294,24 @@
|
|||
handle-fatal-error
|
||||
)
|
||||
(files simple-surflet-api))
|
||||
|
||||
(define-interface handle-fatal-interface
|
||||
(export with-fatal-handler*
|
||||
(with-fatal-handler :syntax)))
|
||||
|
||||
(define-structure handle-fatal handle-fatal-interface
|
||||
(open scheme conditions handle)
|
||||
(files handle-fatal))
|
||||
|
||||
|
||||
(define-interface thread-safe-counter-interface
|
||||
(export make-thread-safe-counter
|
||||
thread-safe-counter-value
|
||||
thread-safe-counter-next!
|
||||
thread-safe-counter?))
|
||||
|
||||
(define-structure thread-safe-counter thread-safe-counter-interface
|
||||
(open scheme
|
||||
locks
|
||||
define-record-types)
|
||||
(files thread-safe-counter))
|
||||
|
|
@ -1,115 +1,39 @@
|
|||
;; the surflet handler
|
||||
;; The SUrflet handler
|
||||
;; Copyright Andreas Bernauer, 2002
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; GLOBALS
|
||||
|
||||
;;; DEBUGging
|
||||
(define *debug* #t)
|
||||
|
||||
;;; 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!))
|
||||
|
||||
(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 surflet-path surflet-prefix cache-surflets? session-lifetime)
|
||||
options?
|
||||
(surflet-path options:surflet-path set-options:surflet-path)
|
||||
(surflet-prefix options:surflet-prefix set-options:surflet-prefix)
|
||||
(cache-surflets? options:cache-surflets? set-options:cache-surflets?)
|
||||
;; session lifetime is in seconds
|
||||
(session-lifetime options:session-lifetime set-options:session-lifetime))
|
||||
|
||||
;;; 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))
|
||||
|
||||
(define (valid-surflet-response-data? data)
|
||||
(or (string? data) (list? data)))
|
||||
|
||||
(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)))
|
||||
|
||||
|
||||
;; Surflet-prefix is unused now. Formerly, it contained the virtual
|
||||
;; path prefix for the handler.
|
||||
(define (make-default-options surflet-path surflet-prefix)
|
||||
(make-options surflet-path surflet-prefix #t 600))
|
||||
|
||||
;;; 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))
|
||||
;; preserved thread fluid because between different calls to
|
||||
;; surflet-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-surflet-path (make-fluid-selector options:surflet-path))
|
||||
(define options-surflet-prefix (make-fluid-selector options:surflet-prefix))
|
||||
(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-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))
|
||||
|
||||
(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....
|
||||
;; INSTANCE is the session that is handled currently.
|
||||
(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 #f))
|
||||
(lambda (path req)
|
||||
|
|
@ -126,10 +50,18 @@
|
|||
(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
|
||||
|
|
@ -168,6 +100,7 @@
|
|||
(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
|
||||
|
|
@ -181,6 +114,11 @@
|
|||
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)
|
||||
|
|
@ -211,8 +149,10 @@
|
|||
"session-surveillance[~s]: unknown message ~s; dieing"
|
||||
session-id (memo:message memo)))))))
|
||||
|
||||
|
||||
;; try to get continuation-table and then the continuation
|
||||
;;; 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)
|
||||
|
|
@ -240,6 +180,7 @@
|
|||
(lambda (path-string surflet-path req)
|
||||
(receive (session-id continuation-id)
|
||||
(resume-url-ids 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))
|
||||
|
|
@ -256,7 +197,14 @@
|
|||
))))
|
||||
|
||||
|
||||
;; RESPONSE-MAKER is a procedure returnig a SURFLET-RESPONSE.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; 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))
|
||||
|
|
@ -280,19 +228,33 @@
|
|||
(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)))
|
||||
|
||||
;; REQ may be #f in some (most) cases.
|
||||
;;; 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)
|
||||
|
|
@ -321,19 +283,28 @@
|
|||
(make-error-response (status-code bad-gateway) #f
|
||||
"The SUrflet returned an invalid response object (no surflet-response)."))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; access to session-table
|
||||
;;; 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
|
||||
|
|
@ -345,6 +316,8 @@
|
|||
(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))
|
||||
|
|
@ -360,16 +333,18 @@
|
|||
(set-memo:message memo 'adjust-timeout))
|
||||
(release-lock *session-table-lock*))
|
||||
|
||||
;; adjusts the timeout of the current session
|
||||
;;; 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-error-handler
|
||||
(with-fatal-handler
|
||||
(lambda (condtion decline)
|
||||
(release-lock *session-table-lock*)
|
||||
(decline))
|
||||
(lambda ()
|
||||
(obtain-lock *session-table-lock*)
|
||||
;; notify session killing
|
||||
(table-walk
|
||||
|
|
@ -377,8 +352,12 @@
|
|||
(memo-killed! (session-memo session)))
|
||||
*session-table*)
|
||||
(set! *session-table* (make-integer-table))
|
||||
(release-lock *session-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 '()))
|
||||
|
|
@ -389,6 +368,10 @@
|
|||
(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
|
||||
|
|
@ -405,6 +388,8 @@
|
|||
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
|
||||
|
|
@ -416,6 +401,9 @@
|
|||
(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
|
||||
|
|
@ -431,21 +419,26 @@
|
|||
(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?)
|
||||
;;; 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
|
||||
(define *surflet-table* (make-string-table)) ; path-string is index
|
||||
(define *surflet-table-lock* (make-lock))
|
||||
|
||||
;; SURFLET-NAME is like "news-dir/latest-news.scm"
|
||||
;;; 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 surflet-name directory)
|
||||
(let* ((full-surflet-name (absolute-file-name surflet-name directory))
|
||||
(load-surflet
|
||||
|
|
@ -487,6 +480,8 @@
|
|||
(load-surflet #t))))
|
||||
(load-surflet #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 '()))
|
||||
|
|
@ -497,35 +492,37 @@
|
|||
(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-error-handler*
|
||||
(with-fatal-handler
|
||||
(lambda (condition decline)
|
||||
(release-lock *surflet-table-lock*)
|
||||
(decline))
|
||||
(lambda ()
|
||||
(obtain-lock *surflet-table-lock*)
|
||||
(set! *surflet-table* (make-string-table))
|
||||
(release-lock *surflet-table-lock*))))
|
||||
(release-lock *surflet-table-lock*)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; INSTANCE
|
||||
(define *instance* (make-thread-cell #f))
|
||||
;;; INSTANCE
|
||||
|
||||
;;; REGISTER-INSTANCE!
|
||||
;; Saves values for current session (in a record).
|
||||
(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))
|
||||
|
||||
;;; INSTANCE-SESSION-ID
|
||||
;; Returns session-id of current *INSTANCE*.
|
||||
(define (instance-session-id)
|
||||
(really-instance-session-id (thread-cell-ref *instance*)))
|
||||
|
||||
|
|
@ -534,93 +531,49 @@
|
|||
(really-instance-return-continuation (thread-cell-ref *instance*)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; RESUME-URL
|
||||
;;; 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) "-" (submatch (* digit)))) ; Continuation-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)))
|
||||
|
||||
(define (resume-url-session-id id-url)
|
||||
;; Return various parts of RESUME-URL
|
||||
(define (resume-url-session-id resume-url)
|
||||
(receive (session-id continuation-id)
|
||||
(resume-url-ids id-url)
|
||||
(resume-url-ids resume-url)
|
||||
session-id))
|
||||
|
||||
(define (resume-url-continuation-id id-url)
|
||||
(define (resume-url-continuation-id resume-url)
|
||||
(receive (session-id continuation-id)
|
||||
(resume-url-ids id-url)
|
||||
(resume-url-ids resume-url)
|
||||
continuation-id))
|
||||
|
||||
(define (resume-url-ids id-url)
|
||||
(let ((match (regexp-search *resume-url-regexp* id-url)))
|
||||
(define (resume-url-ids resume-url)
|
||||
(let ((match (regexp-search *resume-url-regexp* 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 id-url)
|
||||
(let ((match (regexp-search *resume-url-regexp* id-url)))
|
||||
(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? 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 surflet 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 (resume-url? resume-url)
|
||||
(regexp-search? *resume-url-regexp* resume-url))
|
||||
|
||||
(define (bad-gateway-error-response req path-string condition)
|
||||
(make-error-response
|
||||
|
|
@ -628,6 +581,119 @@
|
|||
(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 return-continuation)
|
||||
instance?
|
||||
(session-id really-instance-session-id
|
||||
set-instance-session-id!)
|
||||
(return-continuation really-instance-return-continuation
|
||||
set-instance-return-continuation!))
|
||||
|
||||
|
||||
;;; OPTIONS: options for the surflet-handler
|
||||
(define-record-type options :options
|
||||
(make-options surflet-path surflet-prefix cache-surflets? session-lifetime)
|
||||
options?
|
||||
(surflet-path options:surflet-path set-options:surflet-path)
|
||||
(surflet-prefix options:surflet-prefix set-options:surflet-prefix)
|
||||
(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 surflet-prefix)
|
||||
(make-options surflet-path surflet-prefix #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-surflet-prefix (make-fluid-selector options:surflet-prefix))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,26 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; thread-safe counter
|
||||
|
||||
(define-record-type counter :counter
|
||||
(really-make-counter counter lock)
|
||||
thread-safe-counter?
|
||||
(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-value 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))
|
||||
Loading…
Reference in New Issue