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