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

Add note about danger of killing / deleting current continuation. 

Add current session's id and current session's continuation's id in
this message.
This commit is contained in:
interp 2003-01-16 12:53:10 +00:00
parent bba9c34744
commit 422a1db09f
3 changed files with 70 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -99,7 +99,11 @@
adjust-timeout adjust-timeout
get-continuations get-continuations
delete-continuation! delete-continuation!
instance-session-id)) instance-session-id
resume-url?
resume-url-ids
resume-url-session-id
resume-url-continuation-id))
(define-structures (define-structures
((servlet-handler servlet-handler-interface) ((servlet-handler servlet-handler-interface)

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

@ -489,6 +489,7 @@
(define (instance-session-id) (define (instance-session-id)
(really-instance-session-id (thread-cell-ref *instance*))) (really-instance-session-id (thread-cell-ref *instance*)))
;; unused
(define (instance-return-continuation) (define (instance-return-continuation)
(really-instance-return-continuation (thread-cell-ref *instance*))) (really-instance-return-continuation (thread-cell-ref *instance*)))
@ -519,13 +520,13 @@
(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 session/continuation id" id-url)))) (values #f #f))))
(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)))
(if match (if match
(match:substring match 1) (match:substring match 1)
(error "resume-url-servlet-name: no servlet-name found")))) (values #f #f))))
(define (resume-url? id-url) (define (resume-url? id-url)
(regexp-search? *resume-url-regexp* id-url)) (regexp-search? *resume-url-regexp* id-url))

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

@ -3,9 +3,11 @@
servlets servlets
servlet-handler/admin servlet-handler/admin
httpd-responses httpd-responses
httpd-requests
url
handle-fatal-error handle-fatal-error
let-opt let-opt
srfi-1 ;filter-map srfi-1 ;filter-map, last
sort sort
) )
(begin (begin
@ -54,14 +56,15 @@
(action (input-field-value select bindings))) (action (input-field-value select bindings)))
(if (string=? action action-title) (if (string=? action action-title)
(values #f #f) (values #f #f req)
(values action (values action
(filter-map (lambda (checkbox table-element) (filter-map (lambda (checkbox table-element)
(if (input-field-value checkbox bindings) (if (input-field-value checkbox bindings)
table-element table-element
#f)) #f))
checkboxes checkboxes
table-elements))))) table-elements)
req))))
(define (unload-servlets outdated? servlet-names) (define (unload-servlets outdated? servlet-names)
(if-outdated outdated? (if-outdated outdated?
@ -70,7 +73,10 @@
(define (no-servlets) (define (no-servlets)
`(p "Currently, there are no servlets loaded " `(p "Currently, there are no servlets loaded "
(URL ,(make-callback show-servlets) "(reload)."))) (URL ,(make-callback show-servlets) "(reload)")
", but there may be "
(URL ,(make-callback show-sessions) "sessions")
" you want to administer."))
(define (show-servlets req . maybe-update-text) (define (show-servlets req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
@ -87,7 +93,7 @@
(actions '("unload" "unload all"))) (actions '("unload" "unload all")))
(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 req)
(select-table title ; title (select-table title ; title
header ; header header ; header
'((th "Name")) ; table-header '((th "Name")) ; table-header
@ -98,7 +104,7 @@
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 sessions of this servlet." "the unloading of sessions of this servlet. " (br)
"This can be done on the " "This can be done on the "
(URL ,(make-callback show-sessions) (URL ,(make-callback show-sessions)
"sessions adminstration page.")) "sessions adminstration page."))
@ -144,15 +150,21 @@
(define (show-sessions 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-sessions (sort-list! (get-sessions) session-servlet-name<?))) (current-sessions (sort-list! (get-sessions) session-servlet-name<?)))
(real-sessions current-sessions update-text))) (real-sessions current-sessions update-text
(resume-url-session-id
(last (http-url-path (request-url req)))))))
(define (real-sessions current-sessions update-text) (define (real-sessions current-sessions update-text this-session-id)
(let ((outdated? (make-outdater)) (let ((outdated? (make-outdater))
(title "Servlet Adminstration - Sessions") (title "Servlet Adminstration - Sessions")
(header `((h1 "Servlet Administration") (header `((h1 "Servlet Administration")
(h2 "Sessions") (h2 "Sessions")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (footer `(,(if (not (null? current-sessions))
`(p "Be careful not to kill this adminstration's "
"session (id: " ,this-session-id ").")
#f)
(hr)
(URL ,(make-callback show-servlets) "Return to servlets menu.") (br) (URL ,(make-callback show-servlets) "Return to servlets 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)
@ -164,7 +176,7 @@
(if (null? current-sessions) (if (null? current-sessions)
(send-html `(html (title ,title) (send-html `(html (title ,title)
(body ,@header ,(no-current-sessions) ,footer))) (body ,@header ,(no-current-sessions) ,footer)))
(receive (action selected-sessions) (receive (action selected-sessions req)
(select-table title (select-table title
header header
`((th "Servlet Name") (th "Session-Id")) `((th "Servlet Name") (th "Session-Id"))
@ -198,22 +210,22 @@
(if (zero? (length selected-sessions)) (if (zero? (length selected-sessions))
"You must choose at least one session." "You must choose at least one session."
;; this does not return ;; this does not return
(show-continuations selected-sessions)))) (show-continuations selected-sessions req))))
(else (else
(error "unknown action" action))))) (error "unknown action" action)))))
(show-sessions current-sessions new-update-text))))))) (show-sessions current-sessions new-update-text)))))))
(define (no-current-continuations session) (define (no-current-continuations session req)
`((p "Currently, there are no continuations for this session. ") `((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 session)))) (lambda (req) (show-continuations (list session) req)))
"reload") "reload")
" this page or go back to the " " this page or go back to the "
(URL ,(make-callback show-sessions) "session table overview.")))) (URL ,(make-callback show-sessions) "session table overview."))))
(define (no-more-than-one-session title header1 sessions) (define (no-more-than-one-session title header1 sessions req)
(send-html (send-html
`(html (title ,title) `(html (title ,title)
(body (h1 "Servlet Administration") (body (h1 "Servlet Administration")
@ -229,7 +241,7 @@
,@(map (lambda (session) ,@(map (lambda (session)
`(li (URL ,(make-callback `(li (URL ,(make-callback
(lambda (req) (lambda (req)
(show-continuations (list session)))) (show-continuations (list session) req)))
,(session-servlet-name (cdr session)) ,(session-servlet-name (cdr session))
" (" ,(car session) ")"))) " (" ,(car session) ")")))
sessions))))))) sessions)))))))
@ -237,41 +249,48 @@
(define (continuation-id<? entry1 entry2) (define (continuation-id<? entry1 entry2)
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (show-continuations sessions . maybe-update-text) (define (show-continuations sessions req . 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 sessions))) (if (not (= 1 (length sessions)))
(no-more-than-one-session title header1 sessions) (no-more-than-one-session title header1 sessions req)
(let* ((session-pair (car sessions)) (let* ((session-pair (car sessions))
(session-id (car session-pair)) (session-id (car session-pair))
(session-entry (cdr session-pair)) (session-entry (cdr session-pair))
(this-continuation-id (resume-url-continuation-id
(last (http-url-path (request-url req)))))
(update-text (:optional maybe-update-text ""))) (update-text (:optional maybe-update-text "")))
(let ((current-continuations (let* ((current-continuations
(sort-list! (get-continuations session-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 " ,session-id) `((h2 "Continuations of " ,session-id)
(p "(belongs to the servlet '" (p "(belongs to the servlet '"
,(session-servlet-name session-entry) "')") ,(session-servlet-name session-entry) "')")
(p (font (@ (color "red")) ,update-text))))) (p (font (@ (color "red")) ,update-text)))))
(footer (footer
`((hr) `(,(if (not (null? current-continuations))
(URL ,(make-callback show-servlets) "Return to servlets menu.") (br) `(p "Be careful not to delete this adminstration's "
(URL ,(make-callback show-sessions) "Return to sessions menu.") (br) "continuation (id: " ,this-continuation-id ").")
(URL ,(make-callback return-to-main-page) "Return to administration menu.") #f)
(br) (hr)
(URL "/" "Return to main menu."))) (URL ,(make-callback show-servlets) "Return to servlets menu.") (br)
(actions '("delete" "delete all")) (URL ,(make-callback show-sessions) "Return to sessions menu.") (br)
(continuations-callback (make-callback (lambda (req) (URL ,(make-callback return-to-main-page) "Return to administration menu.")
(show-continuations sessions))))) (br)
(URL "/" "Return to main menu.")))
(actions '("delete" "delete all"))
(continuations-callback
(make-callback (lambda (req)
(show-continuations sessions req)))))
(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 session-pair) ,(no-current-continuations session-pair req)
,footer))) ,footer)))
(receive (action selected-continuations) (receive (action selected-continuations req)
(select-table title (select-table title
header header
'((th "Continuation-Id")) '((th "Continuation-Id"))
@ -282,7 +301,8 @@
actions actions
footer) footer)
(if (not action) (if (not action)
(show-continuations sessions "Choose an action.") (show-continuations sessions req
"Choose an action.")
(begin (begin
(cond (cond
((string=? action "delete") ((string=? action "delete")
@ -293,7 +313,8 @@
session-id current-continuations)) session-id current-continuations))
(else (else
(error "unknown action" action))) (error "unknown action" action)))
(show-continuations sessions "Deleted.")))))))))) (show-continuations sessions req
"Deleted."))))))))))
(define (delete-continuations outdated? continuations-callback (define (delete-continuations outdated? continuations-callback
session-id continuations) session-id continuations)