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:
interp 2002-10-21 08:38:46 +00:00
parent 4925801b9e
commit 13c001841b
10 changed files with 164 additions and 114 deletions

View File

@ -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
"/" "/"))

View File

@ -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"))
))

View File

@ -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)))))

View File

@ -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)

View File

@ -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)

View File

@ -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)))

View File

@ -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)))

View File

@ -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)

View File

@ -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))))))
))

View File

@ -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.")))))))
))