interp
parent
1f8d1d4762
commit
a01015cc44
|
|
@ -4,6 +4,9 @@
|
||||||
servlets
|
servlets
|
||||||
servlet-handler/admin
|
servlet-handler/admin
|
||||||
httpd-responses
|
httpd-responses
|
||||||
|
handle-fatal-error
|
||||||
|
let-opt
|
||||||
|
srfi-1 ;filter-map
|
||||||
sort
|
sort
|
||||||
)
|
)
|
||||||
(begin
|
(begin
|
||||||
|
|
@ -16,61 +19,127 @@
|
||||||
(if match
|
(if match
|
||||||
(match:substring match 1)
|
(match:substring match 1)
|
||||||
file-name)))))
|
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)
|
(define (unload-servlets outdated? servlet-names)
|
||||||
(lambda (req)
|
(if-outdated outdated?
|
||||||
(if-outdated outdated?
|
(show-outdated (make-callback servlets))
|
||||||
(show-outdated (make-callback servlets))
|
(for-each unload-servlet servlet-names)))
|
||||||
(begin
|
|
||||||
(for-each unload-servlet servlet-names)
|
|
||||||
(servlets req)))))
|
|
||||||
|
|
||||||
(define (no-servlets)
|
(define (no-servlets)
|
||||||
`(p "Currently, there are no servlets loaded "
|
`(p "Currently, there are no servlets loaded "
|
||||||
(URL ,(make-callback servlets) "(reload).")))
|
(URL ,(make-callback servlets) "(reload).")))
|
||||||
|
|
||||||
(define (show-servlets loaded-servlets outdated?)
|
(define (servlets req . maybe-update-text)
|
||||||
`((p "This is a list of all loaded servlets:")
|
(let* ((update-text (:optional maybe-update-text ""))
|
||||||
(table
|
(loaded-servlets (sort-list! (get-loaded-servlets) string<?))
|
||||||
(@ (border 1))
|
(outdated? (make-outdater))
|
||||||
(tr (th "Name") (th "Action"))
|
(title "Servlet-Administration -- Servlets")
|
||||||
,@(map
|
(header `((h1 "Servlet Administration")
|
||||||
(lambda (servlet-name)
|
(h2 "Servlets")
|
||||||
`(servlet-form
|
(p (font (@ (color "red")) ,update-text))))
|
||||||
,(make-callback (unload-servlets outdated? (list servlet-name)))
|
(footer `((hr)
|
||||||
(tr (td ,(remove-servlet-path servlet-name))
|
(URL ,(make-callback return-to-main-page) "Return to main page")))
|
||||||
(td ,(make-submit-button '(@ ((value "unload"))))))))
|
(actions '("unload" "unload all" "view instances")))
|
||||||
loaded-servlets))
|
(if (null? loaded-servlets)
|
||||||
(servlet-form
|
(send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer)))
|
||||||
,(make-callback (unload-servlets outdated? loaded-servlets))
|
(receive (action selected-servlets)
|
||||||
,(make-submit-button "unload all"))
|
(select-table title ; title
|
||||||
(p "Note that unloading the servlets does not imply "
|
header ; header
|
||||||
"the unloading of instances of this servlet."
|
'((th "Name")) ; table-header
|
||||||
(br)
|
loaded-servlets ; list of elements
|
||||||
"This can be done on the "
|
(lambda (servlet) ; selector
|
||||||
(URL ,(make-callback instances)
|
`((td
|
||||||
"instances adminstration page."))))
|
,(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."
|
||||||
|
"This can be done on the "
|
||||||
|
(URL ,(make-callback instances)
|
||||||
|
"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)
|
(define (instance-servlet-name<? entry1 entry2)
|
||||||
(string<? (instance-servlet-name (cdr entry1))
|
(let ((name1 (instance-servlet-name (cdr entry1)))
|
||||||
(instance-servlet-name (cdr entry2))))
|
(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)
|
(define (instance-id>? entry1 entry2)
|
||||||
(instance-id<? entry2 entry1))
|
(instance-id<? entry2 entry1))
|
||||||
(define (instance-servlet-name>? entry1 entry2)
|
(define (instance-servlet-name>? entry1 entry2)
|
||||||
|
|
@ -84,141 +153,150 @@
|
||||||
;; Can't use callback here, as there are no valid instances left.
|
;; Can't use callback here, as there are no valid instances left.
|
||||||
(URL "admin.scm" "Go back to main page.")))
|
(URL "admin.scm" "Go back to main page.")))
|
||||||
|
|
||||||
(define (show-current-instances current-instances outdated?)
|
(define (instances req . maybe-update-text)
|
||||||
(let ((instances-callback (make-callback instances)))
|
(let* ((update-text (:optional maybe-update-text ""))
|
||||||
`((p "This is a list of all current instances")
|
(current-instances (sort-list! (get-instances) instance-servlet-name<?)))
|
||||||
(table
|
(real-instances current-instances update-text)))
|
||||||
(@ (border 1))
|
|
||||||
(tr (th "Servlet Name") (th "Instance-Id") (th "Action"))
|
|
||||||
,@(map
|
|
||||||
(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)
|
|
||||||
(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)
|
|
||||||
(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)
|
|
||||||
(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") "."))))
|
|
||||||
|
|
||||||
(define (instances req)
|
(define (real-instances current-instances update-text)
|
||||||
(let ((current-instances (sort-list! (get-instances) instance-servlet-name<?))
|
(let ((outdated? (make-outdater))
|
||||||
(outdated? (make-outdater)))
|
(title "Servlet Adminstration - Instances")
|
||||||
(send-html
|
(header `((h1 "Servlet Administration")
|
||||||
`(html (title "Servlet Adminstration - Instances")
|
(h2 "Instances")
|
||||||
(body (h1 "Servlet Administration")
|
(p (font (@ (color "red")) ,update-text))))
|
||||||
(h2 "Instances")
|
(footer `((hr)
|
||||||
,(if (null? current-instances)
|
(URL ,(make-callback return-to-main-page) "Return to main page")))
|
||||||
(no-current-instances)
|
(actions '("kill"
|
||||||
(show-current-instances current-instances outdated?))
|
"adjust timeout"
|
||||||
(hr)
|
"view continuations"))
|
||||||
(URL ,(make-callback return-to-main-page) "Return to main page"))))))
|
(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)))
|
||||||
|
`((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)
|
||||||
|
(for-each delete-instance!
|
||||||
|
(map car selected-instances)))
|
||||||
|
"Instances killed.")
|
||||||
|
((string=? action "adjust timeout")
|
||||||
|
(if-outdated outdated?
|
||||||
|
(show-outdated instances-callback)
|
||||||
|
(for-each instance-adjust-timeout!
|
||||||
|
(map car selected-instances)))
|
||||||
|
"Instances killed.")
|
||||||
|
((string=? action "view continuations")
|
||||||
|
(if-outdated outdated?
|
||||||
|
(show-outdated instances-callback)
|
||||||
|
(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 (no-current-continuations instance-id instance-entry)
|
|
||||||
'((p "Currently, there are no continuations for this instance. ")
|
(define (no-current-continuations instance)
|
||||||
(p "You may " (URL ,(make-callback continuations instance-id instance-entry)
|
`((p "Currently, there are no continuations for this instance. ")
|
||||||
|
(p "You may " (URL ,(make-callback
|
||||||
|
(lambda (req) (continuations (list instance))))
|
||||||
"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 instances) "instance table overview."))))
|
||||||
|
|
||||||
(define (show-current-continuations current-continuations
|
(define (no-more-than-one-instance title header1)
|
||||||
instance-id instance-entry outdated?)
|
(send-html
|
||||||
(let ((continuations-callback
|
`(html (title ,title)
|
||||||
(make-callback (lambda (req)
|
(body (h1 "Servlet Administration")
|
||||||
(continuations instance-id instance-entry)))))
|
(p "Currently, you may only view the continuations of "
|
||||||
`((p "This is a list of all current continuations hold by the handler:")
|
"one instance at a time. This will be changed in "
|
||||||
(table
|
"future revisions. Sorry for any inconvenience.")
|
||||||
(@ (border 1))
|
(p "You may choose to go back to the "
|
||||||
(tr (th "Continuation-Id") (th "Action"))
|
(URL ,(make-callback instances)
|
||||||
,@(map
|
"instances administration page")
|
||||||
(lambda (continuation-pair)
|
" where you can choose one instance.")))))
|
||||||
(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 (continuation-id<? entry1 entry2)
|
(define (continuation-id<? entry1 entry2)
|
||||||
(< (car entry1) (car entry2)))
|
(< (car entry1) (car entry2)))
|
||||||
|
|
||||||
(define (continuations instance-id instance-entry)
|
(define (continuations instances . maybe-update-text)
|
||||||
(let ((current-continuations (sort-list! (get-continuations instance-id)
|
(let ((title "Servlet Adminstration - Continuations")
|
||||||
continuation-id<?))
|
(header1 '(h1 "Servlet Administration")))
|
||||||
(outdated? (make-outdater)))
|
(if (not (= 1 (length instances)))
|
||||||
(send-html
|
(no-more-than-one-instance title header1)
|
||||||
`(html (title "Servlet Adminstration - Instances")
|
(let* ((instance-pair (car instances))
|
||||||
(body (h1 "Servlet Administration")
|
(instance-id (car instance-pair))
|
||||||
(h2 "Continuations of " ,instance-id)
|
(instance-entry (cdr instance-pair))
|
||||||
(p ,instance-id " belongs to the servlet "
|
(update-text (:optional maybe-update-text "")))
|
||||||
(instance-servlet-name instance-entry))
|
(let ((current-continuations
|
||||||
,(if (null? current-continuations)
|
(sort-list! (get-continuations instance-id)
|
||||||
(no-current-continuations instance-id instance-entry)
|
continuation-id<?))
|
||||||
(show-current-continuations current-continuations
|
(outdated? (make-outdater))
|
||||||
instance-id instance-entry
|
|
||||||
outdated?))
|
(header (cons header1
|
||||||
(hr)
|
`((h2 "Continuations of " ,instance-id)
|
||||||
(URL ,(make-callback instances) "Return to instances page.") (br)
|
(p "(belongs to the servlet '"
|
||||||
(URL ,(make-callback return-to-main-page) "Return to main page."))))))
|
,(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.")))
|
||||||
|
(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)
|
(define (return-to-main-page req)
|
||||||
(send/finish (make-http-error-response http-status/moved-perm req
|
(send/finish (make-http-error-response http-status/moved-perm req
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue