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.
2002-10-21 08:38:46 +00:00 · 2002-10-21 08:38:46 +00:00 · 13c001841b
parent 4925801b9e
commit 13c001841b
10 changed files with 164 additions and 114 deletions
--- 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 
 				   "/" "/"))
--- 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"))
    ))
--- 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)))))
--- 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)
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
@ -55,12 +55,11 @@
 	     (action (input-field-value select bindings)))

 	(if (string=? action action-title)
-	    (select-table title header header-row table-elements selector actions footer)
-	    (values
-	     action
+	    (values #f #f)
+	    (values action
 		    (filter-map (lambda (checkbox table-element)
 				  (if (with-fatal-error-handler
-				(lambda (condition more) #f)
+				       (lambda (c m) #f)
 				       (input-field-value checkbox bindings))
 				      table-element
 				      #f))
@ -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,7 +106,10 @@
 				   (URL ,(make-callback instances) 
 					"instances adminstration page."))
 			       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.")
 		      (cond 
 		       ((string=? action "unload")
@ -128,7 +132,7 @@
 						      instance-servlet-name<?)
 					  "")))
 		       (else
-		    (error "unknown action" action))))))))
+			(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,6 +192,8 @@
 				    (td ,instance-id))))
 			      actions
 			      footer)
+	      (if (not action)
+		  (real-instances current-instances "Choose an action.")
 		  (let ((new-update-text
 			 (cond
 			  ((string=? action "kill")
@ -198,7 +207,7 @@
 			       (show-outdated instances-callback)
 			       (for-each instance-adjust-timeout! 
 					 (map car selected-instances)))
-		       "Instances killed.")
+			   "Timeout adjusted.")
 			  ((string=? action "view continuations")
 			   (if-outdated outdated?
 			       (show-outdated instances-callback)
@ -208,7 +217,7 @@
 				   (continuations selected-instances))))
 			  (else
 			   (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 " 
 		       (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,6 +288,9 @@
 					  `((td ,continuation-id))))
 				      actions
 				      footer)
+		      (if (not action)
+			  (continuations instances "Choose an action.")
+			  (begin
 			    (cond 
 			     ((string=? action "delete")
 			      (delete-continuations outdated? continuations-callback 
@ -285,7 +300,7 @@
 						    instance-id current-continuations))
 			     (else
 			      (error "unknown action" action)))
-		      (continuations instances "Deleted."))))))))
+			    (continuations instances "Deleted."))))))))))

  (define (delete-continuations outdated? continuations-callback
 				instance-id continuations)
--- 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)))
--- 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)))

--- a/scheme/httpd/surflets/web-server/root/surflets/calculate.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/calculate.scm
@ -65,23 +65,25 @@
 			  (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))))
+	  (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."))))
+			   "Please enter a valid first number.")))
 	  ((input-field-binding change-button bindings)
 	   (with-fatal-error-handler
 	    (lambda (c d)
@ -90,11 +92,11 @@
 			 "Internal error. Please retry or report."))
 	    (show-page (input-field-value operator-input-field
 					  bindings)
-		      #f #f)))
+		       number1 number2)))
 	  (else
 	   ;; This should never happen.
 	   (show-page operator-pair #f #f
-		     "Internal error. Please retry or report.")))))
+		      "Internal error. Please retry or report."))))))
    
    (define (calculate operator-pair number1 number2)
      (let ((operator (operator-operator operator-pair)))
@ -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)
--- 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))))))
    ))

--- 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.")))))))
    ))