From 3d3655960b9d4a2fabed59c6a837aea6f446c1aa Mon Sep 17 00:00:00 2001 From: interp Date: Sat, 25 Jan 2003 16:09:03 +0000 Subject: [PATCH] + Outhouse some components of surflet-handler. + Textual restructuring of surflet-handler. + Comments added. --- scheme/httpd/surflets/handle-fatal.scm | 24 + scheme/httpd/surflets/packages.scm | 30 +- scheme/httpd/surflets/surflet-handler.scm | 462 ++++++++++-------- scheme/httpd/surflets/thread-safe-counter.scm | 26 + 4 files changed, 338 insertions(+), 204 deletions(-) create mode 100644 scheme/httpd/surflets/handle-fatal.scm create mode 100644 scheme/httpd/surflets/thread-safe-counter.scm diff --git a/scheme/httpd/surflets/handle-fatal.scm b/scheme/httpd/surflets/handle-fatal.scm new file mode 100644 index 0000000..df577e9 --- /dev/null +++ b/scheme/httpd/surflets/handle-fatal.scm @@ -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 ...))))) \ No newline at end of file diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index 2de0216..9bd1676 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -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)) \ No newline at end of file diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index b4d4b8e..543759c 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -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,25 +333,31 @@ (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 - (lambda (session-id session) - (memo-killed! (session-memo session))) - *session-table*) - (set! *session-table* (make-integer-table)) - (release-lock *session-table*)))) + (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 '())) @@ -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 @@ -415,7 +400,10 @@ (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 @@ -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*)))) + (obtain-lock *surflet-table-lock*) + (set! *surflet-table* (make-string-table)) + (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 diff --git a/scheme/httpd/surflets/thread-safe-counter.scm b/scheme/httpd/surflets/thread-safe-counter.scm new file mode 100644 index 0000000..4d831b0 --- /dev/null +++ b/scheme/httpd/surflets/thread-safe-counter.scm @@ -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))