diff --git a/scheme/httpd/surflets/web-server/root/surflets/add2.scm b/scheme/httpd/surflets/web-server/root/surflets/add2.scm index 7b6fe2b..17928aa 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add2.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add2.scm @@ -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:")) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm index d214ef1..da9f32f 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm @@ -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 diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm index e1e4c18..bd66bca 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm @@ -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) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm index 3c76b56..e758fa9 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm @@ -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 diff --git a/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm b/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm index 6dd96b5..e0890a4 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm @@ -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 diff --git a/scheme/httpd/surflets/web-server/root/surflets/calculate.scm b/scheme/httpd/surflets/web-server/root/surflets/calculate.scm index 36856cc..a09311f 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/calculate.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/calculate.scm @@ -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")) )) \ No newline at end of file