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