add proper error handling on wrong inputs

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)
+    (define (get-number input-text . maybe-update-text)
-      (let* ((title (if (pair? maybe-title) (car maybe-title) #f))
+      (let* ((update-text (:optional maybe-update-text ""))
 	     (result 
 	      (send-html/suspend
 	       (lambda (new-url)
-		 `(html ,(if title
+		 `(html (title ,input-text)
-			     `(title ,title) '())
 			(body
-			 ,(if title `(h1 ,title) '())
+			 (p (font (@ (color "red")) ,update-text))
-			 (p (a (@ href "reset") 
-			       "click here to reset server's servlet cache"))
 			 (p
 			  (servlet-form ,new-url
-					,input-text
+					,input-text " "
 					,number-input-field
 					,(make-submit-button)))))))))
 	(if result
+	    (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))))
+				(form-query (http-url:search (request:url result)))))
-	    (get-number input-text "Please enter a number"))))
+	    (get-number input-text "Please enter a number."))))
 
     (define (get-number1)
       (get-number "First number:"))

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)
+    (define (handler-options req . maybe-update-text)
-      (let* ((number-field 
+      (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)))
-
+	(with-fatal-error-handler
-	(set-options-instance-lifetime! 
+	 (lambda (condition more)
-	 (input-field-value number-field (get-bindings req)))
+	   (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 
-			 `(font (@ (color "red"))
+				 (format #f "Instance lifetime changed to ~a." 
-				,(format #f "Instance lifetime changed to ~a." 
+					 (options-instance-lifetime)))
-					 (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

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)

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)
@@ -59,8 +62,7 @@
 	     action
 	     (filter-map (lambda (checkbox table-element)
 			   (if (with-fatal-error-handler
-			       (lambda (condition more)
+				(lambda (condition more) #f)
-				 #f)
 				(input-field-value checkbox bindings))
 			      table-element
 			      #f))

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)
+				(lambda (condition decline) "0")
-				     (exit "0"))
+				(input-field-value (car checkboxes) bindings))))
-				   (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

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,24 +33,34 @@
 			   `(option ,(operator-symbol operator)))
 			 *operator-alist*)))))
 
-    (define number-field1 (make-number-input-field))
+    (define (change-operator-callback)
-    (define number-field2 (make-number-input-field))
-
-    (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
+    (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
-		,(make-callback (lambda (req)
+			  ,new-url
-				  (calculate operator-pair (get-bindings req))))
 			  (table
 			   (tr (td "Do calculation:"))
 			   (tr (td ,number-field1) 
@@ -59,18 +71,32 @@
 			 (hr)
 			 (p "You may choose another operator:")
 			 (servlet-form
-		,change-operator-callback
+			  ,(change-operator-callback)
 			  (table
 			   (tr (td ,operator-input-field)
-		     (td ,(make-submit-button '(@ (value "change operator")))))))))))
+			       (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)
+    (define (calculate operator-pair number1 number2)
-      (let ((number1 (input-field-value number-field1 bindings))
+      (let ((operator (operator-operator operator-pair)))
-	    (number2 (input-field-value number-field2 bindings))
-	    (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"))
     ))