scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
scheme/httpd/surflets/web-server/root/surflets/add.scm
View File

@ -21,7 +21,10 @@
,input-text ,input-text
(input (@ (type "text") (input (@ (type "text")
(name "number")) (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 (let* ((bindings (form-query
(http-url:search (request:url result)))) (http-url:search (request:url result))))
(number (string->number (number (string->number
@ -46,6 +49,7 @@
(a (@ (href "add.scm")) "new calculation (new instance)")(br) (a (@ (href "add.scm")) "new calculation (new instance)")(br)
(a (@ (href "javascript:history.back(2)")) "new calculation (same instance)")(br) (a (@ (href "javascript:history.back(2)")) "new calculation (same instance)")(br)
(a (@ (href ,new-url)) "close this instance"))))))) (a (@ (href ,new-url)) "close this instance")))))))
;; How to clear instance data and go to another HTML page:
(send/finish (send/finish
(make-http-error-response http-status/moved-temp req (make-http-error-response http-status/moved-temp req
"/" "/")) "/" "/"))

9
scheme/httpd/surflets/web-server/root/surflets/add2.scm
View File

@ -22,7 +22,10 @@
(servlet-form ,new-url (servlet-form ,new-url
,input-text " " ,input-text " "
,number-input-field ,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 (if result
(with-fatal-error-handler (with-fatal-error-handler
(lambda (condition more) (lambda (condition more)
@ -44,7 +47,9 @@
`(html (title "Result") `(html (title "Result")
(body (h1 "Result") (body (h1 "Result")
(p ,(number->string (+ number1 number2))) (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")) "this string will never be evaluated"))
)) ))

5
scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
View File

@ -32,7 +32,8 @@
(td ,submit-button)))) (td ,submit-button))))
options))) options)))
(hr) (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")) (define submit-timeout (make-submit-button "Change"))
@ -72,7 +73,7 @@
#f))) #f)))
(set-options-cache-servlets? cache-plugins?) (set-options-cache-servlets? cache-plugins?)
(handler-options req (handler-options req
(format #f "Caching turned ~s" (format #f "Caching turned ~s."
(if cache-plugins? "on" "off"))))) (if cache-plugins? "on" "off")))))
(else (else
(error "unexpected return" bindings))))) (error "unexpected return" bindings)))))

6
scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
View File

