scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

rename INSTANCE to SESSION and SESSION to INSTANCE

This commit is contained in:
interp 2002-12-07 22:26:40 +00:00
parent 0b57b16fe9
commit 4606552c2b
6 changed files with 338 additions and 339 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
scheme/httpd/surflets/packages.scm
View File

@ -74,7 +74,7 @@
send ;just send (no finish, no suspend) send ;just send (no finish, no suspend)
set-servlet-data! set-servlet-data!
get-servlet-data get-servlet-data
adjust-timeout ;adjusts timeout of current instance adjust-timeout ;adjusts timeout of current session
;Without `!' because PLT ;Without `!' because PLT
;doesn't have it. ;doesn't have it.
)) ))
@ -82,24 +82,24 @@
(define-interface servlet-handler/admin-interface (define-interface servlet-handler/admin-interface
(export get-loaded-servlets (export get-loaded-servlets
unload-servlet unload-servlet
set-options-instance-lifetime set-options-session-lifetime
options-instance-lifetime options-session-lifetime
set-options-cache-servlets? set-options-cache-servlets?
options-cache-servlets? options-cache-servlets?
options-servlet-path options-servlet-path
options-servlet-prefix options-servlet-prefix
get-instances get-sessions
instance-servlet-name session-servlet-name
instance-memo session-memo
instance-continuation-table session-continuation-table
instance-continuation-table-lock session-continuation-table-lock
instance-continuation-counter session-continuation-counter
delete-instance! delete-session!
instance-adjust-timeout! session-adjust-timeout!
adjust-timeout adjust-timeout
get-continuations get-continuations
delete-continuation! delete-continuation!
session-instance-id)) instance-session-id))
(define-structures (define-structures
((servlet-handler servlet-handler-interface) ((servlet-handler servlet-handler-interface)

305
scheme/httpd/surflets/surflet-handler.scm
View File

@ -4,19 +4,19 @@
(define *debug* #t) (define *debug* #t)
;;; instance-table: entry for every new request on a servlet page ;;; session-table: entry for every new request on a servlet page
(define-record-type instance :instance (define-record-type session :session
(make-instance servlet-name memo (make-session servlet-name memo
continuation-table continuation-table-lock continuation-table continuation-table-lock
continuation-counter continuation-counter
servlet-data) servlet-data)
instance? session?
(servlet-name instance-servlet-name) (servlet-name session-servlet-name)
(memo instance-memo set-instance-memo!) (memo session-memo set-session-memo!)
(continuation-table instance-continuation-table) (continuation-table session-continuation-table)
(continuation-table-lock instance-continuation-table-lock) (continuation-table-lock session-continuation-table-lock)
(continuation-counter instance-continuation-counter) (continuation-counter session-continuation-counter)
(servlet-data instance-servlet-data set-instance-servlet-data!)) (servlet-data session-servlet-data set-session-servlet-data!))
(define-record-type memo :memo (define-record-type memo :memo
(make-memo message value new-memo) (make-memo message value new-memo)
@ -32,22 +32,22 @@
(define (memo-killed! memo) (define (memo-killed! memo)
(set-memo:message memo 'killed)) (set-memo:message memo 'killed))
(define-record-type session :session (define-record-type instance :instance
(make-session instance-id return-continuation) (make-instance session-id return-continuation)
session? instance?
(instance-id really-session-instance-id (session-id really-instance-session-id
set-session-instance-id!) set-instance-session-id!)
(return-continuation really-session-return-continuation (return-continuation really-instance-return-continuation
set-session-return-continuation!)) set-instance-return-continuation!))
(define-record-type options :options (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? options?
(servlet-path options:servlet-path set-options:servlet-path) (servlet-path options:servlet-path set-options:servlet-path)
(servlet-prefix options:servlet-prefix set-options:servlet-prefix) (servlet-prefix options:servlet-prefix set-options:servlet-prefix)
(cache-servlets? options:cache-servlets? set-options:cache-servlets?) (cache-servlets? options:cache-servlets? set-options:cache-servlets?)
;; instance lifetime is in seconds ;; session lifetime is in seconds
(instance-lifetime options:instance-lifetime set-options:instance-lifetime)) (session-lifetime options:session-lifetime set-options:session-lifetime))
;; Servlet-prefix is unused now. Formerly, it contained the virtual ;; Servlet-prefix is unused now. Formerly, it contained the virtual
;; path prefix for the handler. ;; path prefix for the handler.
@ -66,12 +66,12 @@
(define options-servlet-path (make-fluid-selector options:servlet-path)) (define options-servlet-path (make-fluid-selector options:servlet-path))
(define options-servlet-prefix (make-fluid-selector options:servlet-prefix)) (define options-servlet-prefix (make-fluid-selector options:servlet-prefix))
(define options-cache-servlets? (make-fluid-selector options:cache-servlets?)) (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-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 *session-table* (make-integer-table)) ; session-id is index
(define *instance-table-lock* (make-lock)) (define *session-table-lock* (make-lock))
(define random (define random
(let* ((source (make-random-source)) (let* ((source (make-random-source))
@ -91,54 +91,54 @@
(string=? request-method "POST")) (string=? request-method "POST"))
(if (resume-url? path-string) (if (resume-url? path-string)
(resume-url path-string servlet-path req) (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 (make-http-error-response http-status/method-not-allowed req
request-method))) request-method)))
(make-http-error-response http-status/bad-request req (make-http-error-response http-status/bad-request req
(format #f "Bad path: ~s" path))))) (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 (cond
((file-not-exists? (absolute-file-name path-string servlet-path)) ((file-not-exists? (absolute-file-name path-string servlet-path))
(make-http-error-response http-status/not-found req path-string)) (make-http-error-response http-status/not-found req path-string))
((string=? (file-name-extension path-string) ".scm") ((string=? (file-name-extension path-string) ".scm")
(obtain-lock *instance-table-lock*) (obtain-lock *session-table-lock*)
;; no access to instance table until new instance-id is saved ;; no access to session table until new session-id is saved
(let ((instance-id (generate-new-table-id *instance-table*)) (let ((session-id (generate-new-table-id *session-table*))
(memo (make-default-memo))) (memo (make-default-memo)))
(table-set! *instance-table* instance-id (table-set! *session-table* session-id
(make-instance path-string ; used to make (make-session path-string ; used to make
; redirections to origin ; redirections to origin
memo memo
(make-integer-table) ; continuation table (make-integer-table) ; continuation table
(make-lock) ; continuation table lock (make-lock) ; continuation table lock
(make-thread-safe-counter) ; continuation counter (make-thread-safe-counter) ; continuation counter
#f)) ; servlet-data #f)) ; servlet-data
(release-lock *instance-table-lock*) (release-lock *session-table-lock*)
(register-session! instance-id 'no-return) (register-instance! session-id 'no-return)
(with-fatal-handler (with-fatal-handler
;; Catch conditions from get-servlet-rt-structure. ;; Catch conditions from get-servlet-rt-structure.
(lambda (condition decline) (lambda (condition decline)
(delete-instance! instance-id) (delete-session! session-id)
(bad-gateway-error-response req path-string condition)) (bad-gateway-error-response req path-string condition))
(let ((servlet (get-servlet-rt-structure path-string servlet-path))) (let ((servlet (get-servlet-rt-structure path-string servlet-path)))
(fork-thread (fork-thread
(instance-surveillance instance-id (session-surveillance session-id
(+ (time) (options-instance-lifetime)) (+ (time) (options-session-lifetime))
memo)) memo))
(reset (reset
(with-fatal-handler (with-fatal-handler
;; Catch conditions that occur while running the servlet. ;; Catch conditions that occur while running the servlet.
(lambda (condition decline) (lambda (condition decline)
(delete-instance! instance-id) (delete-session! session-id)
;; Restore correct continuation with shift. ;; Restore correct continuation with shift.
(shift unused (shift unused
(bad-gateway-error-response req path-string condition))) (bad-gateway-error-response req path-string condition)))
(with-cwd servlet-path (with-cwd servlet-path
(with-names-from-rt-structure (with-names-from-rt-structure
servlet servlet-interface servlet servlet-interface
(main req))))))))) (main req))))))))) ; Launch serlvet's main procedure.
(else ; We'll serve every non-scm file. (else ; We'll serve every non-scm file.
;; We need access to SEND-FILE-RESPONSE of ;; We need access to SEND-FILE-RESPONSE of
;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we ;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we
@ -152,35 +152,35 @@
path-string)) path-string))
)) ))
(define (instance-surveillance instance-id time-to-die memo) (define (session-surveillance session-id time-to-die memo)
(lambda () (lambda ()
(let loop ((time-to-die time-to-die) (let loop ((time-to-die time-to-die)
(memo memo)) (memo memo))
(debug "instance-surveillance[~s]: going to sleep until ~a" (debug "session-surveillance[~s]: going to sleep until ~a"
instance-id (format-date "~c" (date time-to-die))) session-id (format-date "~c" (date time-to-die)))
(let ((seconds-to-sleep (- time-to-die (time)))) (let ((seconds-to-sleep (- time-to-die (time))))
(if (positive? seconds-to-sleep) (if (positive? seconds-to-sleep)
(sleep (* 1000 seconds-to-sleep)))) (sleep (* 1000 seconds-to-sleep))))
;; check state of the world ;; check state of the world
(case (memo:message memo) (case (memo:message memo)
((killed) ; too late ((killed) ; too late
(debug "instance-surveillance[~s]: instance already killed, dieing" (debug "session-surveillance[~s]: session already killed, dieing"
instance-id) session-id)
) )
((adjust-timeout) ; new timeout ((adjust-timeout) ; new timeout
(debug "instance-surveillance[~s]: adjusting timeout" instance-id) (debug "session-surveillance[~s]: adjusting timeout" session-id)
(loop (memo:value memo) (loop (memo:value memo)
(memo:new-memo memo))) (memo:new-memo memo)))
((kill) ; kill instance ((kill) ; kill session
(debug "instance-surveillance[~s]: killing" (debug "session-surveillance[~s]: killing"
instance-id) session-id)
(obtain-lock *instance-table-lock*) (obtain-lock *session-table-lock*)
(table-set! *instance-table* instance-id #f) (table-set! *session-table* session-id #f)
(release-lock *instance-table-lock*)) (release-lock *session-table-lock*))
(else (else
(format (current-error-port) (format (current-error-port)
"instance-surveillance[~s]: unknown message ~s; dieing" "session-surveillance[~s]: unknown message ~s; dieing"
instance-id (memo:message memo))))))) session-id (memo:message memo)))))))
;; try to get continuation-table and then the continuation ;; try to get continuation-table and then the continuation
@ -198,31 +198,30 @@
<li>You URL is illformed.</li> <li>You URL is illformed.</li>
</ul> </ul>
</p> </p>
<p>In any case, you may try to restart the servlet from the <a href=\"~a\">beginning</a>. Your browser may also have cached an old instance of this servlet. In this case, try to reload the page.</p>" <p>In any case, you may try to restart the servlet from the <a href=\"~a\">beginning</a>. Your browser may also have cached an old session of this servlet. In this case, try to reload the page.</p>"
(resume-url-servlet-name path-string))))) (resume-url-servlet-name path-string)))))
(lookup-continuation-table (lookup-continuation-table
(lambda (instance continuation-table continuation-id) (lambda (session continuation-table continuation-id)
(let ((continuation-table-lock (instance-continuation-table-lock instance))) (let ((continuation-table-lock (session-continuation-table-lock session)))
(obtain-lock continuation-table-lock) (obtain-lock continuation-table-lock)
(let ((result (table-ref continuation-table continuation-id))) (let ((result (table-ref continuation-table continuation-id)))
(release-lock continuation-table-lock) (release-lock continuation-table-lock)
result))))) result)))))
(lambda (path-string servlet-path req) (lambda (path-string servlet-path req)
(receive (instance-id continuation-id) (receive (session-id continuation-id)
(resume-url-ids path-string) (resume-url-ids path-string)
(let ((instance (instance-lookup instance-id))) (let ((session (session-lookup session-id)))
(if instance (if session
(let* ((continuation-table (instance-continuation-table instance)) (let* ((continuation-table (session-continuation-table session))
(resume (lookup-continuation-table instance continuation-table (resume (lookup-continuation-table session continuation-table
continuation-id))) continuation-id)))
(if resume (if resume
(with-cwd (with-cwd servlet-path
servlet-path (reset
(reset (begin
(begin (register-instance! session-id 'no-return)
(register-session! instance-id 'no-return) (resume req))))
(resume req))))
(bad-request path-string req))) (bad-request path-string req)))
(bad-request path-string req))) (bad-request path-string req)))
)))) ))))
@ -230,106 +229,106 @@
(define (send/suspend response-maker) (define (send/suspend response-maker)
(shift return (shift return
(let* ((instance-id (session-instance-id)) (let* ((session-id (instance-session-id))
(instance (instance-lookup instance-id))) (session (session-lookup session-id)))
;; the session might be deleted in the meanwhile ;; the instance might be deleted in the meanwhile
(if instance (if session
(begin (begin
(instance-adjust-timeout! instance-id) (session-adjust-timeout! session-id)
(let ((continuations-table (instance-continuation-table instance)) (let ((continuations-table (session-continuation-table session))
(continuation-table-lock (instance-continuation-table-lock instance)) (continuation-table-lock (session-continuation-table-lock session))
(continuation-counter (instance-next-continuation-counter instance))) (continuation-counter (session-next-continuation-counter session)))
(obtain-lock continuation-table-lock) (obtain-lock continuation-table-lock)
(let ((continuation-id (generate-new-table-id continuations-table))) (let ((continuation-id (generate-new-table-id continuations-table)))
(table-set! continuations-table continuation-id return) (table-set! continuations-table continuation-id return)
(release-lock continuation-table-lock) (release-lock continuation-table-lock)
(let ((new-url (make-resume-url (instance-servlet-name instance) (let ((new-url (make-resume-url (session-servlet-name session)
instance-id session-id
continuation-counter continuation-counter
continuation-id))) continuation-id)))
(response-maker new-url))))) (response-maker new-url)))))
(make-http-error-response http-status/not-found #f (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) (define (send/finish response)
(delete-instance! (session-instance-id)) (delete-session! (instance-session-id))
(shift unused response)) (shift unused response))
(define (send response) (define (send response)
(shift unsused response)) (shift unsused response))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; access to instance-table ;; access to session-table
(define (instance-lookup instance-id) (define (session-lookup session-id)
(obtain-lock *instance-table-lock*) (obtain-lock *session-table-lock*)
(let ((result (table-ref *instance-table* instance-id))) (let ((result (table-ref *session-table* session-id)))
(release-lock *instance-table-lock*) (release-lock *session-table-lock*)
result)) result))
(define (instance-next-continuation-counter instance) (define (session-next-continuation-counter session)
(thread-safe-counter-next! (thread-safe-counter-next!
(instance-continuation-counter instance))) (session-continuation-counter session)))
(define (delete-instance! instance-id) (define (delete-session! session-id)
(obtain-lock *instance-table-lock*) (obtain-lock *session-table-lock*)
;; notify surveillance of instance being alread killed (prevents ;; notify surveillance of session being alread killed (prevents
;; surveillance of killing new instance that has the same number by ;; surveillance of killing new session that has the same number by
;; accident) ;; accident)
(let ((instance (table-ref *instance-table* instance-id))) (let ((session (table-ref *session-table* session-id)))
(memo-killed! (instance-memo instance))) (memo-killed! (session-memo session)))
;; why can't table entries be deleted correctly? ;; why can't table entries be deleted correctly?
(table-set! *instance-table* instance-id #f) (table-set! *session-table* session-id #f)
(release-lock *instance-table-lock*)) (release-lock *session-table-lock*))
(define (instance-adjust-timeout! instance-id) (define (session-adjust-timeout! session-id)
(obtain-lock *instance-table-lock*) (obtain-lock *session-table-lock*)
(let* ((instance (table-ref *instance-table* instance-id)) (let* ((session (table-ref *session-table* session-id))
(memo (instance-memo instance)) (memo (session-memo session))
(new-memo (make-default-memo))) (new-memo (make-default-memo)))
;; Do it this way: new values and then new message ;; Do it this way: new values and then new message
(set-memo:value memo (set-memo:value memo
(+ (time) (+ (time)
(options-instance-lifetime))) (options-session-lifetime)))
(set-memo:new-memo memo new-memo) (set-memo:new-memo memo new-memo)
;; I don't think we need locking here. Do you agree? ;; 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)) (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) (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 (with-fatal-error-handler
(lambda (condtion decline) (lambda (condtion decline)
(release-lock *instance-table-lock*) (release-lock *session-table-lock*)
(decline)) (decline))
(lambda () (lambda ()
(obtain-lock *instance-table-lock*) (obtain-lock *session-table-lock*)
;; notify instance killing ;; notify session killing
(table-walk (table-walk
(lambda (instance-id instance) (lambda (session-id session)
(memo-killed! (instance-memo instance))) (memo-killed! (session-memo session)))
*instance-table*) *session-table*)
(set! *instance-table* (make-integer-table)) (set! *session-table* (make-integer-table))
(release-lock *instance-table*)))) (release-lock *session-table*))))
(define (get-instances) (define (get-sessions)
(obtain-lock *instance-table-lock*) (obtain-lock *session-table-lock*)
(let ((instances '())) (let ((sessions '()))
(table-walk (table-walk
(lambda (instance-id instance-entry) (lambda (session-id session-entry)
(set! instances (cons (cons instance-id instance-entry) instances))) (set! sessions (cons (cons session-id session-entry) sessions)))
*instance-table*) *session-table*)
(release-lock *instance-table-lock*) (release-lock *session-table-lock*)
instances)) sessions))
(define (get-continuations instance-id) (define (get-continuations session-id)
(let ((instance (instance-lookup instance-id))) (let ((session (session-lookup session-id)))
(if instance (if session
(let ((continuation-table-lock (instance-continuation-table-lock instance)) (let ((continuation-table-lock (session-continuation-table-lock session))
(continuation-table (instance-continuation-table instance)) (continuation-table (session-continuation-table session))
(continuations '())) (continuations '()))
(obtain-lock continuation-table-lock) (obtain-lock continuation-table-lock)
(table-walk (table-walk
@ -341,11 +340,11 @@
continuations) continuations)
'()))) '())))
(define (delete-continuation! instance-id continuation-id) (define (delete-continuation! session-id continuation-id)
(let ((instance (instance-lookup instance-id))) (let ((session (session-lookup session-id)))
(if instance (if session
(let ((continuation-table-lock (instance-continuation-table-lock instance)) (let ((continuation-table-lock (session-continuation-table-lock session))
(continuation-table (instance-continuation-table instance)) (continuation-table (session-continuation-table session))
(continuations '())) (continuations '()))
(obtain-lock continuation-table-lock) (obtain-lock continuation-table-lock)
(if (table-ref continuation-table continuation-id) (if (table-ref continuation-table continuation-id)
@ -353,17 +352,17 @@
(release-lock continuation-table-lock))))) (release-lock continuation-table-lock)))))
(define (set-servlet-data! new-data) (define (set-servlet-data! new-data)
(let ((instance (instance-lookup (session-instance-id)))) (let ((session (session-lookup (instance-session-id))))
(if instance (if session
(begin (begin
(set-instance-servlet-data! instance new-data) (set-session-servlet-data! session new-data)
#t) #t)
#f))) #f)))
(define (get-servlet-data) (define (get-servlet-data)
(let ((instance (instance-lookup (session-instance-id)))) (let ((session (session-lookup (instance-session-id))))
(if instance (if session
(instance-servlet-data instance) (session-servlet-data session)
(error "Instance no longer alive.")))) (error "Instance no longer alive."))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -450,23 +449,23 @@
(release-lock *servlet-table-lock*)))) (release-lock *servlet-table-lock*))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SESSION ;; INSTANCE
(define *session* (make-thread-cell #f)) (define *instance* (make-thread-cell #f))
(define (register-session! instance-id return-continuation) (define (register-instance! session-id return-continuation)
(thread-cell-set! *session* (thread-cell-set! *instance*
(make-session instance-id return-continuation))) (make-instance session-id return-continuation)))
;(define (save-session-return-continuation! return-continuation) ;(define (save-instance-return-continuation! return-continuation)
; (set-session-instance-id! (thread-cell-ref *session*) ; (set-instance-session-id! (thread-cell-ref *instance*)
; return-continuation)) ; return-continuation))
(define (session-instance-id) (define (instance-session-id)
(really-session-instance-id (thread-cell-ref *session*))) (really-instance-session-id (thread-cell-ref *instance*)))
(define (session-return-continuation) (define (instance-return-continuation)
(really-session-return-continuation (thread-cell-ref *session*))) (really-instance-return-continuation (thread-cell-ref *instance*)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RESUME-URL ;; RESUME-URL
@ -474,19 +473,19 @@
";k" (submatch (* digit)) ; Instance-ID ";k" (submatch (* digit)) ; Instance-ID
";c" (+ digit) "-" (submatch (* digit)))) ; Continuation-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 (string-append path-string
";k" (number->string (session-instance-id)) ";k" (number->string (instance-session-id))
";c" (number->string continuation-counter) ";c" (number->string continuation-counter)
"-" (number->string continuation-id))) "-" (number->string continuation-id)))
(define (resume-url-instance-id id-url) (define (resume-url-session-id id-url)
(receive (instance-id continuation-id) (receive (session-id continuation-id)
(resume-url-ids id-url) (resume-url-ids id-url)
instance-id)) session-id))
(define (resume-url-continuation-id id-url) (define (resume-url-continuation-id id-url)
(receive (instance-id continuation-id) (receive (session-id continuation-id)
(resume-url-ids id-url) (resume-url-ids id-url)
continuation-id)) continuation-id))
@ -495,7 +494,7 @@
(if match (if match
(values (string->number (match:substring match 2)) (values (string->number (match:substring match 2))
(string->number (match:substring match 3))) (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) (define (resume-url-servlet-name id-url)
(let ((match (regexp-search *resume-url-regexp* id-url))) (let ((match (regexp-search *resume-url-regexp* id-url)))

8
scheme/httpd/surflets/web-server/root/surflets/add.scm
View File

@ -46,10 +46,10 @@
`(html (title "Result") `(html (title "Result")
(body (h1 "Result") (body (h1 "Result")
(p ,(number->string (+ (get-number1) (get-number2)))) (p ,(number->string (+ (get-number1) (get-number2))))
(a (@ (href "add.scm")) "new calculation (new instance)")(br) (a (@ (href "add.scm")) "new calculation (new session)")(br)
(a (@ (href "javascript:history.back(2)")) "new calculation (same instance)")(br) (a (@ (href "javascript:history.back(2)")) "new calculation (same session)")(br)
(a (@ (href ,new-url)) "close this instance"))))))) (a (@ (href ,new-url)) "close this session")))))))
;; How to clear instance data and go to another HTML page: ;; How to clear session data and go to another HTML page:
(send/finish (send/finish
(make-http-error-response http-status/moved-temp req (make-http-error-response http-status/moved-temp req
"/" "/")) "/" "/"))

10
scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
View File

@ -45,9 +45,9 @@
(let* ((update-text `(font (@ (color "red")) (let* ((update-text `(font (@ (color "red"))
,(:optional maybe-update-text ""))) ,(:optional maybe-update-text "")))
(number-field (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?))) (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))) ("Cache servlets?" ,cache-checkbox ,submit-cache)))
(req (get-option-change return-address update-text options)) (req (get-option-change return-address update-text options))
(bindings (get-bindings req))) (bindings (get-bindings req)))
@ -60,10 +60,10 @@
(if (and (integer? result) (if (and (integer? result)
(> result 0)) (> result 0))
(begin (begin
(set-options-instance-lifetime result) (set-options-session-lifetime result)
(handler-options req (handler-options req
(format #f "Instance lifetime changed to ~a." (format #f "Session lifetime changed to ~a."
(options-instance-lifetime)))) (options-session-lifetime))))
(error "not a positive integer")) (error "not a positive integer"))
(handler-options req "Please enter a valid, positive integer number")))) (handler-options req "Please enter a valid, positive integer number"))))
((input-field-binding submit-cache bindings) ((input-field-binding submit-cache bindings)

166
scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm
View File

@ -83,7 +83,7 @@
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (footer `((hr)
(URL ,(make-callback return-to-main-page) "Return to main page"))) (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) (if (null? loaded-servlets)
(send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer))) (send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer)))
(receive (action selected-servlets) (receive (action selected-servlets)
@ -97,10 +97,10 @@
actions ; actions to perform actions ; actions to perform
(cons ; footer (cons ; footer
`(p "Note that unloading the servlets does not imply " `(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 " "This can be done on the "
(URL ,(make-callback instances) (URL ,(make-callback sessions)
"instances adminstration page.")) "sessions adminstration page."))
footer)) footer))
(if (null? selected-servlets) (if (null? selected-servlets)
(servlets 'no-req "You must choose at least one element.") (servlets 'no-req "You must choose at least one element.")
@ -111,157 +111,157 @@
((string=? action "unload all") ((string=? action "unload all")
(unload-servlets outdated? loaded-servlets) (unload-servlets outdated? loaded-servlets)
(servlets 'no-req "Servlets unloaded.")) (servlets 'no-req "Servlets unloaded."))
((string=? action "view instances") ((string=? action "view sessions")
(format #t "~s~%" selected-servlets) (format #t "~s~%" selected-servlets)
(let* ((path-stripped-selected-servlets (let* ((path-stripped-selected-servlets
(map remove-servlet-path selected-servlets)) (map remove-servlet-path selected-servlets))
(selected-instances (selected-sessions
(filter (lambda (instance-pair) (filter (lambda (session-pair)
(member (instance-servlet-name (cdr instance-pair)) (member (session-servlet-name (cdr session-pair))
path-stripped-selected-servlets)) path-stripped-selected-servlets))
(get-instances)))) (get-sessions))))
;; this does not return ;; this does not return
(real-instances (sort-list! selected-instances (real-sessions (sort-list! selected-sessions
instance-servlet-name<?) session-servlet-name<?)
""))) "")))
(else (else
(error "unknown action" action)))))))) (error "unknown action" action))))))))
(define (instance-servlet-name<? entry1 entry2) (define (session-servlet-name<? entry1 entry2)
(let ((name1 (instance-servlet-name (cdr entry1))) (let ((name1 (session-servlet-name (cdr entry1)))
(name2 (instance-servlet-name (cdr entry2)))) (name2 (session-servlet-name (cdr entry2))))
;; handle multiple instance names ;; handle multiple session names
(if (string=? name1 name2) (if (string=? name1 name2)
(instance-id<? entry1 entry2) (session-id<? entry1 entry2)
(string<? name1 name2)))) (string<? name1 name2))))
(define (instance-id<? entry1 entry2) (define (session-id<? entry1 entry2)
;; there are no multiple instance-ids ;; there are no multiple session-ids
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (instance-id>? entry1 entry2) (define (session-id>? entry1 entry2)
(instance-id<? entry2 entry1)) (session-id<? entry2 entry1))
(define (instance-servlet-name>? entry1 entry2) (define (session-servlet-name>? entry1 entry2)
(instance-servlet-name<? entry2 entry1)) (session-servlet-name<? entry2 entry1))
(define (no-current-instances) (define (no-current-sessions)
;; Avoid using send/suspend in this context as there ;; Avoid using send/suspend in this context as there
;; are no instances available any more. ;; are no sessions available any more.
'(p "Currently, there are no instances, " '(p "Currently, there are no sessions, "
"i.e. the administration servlet is no longer running. " "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."))) (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 "")) (let* ((update-text (:optional maybe-update-text ""))
(current-instances (sort-list! (get-instances) instance-servlet-name<?))) (current-sessions (sort-list! (get-sessions) session-servlet-name<?)))
(real-instances current-instances update-text))) (real-sessions current-sessions update-text)))
(define (real-instances current-instances update-text) (define (real-sessions current-sessions update-text)
(let ((outdated? (make-outdater)) (let ((outdated? (make-outdater))
(title "Servlet Adminstration - Instances") (title "Servlet Adminstration - Sessions")
(header `((h1 "Servlet Administration") (header `((h1 "Servlet Administration")
(h2 "Instances") (h2 "Sessions")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (footer `((hr)
(URL ,(make-callback return-to-main-page) "Return to main page"))) (URL ,(make-callback return-to-main-page) "Return to main page")))
(actions '("kill" (actions '("kill"
"adjust timeout" "adjust timeout"
"view continuations")) "view continuations"))
(instances-callback (make-callback instances))) (sessions-callback (make-callback sessions)))
(if (null? current-instances) (if (null? current-sessions)
(send-html `(html (title ,title) (send-html `(html (title ,title)
(body ,@header ,(no-current-instances) ,footer))) (body ,@header ,(no-current-sessions) ,footer)))
(receive (action selected-instances) (receive (action selected-sessions)
(select-table title (select-table title
header header
`((th "Servlet Name") (th "Instance-Id")) `((th "Servlet Name") (th "Session-Id"))
current-instances current-sessions
(lambda (instance-pair) (lambda (session-pair)
(let ((instance-id (car instance-pair)) (let ((session-id (car session-pair))
(instance-entry (cdr instance-pair))) (session-entry (cdr session-pair)))
`((td ,(instance-servlet-name instance-entry)) `((td ,(session-servlet-name session-entry))
(td ,instance-id)))) (td ,session-id))))
actions actions
footer) footer)
(let ((new-update-text (let ((new-update-text
(cond (cond
((string=? action "kill") ((string=? action "kill")
(if-outdated outdated? (if-outdated outdated?
(show-outdated instances-callback) (show-outdated sessions-callback)
(for-each delete-instance! (for-each delete-session!
(map car selected-instances))) (map car selected-sessions)))
"Instances killed.") "Sessions killed.")
((string=? action "adjust timeout") ((string=? action "adjust timeout")
(if-outdated outdated? (if-outdated outdated?
(show-outdated instances-callback) (show-outdated sessions-callback)
(for-each instance-adjust-timeout! (for-each session-adjust-timeout!
(map car selected-instances))) (map car selected-sessions)))
"Instances killed.") "Sessions killed.")
((string=? action "view continuations") ((string=? action "view continuations")
(if-outdated outdated? (if-outdated outdated?
(show-outdated instances-callback) (show-outdated sessions-callback)
(if (zero? (length selected-instances)) (if (zero? (length selected-sessions))
"You must choose at least one instance." "You must choose at least one session."
;; this does not return ;; this does not return
(continuations selected-instances)))) (continuations selected-sessions))))
(else (else
(error "unknown action" action))))) (error "unknown action" action)))))
(instances 'no-req new-update-text)))))) (sessions 'no-req new-update-text))))))
(define (no-current-continuations instance) (define (no-current-continuations session)
`((p "Currently, there are no continuations for this instance. ") `((p "Currently, there are no continuations for this session. ")
(p "You may " (URL ,(make-callback (p "You may " (URL ,(make-callback
(lambda (req) (continuations (list instance)))) (lambda (req) (continuations (list session))))
"reload") "reload")
" this page or go back to the " " 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 (send-html
`(html (title ,title) `(html (title ,title)
(body (h1 "Servlet Administration") (body (h1 "Servlet Administration")
(p "Currently, you may only view the continuations of " (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.") "future revisions. Sorry for any inconvenience.")
(p "You may choose to go back to the " (p "You may choose to go back to the "
(URL ,(make-callback instances) (URL ,(make-callback sessions)
"instances administration page") "sessions administration page")
" where you can choose one instance."))))) " where you can choose one session.")))))
(define (continuation-id<? entry1 entry2) (define (continuation-id<? entry1 entry2)
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (continuations instances . maybe-update-text) (define (continuations sessions . maybe-update-text)
(let ((title "Servlet Adminstration - Continuations") (let ((title "Servlet Adminstration - Continuations")
(header1 '(h1 "Servlet Administration"))) (header1 '(h1 "Servlet Administration")))
(if (not (= 1 (length instances))) (if (not (= 1 (length sessions)))
(no-more-than-one-instance title header1) (no-more-than-one-session title header1)
(let* ((instance-pair (car instances)) (let* ((session-pair (car sessions))
(instance-id (car instance-pair)) (session-id (car session-pair))
(instance-entry (cdr instance-pair)) (session-entry (cdr session-pair))
(update-text (:optional maybe-update-text ""))) (update-text (:optional maybe-update-text "")))
(let ((current-continuations (let ((current-continuations
(sort-list! (get-continuations instance-id) (sort-list! (get-continuations session-id)
continuation-id<?)) continuation-id<?))
(outdated? (make-outdater)) (outdated? (make-outdater))
(header (cons header1 (header (cons header1
`((h2 "Continuations of " ,instance-id) `((h2 "Continuations of " ,session-id)
(p "(belongs to the servlet '" (p "(belongs to the servlet '"
,(instance-servlet-name instance-entry) "')") ,(session-servlet-name session-entry) "')")
(p (font (@ (color "red")) ,update-text))))) (p (font (@ (color "red")) ,update-text)))))
(footer (footer
`((hr) `((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."))) (URL ,(make-callback return-to-main-page) "Return to main page.")))
(actions '("delete" "delete all")) (actions '("delete" "delete all"))
(continuations-callback (make-callback (lambda (req) (continuations-callback (make-callback (lambda (req)
(continuations instances))))) (continuations sessions)))))
(if (null? current-continuations) (if (null? current-continuations)
(send-html `(html (title ,title) (send-html `(html (title ,title)
(body ,header (body ,header
,(no-current-continuations instance-pair) ,(no-current-continuations session-pair)
,footer))) ,footer)))
(receive (action selected-continuations) (receive (action selected-continuations)
(select-table title (select-table title
@ -276,23 +276,23 @@
(cond (cond
((string=? action "delete") ((string=? action "delete")
(delete-continuations outdated? continuations-callback (delete-continuations outdated? continuations-callback
instance-id selected-continuations)) session-id selected-continuations))
((string=? action "delete all") ((string=? action "delete all")
(delete-continuations outdated? continuations-callback (delete-continuations outdated? continuations-callback
instance-id current-continuations)) session-id current-continuations))
(else (else
(error "unknown action" action))) (error "unknown action" action)))
(continuations instances "Deleted.")))))))) (continuations sessions "Deleted."))))))))
(define (delete-continuations outdated? continuations-callback (define (delete-continuations outdated? continuations-callback
instance-id continuations) session-id continuations)
(if-outdated outdated? (if-outdated outdated?
(show-outdated continuations-callback) (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. ;; future.
(for-each delete-continuation! (for-each delete-continuation!
(make-list (length continuations) (make-list (length continuations)
instance-id) session-id)
(map car continuations)))) (map car continuations))))
(define (return-to-main-page req) (define (return-to-main-page req)

164
scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
View File

@ -99,10 +99,10 @@
actions ; actions to perform actions ; actions to perform
(cons ; footer (cons ; footer
`(p "Note that unloading the servlets does not imply " `(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 " "This can be done on the "
(URL ,(make-callback show-instances) (URL ,(make-callback show-sessions)
"instances adminstration page.")) "sessions adminstration page."))
footer)) footer))
(if (not action) (if (not action)
(show-servlets 'no-req "Choose an action.") (show-servlets 'no-req "Choose an action.")
@ -119,39 +119,39 @@
(else (else
(error "unknown action" action))))))))) (error "unknown action" action)))))))))
(define (instance-servlet-name<? entry1 entry2) (define (session-servlet-name<? entry1 entry2)
(let ((name1 (instance-servlet-name (cdr entry1))) (let ((name1 (session-servlet-name (cdr entry1)))
(name2 (instance-servlet-name (cdr entry2)))) (name2 (session-servlet-name (cdr entry2))))
;; handle multiple instance names ;; handle multiple session names
(if (string=? name1 name2) (if (string=? name1 name2)
(instance-id<? entry1 entry2) (session-id<? entry1 entry2)
(string<? name1 name2)))) (string<? name1 name2))))
(define (instance-id<? entry1 entry2) (define (session-id<? entry1 entry2)
;; there are no multiple instance-ids ;; there are no multiple session-ids
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (instance-id>? entry1 entry2) (define (session-id>? entry1 entry2)
(instance-id<? entry2 entry1)) (session-id<? entry2 entry1))
(define (instance-servlet-name>? entry1 entry2) (define (session-servlet-name>? entry1 entry2)
(instance-servlet-name<? entry2 entry1)) (session-servlet-name<? entry2 entry1))
(define (no-current-instances) (define (no-current-sessions)
;; Avoid using send/suspend in this context as there ;; Avoid using send/suspend in this context as there
;; are no instances available any more. ;; are no sessions available any more.
'(p "Currently, there are no instances, " '(p "Currently, there are no sessions, "
"i.e. the administration servlet is no longer running. " "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."))) (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 "")) (let* ((update-text (:optional maybe-update-text ""))
(current-instances (sort-list! (get-instances) instance-servlet-name<?))) (current-sessions (sort-list! (get-sessions) session-servlet-name<?)))
(real-instances current-instances update-text))) (real-sessions current-sessions update-text)))
(define (real-instances current-instances update-text) (define (real-sessions current-sessions update-text)
(let ((outdated? (make-outdater)) (let ((outdated? (make-outdater))
(title "Servlet Adminstration - Instances") (title "Servlet Adminstration - Sessions")
(header `((h1 "Servlet Administration") (header `((h1 "Servlet Administration")
(h2 "Instances") (h2 "Sessions")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (footer `((hr)
(URL ,(make-callback show-servlets) "Return to servlets menu.") (br) (URL ,(make-callback show-servlets) "Return to servlets menu.") (br)
@ -161,116 +161,116 @@
(actions '("kill" (actions '("kill"
"adjust timeout" "adjust timeout"
"view continuations")) "view continuations"))
(instances-callback (make-callback show-instances))) (sessions-callback (make-callback show-sessions)))
(if (null? current-instances) (if (null? current-sessions)
(send-html `(html (title ,title) (send-html `(html (title ,title)
(body ,@header ,(no-current-instances) ,footer))) (body ,@header ,(no-current-sessions) ,footer)))
(receive (action selected-instances) (receive (action selected-sessions)
(select-table title (select-table title
header header
`((th "Servlet Name") (th "Instance-Id")) `((th "Servlet Name") (th "Session-Id"))
current-instances current-sessions
(lambda (instance-pair) (lambda (session-pair)
(let ((instance-id (car instance-pair)) (let ((session-id (car session-pair))
(instance-entry (cdr instance-pair))) (session-entry (cdr session-pair)))
`((td ,(instance-servlet-name instance-entry)) `((td ,(session-servlet-name session-entry))
(td ,instance-id)))) (td ,session-id))))
actions actions
footer) footer)
(if (not action) (if (not action)
(show-instances current-instances "Choose an action.") (show-sessions current-sessions "Choose an action.")
(let ((new-update-text (let ((new-update-text
(cond (cond
((string=? action "kill") ((string=? action "kill")
(if-outdated outdated? (if-outdated outdated?
(show-outdated instances-callback) (show-outdated sessions-callback)
(for-each delete-instance! (for-each delete-session!
(map car selected-instances))) (map car selected-sessions)))
"Instances killed.") "Sessions killed.")
((string=? action "adjust timeout") ((string=? action "adjust timeout")
(if-outdated outdated? (if-outdated outdated?
(show-outdated instances-callback) (show-outdated sessions-callback)
(for-each instance-adjust-timeout! (for-each session-adjust-timeout!
(map car selected-instances))) (map car selected-sessions)))
"Timeout adjusted.") "Timeout adjusted.")
((string=? action "view continuations") ((string=? action "view continuations")
(if-outdated outdated? (if-outdated outdated?
(show-outdated instances-callback) (show-outdated sessions-callback)
(if (zero? (length selected-instances)) (if (zero? (length selected-sessions))
"You must choose at least one instance." "You must choose at least one session."
;; this does not return ;; this does not return
(show-continuations selected-instances)))) (show-continuations selected-sessions))))
(else (else
(error "unknown action" action))))) (error "unknown action" action)))))
(show-instances current-instances new-update-text))))))) (show-sessions current-sessions new-update-text)))))))
(define (no-current-continuations instance) (define (no-current-continuations session)
`((p "Currently, there are no continuations for this instance. ") `((p "Currently, there are no continuations for this session. ")
(p "You may " (URL ,(make-callback (p "You may " (URL ,(make-callback
(lambda (req) (show-continuations (list instance)))) (lambda (req) (show-continuations (list session))))
"reload") "reload")
" this page or go back to the " " 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 (send-html
`(html (title ,title) `(html (title ,title)
(body (h1 "Servlet Administration") (body (h1 "Servlet Administration")
(p "Currently, you may only view the continuations of " (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.") "future revisions. Sorry for any inconvenience.")
(p "You may choose to go back to the " (p "You may choose to go back to the "
(URL ,(make-callback show-instances) (URL ,(make-callback show-sessions)
"instances administration page") "sessions administration page")
" where you can select one instance" " where you can select one session"
" or select one instance from your chosen instances:" (br) " or select one session from your chosen sessions:" (br)
(ul (ul
,@(map (lambda (instance) ,@(map (lambda (session)
`(li (URL ,(make-callback `(li (URL ,(make-callback
(lambda (req) (lambda (req)
(show-continuations (list instance)))) (show-continuations (list session))))
,(instance-servlet-name (cdr instance)) ,(session-servlet-name (cdr session))
" (" ,(car instance) ")"))) " (" ,(car session) ")")))
instances))))))) sessions)))))))
(define (continuation-id<? entry1 entry2) (define (continuation-id<? entry1 entry2)
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (show-continuations instances . maybe-update-text) (define (show-continuations sessions . maybe-update-text)
(let ((title "Servlet Adminstration - Continuations") (let ((title "Servlet Adminstration - Continuations")
(header1 '(h1 "Servlet Administration"))) (header1 '(h1 "Servlet Administration")))
(if (not (= 1 (length instances))) (if (not (= 1 (length sessions)))
(no-more-than-one-instance title header1 instances) (no-more-than-one-session title header1 sessions)
(let* ((instance-pair (car instances)) (let* ((session-pair (car sessions))
(instance-id (car instance-pair)) (session-id (car session-pair))
(instance-entry (cdr instance-pair)) (session-entry (cdr session-pair))
(update-text (:optional maybe-update-text ""))) (update-text (:optional maybe-update-text "")))
(let ((current-continuations (let ((current-continuations
(sort-list! (get-continuations instance-id) (sort-list! (get-continuations session-id)
continuation-id<?)) continuation-id<?))
(outdated? (make-outdater)) (outdated? (make-outdater))
(header (cons header1 (header (cons header1
`((h2 "Continuations of " ,instance-id) `((h2 "Continuations of " ,session-id)
(p "(belongs to the servlet '" (p "(belongs to the servlet '"
,(instance-servlet-name instance-entry) "')") ,(session-servlet-name session-entry) "')")
(p (font (@ (color "red")) ,update-text))))) (p (font (@ (color "red")) ,update-text)))))
(footer (footer
`((hr) `((hr)
(URL ,(make-callback show-servlets) "Return to servlets menu.") (br) (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.") (URL ,(make-callback return-to-main-page) "Return to administration menu.")
(br) (br)
(URL "/" "Return to main menu."))) (URL "/" "Return to main menu.")))
(actions '("delete" "delete all")) (actions '("delete" "delete all"))
(continuations-callback (make-callback (lambda (req) (continuations-callback (make-callback (lambda (req)
(show-continuations instances))))) (show-continuations sessions)))))
(if (null? current-continuations) (if (null? current-continuations)
(send-html `(html (title ,title) (send-html `(html (title ,title)
(body ,header (body ,header
,(no-current-continuations instance-pair) ,(no-current-continuations session-pair)
,footer))) ,footer)))
(receive (action selected-continuations) (receive (action selected-continuations)
(select-table title (select-table title
@ -283,28 +283,28 @@
actions actions
footer) footer)
(if (not action) (if (not action)
(show-continuations instances "Choose an action.") (show-continuations sessions "Choose an action.")
(begin (begin
(cond (cond
((string=? action "delete") ((string=? action "delete")
(delete-continuations outdated? continuations-callback (delete-continuations outdated? continuations-callback
instance-id selected-continuations)) session-id selected-continuations))
((string=? action "delete all") ((string=? action "delete all")
(delete-continuations outdated? continuations-callback (delete-continuations outdated? continuations-callback
instance-id current-continuations)) session-id current-continuations))
(else (else
(error "unknown action" action))) (error "unknown action" action)))
(show-continuations instances "Deleted.")))))))))) (show-continuations sessions "Deleted."))))))))))
(define (delete-continuations outdated? continuations-callback (define (delete-continuations outdated? continuations-callback
instance-id continuations) session-id continuations)
(if-outdated outdated? (if-outdated outdated?
(show-outdated continuations-callback) (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. ;; future.
(for-each delete-continuation! (for-each delete-continuation!
(make-list (length continuations) (make-list (length continuations)
instance-id) session-id)
(map car continuations)))) (map car continuations))))
(define (return-to-main-page req) (define (return-to-main-page req)