Various changes and improvements, namely:
+ added links to previous menus + removed some typos + admin-servlets: + make unload all work + improved machine-user dialog + calculate.scm: + numbers are restored, if operator is changed Sorry for this packed commit, but my ISP went down on weekend.
This commit is contained in:
parent
4925801b9e
commit
13c001841b
|
@ -21,7 +21,10 @@
|
|||
,input-text
|
||||
(input (@ (type "text")
|
||||
(name "number"))
|
||||
(input (@ (type "submit"))))))))))))
|
||||
(input (@ (type "submit"))))))
|
||||
(hr)
|
||||
(p (URL "/" "Return to main menu") (br)
|
||||
(URL "add.scm" "Start new calculation."))))))))
|
||||
(let* ((bindings (form-query
|
||||
(http-url:search (request:url result))))
|
||||
(number (string->number
|
||||
|
@ -46,6 +49,7 @@
|
|||
(a (@ (href "add.scm")) "new calculation (new instance)")(br)
|
||||
(a (@ (href "javascript:history.back(2)")) "new calculation (same instance)")(br)
|
||||
(a (@ (href ,new-url)) "close this instance")))))))
|
||||
;; How to clear instance data and go to another HTML page:
|
||||
(send/finish
|
||||
(make-http-error-response http-status/moved-temp req
|
||||
"/" "/"))
|
||||
|
|
|
@ -22,7 +22,10 @@
|
|||
(servlet-form ,new-url
|
||||
,input-text " "
|
||||
,number-input-field
|
||||
,(make-submit-button)))))))))
|
||||
,(make-submit-button)))
|
||||
(hr)
|
||||
(p (URL "/" "Return to main menu.") (br)
|
||||
(URL "add2.scm" "Start new calculation."))))))))
|
||||
(if result
|
||||
(with-fatal-error-handler
|
||||
(lambda (condition more)
|
||||
|
@ -44,7 +47,9 @@
|
|||
`(html (title "Result")
|
||||
(body (h1 "Result")
|
||||
(p ,(number->string (+ number1 number2)))
|
||||
(a (@ (href "/")) "done"))))
|
||||
(hr)
|
||||
(p (URL "add2.scm" "Make new calculation.") (br)
|
||||
(URL "/" "Return to main menu.")))))
|
||||
|
||||
"this string will never be evaluated"))
|
||||
))
|
||||
|
|
|
@ -32,7 +32,8 @@
|
|||
(td ,submit-button))))
|
||||
options)))
|
||||
(hr)
|
||||
(URL ,(return-address new-url) "Return to main page")))
|
||||
(p (URL ,(return-address new-url) "Return to adminstration menu.") (br)
|
||||
(URL "/" "Return to main menu."))))
|
||||
)))
|
||||
|
||||
(define submit-timeout (make-submit-button "Change"))
|
||||
|
@ -72,7 +73,7 @@
|
|||
#f)))
|
||||
(set-options-cache-servlets? cache-plugins?)
|
||||
(handler-options req
|
||||
(format #f "Caching turned ~s"
|
||||
(format #f "Caching turned ~s."
|
||||
(if cache-plugins? "on" "off")))))
|
||||
(else
|
||||
(error "unexpected return" bindings)))))
|
||||
|
|
|
@ -68,10 +68,12 @@
|
|||
"Delete files and reset profile state."))))
|
||||
(hr)
|
||||
(URL ,(return-address new-url)
|
||||
"Return to main page leaving files and state untouched.")
|
||||
"Return to administration menu leaving files and state untouched.")
|
||||
(br)
|
||||
(URL ,(reset-return-address new-url)
|
||||
"Return to main page removing files and reseting state."))))))
|
||||
"Return to administration menu removing files and reseting state.")
|
||||
(br)
|
||||
(URL "/" "Return to main menu."))))))
|
||||
(bindings (get-bindings req)))
|
||||
(cond
|
||||
((returned-via? new-profile-address bindings)
|
||||
|
|
|
@ -55,17 +55,16 @@
|
|||
(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)))))
|
||||
(values #f #f)
|
||||
(values action
|
||||
(filter-map (lambda (checkbox table-element)
|
||||
(if (with-fatal-error-handler
|
||||
(lambda (c m) #f)
|
||||
(input-field-value checkbox bindings))
|
||||
table-element
|
||||
#f))
|
||||
checkboxes
|
||||
table-elements)))))
|
||||
|
||||
(define (unload-servlets outdated? servlet-names)
|
||||
(if-outdated outdated?
|
||||
|
@ -85,7 +84,9 @@
|
|||
(h2 "Servlets")
|
||||
(p (font (@ (color "red")) ,update-text))))
|
||||
(footer `((hr)
|
||||
(URL ,(make-callback return-to-main-page) "Return to main page")))
|
||||
(URL ,(make-callback return-to-main-page) "Return to administration menu.")
|
||||
(br)
|
||||
(URL "/" "Return to main menu.")))
|
||||
(actions '("unload" "unload all" "view instances")))
|
||||
(if (null? loaded-servlets)
|
||||
(send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer)))
|
||||
|
@ -105,30 +106,33 @@
|
|||
(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))))))))
|
||||
(if (not action)
|
||||
(servlets 'no-req "Choose an action.")
|
||||
(if (and (null? selected-servlets)
|
||||
(not (string=? action "unload all")))
|
||||
(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)))
|
||||
|
@ -165,7 +169,10 @@
|
|||
(h2 "Instances")
|
||||
(p (font (@ (color "red")) ,update-text))))
|
||||
(footer `((hr)
|
||||
(URL ,(make-callback return-to-main-page) "Return to main page")))
|
||||
(URL ,(make-callback servlets) "Return to servlets menu.") (br)
|
||||
(URL ,(make-callback return-to-main-page) "Return to administration menu.")
|
||||
(br)
|
||||
(URL "/" "Return to main menu.")))
|
||||
(actions '("kill"
|
||||
"adjust timeout"
|
||||
"view continuations"))
|
||||
|
@ -185,30 +192,32 @@
|
|||
(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))))))
|
||||
(if (not action)
|
||||
(real-instances current-instances "Choose an action.")
|
||||
(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)))
|
||||
"Timeout adjusted.")
|
||||
((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)))))
|
||||
(real-instances current-instances new-update-text)))))))
|
||||
|
||||
|
||||
|
||||
|
@ -230,7 +239,7 @@
|
|||
(p "You may choose to go back to the "
|
||||
(URL ,(make-callback instances)
|
||||
"instances administration page")
|
||||
" where you can choose one instance.")))))
|
||||
" where you can select one instance.")))))
|
||||
|
||||
(define (continuation-id<? entry1 entry2)
|
||||
(< (car entry1) (car entry2)))
|
||||
|
@ -256,8 +265,11 @@
|
|||
(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.")))
|
||||
(URL ,(make-callback servlets) "Return to servlets menu.") (br)
|
||||
(URL ,(make-callback instances) "Return to instances menu.") (br)
|
||||
(URL ,(make-callback return-to-main-page) "Return to administration menu.")
|
||||
(br)
|
||||
(URL "/" "Return to main menu.")))
|
||||
(actions '("delete" "delete all"))
|
||||
(continuations-callback (make-callback (lambda (req)
|
||||
(continuations instances)))))
|
||||
|
@ -276,16 +288,19 @@
|
|||
`((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."))))))))
|
||||
(if (not action)
|
||||
(continuations instances "Choose an action.")
|
||||
(begin
|
||||
(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)
|
||||
|
|
|
@ -8,14 +8,16 @@
|
|||
|
||||
(define (main-page)
|
||||
`(html (title "Servlet Administration")
|
||||
(body (h1 "Servlet Administration")
|
||||
(body (h1 "Servlet Administration Menu")
|
||||
(p "This servlet allows you to do some adminstration tasks.")
|
||||
(p "Choose one of the following submenus:")
|
||||
(p
|
||||
(ul
|
||||
(li (URL "admin-handler.scm" "Set handler options..."))
|
||||
(li (URL "admin-servlets.scm" "Servlets..."))
|
||||
(li (URL "admin-profiling.scm" "Profiling...")))))))
|
||||
(li (URL "admin-profiling.scm" "Profiling..."))))
|
||||
(hr)
|
||||
(p (URL "/" "Return to main menu.")))))
|
||||
|
||||
(define (main req)
|
||||
(send-html (main-page)))
|
||||
|
|
|
@ -40,7 +40,10 @@
|
|||
`(html (title "Result")
|
||||
(body
|
||||
(h2 "Result")
|
||||
(p "You've entered " ,result ".")))))
|
||||
(p "You've entered " ,result ".")
|
||||
(hr)
|
||||
(p (URL "byte-input.scm" "Make new byte input.") (br)
|
||||
(URL "/" "Return to main menu."))))))
|
||||
|
||||
(define (get-byte-input)
|
||||
(let* ((req (send-html/suspend
|
||||
|
@ -51,7 +54,9 @@
|
|||
(p "Enter your byte (msb left):")
|
||||
(servlet-form ,new-url
|
||||
,byte-input-fields
|
||||
,(make-submit-button)))))))
|
||||
,(make-submit-button))
|
||||
(hr)
|
||||
(p (URL "/" "Return to main menu.")))))))
|
||||
(bindings (form-query (http-url:search (request:url req)))))
|
||||
(input-field-value byte-input-fields bindings)))
|
||||
|
||||
|
|
|
@ -65,37 +65,39 @@
|
|||
(p "You may choose another operator:")
|
||||
(table
|
||||
(tr (td ,operator-input-field)
|
||||
(td ,change-button)))))))))
|
||||
(td ,change-button)))
|
||||
(hr)
|
||||
(p (URL "/" "Return to main menu."))))))))
|
||||
(bindings (get-bindings req)))
|
||||
(cond
|
||||
((input-field-binding calculate-button bindings)
|
||||
(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))))
|
||||
(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))))
|
||||
(cond
|
||||
((input-field-binding calculate-button 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."))))
|
||||
((input-field-binding change-button bindings)
|
||||
(with-fatal-error-handler
|
||||
(lambda (c d)
|
||||
;; This should never happen.
|
||||
(show-page operator-pair #f #f
|
||||
"Internal error. Please retry or report."))
|
||||
(show-page (input-field-value operator-input-field
|
||||
bindings)
|
||||
#f #f)))
|
||||
(else
|
||||
;; This should never happen.
|
||||
(show-page operator-pair #f #f
|
||||
"Internal error. Please retry or report.")))))
|
||||
|
||||
"Please enter a valid first number.")))
|
||||
((input-field-binding change-button bindings)
|
||||
(with-fatal-error-handler
|
||||
(lambda (c d)
|
||||
;; This should never happen.
|
||||
(show-page operator-pair #f #f
|
||||
"Internal error. Please retry or report."))
|
||||
(show-page (input-field-value operator-input-field
|
||||
bindings)
|
||||
number1 number2)))
|
||||
(else
|
||||
;; This should never happen.
|
||||
(show-page operator-pair #f #f
|
||||
"Internal error. Please retry or report."))))))
|
||||
|
||||
(define (calculate operator-pair number1 number2)
|
||||
(let ((operator (operator-operator operator-pair)))
|
||||
(show-result number1 (operator-symbol operator-pair) number2
|
||||
|
@ -106,7 +108,10 @@
|
|||
`(html (title "Calculation Result")
|
||||
(body (h1 "Result")
|
||||
(p ,number1 " " ,operator-symbol " " ,number2
|
||||
" = " ,result)))))
|
||||
" = " ,result)
|
||||
(hr)
|
||||
(p (URL "calculate.scm" "Make new calculation") (br)
|
||||
(URL "/" "Return to main menu."))))))
|
||||
|
||||
(define (main req)
|
||||
(show-page (car *operator-alist*) #f #f)
|
||||
|
|
|
@ -21,12 +21,18 @@
|
|||
(if (< count 0)
|
||||
(send-html/finish
|
||||
`(html (body (p (h1 "THAT'S IT"))
|
||||
(p ("That's it...")))))
|
||||
(p ("That's it..."))
|
||||
(hr)
|
||||
(p (URL "news.scm" "See news again.") (br)
|
||||
(URL "/" "Return to main menu.")))))
|
||||
(begin
|
||||
(send-html/suspend
|
||||
(lambda (next-url)
|
||||
`(html (body (p (h1 ,(list-ref *data* count))))
|
||||
(a (@ href ,next-url) "read more..."))))
|
||||
`(html (body (p (h1 ,(list-ref *data* count)))
|
||||
(a (@ href ,next-url) "read more...")
|
||||
(hr)
|
||||
(p (URL "news.scm" "See news again from beginning.") (br)
|
||||
(URL "/" "Return to main menu."))))))
|
||||
(loop (- count 1))))))
|
||||
))
|
||||
|
||||
|
|
|
@ -14,8 +14,13 @@
|
|||
,new-url
|
||||
,select
|
||||
,(make-submit-button))
|
||||
(hr)
|
||||
(p (URL "/" "Return to main menu."))
|
||||
))))))
|
||||
(send-html/finish
|
||||
`(html (body (h1 "Result")
|
||||
,(format #f "~s" (get-bindings req)))))))
|
||||
,(format #f "~s" (get-bindings req))
|
||||
(hr)
|
||||
(p (URL "test.scm" "Test again.") (br)
|
||||
(URL "/" "Return to main menu.")))))))
|
||||
))
|
||||
|
|
Loading…
Reference in New Issue