@ -68,10 +68,12 @@
"Delete files and reset profile state.")))) "Delete files and reset profile state."))))
(hr) (hr)
(URL ,(return-address new-url) (URL ,(return-address new-url)
"Return to main page leaving files and state untouched.") "Return to administration menu leaving files and state untouched.")
(br) (br)
(URL ,(reset-return-address new-url) (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))) (bindings (get-bindings req)))
(cond (cond
((returned-via? new-profile-address bindings) ((returned-via? new-profile-address bindings)

43
scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
View File

@ -55,12 +55,11 @@
(action (input-field-value select bindings))) (action (input-field-value select bindings)))
(if (string=? action action-title) (if (string=? action action-title)
(select-table title header header-row table-elements selector actions footer) (values #f #f)
(values (values action
action
(filter-map (lambda (checkbox table-element) (filter-map (lambda (checkbox table-element)
(if (with-fatal-error-handler (if (with-fatal-error-handler
(lambda (condition more) #f) (lambda (c m) #f)
(input-field-value checkbox bindings)) (input-field-value checkbox bindings))
table-element table-element
#f)) #f))
@ -85,7 +84,9 @@
(h2 "Servlets") (h2 "Servlets")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (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"))) (actions '("unload" "unload all" "view instances")))
(if (null? loaded-servlets) (if (null? loaded-servlets)
(send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer))) (send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer)))
@ -105,7 +106,10 @@
(URL ,(make-callback instances) (URL ,(make-callback instances)
"instances adminstration page.")) "instances adminstration page."))
footer)) footer))
(if (null? selected-servlets) (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.") (servlets 'no-req "You must choose at least one element.")
(cond (cond
((string=? action "unload") ((string=? action "unload")
@ -128,7 +132,7 @@
instance-servlet-name<?) instance-servlet-name<?)
""))) "")))
(else (else
(error "unknown action" action)))))))) (error "unknown action" action)))))))))
(define (instance-servlet-name<? entry1 entry2) (define (instance-servlet-name<? entry1 entry2)
(let ((name1 (instance-servlet-name (cdr entry1))) (let ((name1 (instance-servlet-name (cdr entry1)))
@ -165,7 +169,10 @@
(h2 "Instances") (h2 "Instances")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (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" (actions '("kill"
"adjust timeout" "adjust timeout"
"view continuations")) "view continuations"))
@ -185,6 +192,8 @@
(td ,instance-id)))) (td ,instance-id))))
actions actions
footer) footer)
(if (not action)
(real-instances current-instances "Choose an action.")
(let ((new-update-text (let ((new-update-text
(cond (cond
((string=? action "kill") ((string=? action "kill")
@ -198,7 +207,7 @@
(show-outdated instances-callback) (show-outdated instances-callback)
(for-each instance-adjust-timeout! (for-each instance-adjust-timeout!
(map car selected-instances))) (map car selected-instances)))
"Instances killed.") "Timeout adjusted.")
((string=? action "view continuations") ((string=? action "view continuations")
(if-outdated outdated? (if-outdated outdated?
(show-outdated instances-callback) (show-outdated instances-callback)
@ -208,7 +217,7 @@
(continuations selected-instances)))) (continuations selected-instances))))
(else (else
(error "unknown action" action))))) (error "unknown action" action)))))
(instances 'no-req new-update-text)))))) (real-instances current-instances new-update-text)))))))
@ -230,7 +239,7 @@
(p "You may choose to go back to the " (p "You may choose to go back to the "
(URL ,(make-callback instances) (URL ,(make-callback instances)
"instances administration page") "instances administration page")
" where you can choose one instance."))))) " where you can select one instance.")))))
(define (continuation-id<? entry1 entry2) (define (continuation-id<? entry1 entry2)
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
@ -256,8 +265,11 @@
(p (font (@ (color "red")) ,update-text))))) (p (font (@ (color "red")) ,update-text)))))
(footer (footer
`((hr) `((hr)
(URL ,(make-callback instances) "Return to instances page.") (br) (URL ,(make-callback servlets) "Return to servlets menu.") (br)
(URL ,(make-callback return-to-main-page) "Return to main page."))) (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")) (actions '("delete" "delete all"))
(continuations-callback (make-callback (lambda (req) (continuations-callback (make-callback (lambda (req)
(continuations instances))))) (continuations instances)))))
@ -276,6 +288,9 @@
`((td ,continuation-id)))) `((td ,continuation-id))))
actions actions
footer) footer)
(if (not action)
(continuations instances "Choose an action.")
(begin
(cond (cond
((string=? action "delete") ((string=? action "delete")
(delete-continuations outdated? continuations-callback (delete-continuations outdated? continuations-callback
@ -285,7 +300,7 @@
instance-id current-continuations)) instance-id current-continuations))
(else (else
(error "unknown action" action))) (error "unknown action" action)))
(continuations instances "Deleted.")))))))) (continuations instances "Deleted."))))))))))
(define (delete-continuations outdated? continuations-callback (define (delete-continuations outdated? continuations-callback
instance-id continuations) instance-id continuations)

6
scheme/httpd/surflets/web-server/root/surflets/admin.scm
View File

@ -8,14 +8,16 @@
(define (main-page) (define (main-page)
`(html (title "Servlet Administration") `(html (title "Servlet Administration")
(body (h1 "Servlet Administration") (body (h1 "Servlet Administration Menu")
(p "This servlet allows you to do some adminstration tasks.") (p "This servlet allows you to do some adminstration tasks.")
(p "Choose one of the following submenus:") (p "Choose one of the following submenus:")
(p (p
(ul (ul
(li (URL "admin-handler.scm" "Set handler options...")) (li (URL "admin-handler.scm" "Set handler options..."))
(li (URL "admin-servlets.scm" "Servlets...")) (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) (define (main req)
(send-html (main-page))) (send-html (main-page)))

9
scheme/httpd/surflets/web-server/root/surflets/byte-input.scm
View File

@ -40,7 +40,10 @@
`(html (title "Result") `(html (title "Result")
(body (body
(h2 "Result") (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) (define (get-byte-input)
(let* ((req (send-html/suspend (let* ((req (send-html/suspend
@ -51,7 +54,9 @@
(p "Enter your byte (msb left):") (p "Enter your byte (msb left):")
(servlet-form ,new-url (servlet-form ,new-url
,byte-input-fields ,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))))) (bindings (form-query (http-url:search (request:url req)))))
(input-field-value byte-input-fields bindings))) (input-field-value byte-input-fields bindings)))

19
scheme/httpd/surflets/web-server/root/surflets/calculate.scm
View File

@ -65,23 +65,25 @@
(p "You may choose another operator:") (p "You may choose another operator:")
(table (table
(tr (td ,operator-input-field) (tr (td ,operator-input-field)
(td ,change-button))))))))) (td ,change-button)))
(hr)
(p (URL "/" "Return to main menu."))))))))
(bindings (get-bindings req))) (bindings (get-bindings req)))
(cond
((input-field-binding calculate-button bindings)
(let ((number1 (with-fatal-error-handler (let ((number1 (with-fatal-error-handler
(lambda (c d) #f) (lambda (c d) #f)
(input-field-value number-field1 bindings))) (input-field-value number-field1 bindings)))
(number2 (with-fatal-error-handler (number2 (with-fatal-error-handler
(lambda (c d) #f) (lambda (c d) #f)
(input-field-value number-field2 bindings)))) (input-field-value number-field2 bindings))))
(cond
((input-field-binding calculate-button bindings)
(if number1 (if number1
(if number2 (if number2
(calculate operator-pair number1 number2) (calculate operator-pair number1 number2)
(show-page operator-pair number1 number2 (show-page operator-pair number1 number2
"Please enter a valid second number.")) "Please enter a valid second number."))
(show-page operator-pair number1 number2 (show-page operator-pair number1 number2
"Please enter a valid first number.")))) "Please enter a valid first number.")))
((input-field-binding change-button bindings) ((input-field-binding change-button bindings)
(with-fatal-error-handler (with-fatal-error-handler
(lambda (c d) (lambda (c d)
@ -90,11 +92,11 @@
"Internal error. Please retry or report.")) "Internal error. Please retry or report."))
(show-page (input-field-value operator-input-field (show-page (input-field-value operator-input-field
bindings) bindings)
#f #f))) number1 number2)))
(else (else
;; This should never happen. ;; This should never happen.
(show-page operator-pair #f #f (show-page operator-pair #f #f
"Internal error. Please retry or report."))))) "Internal error. Please retry or report."))))))
(define (calculate operator-pair number1 number2) (define (calculate operator-pair number1 number2)
(let ((operator (operator-operator operator-pair))) (let ((operator (operator-operator operator-pair)))
@ -106,7 +108,10 @@
`(html (title "Calculation Result") `(html (title "Calculation Result")
(body (h1 "Result") (body (h1 "Result")
(p ,number1 " " ,operator-symbol " " ,number2 (p ,number1 " " ,operator-symbol " " ,number2
" = " ,result))))) " = " ,result)
(hr)
(p (URL "calculate.scm" "Make new calculation") (br)
(URL "/" "Return to main menu."))))))
(define (main req) (define (main req)
(show-page (car *operator-alist*) #f #f) (show-page (car *operator-alist*) #f #f)

12
scheme/httpd/surflets/web-server/root/surflets/news.scm
View File

@ -21,12 +21,18 @@
(if (< count 0) (if (< count 0)
(send-html/finish (send-html/finish
`(html (body (p (h1 "THAT'S IT")) `(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 (begin
(send-html/suspend (send-html/suspend
(lambda (next-url) (lambda (next-url)
`(html (body (p (h1 ,(list-ref *data* count)))) `(html (body (p (h1 ,(list-ref *data* count)))
(a (@ href ,next-url) "read more...")))) (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)))))) (loop (- count 1))))))
)) ))

7
scheme/httpd/surflets/web-server/root/surflets/test.scm
View File

@ -14,8 +14,13 @@
,new-url ,new-url
,select ,select
,(make-submit-button)) ,(make-submit-button))
(hr)
(p (URL "/" "Return to main menu."))
)))))) ))))))
(send-html/finish (send-html/finish
`(html (body (h1 "Result") `(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.")))))))
)) ))