diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index bcb086d..a742ee5 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -74,7 +74,7 @@ send ;just send (no finish, no suspend) set-servlet-data! get-servlet-data - adjust-timeout ;adjusts timeout of current instance + adjust-timeout ;adjusts timeout of current session ;Without `!' because PLT ;doesn't have it. )) @@ -82,24 +82,24 @@ (define-interface servlet-handler/admin-interface (export get-loaded-servlets unload-servlet - set-options-instance-lifetime - options-instance-lifetime + set-options-session-lifetime + options-session-lifetime set-options-cache-servlets? options-cache-servlets? options-servlet-path options-servlet-prefix - get-instances - instance-servlet-name - instance-memo - instance-continuation-table - instance-continuation-table-lock - instance-continuation-counter - delete-instance! - instance-adjust-timeout! + get-sessions + session-servlet-name + session-memo + session-continuation-table + session-continuation-table-lock + session-continuation-counter + delete-session! + session-adjust-timeout! adjust-timeout get-continuations delete-continuation! - session-instance-id)) + instance-session-id)) (define-structures ((servlet-handler servlet-handler-interface) diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 21db862..44a49a2 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -4,19 +4,19 @@ (define *debug* #t) -;;; instance-table: entry for every new request on a servlet page -(define-record-type instance :instance - (make-instance servlet-name memo +;;; session-table: entry for every new request on a servlet page +(define-record-type session :session + (make-session servlet-name memo continuation-table continuation-table-lock continuation-counter servlet-data) - instance? - (servlet-name instance-servlet-name) - (memo instance-memo set-instance-memo!) - (continuation-table instance-continuation-table) - (continuation-table-lock instance-continuation-table-lock) - (continuation-counter instance-continuation-counter) - (servlet-data instance-servlet-data set-instance-servlet-data!)) + session? + (servlet-name session-servlet-name) + (memo session-memo set-session-memo!) + (continuation-table session-continuation-table) + (continuation-table-lock session-continuation-table-lock) + (continuation-counter session-continuation-counter) + (servlet-data session-servlet-data set-session-servlet-data!)) (define-record-type memo :memo (make-memo message value new-memo) @@ -32,22 +32,22 @@ (define (memo-killed! memo) (set-memo:message memo 'killed)) -(define-record-type session :session - (make-session instance-id return-continuation) - session? - (instance-id really-session-instance-id - set-session-instance-id!) - (return-continuation really-session-return-continuation - set-session-return-continuation!)) +(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 servlet-path servlet-prefix cache-servlets? instance-lifetime) + (make-options servlet-path servlet-prefix cache-servlets? session-lifetime) options? (servlet-path options:servlet-path set-options:servlet-path) (servlet-prefix options:servlet-prefix set-options:servlet-prefix) (cache-servlets? options:cache-servlets? set-options:cache-servlets?) - ;; instance lifetime is in seconds - (instance-lifetime options:instance-lifetime set-options:instance-lifetime)) + ;; session lifetime is in seconds + (session-lifetime options:session-lifetime set-options:session-lifetime)) ;; Servlet-prefix is unused now. Formerly, it contained the virtual ;; path prefix for the handler. @@ -66,12 +66,12 @@ (define options-servlet-path (make-fluid-selector options:servlet-path)) (define options-servlet-prefix (make-fluid-selector options:servlet-prefix)) (define options-cache-servlets? (make-fluid-selector options:cache-servlets?)) -(define options-instance-lifetime (make-fluid-selector options:instance-lifetime)) +(define options-session-lifetime (make-fluid-selector options:session-lifetime)) (define set-options-cache-servlets? (make-fluid-setter set-options:cache-servlets?)) -(define set-options-instance-lifetime (make-fluid-setter set-options:instance-lifetime)) +(define set-options-session-lifetime (make-fluid-setter set-options:session-lifetime)) -(define *instance-table* (make-integer-table)) ; instance-id is index -(define *instance-table-lock* (make-lock)) +(define *session-table* (make-integer-table)) ; session-id is index +(define *session-table-lock* (make-lock)) (define random (let* ((source (make-random-source)) @@ -91,54 +91,54 @@ (string=? request-method "POST")) (if (resume-url? path-string) (resume-url path-string servlet-path req) - (launch-new-instance path-string servlet-path req)) + (launch-new-session path-string servlet-path req)) (make-http-error-response http-status/method-not-allowed req request-method))) (make-http-error-response http-status/bad-request req (format #f "Bad path: ~s" path))))) -(define (launch-new-instance path-string servlet-path req) +(define (launch-new-session path-string servlet-path req) (cond ((file-not-exists? (absolute-file-name path-string servlet-path)) (make-http-error-response http-status/not-found req path-string)) ((string=? (file-name-extension path-string) ".scm") - (obtain-lock *instance-table-lock*) - ;; no access to instance table until new instance-id is saved - (let ((instance-id (generate-new-table-id *instance-table*)) + (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! *instance-table* instance-id - (make-instance path-string ; used to make + (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)) ; servlet-data - (release-lock *instance-table-lock*) - (register-session! instance-id 'no-return) + (release-lock *session-table-lock*) + (register-instance! session-id 'no-return) (with-fatal-handler ;; Catch conditions from get-servlet-rt-structure. (lambda (condition decline) - (delete-instance! instance-id) + (delete-session! session-id) (bad-gateway-error-response req path-string condition)) (let ((servlet (get-servlet-rt-structure path-string servlet-path))) (fork-thread - (instance-surveillance instance-id - (+ (time) (options-instance-lifetime)) + (session-surveillance session-id + (+ (time) (options-session-lifetime)) memo)) (reset (with-fatal-handler ;; Catch conditions that occur while running the servlet. (lambda (condition decline) - (delete-instance! instance-id) + (delete-session! session-id) ;; Restore correct continuation with shift. (shift unused (bad-gateway-error-response req path-string condition))) (with-cwd servlet-path (with-names-from-rt-structure servlet servlet-interface - (main req))))))))) + (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 @@ -152,35 +152,35 @@ path-string)) )) -(define (instance-surveillance instance-id time-to-die memo) +(define (session-surveillance session-id time-to-die memo) (lambda () (let loop ((time-to-die time-to-die) (memo memo)) - (debug "instance-surveillance[~s]: going to sleep until ~a" - instance-id (format-date "~c" (date time-to-die))) + (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 "instance-surveillance[~s]: instance already killed, dieing" - instance-id) + (debug "session-surveillance[~s]: session already killed, dieing" + session-id) ) ((adjust-timeout) ; new timeout - (debug "instance-surveillance[~s]: adjusting timeout" instance-id) + (debug "session-surveillance[~s]: adjusting timeout" session-id) (loop (memo:value memo) (memo:new-memo memo))) - ((kill) ; kill instance - (debug "instance-surveillance[~s]: killing" - instance-id) - (obtain-lock *instance-table-lock*) - (table-set! *instance-table* instance-id #f) - (release-lock *instance-table-lock*)) + ((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) - "instance-surveillance[~s]: unknown message ~s; dieing" - instance-id (memo:message memo))))))) + "session-surveillance[~s]: unknown message ~s; dieing" + session-id (memo:message memo))))))) ;; try to get continuation-table and then the continuation @@ -198,31 +198,30 @@
In any case, you may try to restart the servlet from the beginning. Your browser may also have cached an old instance of this servlet. In this case, try to reload the page.
" +In any case, you may try to restart the servlet from the beginning. Your browser may also have cached an old session of this servlet. In this case, try to reload the page.
" (resume-url-servlet-name path-string))))) (lookup-continuation-table - (lambda (instance continuation-table continuation-id) - (let ((continuation-table-lock (instance-continuation-table-lock instance))) + (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 servlet-path req) - (receive (instance-id continuation-id) + (receive (session-id continuation-id) (resume-url-ids path-string) - (let ((instance (instance-lookup instance-id))) - (if instance - (let* ((continuation-table (instance-continuation-table instance)) - (resume (lookup-continuation-table instance continuation-table + (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 - servlet-path - (reset - (begin - (register-session! instance-id 'no-return) - (resume req)))) + (with-cwd servlet-path + (reset + (begin + (register-instance! session-id 'no-return) + (resume req)))) (bad-request path-string req))) (bad-request path-string req))) )))) @@ -230,106 +229,106 @@ (define (send/suspend response-maker) (shift return - (let* ((instance-id (session-instance-id)) - (instance (instance-lookup instance-id))) - ;; the session might be deleted in the meanwhile - (if instance + (let* ((session-id (instance-session-id)) + (session (session-lookup session-id))) + ;; the instance might be deleted in the meanwhile + (if session (begin - (instance-adjust-timeout! instance-id) - (let ((continuations-table (instance-continuation-table instance)) - (continuation-table-lock (instance-continuation-table-lock instance)) - (continuation-counter (instance-next-continuation-counter instance))) + (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 (instance-servlet-name instance) - instance-id + (let ((new-url (make-resume-url (session-servlet-name session) + session-id continuation-counter continuation-id))) (response-maker new-url))))) (make-http-error-response http-status/not-found #f - "The URL refers to a servlet, whose instance is no longer alive."))))) + "The URL refers to a servlet, whose session is no longer alive."))))) (define (send/finish response) - (delete-instance! (session-instance-id)) + (delete-session! (instance-session-id)) (shift unused response)) (define (send response) (shift unsused response)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; access to instance-table -(define (instance-lookup instance-id) - (obtain-lock *instance-table-lock*) - (let ((result (table-ref *instance-table* instance-id))) - (release-lock *instance-table-lock*) +;; access to session-table +(define (session-lookup session-id) + (obtain-lock *session-table-lock*) + (let ((result (table-ref *session-table* session-id))) + (release-lock *session-table-lock*) result)) -(define (instance-next-continuation-counter instance) +(define (session-next-continuation-counter session) (thread-safe-counter-next! - (instance-continuation-counter instance))) + (session-continuation-counter session))) -(define (delete-instance! instance-id) - (obtain-lock *instance-table-lock*) - ;; notify surveillance of instance being alread killed (prevents - ;; surveillance of killing new instance that has the same number by +(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 ((instance (table-ref *instance-table* instance-id))) - (memo-killed! (instance-memo instance))) + (let ((session (table-ref *session-table* session-id))) + (memo-killed! (session-memo session))) ;; why can't table entries be deleted correctly? - (table-set! *instance-table* instance-id #f) - (release-lock *instance-table-lock*)) + (table-set! *session-table* session-id #f) + (release-lock *session-table-lock*)) -(define (instance-adjust-timeout! instance-id) - (obtain-lock *instance-table-lock*) - (let* ((instance (table-ref *instance-table* instance-id)) - (memo (instance-memo instance)) +(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-instance-lifetime))) + (options-session-lifetime))) (set-memo:new-memo memo new-memo) ;; I don't think we need locking here. Do you agree? - (set-instance-memo! instance new-memo) + (set-session-memo! session new-memo) (set-memo:message memo 'adjust-timeout)) - (release-lock *instance-table-lock*)) + (release-lock *session-table-lock*)) -;; adjusts the timeout of the current instance +;; adjusts the timeout of the current session (define (adjust-timeout) - (instance-adjust-timeout! (session-instance-id))) + (session-adjust-timeout! (instance-session-id))) -(define (reset-instance-table!) +(define (reset-session-table!) (with-fatal-error-handler (lambda (condtion decline) - (release-lock *instance-table-lock*) + (release-lock *session-table-lock*) (decline)) (lambda () - (obtain-lock *instance-table-lock*) - ;; notify instance killing + (obtain-lock *session-table-lock*) + ;; notify session killing (table-walk - (lambda (instance-id instance) - (memo-killed! (instance-memo instance))) - *instance-table*) - (set! *instance-table* (make-integer-table)) - (release-lock *instance-table*)))) + (lambda (session-id session) + (memo-killed! (session-memo session))) + *session-table*) + (set! *session-table* (make-integer-table)) + (release-lock *session-table*)))) -(define (get-instances) - (obtain-lock *instance-table-lock*) - (let ((instances '())) +(define (get-sessions) + (obtain-lock *session-table-lock*) + (let ((sessions '())) (table-walk - (lambda (instance-id instance-entry) - (set! instances (cons (cons instance-id instance-entry) instances))) - *instance-table*) - (release-lock *instance-table-lock*) - instances)) + (lambda (session-id session-entry) + (set! sessions (cons (cons session-id session-entry) sessions))) + *session-table*) + (release-lock *session-table-lock*) + sessions)) -(define (get-continuations instance-id) - (let ((instance (instance-lookup instance-id))) - (if instance - (let ((continuation-table-lock (instance-continuation-table-lock instance)) - (continuation-table (instance-continuation-table instance)) +(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 @@ -341,11 +340,11 @@ continuations) '()))) -(define (delete-continuation! instance-id continuation-id) - (let ((instance (instance-lookup instance-id))) - (if instance - (let ((continuation-table-lock (instance-continuation-table-lock instance)) - (continuation-table (instance-continuation-table instance)) +(define (delete-continuation! session-id continuation-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) (if (table-ref continuation-table continuation-id) @@ -353,17 +352,17 @@ (release-lock continuation-table-lock))))) (define (set-servlet-data! new-data) - (let ((instance (instance-lookup (session-instance-id)))) - (if instance + (let ((session (session-lookup (instance-session-id)))) + (if session (begin - (set-instance-servlet-data! instance new-data) + (set-session-servlet-data! session new-data) #t) #f))) (define (get-servlet-data) - (let ((instance (instance-lookup (session-instance-id)))) - (if instance - (instance-servlet-data instance) + (let ((session (session-lookup (instance-session-id)))) + (if session + (session-servlet-data session) (error "Instance no longer alive.")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -450,23 +449,23 @@ (release-lock *servlet-table-lock*)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; SESSION -(define *session* (make-thread-cell #f)) +;; INSTANCE +(define *instance* (make-thread-cell #f)) -(define (register-session! instance-id return-continuation) - (thread-cell-set! *session* - (make-session instance-id return-continuation))) +(define (register-instance! session-id return-continuation) + (thread-cell-set! *instance* + (make-instance session-id return-continuation))) -;(define (save-session-return-continuation! return-continuation) -; (set-session-instance-id! (thread-cell-ref *session*) +;(define (save-instance-return-continuation! return-continuation) +; (set-instance-session-id! (thread-cell-ref *instance*) ; return-continuation)) -(define (session-instance-id) - (really-session-instance-id (thread-cell-ref *session*))) +(define (instance-session-id) + (really-instance-session-id (thread-cell-ref *instance*))) -(define (session-return-continuation) - (really-session-return-continuation (thread-cell-ref *session*))) +(define (instance-return-continuation) + (really-instance-return-continuation (thread-cell-ref *instance*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; RESUME-URL @@ -474,19 +473,19 @@ ";k" (submatch (* digit)) ; Instance-ID ";c" (+ digit) "-" (submatch (* digit)))) ; Continuation-ID -(define (make-resume-url path-string instance-id continuation-counter continuation-id) +(define (make-resume-url path-string session-id continuation-counter continuation-id) (string-append path-string - ";k" (number->string (session-instance-id)) + ";k" (number->string (instance-session-id)) ";c" (number->string continuation-counter) "-" (number->string continuation-id))) -(define (resume-url-instance-id id-url) - (receive (instance-id continuation-id) +(define (resume-url-session-id id-url) + (receive (session-id continuation-id) (resume-url-ids id-url) - instance-id)) + session-id)) (define (resume-url-continuation-id id-url) - (receive (instance-id continuation-id) + (receive (session-id continuation-id) (resume-url-ids id-url) continuation-id)) @@ -495,7 +494,7 @@ (if match (values (string->number (match:substring match 2)) (string->number (match:substring match 3))) - (error "resume-url-ids: no instance/continuation id" id-url)))) + (error "resume-url-ids: no session/continuation id" id-url)))) (define (resume-url-servlet-name id-url) (let ((match (regexp-search *resume-url-regexp* id-url))) diff --git a/scheme/httpd/surflets/web-server/root/surflets/add.scm b/scheme/httpd/surflets/web-server/root/surflets/add.scm index 9397af9..ce4d166 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add.scm @@ -46,10 +46,10 @@ `(html (title "Result") (body (h1 "Result") (p ,(number->string (+ (get-number1) (get-number2)))) - (a (@ (href "add.scm")) "new calculation (new instance)")(br) - (a (@ (href "javascript:history.back(2)")) "new calculation (same instance)")(br) - (a (@ (href ,new-url)) "close this instance"))))))) - ;; How to clear instance data and go to another HTML page: + (a (@ (href "add.scm")) "new calculation (new session)")(br) + (a (@ (href "javascript:history.back(2)")) "new calculation (same session)")(br) + (a (@ (href ,new-url)) "close this session"))))))) + ;; How to clear session data and go to another HTML page: (send/finish (make-http-error-response http-status/moved-temp req "/" "/")) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm index ccd86b5..48bc97a 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm @@ -45,9 +45,9 @@ (let* ((update-text `(font (@ (color "red")) ,(:optional maybe-update-text ""))) (number-field - (make-number-input-field (options-instance-lifetime))) + (make-number-input-field (options-session-lifetime))) (cache-checkbox (make-checkbox-input-field (options-cache-servlets?))) - (options `(("Current instance lifetime: " ,number-field ,submit-timeout) + (options `(("Current session lifetime: " ,number-field ,submit-timeout) ("Cache servlets?" ,cache-checkbox ,submit-cache))) (req (get-option-change return-address update-text options)) (bindings (get-bindings req))) @@ -60,10 +60,10 @@ (if (and (integer? result) (> result 0)) (begin - (set-options-instance-lifetime result) + (set-options-session-lifetime result) (handler-options req - (format #f "Instance lifetime changed to ~a." - (options-instance-lifetime)))) + (format #f "Session lifetime changed to ~a." + (options-session-lifetime)))) (error "not a positive integer")) (handler-options req "Please enter a valid, positive integer number")))) ((input-field-binding submit-cache bindings) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm index 485a303..a13ceb5 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm @@ -83,7 +83,7 @@ (p (font (@ (color "red")) ,update-text)))) (footer `((hr) (URL ,(make-callback return-to-main-page) "Return to main page"))) - (actions '("unload" "unload all" "view instances"))) + (actions '("unload" "unload all" "view sessions"))) (if (null? loaded-servlets) (send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer))) (receive (action selected-servlets) @@ -97,10 +97,10 @@ actions ; actions to perform (cons ; footer `(p "Note that unloading the servlets does not imply " - "the unloading of instances of this servlet." + "the unloading of sessions of this servlet." "This can be done on the " - (URL ,(make-callback instances) - "instances adminstration page.")) + (URL ,(make-callback sessions) + "sessions adminstration page.")) footer)) (if (null? selected-servlets) (servlets 'no-req "You must choose at least one element.") @@ -111,157 +111,157 @@ ((string=? action "unload all") (unload-servlets outdated? loaded-servlets) (servlets 'no-req "Servlets unloaded.")) - ((string=? action "view instances") + ((string=? action "view sessions") (format #t "~s~%" selected-servlets) (let* ((path-stripped-selected-servlets (map remove-servlet-path selected-servlets)) - (selected-instances - (filter (lambda (instance-pair) - (member (instance-servlet-name (cdr instance-pair)) + (selected-sessions + (filter (lambda (session-pair) + (member (session-servlet-name (cdr session-pair)) path-stripped-selected-servlets)) - (get-instances)))) + (get-sessions)))) ;; this does not return - (real-instances (sort-list! selected-instances - instance-servlet-name) + (real-sessions (sort-list! selected-sessions + session-servlet-name) ""))) (else (error "unknown action" action)))))))) - (define (instance-servlet-name entry1 entry2) - (let ((name1 (instance-servlet-name (cdr entry1))) - (name2 (instance-servlet-name (cdr entry2)))) - ;; handle multiple instance names + (define (session-servlet-name entry1 entry2) + (let ((name1 (session-servlet-name (cdr entry1))) + (name2 (session-servlet-name (cdr entry2)))) + ;; handle multiple session names (if (string=? name1 name2) - (instance-id entry1 entry2) + (session-id entry1 entry2) (string name1 name2)))) - (define (instance-id entry1 entry2) - ;; there are no multiple instance-ids + (define (session-id entry1 entry2) + ;; there are no multiple session-ids (< (car entry1) (car entry2))) - (define (instance-id>? entry1 entry2) - (instance-id entry2 entry1)) - (define (instance-servlet-name>? entry1 entry2) - (instance-servlet-name entry2 entry1)) + (define (session-id>? entry1 entry2) + (session-id entry2 entry1)) + (define (session-servlet-name>? entry1 entry2) + (session-servlet-name entry2 entry1)) - (define (no-current-instances) + (define (no-current-sessions) ;; Avoid using send/suspend in this context as there - ;; are no instances available any more. - '(p "Currently, there are no instances, " + ;; are no sessions available any more. + '(p "Currently, there are no sessions, " "i.e. the administration servlet is no longer running. " - ;; Can't use callback here, as there are no valid instances left. + ;; Can't use callback here, as there are no valid sessions left. (URL "admin.scm" "Go back to main page."))) - (define (instances req . maybe-update-text) + (define (sessions req . maybe-update-text) (let* ((update-text (:optional maybe-update-text "")) - (current-instances (sort-list! (get-instances) instance-servlet-name))) - (real-instances current-instances update-text))) + (current-sessions (sort-list! (get-sessions) session-servlet-name))) + (real-sessions current-sessions update-text))) - (define (real-instances current-instances update-text) + (define (real-sessions current-sessions update-text) (let ((outdated? (make-outdater)) - (title "Servlet Adminstration - Instances") + (title "Servlet Adminstration - Sessions") (header `((h1 "Servlet Administration") - (h2 "Instances") + (h2 "Sessions") (p (font (@ (color "red")) ,update-text)))) (footer `((hr) (URL ,(make-callback return-to-main-page) "Return to main page"))) (actions '("kill" "adjust timeout" "view continuations")) - (instances-callback (make-callback instances))) - (if (null? current-instances) + (sessions-callback (make-callback sessions))) + (if (null? current-sessions) (send-html `(html (title ,title) - (body ,@header ,(no-current-instances) ,footer))) - (receive (action selected-instances) + (body ,@header ,(no-current-sessions) ,footer))) + (receive (action selected-sessions) (select-table title header - `((th "Servlet Name") (th "Instance-Id")) - current-instances - (lambda (instance-pair) - (let ((instance-id (car instance-pair)) - (instance-entry (cdr instance-pair))) - `((td ,(instance-servlet-name instance-entry)) - (td ,instance-id)))) + `((th "Servlet Name") (th "Session-Id")) + current-sessions + (lambda (session-pair) + (let ((session-id (car session-pair)) + (session-entry (cdr session-pair))) + `((td ,(session-servlet-name session-entry)) + (td ,session-id)))) actions footer) (let ((new-update-text (cond ((string=? action "kill") (if-outdated outdated? - (show-outdated instances-callback) - (for-each delete-instance! - (map car selected-instances))) - "Instances killed.") + (show-outdated sessions-callback) + (for-each delete-session! + (map car selected-sessions))) + "Sessions killed.") ((string=? action "adjust timeout") (if-outdated outdated? - (show-outdated instances-callback) - (for-each instance-adjust-timeout! - (map car selected-instances))) - "Instances killed.") + (show-outdated sessions-callback) + (for-each session-adjust-timeout! + (map car selected-sessions))) + "Sessions killed.") ((string=? action "view continuations") (if-outdated outdated? - (show-outdated instances-callback) - (if (zero? (length selected-instances)) - "You must choose at least one instance." + (show-outdated sessions-callback) + (if (zero? (length selected-sessions)) + "You must choose at least one session." ;; this does not return - (continuations selected-instances)))) + (continuations selected-sessions)))) (else (error "unknown action" action))))) - (instances 'no-req new-update-text)))))) + (sessions 'no-req new-update-text)))))) - (define (no-current-continuations instance) - `((p "Currently, there are no continuations for this instance. ") + (define (no-current-continuations session) + `((p "Currently, there are no continuations for this session. ") (p "You may " (URL ,(make-callback - (lambda (req) (continuations (list instance)))) + (lambda (req) (continuations (list session)))) "reload") " this page or go back to the " - (URL ,(make-callback instances) "instance table overview.")))) + (URL ,(make-callback sessions) "session table overview.")))) - (define (no-more-than-one-instance title header1) + (define (no-more-than-one-session title header1) (send-html `(html (title ,title) (body (h1 "Servlet Administration") (p "Currently, you may only view the continuations of " - "one instance at a time. This will be changed in " + "one session at a time. This will be changed in " "future revisions. Sorry for any inconvenience.") (p "You may choose to go back to the " - (URL ,(make-callback instances) - "instances administration page") - " where you can choose one instance."))))) + (URL ,(make-callback sessions) + "sessions administration page") + " where you can choose one session."))))) (define (continuation-id entry1 entry2) (< (car entry1) (car entry2))) - (define (continuations instances . maybe-update-text) + (define (continuations sessions . maybe-update-text) (let ((title "Servlet Adminstration - Continuations") (header1 '(h1 "Servlet Administration"))) - (if (not (= 1 (length instances))) - (no-more-than-one-instance title header1) - (let* ((instance-pair (car instances)) - (instance-id (car instance-pair)) - (instance-entry (cdr instance-pair)) + (if (not (= 1 (length sessions))) + (no-more-than-one-session title header1) + (let* ((session-pair (car sessions)) + (session-id (car session-pair)) + (session-entry (cdr session-pair)) (update-text (:optional maybe-update-text ""))) (let ((current-continuations - (sort-list! (get-continuations instance-id) + (sort-list! (get-continuations session-id) continuation-id)) (outdated? (make-outdater)) (header (cons header1 - `((h2 "Continuations of " ,instance-id) + `((h2 "Continuations of " ,session-id) (p "(belongs to the servlet '" - ,(instance-servlet-name instance-entry) "')") + ,(session-servlet-name session-entry) "')") (p (font (@ (color "red")) ,update-text))))) (footer `((hr) - (URL ,(make-callback instances) "Return to instances page.") (br) + (URL ,(make-callback sessions) "Return to sessions page.") (br) (URL ,(make-callback return-to-main-page) "Return to main page."))) (actions '("delete" "delete all")) (continuations-callback (make-callback (lambda (req) - (continuations instances))))) + (continuations sessions))))) (if (null? current-continuations) (send-html `(html (title ,title) (body ,header - ,(no-current-continuations instance-pair) + ,(no-current-continuations session-pair) ,footer))) (receive (action selected-continuations) (select-table title @@ -276,23 +276,23 @@ (cond ((string=? action "delete") (delete-continuations outdated? continuations-callback - instance-id selected-continuations)) + session-id selected-continuations)) ((string=? action "delete all") (delete-continuations outdated? continuations-callback - instance-id current-continuations)) + session-id current-continuations)) (else (error "unknown action" action))) - (continuations instances "Deleted.")))))))) + (continuations sessions "Deleted.")))))))) (define (delete-continuations outdated? continuations-callback - instance-id continuations) + session-id continuations) (if-outdated outdated? (show-outdated continuations-callback) - ;; Do it this way to easily expand to more instances in the + ;; Do it this way to easily expand to more sessions in the ;; future. (for-each delete-continuation! (make-list (length continuations) - instance-id) + session-id) (map car continuations)))) (define (return-to-main-page req) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm index 94aa3bc..d347c38 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm @@ -99,10 +99,10 @@ actions ; actions to perform (cons ; footer `(p "Note that unloading the servlets does not imply " - "the unloading of instances of this servlet." + "the unloading of sessions of this servlet." "This can be done on the " - (URL ,(make-callback show-instances) - "instances adminstration page.")) + (URL ,(make-callback show-sessions) + "sessions adminstration page.")) footer)) (if (not action) (show-servlets 'no-req "Choose an action.") @@ -119,39 +119,39 @@ (else (error "unknown action" action))))))))) - (define (instance-servlet-name entry1 entry2) - (let ((name1 (instance-servlet-name (cdr entry1))) - (name2 (instance-servlet-name (cdr entry2)))) - ;; handle multiple instance names + (define (session-servlet-name entry1 entry2) + (let ((name1 (session-servlet-name (cdr entry1))) + (name2 (session-servlet-name (cdr entry2)))) + ;; handle multiple session names (if (string=? name1 name2) - (instance-id entry1 entry2) + (session-id entry1 entry2) (string name1 name2)))) - (define (instance-id entry1 entry2) - ;; there are no multiple instance-ids + (define (session-id entry1 entry2) + ;; there are no multiple session-ids (< (car entry1) (car entry2))) - (define (instance-id>? entry1 entry2) - (instance-id entry2 entry1)) - (define (instance-servlet-name>? entry1 entry2) - (instance-servlet-name entry2 entry1)) + (define (session-id>? entry1 entry2) + (session-id entry2 entry1)) + (define (session-servlet-name>? entry1 entry2) + (session-servlet-name entry2 entry1)) - (define (no-current-instances) + (define (no-current-sessions) ;; Avoid using send/suspend in this context as there - ;; are no instances available any more. - '(p "Currently, there are no instances, " + ;; are no sessions available any more. + '(p "Currently, there are no sessions, " "i.e. the administration servlet is no longer running. " - ;; Can't use callback here, as there are no valid instances left. + ;; Can't use callback here, as there are no valid sessions left. (URL "admin.scm" "Go back to main page."))) - (define (show-instances req . maybe-update-text) + (define (show-sessions req . maybe-update-text) (let* ((update-text (:optional maybe-update-text "")) - (current-instances (sort-list! (get-instances) instance-servlet-name))) - (real-instances current-instances update-text))) + (current-sessions (sort-list! (get-sessions) session-servlet-name))) + (real-sessions current-sessions update-text))) - (define (real-instances current-instances update-text) + (define (real-sessions current-sessions update-text) (let ((outdated? (make-outdater)) - (title "Servlet Adminstration - Instances") + (title "Servlet Adminstration - Sessions") (header `((h1 "Servlet Administration") - (h2 "Instances") + (h2 "Sessions") (p (font (@ (color "red")) ,update-text)))) (footer `((hr) (URL ,(make-callback show-servlets) "Return to servlets menu.") (br) @@ -161,116 +161,116 @@ (actions '("kill" "adjust timeout" "view continuations")) - (instances-callback (make-callback show-instances))) - (if (null? current-instances) + (sessions-callback (make-callback show-sessions))) + (if (null? current-sessions) (send-html `(html (title ,title) - (body ,@header ,(no-current-instances) ,footer))) - (receive (action selected-instances) + (body ,@header ,(no-current-sessions) ,footer))) + (receive (action selected-sessions) (select-table title header - `((th "Servlet Name") (th "Instance-Id")) - current-instances - (lambda (instance-pair) - (let ((instance-id (car instance-pair)) - (instance-entry (cdr instance-pair))) - `((td ,(instance-servlet-name instance-entry)) - (td ,instance-id)))) + `((th "Servlet Name") (th "Session-Id")) + current-sessions + (lambda (session-pair) + (let ((session-id (car session-pair)) + (session-entry (cdr session-pair))) + `((td ,(session-servlet-name session-entry)) + (td ,session-id)))) actions footer) (if (not action) - (show-instances current-instances "Choose an action.") + (show-sessions current-sessions "Choose an action.") (let ((new-update-text (cond ((string=? action "kill") (if-outdated outdated? - (show-outdated instances-callback) - (for-each delete-instance! - (map car selected-instances))) - "Instances killed.") + (show-outdated sessions-callback) + (for-each delete-session! + (map car selected-sessions))) + "Sessions killed.") ((string=? action "adjust timeout") (if-outdated outdated? - (show-outdated instances-callback) - (for-each instance-adjust-timeout! - (map car selected-instances))) + (show-outdated sessions-callback) + (for-each session-adjust-timeout! + (map car selected-sessions))) "Timeout adjusted.") ((string=? action "view continuations") (if-outdated outdated? - (show-outdated instances-callback) - (if (zero? (length selected-instances)) - "You must choose at least one instance." + (show-outdated sessions-callback) + (if (zero? (length selected-sessions)) + "You must choose at least one session." ;; this does not return - (show-continuations selected-instances)))) + (show-continuations selected-sessions)))) (else (error "unknown action" action))))) - (show-instances current-instances new-update-text))))))) + (show-sessions current-sessions new-update-text))))))) - (define (no-current-continuations instance) - `((p "Currently, there are no continuations for this instance. ") + (define (no-current-continuations session) + `((p "Currently, there are no continuations for this session. ") (p "You may " (URL ,(make-callback - (lambda (req) (show-continuations (list instance)))) + (lambda (req) (show-continuations (list session)))) "reload") " this page or go back to the " - (URL ,(make-callback show-instances) "instance table overview.")))) + (URL ,(make-callback show-sessions) "session table overview.")))) - (define (no-more-than-one-instance title header1 instances) + (define (no-more-than-one-session title header1 sessions) (send-html `(html (title ,title) (body (h1 "Servlet Administration") (p "Currently, you may only view the continuations of " - "one instance at a time. This will be changed in " + "one session at a time. This will be changed in " "future revisions. Sorry for any inconvenience.") (p "You may choose to go back to the " - (URL ,(make-callback show-instances) - "instances administration page") - " where you can select one instance" - " or select one instance from your chosen instances:" (br) + (URL ,(make-callback show-sessions) + "sessions administration page") + " where you can select one session" + " or select one session from your chosen sessions:" (br) (ul - ,@(map (lambda (instance) + ,@(map (lambda (session) `(li (URL ,(make-callback (lambda (req) - (show-continuations (list instance)))) - ,(instance-servlet-name (cdr instance)) - " (" ,(car instance) ")"))) - instances))))))) + (show-continuations (list session)))) + ,(session-servlet-name (cdr session)) + " (" ,(car session) ")"))) + sessions))))))) (define (continuation-id entry1 entry2) (< (car entry1) (car entry2))) - (define (show-continuations instances . maybe-update-text) + (define (show-continuations sessions . maybe-update-text) (let ((title "Servlet Adminstration - Continuations") (header1 '(h1 "Servlet Administration"))) - (if (not (= 1 (length instances))) - (no-more-than-one-instance title header1 instances) - (let* ((instance-pair (car instances)) - (instance-id (car instance-pair)) - (instance-entry (cdr instance-pair)) + (if (not (= 1 (length sessions))) + (no-more-than-one-session title header1 sessions) + (let* ((session-pair (car sessions)) + (session-id (car session-pair)) + (session-entry (cdr session-pair)) (update-text (:optional maybe-update-text ""))) (let ((current-continuations - (sort-list! (get-continuations instance-id) + (sort-list! (get-continuations session-id) continuation-id)) (outdated? (make-outdater)) (header (cons header1 - `((h2 "Continuations of " ,instance-id) + `((h2 "Continuations of " ,session-id) (p "(belongs to the servlet '" - ,(instance-servlet-name instance-entry) "')") + ,(session-servlet-name session-entry) "')") (p (font (@ (color "red")) ,update-text))))) (footer `((hr) (URL ,(make-callback show-servlets) "Return to servlets menu.") (br) - (URL ,(make-callback show-instances) "Return to instances menu.") (br) + (URL ,(make-callback show-sessions) "Return to sessions menu.") (br) (URL ,(make-callback return-to-main-page) "Return to administration menu.") (br) (URL "/" "Return to main menu."))) (actions '("delete" "delete all")) (continuations-callback (make-callback (lambda (req) - (show-continuations instances))))) + (show-continuations sessions))))) (if (null? current-continuations) (send-html `(html (title ,title) (body ,header - ,(no-current-continuations instance-pair) + ,(no-current-continuations session-pair) ,footer))) (receive (action selected-continuations) (select-table title @@ -283,28 +283,28 @@ actions footer) (if (not action) - (show-continuations instances "Choose an action.") + (show-continuations sessions "Choose an action.") (begin (cond ((string=? action "delete") (delete-continuations outdated? continuations-callback - instance-id selected-continuations)) + session-id selected-continuations)) ((string=? action "delete all") (delete-continuations outdated? continuations-callback - instance-id current-continuations)) + session-id current-continuations)) (else (error "unknown action" action))) - (show-continuations instances "Deleted.")))))))))) + (show-continuations sessions "Deleted.")))))))))) (define (delete-continuations outdated? continuations-callback - instance-id continuations) + session-id continuations) (if-outdated outdated? (show-outdated continuations-callback) - ;; Do it this way to easily expand to more instances in the + ;; Do it this way to easily expand to more sessions in the ;; future. (for-each delete-continuation! (make-list (length continuations) - instance-id) + session-id) (map car continuations)))) (define (return-to-main-page req)