Some versions using callback.More will come soon. To be improved.
This commit is contained in:
interp
parent
13c001841b
commit
163e250b89
|
|
@ -0,0 +1,308 @@
|
|||
(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
|
||||
(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)
|
||||
(if-outdated outdated?
|
||||
(show-outdated (make-callback servlets))
|
||||
(for-each unload-servlet servlet-names)))
|
||||
|
||||
(define (no-servlets)
|
||||
`(p "Currently, there are no servlets loaded "
|
||||
(URL ,(make-callback servlets) "(reload).")))
|
||||
|
||||
(define (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 main page")))
|
||||
(actions '("unload" "unload all" "view instances")))
|
||||
(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 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 (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 (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 return-to-main-page) "Return to main page")))
|
||||
(actions '("kill"
|
||||
"adjust timeout"
|
||||
"view continuations"))
|
||||
(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)
|
||||
`((p "Currently, there are no continuations for this instance. ")
|
||||
(p "You may " (URL ,(make-callback
|
||||
(lambda (req) (continuations (list instance))))
|
||||
"reload")
|
||||
" this page or go back to the "
|
||||
(URL ,(make-callback instances) "instance table overview."))))
|
||||
|
||||
(define (no-more-than-one-instance title header1)
|
||||
(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 instances)
|
||||
"instances administration page")
|
||||
" where you can choose one instance.")))))
|
||||
|
||||
(define (continuation-id<? entry1 entry2)
|
||||
(< (car entry1) (car entry2)))
|
||||
|
||||
(define (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)
|
||||
(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 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)
|
||||
(send/finish (make-http-error-response http-status/moved-perm req
|
||||
"admin.scm" "admin.scm")))
|
||||
|
||||
(define (main req)
|
||||
(servlets req))
|
||||
|
||||
))
|
||||
|
|
@ -0,0 +1,114 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
httpd-request
|
||||
handle-fatal-error
|
||||
let-opt
|
||||
scsh
|
||||
scheme)
|
||||
(begin
|
||||
|
||||
;; This uses callbacks.
|
||||
|
||||
(define *operator-alist*
|
||||
`(("+" . ,+)
|
||||
("-" . ,-)
|
||||
("*" . ,*)
|
||||
("/" . ,/)))
|
||||
|
||||
(define operator-symbol car)
|
||||
(define operator-operator cdr)
|
||||
|
||||
(define operator-input-field
|
||||
(let ((name (generate-input-field-name "operator")))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (operator-string)
|
||||
(cond
|
||||
((assoc operator-string *operator-alist*) =>
|
||||
(lambda (a) a))
|
||||
(else
|
||||
(error "no such operator" operator-string))))
|
||||
`(select (@ (name ,name))
|
||||
,@(map (lambda (operator)
|
||||
`(option ,(operator-symbol operator)))
|
||||
*operator-alist*)))))
|
||||
|
||||
(define (change-operator-callback)
|
||||
(make-callback
|
||||
(lambda (req)
|
||||
(change-operator
|
||||
;; This yields an error only when the browser doing wrong.
|
||||
(input-field-value operator-input-field
|
||||
(get-bindings req))))
|
||||
))
|
||||
|
||||
|
||||
(define (make-number-input-field/default default)
|
||||
(if default
|
||||
(make-number-input-field `(@ (value ,default)))
|
||||
(make-number-input-field)))
|
||||
|
||||
(define (show-page operator-pair number1 number2 . maybe-update-text)
|
||||
(format #t "number1 ~s number2 ~s~%" number1 number2)
|
||||
(let* ((update-text (:optional maybe-update-text ""))
|
||||
(number-field1 (make-number-input-field/default number1))
|
||||
(number-field2 (make-number-input-field/default number2))
|
||||
(req
|
||||
(send-html/suspend
|
||||
(lambda (new-url)
|
||||
`(html
|
||||
(title "Simple calculator")
|
||||
(body (h1 "Simple calculator")
|
||||
(font (@ (color "red")) ,update-text)
|
||||
(servlet-form
|
||||
,new-url
|
||||
(table
|
||||
(tr (td "Do calculation:"))
|
||||
(tr (td ,number-field1)
|
||||
(td ,(operator-symbol operator-pair))
|
||||
(td ,number-field2)
|
||||
(td " = ")
|
||||
(td ,(make-submit-button '(@ (value "calculate")))))))
|
||||
(hr)
|
||||
(p "You may choose another operator:")
|
||||
(servlet-form
|
||||
,(change-operator-callback)
|
||||
(table
|
||||
(tr (td ,operator-input-field)
|
||||
(td ,(make-submit-button
|
||||
'(@ (value "change operator"))))))))))))
|
||||
(bindings (get-bindings req)))
|
||||
(let ((number1
|
||||
(with-fatal-error-handler
|
||||
(lambda (c d) #f)
|
||||
(input-field-value number-field1 bindings)))
|
||||
(number2
|
||||
(with-fatal-error-handler
|
||||
(lambda (c d) #f)
|
||||
(input-field-value number-field2 bindings))))
|
||||
(if number1
|
||||
(if number2
|
||||
(calculate operator-pair number1 number2)
|
||||
(show-page operator-pair number1 number2 "Please enter a valid second number."))
|
||||
(show-page operator-pair number1 number2 "Please enter a valid first number."))
|
||||
)))
|
||||
|
||||
(define (change-operator to-operation)
|
||||
(show-page to-operation #f #f))
|
||||
|
||||
(define (calculate operator-pair number1 number2)
|
||||
(let ((operator (operator-operator operator-pair)))
|
||||
(show-result number1 (operator-symbol operator-pair) number2
|
||||
(operator number1 number2))))
|
||||
|
||||
(define (show-result number1 operator-symbol number2 result)
|
||||
(send-html
|
||||
`(html (title "Calculation Result")
|
||||
(body (h1 "Result")
|
||||
(p ,number1 " " ,operator-symbol " " ,number2
|
||||
" = " ,result)))))
|
||||
|
||||
(define (main req)
|
||||
(show-page (car *operator-alist*) #f #f)
|
||||
(error "This does not return"))
|
||||
))
|
||||
Loading…
Reference in New Issue