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

Adapt to recent change of session-interface in surflet-handler

This commit is contained in:
interp 2003-04-16 16:03:06 +00:00
parent 5b2e2ddd6a
commit 20821bdfb5
1 changed files with 117 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -72,28 +72,31 @@
(show-outdated (make-callback show-surflets)) (show-outdated (make-callback show-surflets))
(for-each unload-surflet surflet-names))) (for-each unload-surflet surflet-names)))
(define (no-surflets) (define (no-surflets callback)
`(p "Currently, there are no SUrflets loaded " `(p "Currently, there are no SUrflets loaded "
(url ,(make-callback show-surflets) "(reload)") (url ,(callback show-surflets) "(reload)")
", but there may be " ", but there may be "
(url ,(make-callback show-sessions) "sessions") (url ,(callback show-sessions) "sessions")
" you want to administer.")) " you want to administer."))
(define (show-surflets req . maybe-update-text) (define (show-surflets req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(loaded-surflets (sort-list! (get-loaded-surflets) string<?)) (loaded-surflets (sort-list! (get-loaded-surflets) string<?))
(outdated? (make-outdater)) (outdated? (make-outdater))
(callback (make-annotated-callback callback-functor))
(title "SUrflet-Administration -- SUrflets") (title "SUrflet-Administration -- SUrflets")
(header `((h1 "SUrflet Administration") (header `((h1 "SUrflet Administration")
(h2 "SUrflets") (h2 "SUrflets")
(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 administration menu.") (url ,(callback return-to-main-page)
"Return to administration menu.")
(br) (br)
(url "/" "Return to main menu."))) (url "/" "Return to main menu.")))
(actions '("unload" "unload all"))) (actions '("unload" "unload all")))
(if (null? loaded-surflets) (if (null? loaded-surflets)
(send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer))) (send-html `(html (title ,title)
(body ,header ,(no-surflets callback) ,footer)))
(receive (action selected-surflets req) (receive (action selected-surflets req)
(select-table title ; title (select-table title ; title
header ; header header ; header
@ -107,7 +110,7 @@
`(p "Note that unloading the SUrflets does not imply " `(p "Note that unloading the SUrflets does not imply "
"the unloading of sessions of this SUrflet. " (br) "the unloading of sessions of this SUrflet. " (br)
"This can be done on the " "This can be done on the "
(url ,(make-callback show-sessions) (url ,(callback show-sessions)
"sessions adminstration page.")) "sessions adminstration page."))
footer)) footer))
(if (not action) (if (not action)
@ -125,20 +128,21 @@
(else (else
(error "unknown action" action))))))))) (error "unknown action" action)))))))))
(define (session-surflet-name<? entry1 entry2) (define (session-surflet-name<? session1 session2)
(let ((name1 (session-surflet-name (cdr entry1))) (let ((name1 (session-surflet-name session1))
(name2 (session-surflet-name (cdr entry2)))) (name2 (session-surflet-name session2)))
;; handle multiple session names ;; handle multiple session names
(if (string=? name1 name2) (if (string=? name1 name2)
(session-id<? entry1 entry2) (session-id<? session1 session2)
(string<? name1 name2)))) (string<? name1 name2))))
(define (session-id<? entry1 entry2) (define (session-id<? session1 session2)
;; there are no multiple session-ids ;; there are no multiple session-ids
(< (car entry1) (car entry2))) (< (session-session-id session1)
(define (session-id>? entry1 entry2) (session-session-id session2)))
(session-id<? entry2 entry1)) (define (session-surflet-name>? session1 session2)
(define (session-surflet-name>? entry1 entry2) (session-surflet-name<? session2 session1))
(session-surflet-name<? entry2 entry1)) (define (session-id>? session1 session2)
(session-id<? session2 session1))
(define (no-current-sessions) (define (no-current-sessions)
;; Avoid using send/suspend in this context as there ;; Avoid using send/suspend in this context as there
@ -155,24 +159,26 @@
(my-session-id req)))) (my-session-id req))))
(define (real-sessions current-sessions update-text this-session-id) (define (real-sessions current-sessions update-text this-session-id)
(let ((outdated? (make-outdater)) (let* ((outdated? (make-outdater))
(title "SUrflet Adminstration - Sessions") (callback (make-annotated-callback callback-functor))
(header `((h1 "SUrflet Administration") (title "SUrflet Adminstration - Sessions")
(h2 "Sessions") (header `((h1 "SUrflet Administration")
(p (font (@ (color "red")) ,update-text)))) (h2 "Sessions")
(footer `(,(if (not (null? current-sessions)) (p (font (@ (color "red")) ,update-text))))
`(p "Be careful not to kill this adminstration's " (footer `(,(if (not (null? current-sessions))
"session (id: " ,this-session-id ").") `(p "Be careful not to kill this adminstration's "
#f) "session (id: " ,this-session-id ").")
(hr) #f)
(url ,(make-callback show-surflets) "Return to SUrflets menu.") (br) (hr)
(url ,(make-callback return-to-main-page) "Return to administration menu.") (url ,(callback show-surflets)
(br) "Return to SUrflets menu.")
(url "/" "Return to main menu."))) (br) (url ,(callback return-to-main-page)
"Return to administration menu.")
(br) (url "/" "Return to main menu.")))
(actions '("kill" (actions '("kill"
"adjust timeout" "adjust timeout"
"view continuations")) "view continuations"))
(sessions-callback (make-callback show-sessions))) (sessions-callback (callback show-sessions)))
(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)))
@ -181,11 +187,10 @@
header header
`((th "SUrflet Name") (th "Session-Id")) `((th "SUrflet Name") (th "Session-Id"))
current-sessions current-sessions
(lambda (session-pair) (lambda (session)
(let ((session-id (car session-pair)) `((td ,(session-surflet-name session))
(session-entry (cdr session-pair))) (td (@ (align "right"))
`((td ,(session-surflet-name session-entry)) ,(session-session-id session))))
(td (@ (align "right")) ,session-id))))
actions actions
footer) footer)
(if (not action) (if (not action)
@ -196,13 +201,13 @@
(if-outdated outdated? (if-outdated outdated?
(show-outdated sessions-callback) (show-outdated sessions-callback)
(for-each delete-session! (for-each delete-session!
(map car selected-sessions))) selected-sessions))
"Sessions killed.") "Sessions killed.")
((string=? action "adjust timeout") ((string=? action "adjust timeout")
(if-outdated outdated? (if-outdated outdated?
(show-outdated sessions-callback) (show-outdated sessions-callback)
(for-each session-adjust-timeout! (for-each session-adjust-timeout!
(map car selected-sessions))) selected-sessions))
"Timeout adjusted.") "Timeout adjusted.")
((string=? action "view continuations") ((string=? action "view continuations")
(if-outdated outdated? (if-outdated outdated?
@ -210,20 +215,19 @@
(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 req)))) (show-continuations req selected-sessions))))
(else (else
(error "unknown action" action))))) (error "unknown action" action)))))
(show-sessions req new-update-text))))))) (show-sessions req new-update-text)))))))
(define (no-current-continuations session req) (define (no-current-continuations callback 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 ,(callback 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 ,(callback show-sessions) "session table overview."))))
(define (no-more-than-one-session title header1 sessions req) (define (no-more-than-one-session title header1 sessions req)
(let* ((address (make-annotated-address)) (let* ((address (make-annotated-address))
@ -242,83 +246,85 @@
" where you can select one session" " where you can select one session"
" or select one session from your chosen sessions:" (br) " or select one session from your chosen sessions:" (br)
(ul (ul
,@(map (lambda (session) ,@(map
`(li (url ,(address k-url session) (lambda (session)
,(session-surflet-name (cdr session)) `(li (url ,(address k-url session)
" (" ,(car session) ")"))) ,(session-surflet-name session)
" (" ,(session-session-id session) ")")))
sessions)))))))) sessions))))))))
(bindings (get-bindings req)) (bindings (get-bindings req))
(chosen-session (returned-via address bindings))) (chosen-session (returned-via address bindings)))
(show-continuations (list chosen-session) req))) (show-continuations req (list chosen-session))))
(define (continuation-id<? entry1 entry2) (define (continuation-id<? cont1 cont2)
(< (car entry1) (car entry2))) (< (continuation-id cont1)
(continuation-id cont2)))
(define (show-continuations sessions req . maybe-update-text) (define (show-continuations req sessions . maybe-update-text)
(let ((title "SUrflet Adminstration - Continuations") (let ((title "SUrflet Adminstration - Continuations")
(header1 '(h1 "SUrflet Administration"))) (header1 '(h1 "SUrflet Administration")))
(if (not (= 1 (length sessions))) (if (not (= 1 (length sessions)))
(no-more-than-one-session title header1 sessions req) (no-more-than-one-session title header1 sessions req)
(let* ((session-pair (car sessions)) (let* ((session (car sessions))
(session-id (car session-pair)) (session-id (session-session-id session))
(session-entry (cdr session-pair))
(this-continuation-id (my-continuation-id req)) (this-continuation-id (my-continuation-id req))
(update-text (:optional maybe-update-text ""))) (update-text (:optional maybe-update-text ""))
(let* ((current-continuations (current-continuations
(sort-list! (get-continuations session-id) (sort-list! (get-continuations session-id)
continuation-id<?)) continuation-id<?))
(outdated? (make-outdater)) (outdated? (make-outdater))
(callback (make-annotated-callback callback-functor))
(header (cons header1 (header (cons header1
`((h2 "Continuations of " ,session-id) `((h2 "Continuations of " ,session-id)
(p "(belongs to the SUrflet '" (p "(belongs to the SUrflet '"
,(session-surflet-name session-entry) "')") ,(session-surflet-name session) "')")
(p (font (@ (color "red")) ,update-text))))) (p (font (@ (color "red")) ,update-text)))))
(footer (footer
`(,(if (not (null? current-continuations)) `(,(if (not (null? current-continuations))
`(p "Be careful not to delete this adminstration's " `(p "Be careful not to delete this adminstration's "
"continuation (id: " ,this-continuation-id ").") "continuation (id: " ,this-continuation-id ").")
#f) #f)
(hr) (hr)
(url ,(make-callback show-surflets) "Return to SUrflets menu.") (br) (url ,(callback show-surflets)
(url ,(make-callback show-sessions) "Return to sessions menu.") (br) "Return to SUrflets menu.")
(url ,(make-callback return-to-main-page) "Return to administration menu.") (br) (url ,(callback show-sessions)
(br) "Return to sessions menu.")
(url "/" "Return to main menu."))) (br) (url ,(callback return-to-main-page)
(actions '("delete" "delete all")) "Return to administration menu.")
(continuations-callback (br) (url "/" "Return to main menu.")))
(make-callback (lambda (req) (actions '("delete" "delete all"))
(show-continuations sessions req))))) (continuations-callback (callback show-continuations sessions)))
(if (null? current-continuations) (if (null? current-continuations)
(send-html `(html (title ,title) (send-html
(body ,header `(html (title ,title)
,(no-current-continuations session-pair req) (body ,header
,footer))) ,(no-current-continuations callback session req)
(receive (action selected-continuations req) ,footer)))
(select-table title (receive (action selected-continuations req)
header (select-table title
'((th "Continuation-Id")) header
current-continuations '((th "Continuation-Id"))
(lambda (continuation-pair) current-continuations
(let ((continuation-id (car continuation-pair))) (lambda (continuation)
`((td (@ (align "right")) ,continuation-id)))) `((td (@ (align "right"))
actions ,(continuation-id continuation))))
footer) actions
(if (not action) footer)
(show-continuations sessions req (if (not action)
"Choose an action.") (show-continuations req sessions
(begin "Choose an action.")
(cond (begin
((string=? action "delete") (cond
(delete-continuations outdated? continuations-callback ((string=? action "delete")
session-id selected-continuations)) (delete-continuations outdated? continuations-callback
((string=? action "delete all") session-id selected-continuations))
(delete-continuations outdated? continuations-callback ((string=? action "delete all")
session-id current-continuations)) (delete-continuations outdated? continuations-callback
(else session-id current-continuations))
(error "unknown action" action))) (else
(show-continuations sessions req (error "unknown action" action)))
"Deleted.")))))))))) (show-continuations req sessions
"Deleted.")))))))))
(define (delete-continuations outdated? continuations-callback (define (delete-continuations outdated? continuations-callback
session-id continuations) session-id continuations)
@ -326,10 +332,7 @@
(show-outdated continuations-callback) (show-outdated continuations-callback)
;; Do it this way to easily expand to more sessions in the ;; Do it this way to easily expand to more sessions in the
;; future. ;; future.
(for-each delete-continuation! (for-each delete-continuation! continuations)))
(make-list (length continuations)
session-id)
(map car continuations))))
(define (return-to-main-page req) (define (return-to-main-page req)
(send-error (status-code moved-perm) req (send-error (status-code moved-perm) req