rename INSTANCE to SESSION and SESSION to INSTANCE
This commit is contained in:
interp
parent
0b57b16fe9
commit
4606552c2b
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 @@
|
|||
<li>You URL is illformed.</li>
|
||||
</ul>
|
||||
</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)))))
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
"/" "/"))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue