+ internal restructuring

+ nicer interface
This commit is contained in:
interp 2002-10-02 13:39:55 +00:00
parent 1f8d1d4762
commit a01015cc44
1 changed files with 251 additions and 173 deletions

View File

@ -4,6 +4,9 @@
servlets
servlet-handler/admin
httpd-responses
handle-fatal-error
let-opt
srfi-1 ;filter-map
sort
)
(begin
@ -17,60 +20,126 @@
(match:substring match 1)
file-name)))))
;; returns two values: an action to perform out of ACTIONS and a
;; list of selected elements out of TABLE-ELEMENTS.
(define (select-table title header header-row
table-elements selector actions footer)
(let* ((checkboxes (map (lambda (_)
(make-checkbox-input-field))
table-elements))
(action-title "Choose an action")
(select (make-select-input-field (cons action-title actions)
'(@ (size 1))))
(req
(send-html/suspend
(lambda (new-url)
`(html
(title ,title)
(body
,header
(servlet-form
,new-url
(table
,@(cons '(th) header-row)
,@(map (lambda (checkbox table-element)
`(tr
(td ,checkbox)
,@(selector table-element)))
checkboxes
table-elements))
(p ,select
,(make-submit-button "Do it")))
,footer)))))
(bindings (get-bindings req))
(action (input-field-value select bindings)))
(if (string=? action action-title)
(select-table title header header-row table-elements selector actions footer)
(values
action
(filter-map (lambda (checkbox table-element)
(if(with-fatal-error-handler
(lambda (condition more)
#f)
(input-field-value checkbox bindings))
table-element
#f))
checkboxes
table-elements)))))
(define (unload-servlets outdated? servlet-names)
(lambda (req)
(if-outdated outdated?
(show-outdated (make-callback servlets))
(begin
(for-each unload-servlet servlet-names)
(servlets req)))))
(for-each unload-servlet servlet-names)))
(define (no-servlets)
`(p "Currently, there are no servlets loaded "
(URL ,(make-callback servlets) "(reload).")))
(define (show-servlets loaded-servlets outdated?)
`((p "This is a list of all loaded servlets:")
(table
(@ (border 1))
(tr (th "Name") (th "Action"))
,@(map
(lambda (servlet-name)
`(servlet-form
,(make-callback (unload-servlets outdated? (list servlet-name)))
(tr (td ,(remove-servlet-path servlet-name))
(td ,(make-submit-button '(@ ((value "unload"))))))))
loaded-servlets))
(servlet-form
,(make-callback (unload-servlets outdated? loaded-servlets))
,(make-submit-button "unload all"))
(p "Note that unloading the servlets does not imply "
(define (servlets req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text ""))
(loaded-servlets (sort-list! (get-loaded-servlets) string<?))
(outdated? (make-outdater))
(title "Servlet-Administration -- Servlets")
(header `((h1 "Servlet Administration")
(h2 "Servlets")
(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")))
(if (null? loaded-servlets)
(send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer)))
(receive (action selected-servlets)
(select-table title ; title
header ; header
'((th "Name")) ; table-header
loaded-servlets ; list of elements
(lambda (servlet) ; selector
`((td
,(remove-servlet-path servlet))))
actions ; actions to perform
(cons ; footer
`(p "Note that unloading the servlets does not imply "
"the unloading of instances of this servlet."
(br)
"This can be done on the "
(URL ,(make-callback instances)
"instances adminstration page."))))
"instances adminstration page."))
footer))
(if (null? selected-servlets)
(servlets 'no-req "You must choose at least one element.")
(cond
((string=? action "unload")
(unload-servlets outdated? selected-servlets)
(servlets 'no-req "Servlets unloaded."))
((string=? action "unload all")
(unload-servlets outdated? loaded-servlets)
(servlets 'no-req "Servlets unloaded."))
((string=? action "view instances")
(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))
path-stripped-selected-servlets))
(get-instances))))
;; this does not return
(real-instances (sort-list! selected-instances
instance-servlet-name<?)
"")))
(else
(error "unknown action" action))))))))
(define (servlets req)
(let ((loaded-servlets (sort-list! (get-loaded-servlets) string<?))
(outdated? (make-outdater)))
(send-html
`(html (title "Servlet Adminstration - Servlets")
(body (h1 "Servlet Administration")
(h2 "Servlets")
,(if (null? loaded-servlets)
(no-servlets)
(show-servlets loaded-servlets outdated?))
(hr)
(URL ,(make-callback return-to-main-page) "Return to main page"))))))
(define (instance-id<? entry1 entry2)
(< (car entry1) (car entry2)))
(define (instance-servlet-name<? entry1 entry2)
(string<? (instance-servlet-name (cdr entry1))
(instance-servlet-name (cdr entry2))))
(let ((name1 (instance-servlet-name (cdr entry1)))
(name2 (instance-servlet-name (cdr entry2))))
;; handle multiple instance names
(if (string=? name1 name2)
(instance-id<? entry1 entry2)
(string<? name1 name2))))
(define (instance-id<? entry1 entry2)
;; there are no multiple instance-ids
(< (car entry1) (car entry2)))
(define (instance-id>? entry1 entry2)
(instance-id<? entry2 entry1))
(define (instance-servlet-name>? entry1 entry2)
@ -84,141 +153,150 @@
;; Can't use callback here, as there are no valid instances left.
(URL "admin.scm" "Go back to main page.")))
(define (show-current-instances current-instances outdated?)
(let ((instances-callback (make-callback instances)))
`((p "This is a list of all current instances")
(table
(@ (border 1))
(tr (th "Servlet Name") (th "Instance-Id") (th "Action"))
,@(map
(define (instances 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)))
(define (real-instances current-instances update-text)
(let ((outdated? (make-outdater))
(title "Servlet Adminstration - Instances")
(header `((h1 "Servlet Administration")
(h2 "Instances")
(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)
(send-html `(html (title ,title)
(body ,@header ,(no-current-instances) ,footer)))
(receive (action selected-instances)
(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)))
`(tr
(td ,(instance-servlet-name instance-entry))
(td ,instance-id)
(td
(table
(tr
(td
(servlet-form
,(make-callback
(lambda (req)
`((td ,(instance-servlet-name instance-entry))
(td ,instance-id))))
actions
footer)
(let ((new-update-text
(cond
((string=? action "kill")
(if-outdated outdated?
(show-outdated instances-callback)
(begin
(delete-instance! instance-id)
(instances req)))))
,(make-submit-button "kill")))
(td
(servlet-form
,(make-callback
(lambda (req)
(for-each delete-instance!
(map car selected-instances)))
"Instances killed.")
((string=? action "adjust timeout")
(if-outdated outdated?
(show-outdated instances-callback)
(begin
(format #t "adjusting ~a~%" instance-id)
(instance-adjust-timeout! instance-id)
(instances req)))))
,(make-submit-button "adjust timeout")))
(td
(URL
,(make-callback
(lambda (req)
(for-each instance-adjust-timeout!
(map car selected-instances)))
"Instances killed.")
((string=? action "view continuations")
(if-outdated outdated?
(show-outdated instances-callback)
(continuations instance-id instance-entry))))
"view continuations"))))))))
current-instances))
(servlet-form
,(make-callback
(lambda (req)
(if-outdated outdated?
(show-outdated instances-callback)
(begin
(for-each delete-instance! (map car current-instances))
(instances req)))))
,(make-submit-button "kill all"))
(p "Note that killing an instance implies the killing of all associated continuations. Furthermore, killing all instances implies the killing of instances of this adminstration servlet, i.e. you must restart the servlet from the "
(URL ,(make-callback return-to-main-page) "main page") "."))))
(if (zero? (length selected-instances))
"You must choose at least one instance."
;; this does not return
(continuations selected-instances))))
(else
(error "unknown action" action)))))
(instances 'no-req new-update-text))))))
(define (instances req)
(let ((current-instances (sort-list! (get-instances) instance-servlet-name<?))
(outdated? (make-outdater)))
(send-html
`(html (title "Servlet Adminstration - Instances")
(body (h1 "Servlet Administration")
(h2 "Instances")
,(if (null? current-instances)
(no-current-instances)
(show-current-instances current-instances outdated?))
(hr)
(URL ,(make-callback return-to-main-page) "Return to main page"))))))
(define (no-current-continuations instance-id instance-entry)
'((p "Currently, there are no continuations for this instance. ")
(p "You may " (URL ,(make-callback continuations instance-id instance-entry)
(define (no-current-continuations instance)
`((p "Currently, there are no continuations for this instance. ")
(p "You may " (URL ,(make-callback
(lambda (req) (continuations (list instance))))
"reload")
" this page or go back to the "
(URL ,(make-callback instances) "instance table overview."))))
(define (show-current-continuations current-continuations
instance-id instance-entry outdated?)
(let ((continuations-callback
(make-callback (lambda (req)
(continuations instance-id instance-entry)))))
`((p "This is a list of all current continuations hold by the handler:")
(table
(@ (border 1))
(tr (th "Continuation-Id") (th "Action"))
,@(map
(lambda (continuation-pair)
(let ((continuation-id (car continuation-pair)))
`(tr
(td ,continuation-id)
(td (servlet-form
,(make-callback
(lambda (req)
(if-outdated outdated?
(show-outdated continuations-callback)
(begin
(delete-continuation! instance-id continuation-id)
(continuations instance-id instance-entry)))))
,(make-submit-button "delete"))))))
current-continuations))
(servlet-form
,(make-callback
(lambda (req)
(if-outdated outdated?
(show-outdated continuations-callback)
(begin
(for-each delete-instance! (map car current-continuations))
(continuations instance-id instance-entry)))))
,(make-submit-button "delete all"))
(p "Note that deleting a continuation may turn the "
"current servlet session unusable."))))
(define (no-more-than-one-instance 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 "
"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.")))))
(define (continuation-id<? entry1 entry2)
(< (car entry1) (car entry2)))
(define (continuations instance-id instance-entry)
(let ((current-continuations (sort-list! (get-continuations instance-id)
(define (continuations instances . 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))
(update-text (:optional maybe-update-text "")))
(let ((current-continuations
(sort-list! (get-continuations instance-id)
continuation-id<?))
(outdated? (make-outdater)))
(send-html
`(html (title "Servlet Adminstration - Instances")
(body (h1 "Servlet Administration")
(h2 "Continuations of " ,instance-id)
(p ,instance-id " belongs to the servlet "
(instance-servlet-name instance-entry))
,(if (null? current-continuations)
(no-current-continuations instance-id instance-entry)
(show-current-continuations current-continuations
instance-id instance-entry
outdated?))
(hr)
(outdated? (make-outdater))
(header (cons header1
`((h2 "Continuations of " ,instance-id)
(p "(belongs to the servlet '"
,(instance-servlet-name instance-entry) "')")
(p (font (@ (color "red")) ,update-text)))))
(footer
`((hr)
(URL ,(make-callback instances) "Return to instances 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"))
(continuations-callback (make-callback (lambda (req)
(continuations instances)))))
(if (null? current-continuations)
(send-html `(html (title ,title)
(body ,header
,(no-current-continuations instance-pair)
,footer)))
(receive (action selected-continuations)
(select-table title
header
'((th "Continuation-Id"))
current-continuations
(lambda (continuation-pair)
(let ((continuation-id (car continuation-pair)))
`((td ,continuation-id))))
actions
footer)
(cond
((string=? action "delete")
(delete-continuations outdated? continuations-callback
instance-id selected-continuations))
((string=? action "delete all")
(delete-continuations outdated? continuations-callback
instance-id current-continuations))
(else
(error "unknown action" action)))
(continuations instances "Deleted."))))))))
(define (delete-continuations outdated? continuations-callback
instance-id continuations)
(if-outdated outdated?
(show-outdated continuations-callback)
;; Do it this way to easily expand to more instances in the
;; future.
(for-each delete-continuation!
(make-list (length continuations)
instance-id)
(map car continuations))))
(define (return-to-main-page req)
(send/finish (make-http-error-response http-status/moved-perm req