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

add proper error handling on wrong inputs

This commit is contained in:
interp 2002-10-02 15:14:53 +00:00
parent a01015cc44
commit d56d7f9fce
6 changed files with 103 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,32 +2,34 @@
(open servlets
httpd-request
url
handle-fatal-error
let-opt
scsh
scheme)
(begin
(define number-input-field (make-number-input-field '(@ (maxlength 10))))
(define (get-number input-text . maybe-title)
(let* ((title (if (pair? maybe-title) (car maybe-title) #f))
(define (get-number input-text . maybe-update-text)
(let* ((update-text (:optional maybe-update-text ""))
(result
(send-html/suspend
(lambda (new-url)
`(html ,(if title
`(title ,title) '())
`(html (title ,input-text)
(body
,(if title `(h1 ,title) '())
(p (a (@ href "reset")
"click here to reset server's servlet cache"))
(p (font (@ (color "red")) ,update-text))
(p
(servlet-form ,new-url
,input-text
,input-text " "
,number-input-field
,(make-submit-button)))))))))
(if result
(input-field-value number-input-field
(form-query (http-url:search (request:url result))))
(get-number input-text "Please enter a number"))))
(with-fatal-error-handler
(lambda (condition more)
(get-number input-text "Please enter a valid number."))
(input-field-value number-input-field
(form-query (http-url:search (request:url result)))))
(get-number input-text "Please enter a number."))))
(define (get-number1)
(get-number "First number:"))

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

@ -1,6 +1,8 @@
(define-structure servlet servlet-interface
(open scsh
scheme
handle-fatal-error
let-opt
servlets
servlet-handler/admin
httpd-responses
@ -26,17 +28,23 @@
(URL ,(make-callback return-to-main-page) "Return to main page")))
)))
(define (handler-options req . update-text)
(let* ((number-field
(define (handler-options req . maybe-update-text)
(let* ((update-text `(font (@ (color "red"))
,(:optional maybe-update-text "")))
(number-field
(make-number-input-field `(@ ((value ,(options-instance-lifetime))))))
(req (get-option-change number-field update-text)))
(set-options-instance-lifetime!
(input-field-value number-field (get-bindings req)))
(handler-options req
`(font (@ (color "red"))
,(format #f "Instance lifetime changed to ~a."
(options-instance-lifetime))))))
(with-fatal-error-handler
(lambda (condition more)
(handler-options req "Please enter a valid, positive integer number"))
(set-options-instance-lifetime
(let ((result (input-field-value number-field (get-bindings req))))
(if (and (integer? result)
(> result 0))
(handler-options req
(format #f "Instance lifetime changed to ~a."
(options-instance-lifetime)))
(error "not a positive integer")))))))
(define (return-to-main-page req)
(send/finish (make-http-error-response http-status/moved-perm req

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

@ -42,7 +42,7 @@
(br)
(servlet-form
,new-url
(p "This uses " (pre "gnuplot") " that is searched at "
(p "This uses " (var "gnuplot") " that is searched at "
,input-field ,(make-submit-button "Change"))))
(li (URL ,(make-callback reset) "Delete files and reset profile state.")))
(hr)
@ -56,11 +56,12 @@
(lambda (condition more)
#f)
(input-field-value input-field bindings))))
(if new-gnuplot-location
(if (and new-gnuplot-location
(file-executable? new-gnuplot-location))
(begin
(set! gnuplot new-gnuplot-location)
(profile req (format #f "Gnuplot is now searched at ~a." gnuplot)))
(profile req)))))
(profile req "Please enter a file name of an existing executable.")))))
(define (new-profile req)
(profile-space file-name)

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

@ -51,6 +51,9 @@
,(make-submit-button "Do it")))
,footer)))))
(bindings (get-bindings req))
;; No error handling as always something is selected. If
;; not, the browser did something wrong and we may yield
;; an error anyway.
(action (input-field-value select bindings)))
(if (string=? action action-title)
@ -58,10 +61,9 @@
(values
action
(filter-map (lambda (checkbox table-element)
(if(with-fatal-error-handler
(lambda (condition more)
#f)
(input-field-value checkbox bindings))
(if (with-fatal-error-handler
(lambda (condition more) #f)
(input-field-value checkbox bindings))
table-element
#f))
checkboxes

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

@ -27,12 +27,9 @@
(if (null? checkboxes)
sum
(loop (+ sum (string->number
(call-with-current-continuation
(lambda (exit)
(with-fatal-error-handler
(lambda (condition decline)
(exit "0"))
(input-field-value (car checkboxes) bindings))))))
(with-fatal-error-handler
(lambda (condition decline) "0")
(input-field-value (car checkboxes) bindings))))
(cdr checkboxes)))))
checkboxes)))
@ -43,7 +40,7 @@
`(html (title "Result")
(body
(h2 "Result")
(p "You've entered " ,result)))))
(p "You've entered " ,result ".")))))
(define (get-byte-input)
(let* ((req (send-html/suspend

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

@ -1,6 +1,8 @@
(define-structure servlet servlet-interface
(open servlets
httpd-request
handle-fatal-error
let-opt
scsh
scheme)
(begin
@ -31,46 +33,70 @@
`(option ,(operator-symbol operator)))
*operator-alist*)))))
(define number-field1 (make-number-input-field))
(define number-field2 (make-number-input-field))
(define change-operator-callback
(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))))))
(get-bindings req))))
))
(define (show-page operator-pair)
(send-html
`(html
(title "Simple calculator")
(body (h1 "Simple calculator")
(servlet-form
,(make-callback (lambda (req)
(calculate operator-pair (get-bindings req))))
(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")))))))))))
(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)
(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))
(show-page to-operation #f #f))
(define (calculate operator-pair bindings)
(let ((number1 (input-field-value number-field1 bindings))
(number2 (input-field-value number-field2 bindings))
(operator (operator-operator operator-pair)))
(define (calculate operator-pair number1 number2)
(let ((operator (operator-operator operator-pair)))
(show-result number1 (operator-symbol operator-pair) number2
(operator number1 number2))))
@ -82,6 +108,6 @@
" = " ,result)))))
(define (main req)
(show-page (car *operator-alist*))
(show-page (car *operator-alist*) #f #f)
(error "This does not return"))
))