From 13c001841b643bf98aa3bd6121be272f77360bdb Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Mon, 21 Oct 2002 08:38:46 +0000
Subject: [PATCH] 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.
---
 .../surflets/web-server/root/surflets/add.scm |   6 +-
 .../web-server/root/surflets/add2.scm         |   9 +-
 .../root/surflets/admin-handler.scm           |   5 +-
 .../root/surflets/admin-profiling.scm         |   6 +-
 .../root/surflets/admin-servlets.scm          | 163 ++++++++++--------
 .../web-server/root/surflets/admin.scm        |   6 +-
 .../web-server/root/surflets/byte-input.scm   |   9 +-
 .../web-server/root/surflets/calculate.scm    |  55 +++---
 .../web-server/root/surflets/news.scm         |  12 +-
 .../web-server/root/surflets/test.scm         |   7 +-
 10 files changed, 164 insertions(+), 114 deletions(-)

diff --git a/scheme/httpd/surflets/web-server/root/surflets/add.scm b/scheme/httpd/surflets/web-server/root/surflets/add.scm
index 058f923..bd58905 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/add.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/add.scm
@@ -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 
 				   "/" "/"))
diff --git a/scheme/httpd/surflets/web-server/root/surflets/add2.scm b/scheme/httpd/surflets/web-server/root/surflets/add2.scm
index 17928aa..61186d9 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/add2.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/add2.scm
@@ -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"))
     ))
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 1a4cd65..997d814 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
@@ -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)))))
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 bec467d..2f8411d 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
@@ -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)
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 23b2e10..421d2dc 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
@@ -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)
diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin.scm b/scheme/httpd/surflets/web-server/root/surflets/admin.scm
index 0f88fa1..5d374f2 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/admin.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin.scm
@@ -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)))
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 a9d0c17..a4fd330 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm
@@ -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)))
 
diff --git a/scheme/httpd/surflets/web-server/root/surflets/calculate.scm b/scheme/httpd/surflets/web-server/root/surflets/calculate.scm
index 94f3440..5ef7b44 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/calculate.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/calculate.scm
@@ -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)
diff --git a/scheme/httpd/surflets/web-server/root/surflets/news.scm b/scheme/httpd/surflets/web-server/root/surflets/news.scm
index c9fa970..bb0a879 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/news.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/news.scm
@@ -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))))))
     ))
 
diff --git a/scheme/httpd/surflets/web-server/root/surflets/test.scm b/scheme/httpd/surflets/web-server/root/surflets/test.scm
index 81e28ea..d2b01e5 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/test.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/test.scm
@@ -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.")))))))
     ))