Use some of the new input field features
This commit is contained in:
interp
parent
ee5e3cd6ec
commit
5a8d56672d
|
|
@ -26,12 +26,10 @@
|
|||
;; 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))
|
||||
(let* ((checkboxes (map make-annotated-checkbox-input-field
|
||||
table-elements))
|
||||
(action-title "Choose an action")
|
||||
(select (make-select-input-field (cons action-title actions)
|
||||
'(@ (size 1))))
|
||||
(select (make-annotated-select-input-field
|
||||
actions '(@ (size 1))))
|
||||
(req
|
||||
(send-html/suspend
|
||||
(lambda (new-url)
|
||||
|
|
@ -54,24 +52,22 @@
|
|||
,(make-submit-button "Do it")))
|
||||
,footer)))))
|
||||
(bindings (get-bindings req))
|
||||
(selected (filter-map (lambda (checkbox)
|
||||
(input-field-value checkbox bindings))
|
||||
checkboxes))
|
||||
(action (input-field-value select bindings)))
|
||||
(action req selected)))
|
||||
|
||||
(if (string=? action action-title)
|
||||
(values #f #f req)
|
||||
(values action
|
||||
(filter-map (lambda (checkbox table-element)
|
||||
(if (input-field-value checkbox bindings)
|
||||
table-element
|
||||
#f))
|
||||
checkboxes
|
||||
table-elements)
|
||||
req))))
|
||||
|
||||
(define (unload-surflets outdated? surflet-names)
|
||||
(if-outdated outdated?
|
||||
(show-outdated (make-callback show-surflets))
|
||||
(for-each unload-surflet surflet-names)))
|
||||
|
||||
(define (unload-surflets outdated?)
|
||||
(lambda (req surflet-names)
|
||||
(if (null? surflet-names)
|
||||
(show-surflets req "You must choose at least one element.")
|
||||
(if-outdated outdated?
|
||||
(show-outdated (make-callback show-surflets))
|
||||
(begin
|
||||
(for-each unload-surflet surflet-names)
|
||||
(show-surflets req "SUrflets unloaded."))))))
|
||||
|
||||
(define (no-surflets callback)
|
||||
`(p "Currently, there are no SUrflets loaded "
|
||||
(url ,(callback show-surflets) "(reload)")
|
||||
|
|
@ -79,6 +75,10 @@
|
|||
(url ,(callback show-sessions) "sessions")
|
||||
" you want to administer."))
|
||||
|
||||
(define (choose-an-action show)
|
||||
(lambda (req _)
|
||||
(show req "Choose an action.")))
|
||||
|
||||
(define (show-surflets req . maybe-update-text)
|
||||
(let* ((update-text (:optional maybe-update-text ""))
|
||||
(loaded-surflets (sort-list! (get-loaded-surflets) string<?))
|
||||
|
|
@ -92,41 +92,35 @@
|
|||
(url ,(callback return-to-main-page)
|
||||
"Return to administration menu.")
|
||||
(br)
|
||||
(url "/" "Return to main menu.")))
|
||||
(actions '("unload" "unload all")))
|
||||
(url "/" "Return to main menu."))))
|
||||
(if (null? loaded-surflets)
|
||||
(send-html `(html (title ,title)
|
||||
(body ,header ,(no-surflets callback) ,footer)))
|
||||
(receive (action selected-surflets req)
|
||||
(select-table title ; title
|
||||
header ; header
|
||||
'((th "Name")) ; table-header
|
||||
loaded-surflets ; list of elements
|
||||
(lambda (surflet) ; selector
|
||||
`((td
|
||||
,(remove-surflet-path surflet))))
|
||||
actions ; actions to perform
|
||||
(cons ; footer
|
||||
`(p "Note that unloading the SUrflets does not imply "
|
||||
"the unloading of sessions of this SUrflet. " (br)
|
||||
"This can be done on the "
|
||||
(url ,(callback show-sessions)
|
||||
"sessions adminstration page."))
|
||||
footer))
|
||||
(if (not action)
|
||||
(show-surflets 'no-req "Choose an action.")
|
||||
(if (and (null? selected-surflets)
|
||||
(not (string=? action "unload all")))
|
||||
(show-surflets 'no-req "You must choose at least one element.")
|
||||
(cond
|
||||
((string=? action "unload")
|
||||
(unload-surflets outdated? selected-surflets)
|
||||
(show-surflets 'no-req "SUrflets unloaded."))
|
||||
((string=? action "unload all")
|
||||
(unload-surflets outdated? loaded-surflets)
|
||||
(show-surflets 'no-req "SUrflets unloaded."))
|
||||
(else
|
||||
(error "unknown action" action)))))))))
|
||||
(let ((actions
|
||||
(map (lambda (action-pair)
|
||||
(make-annotated-sel-if-option
|
||||
(car action-pair)
|
||||
(cdr action-pair)))
|
||||
`(("Choose an action" . ,(choose-an-action show-surflets))
|
||||
("unload" . ,(unload-surflets outdated?))
|
||||
("unload all" . ,(lambda (req _)
|
||||
((unload-surflets outdated?)
|
||||
req loaded-surflets)))))))
|
||||
(select-table title ; title
|
||||
header ; header
|
||||
'((th "Name")) ; table-header
|
||||
loaded-surflets ; list of elements
|
||||
(lambda (surflet) ; selector
|
||||
`((td
|
||||
,(remove-surflet-path surflet))))
|
||||
actions ; actions to perform
|
||||
(cons ; footer
|
||||
`(p "Note that unloading the SUrflets does not imply "
|
||||
"the unloading of sessions of this SUrflet. " (br)
|
||||
"This can be done on the "
|
||||
(url ,(callback show-sessions)
|
||||
"sessions adminstration page."))
|
||||
footer))))))
|
||||
|
||||
(define (session-surflet-name<? session1 session2)
|
||||
(let ((name1 (session-surflet-name session1))
|
||||
|
|
@ -158,69 +152,75 @@
|
|||
(real-sessions current-sessions update-text
|
||||
(my-session-id req))))
|
||||
|
||||
(define (kill-sessions outdated? sessions-callback)
|
||||
(lambda (req selected-sessions)
|
||||
(if-outdated outdated?
|
||||
(show-outdated sessions-callback)
|
||||
(for-each delete-session!
|
||||
selected-sessions))
|
||||
(show-sessions req "Sessions killed.")))
|
||||
|
||||
(define (adjust-session-timeout outdated? sessions-callback)
|
||||
(lambda (req selected-sessions)
|
||||
(if-outdated outdated?
|
||||
(show-outdated sessions-callback)
|
||||
(for-each session-adjust-timeout!
|
||||
selected-sessions))
|
||||
(show-sessions req "Timeout adjusted.")))
|
||||
|
||||
(define (view-continuations outdated? sessions-callback)
|
||||
(lambda (req selected-sessions)
|
||||
(if-outdated outdated?
|
||||
(show-outdated sessions-callback)
|
||||
(if (zero? (length selected-sessions))
|
||||
(show-sessions req "You must choose at least one session.")
|
||||
;; this does not return
|
||||
(show-continuations req selected-sessions)))))
|
||||
|
||||
(define (real-sessions current-sessions update-text this-session-id)
|
||||
(let* ((outdated? (make-outdater))
|
||||
(callback (make-annotated-callback callback-functor))
|
||||
(title "SUrflet Adminstration - Sessions")
|
||||
(header `((h1 "SUrflet Administration")
|
||||
(h2 "Sessions")
|
||||
(p (font (@ (color "red")) ,update-text))))
|
||||
(footer `(,(if (not (null? current-sessions))
|
||||
`(p "Be careful not to kill this adminstration's "
|
||||
"session (id: " ,this-session-id ").")
|
||||
#f)
|
||||
(hr)
|
||||
(url ,(callback show-surflets)
|
||||
"Return to SUrflets menu.")
|
||||
(br) (url ,(callback return-to-main-page)
|
||||
"Return to administration menu.")
|
||||
(br) (url "/" "Return to main menu.")))
|
||||
(actions '("kill"
|
||||
"adjust timeout"
|
||||
"view continuations"))
|
||||
(callback (make-annotated-callback callback-functor))
|
||||
(title "SUrflet Adminstration - Sessions")
|
||||
(header `((h1 "SUrflet Administration")
|
||||
(h2 "Sessions")
|
||||
(p (font (@ (color "red")) ,update-text))))
|
||||
(footer `(,(if (not (null? current-sessions))
|
||||
`(p "Be careful not to kill this adminstration's "
|
||||
"session (id: " ,this-session-id ").")
|
||||
#f)
|
||||
(hr)
|
||||
(url ,(callback show-surflets)
|
||||
"Return to SUrflets menu.")
|
||||
(br) (url ,(callback return-to-main-page)
|
||||
"Return to administration menu.")
|
||||
(br) (url "/" "Return to main menu.")))
|
||||
(sessions-callback (callback show-sessions)))
|
||||
(if (null? current-sessions)
|
||||
(send-html `(html (title ,title)
|
||||
(body ,@header ,(no-current-sessions) ,footer)))
|
||||
(receive (action selected-sessions req)
|
||||
(select-table title
|
||||
header
|
||||
`((th "SUrflet Name") (th "Session-Id"))
|
||||
current-sessions
|
||||
(lambda (session)
|
||||
`((td ,(session-surflet-name session))
|
||||
(td (@ (align "right"))
|
||||
,(session-session-id session))))
|
||||
actions
|
||||
footer)
|
||||
(if (not action)
|
||||
(show-sessions current-sessions "Choose an action.")
|
||||
(let ((new-update-text
|
||||
(cond
|
||||
((string=? action "kill")
|
||||
(if-outdated outdated?
|
||||
(show-outdated sessions-callback)
|
||||
(for-each delete-session!
|
||||
selected-sessions))
|
||||
"Sessions killed.")
|
||||
((string=? action "adjust timeout")
|
||||
(if-outdated outdated?
|
||||
(show-outdated sessions-callback)
|
||||
(for-each session-adjust-timeout!
|
||||
selected-sessions))
|
||||
"Timeout adjusted.")
|
||||
((string=? action "view continuations")
|
||||
(if-outdated outdated?
|
||||
(show-outdated sessions-callback)
|
||||
(if (zero? (length selected-sessions))
|
||||
"You must choose at least one session."
|
||||
;; this does not return
|
||||
(show-continuations req selected-sessions))))
|
||||
(else
|
||||
(error "unknown action" action)))))
|
||||
(show-sessions req new-update-text)))))))
|
||||
|
||||
|
||||
(let ((actions
|
||||
(map (lambda (action-pair)
|
||||
(make-annotated-sel-if-option
|
||||
(car action-pair)
|
||||
(cdr action-pair)))
|
||||
`(("Choose an action" . ,(choose-an-action show-sessions))
|
||||
("kill" . ,(kill-sessions outdated? sessions-callback))
|
||||
("adjust timeout" .
|
||||
,(adjust-session-timeout outdated?
|
||||
sessions-callback))
|
||||
("view continuations" .
|
||||
,(view-continuations outdated?
|
||||
sessions-callback))))))
|
||||
(select-table title
|
||||
header
|
||||
`((th "SUrflet Name") (th "Session-Id"))
|
||||
current-sessions
|
||||
(lambda (session)
|
||||
`((td ,(session-surflet-name session))
|
||||
(td (@ (align "right"))
|
||||
,(session-session-id session))))
|
||||
actions
|
||||
footer)))))
|
||||
|
||||
(define (no-current-continuations callback session req)
|
||||
`((p "Currently, there are no continuations for this session. ")
|
||||
|
|
@ -285,14 +285,13 @@
|
|||
"continuation (id: " ,this-continuation-id ").")
|
||||
#f)
|
||||
(hr)
|
||||
(url ,(callback show-surflets)
|
||||
"Return to SUrflets menu.")
|
||||
(br) (url ,(callback show-sessions)
|
||||
"Return to sessions menu.")
|
||||
(url ,(callback show-sessions)
|
||||
"Return to sessions menu.")
|
||||
(br) (url ,(callback show-surflets)
|
||||
"Return to SUrflets menu.")
|
||||
(br) (url ,(callback return-to-main-page)
|
||||
"Return to administration menu.")
|
||||
(br) (url "/" "Return to main menu.")))
|
||||
(actions '("delete" "delete all"))
|
||||
(continuations-callback (callback show-continuations sessions)))
|
||||
(if (null? current-continuations)
|
||||
(send-html
|
||||
|
|
@ -300,34 +299,41 @@
|
|||
(body ,header
|
||||
,(no-current-continuations callback session req)
|
||||
,footer)))
|
||||
(receive (action selected-continuations req)
|
||||
(select-table title
|
||||
header
|
||||
'((th "Continuation-Id"))
|
||||
current-continuations
|
||||
(lambda (continuation)
|
||||
`((td (@ (align "right"))
|
||||
,(continuation-id continuation))))
|
||||
actions
|
||||
footer)
|
||||
(if (not action)
|
||||
(show-continuations req sessions
|
||||
"Choose an action.")
|
||||
(begin
|
||||
(cond
|
||||
((string=? action "delete")
|
||||
(delete-continuations outdated? continuations-callback
|
||||
session-id selected-continuations))
|
||||
((string=? action "delete all")
|
||||
(delete-continuations outdated? continuations-callback
|
||||
session-id current-continuations))
|
||||
(else
|
||||
(error "unknown action" action)))
|
||||
(show-continuations req sessions
|
||||
"Deleted.")))))))))
|
||||
(let ((actions
|
||||
(map (lambda (action-pair)
|
||||
(make-annotated-sel-if-option
|
||||
(car action-pair)
|
||||
(cdr action-pair)))
|
||||
`(("Choose an action" .
|
||||
,(lambda (req _)
|
||||
(show-continuations req sessions
|
||||
"Choose an action.")))
|
||||
("delete" .
|
||||
,(lambda (req selected-continuations)
|
||||
(delete-continuations outdated?
|
||||
continuations-callback
|
||||
selected-continuations)
|
||||
(show-continuations req sessions
|
||||
"Deleted.")))
|
||||
("delete all" .
|
||||
,(lambda (req _)
|
||||
(delete-continuations outdated?
|
||||
continuations-callback
|
||||
current-continuations)
|
||||
(show-continuations req sessions
|
||||
"Deleted.")))))))
|
||||
(select-table title
|
||||
header
|
||||
'((th "Continuation-Id"))
|
||||
current-continuations
|
||||
(lambda (continuation)
|
||||
`((td (@ (align "right"))
|
||||
,(continuation-id continuation))))
|
||||
actions
|
||||
footer)))))))
|
||||
|
||||
(define (delete-continuations outdated? continuations-callback
|
||||
session-id continuations)
|
||||
continuations)
|
||||
(if-outdated outdated?
|
||||
(show-outdated continuations-callback)
|
||||
;; Do it this way to easily expand to more sessions in the
|
||||
|
|
|
|||
Loading…
Reference in New Issue