317 lines
11 KiB
Scheme
317 lines
11 KiB
Scheme
(define-structure servlet servlet-interface
|
|
(open scsh
|
|
scheme
|
|
servlets
|
|
servlet-handler/admin
|
|
httpd-responses
|
|
handle-fatal-error
|
|
let-opt
|
|
srfi-1 ;filter-map
|
|
sort
|
|
)
|
|
(begin
|
|
|
|
(define remove-servlet-path
|
|
(let ((regexp (rx ,(file-name-as-directory (options-servlet-path))
|
|
(submatch (* any)))))
|
|
(lambda (file-name)
|
|
(let ((match (regexp-search regexp file-name)))
|
|
(if match
|
|
(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
|
|
POST
|
|
(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)
|
|
(values #f #f)
|
|
(values action
|
|
(filter-map (lambda (checkbox table-element)
|
|
(if (input-field-value checkbox bindings)
|
|
table-element
|
|
#f))
|
|
checkboxes
|
|
table-elements)))))
|
|
|
|
(define (unload-servlets outdated? servlet-names)
|
|
(if-outdated outdated?
|
|
(show-outdated (make-callback show-servlets))
|
|
(for-each unload-servlet servlet-names)))
|
|
|
|
(define (no-servlets)
|
|
`(p "Currently, there are no servlets loaded "
|
|
(URL ,(make-callback show-servlets) "(reload).")))
|
|
|
|
(define (show-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 administration menu.")
|
|
(br)
|
|
(URL "/" "Return to main menu.")))
|
|
(actions '("unload" "unload all")))
|
|
(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."
|
|
"This can be done on the "
|
|
(URL ,(make-callback show-instances)
|
|
"instances adminstration page."))
|
|
footer))
|
|
(if (not action)
|
|
(show-servlets 'no-req "Choose an action.")
|
|
(if (and (null? selected-servlets)
|
|
(not (string=? action "unload all")))
|
|
(show-servlets 'no-req "You must choose at least one element.")
|
|
(cond
|
|
((string=? action "unload")
|
|
(unload-servlets outdated? selected-servlets)
|
|
(show-servlets 'no-req "Servlets unloaded."))
|
|
((string=? action "unload all")
|
|
(unload-servlets outdated? loaded-servlets)
|
|
(show-servlets 'no-req "Servlets unloaded."))
|
|
(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
|
|
(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)
|
|
(instance-servlet-name<? entry2 entry1))
|
|
|
|
(define (no-current-instances)
|
|
;; Avoid using send/suspend in this context as there
|
|
;; are no instances available any more.
|
|
'(p "Currently, there are no instances, "
|
|
"i.e. the administration servlet is no longer running. "
|
|
;; Can't use callback here, as there are no valid instances left.
|
|
(URL "admin.scm" "Go back to main page.")))
|
|
|
|
(define (show-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 show-servlets) "Return to servlets menu.") (br)
|
|
(URL ,(make-callback return-to-main-page) "Return to administration menu.")
|
|
(br)
|
|
(URL "/" "Return to main menu.")))
|
|
(actions '("kill"
|
|
"adjust timeout"
|
|
"view continuations"))
|
|
(instances-callback (make-callback show-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)
|
|
(if (not action)
|
|
(show-instances current-instances "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.")
|
|
((string=? action "adjust timeout")
|
|
(if-outdated outdated?
|
|
(show-outdated instances-callback)
|
|
(for-each instance-adjust-timeout!
|
|
(map car selected-instances)))
|
|
"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."
|
|
;; this does not return
|
|
(show-continuations selected-instances))))
|
|
(else
|
|
(error "unknown action" action)))))
|
|
(show-instances current-instances new-update-text)))))))
|
|
|
|
|
|
|
|
(define (no-current-continuations instance)
|
|
`((p "Currently, there are no continuations for this instance. ")
|
|
(p "You may " (URL ,(make-callback
|
|
(lambda (req) (show-continuations (list instance))))
|
|
"reload")
|
|
" this page or go back to the "
|
|
(URL ,(make-callback show-instances) "instance table overview."))))
|
|
|
|
(define (no-more-than-one-instance title header1 instances)
|
|
(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 show-instances)
|
|
"instances administration page")
|
|
" where you can select one instance"
|
|
" or select one instance from your chosen instances:" (br)
|
|
(ul
|
|
,@(map (lambda (instance)
|
|
`(li (URL ,(make-callback
|
|
(lambda (req)
|
|
(show-continuations (list instance))))
|
|
,(instance-servlet-name (cdr instance))
|
|
" (" ,(car instance) ")")))
|
|
instances)))))))
|
|
|
|
(define (continuation-id<? entry1 entry2)
|
|
(< (car entry1) (car entry2)))
|
|
|
|
(define (show-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 instances)
|
|
(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))
|
|
|
|
(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 show-servlets) "Return to servlets menu.") (br)
|
|
(URL ,(make-callback show-instances) "Return to instances 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)))))
|
|
(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)
|
|
(if (not action)
|
|
(show-continuations instances "Choose an action.")
|
|
(begin
|
|
(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)))
|
|
(show-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
|
|
"admin.scm" "admin.scm")))
|
|
|
|
(define (main req)
|
|
(show-servlets req))
|
|
|
|
)) |