350 lines
12 KiB
Scheme
350 lines
12 KiB
Scheme
(define-structure surflet surflet-interface
|
|
(open scheme-with-scsh
|
|
surflets
|
|
surflets/callbacks ;make-callback
|
|
surflets/outdaters
|
|
surflets/ids
|
|
surflets/error
|
|
surflet-handler/admin
|
|
handle-fatal-error
|
|
let-opt
|
|
srfi-1 ;filter-map, last
|
|
sort
|
|
)
|
|
(begin
|
|
|
|
(define remove-surflet-path
|
|
(let ((regexp (rx ,(file-name-as-directory (options-surflet-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 make-annotated-checkbox
|
|
table-elements))
|
|
(select (make-annotated-select
|
|
actions #f '(@ (size 1))))
|
|
(req
|
|
(send-html/suspend
|
|
(lambda (new-url)
|
|
`(html
|
|
(title ,title)
|
|
(body
|
|
,header
|
|
(surflet-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))
|
|
(selected (filter-map (lambda (checkbox)
|
|
(input-field-value checkbox bindings))
|
|
checkboxes))
|
|
(action (input-field-value select bindings)))
|
|
(action req selected)))
|
|
|
|
(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)")
|
|
", but there may be "
|
|
(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<?))
|
|
(outdated? (make-outdater))
|
|
(callback (make-annotated-callback callback-function))
|
|
(title "SUrflet-Administration -- SUrflets")
|
|
(header `((h1 "SUrflet Administration")
|
|
(h2 "SUrflets")
|
|
(p (font (@ (color "red")) ,update-text))))
|
|
(footer `((hr)
|
|
(url ,(callback return-to-main-page)
|
|
"Return to administration menu.")
|
|
(br)
|
|
(url "/" "Return to main menu."))))
|
|
(if (null? loaded-surflets)
|
|
(send-html `(html (title ,title)
|
|
(body ,header ,(no-surflets callback) ,footer)))
|
|
(let ((actions
|
|
(map (lambda (action-pair)
|
|
(make-annotated-select-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))
|
|
(name2 (session-surflet-name session2)))
|
|
;; handle multiple session names
|
|
(if (string=? name1 name2)
|
|
(session-id<? session1 session2)
|
|
(string<? name1 name2))))
|
|
(define (session-id<? session1 session2)
|
|
;; there are no multiple session-ids
|
|
(< (session-session-id session1)
|
|
(session-session-id session2)))
|
|
(define (session-surflet-name>? session1 session2)
|
|
(session-surflet-name<? session2 session1))
|
|
(define (session-id>? session1 session2)
|
|
(session-id<? session2 session1))
|
|
|
|
(define (no-current-sessions)
|
|
;; Avoid using send/suspend in this context as there
|
|
;; are no sessions available any more.
|
|
'(p "Currently, there are no sessions, "
|
|
"i.e. the administration SUrflet is no longer running. "
|
|
;; Can't use callback here, as there are no valid sessions left.
|
|
(url "admin.scm" "Go back to main page.")))
|
|
|
|
(define (show-sessions req . maybe-update-text)
|
|
(let* ((update-text (:optional maybe-update-text ""))
|
|
(current-sessions (sort-list! (get-sessions) session-surflet-name<?)))
|
|
(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-function))
|
|
(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)))
|
|
(let ((actions
|
|
(map (lambda (action-pair)
|
|
(make-annotated-select-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. ")
|
|
(p "You may " (url ,(callback show-continuations (list session))
|
|
"reload")
|
|
" this page or go back to the "
|
|
(url ,(callback show-sessions) "session table overview."))))
|
|
|
|
(define (no-more-than-one-session title header1 sessions req)
|
|
(let* ((address (make-annotated-address))
|
|
(req (send-html/suspend
|
|
(lambda (k-url)
|
|
`(html
|
|
(title ,title)
|
|
(body
|
|
(h1 "SUrflet Administration")
|
|
(p "Currently, you may only view the continuations of "
|
|
"one session 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-sessions)
|
|
"sessions administration page")
|
|
" where you can select one session"
|
|
" or select one session from your chosen sessions:" (br)
|
|
(ul
|
|
,@(map
|
|
(lambda (session)
|
|
`(li (url ,(address k-url session)
|
|
,(session-surflet-name session)
|
|
" (" ,(session-session-id session) ")")))
|
|
sessions))))))))
|
|
(bindings (get-bindings req))
|
|
(chosen-session (returned-via address bindings)))
|
|
(show-continuations req (list chosen-session))))
|
|
|
|
(define (continuation-id<? cont1 cont2)
|
|
(< (continuation-id cont1)
|
|
(continuation-id cont2)))
|
|
|
|
(define (show-continuations req sessions . maybe-update-text)
|
|
(let ((title "SUrflet Adminstration - Continuations")
|
|
(header1 '(h1 "SUrflet Administration")))
|
|
(if (not (= 1 (length sessions)))
|
|
(no-more-than-one-session title header1 sessions req)
|
|
(let* ((session (car sessions))
|
|
(session-id (session-session-id session))
|
|
(this-continuation-id (my-continuation-id req))
|
|
(update-text (:optional maybe-update-text ""))
|
|
(current-continuations
|
|
(sort-list! (get-continuations session-id)
|
|
continuation-id<?))
|
|
(outdated? (make-outdater))
|
|
(callback (make-annotated-callback callback-function))
|
|
(header (cons header1
|
|
`((h2 "Continuations of " ,session-id)
|
|
(p "(belongs to the SUrflet '"
|
|
,(session-surflet-name session) "')")
|
|
(p (font (@ (color "red")) ,update-text)))))
|
|
(footer
|
|
`(,(if (not (null? current-continuations))
|
|
`(p "Be careful not to delete this adminstration's "
|
|
"continuation (id: " ,this-continuation-id ").")
|
|
#f)
|
|
(hr)
|
|
(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.")))
|
|
(continuations-callback (callback show-continuations sessions)))
|
|
(if (null? current-continuations)
|
|
(send-html
|
|
`(html (title ,title)
|
|
(body ,header
|
|
,(no-current-continuations callback session req)
|
|
,footer)))
|
|
(let ((actions
|
|
(map (lambda (action-pair)
|
|
(make-annotated-select-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
|
|
continuations)
|
|
(if-outdated outdated?
|
|
(show-outdated continuations-callback)
|
|
;; Do it this way to easily expand to more sessions in the
|
|
;; future.
|
|
(for-each delete-continuation! continuations)))
|
|
|
|
(define (return-to-main-page req)
|
|
(send-error (status-code moved-perm) req
|
|
"admin.scm" "admin.scm"))
|
|
|
|
(define (main req)
|
|
(show-surflets req))
|
|
|
|
)) |