Use some of the new input field features

scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm

@@ -26,12 +26,10 @@
     ;; list of selected elements out of TABLE-ELEMENTS.
     (define (select-table title header header-row 
 			  table-elements selector actions footer)
-      (let* ((checkboxes (map (lambda (_) 
+      (let* ((checkboxes (map make-annotated-checkbox-input-field
-				(make-checkbox-input-field)) 
 			      table-elements))
-	     (action-title "Choose an action")
+	     (select (make-annotated-select-input-field 
-	     (select (make-select-input-field (cons action-title actions) 
+		      actions '(@ (size 1))))
-					      '(@ (size 1))))
 	     (req
 	      (send-html/suspend
 	       (lambda (new-url)
@@ -54,23 +52,21 @@
 			,(make-submit-button "Do it")))
 		    ,footer)))))
 	     (bindings (get-bindings req))
+	     (selected (filter-map (lambda (checkbox)
+				  (input-field-value checkbox bindings))
+				checkboxes))
 	     (action (input-field-value select bindings)))
+	(action req selected)))
 
-	(if (string=? action action-title)
+    (define (unload-surflets outdated?)
-	    (values #f #f req)
+      (lambda (req surflet-names)
-	    (values action
+	(if (null? surflet-names)
-		    (filter-map (lambda (checkbox table-element)
+	    (show-surflets req "You must choose at least one element.")
-				  (if (input-field-value checkbox bindings)
-				      table-element
-				      #f))
-				checkboxes
-				table-elements)
-		    req))))
-
-    (define (unload-surflets outdated? surflet-names)
 	    (if-outdated outdated?
 		(show-outdated (make-callback show-surflets))
-	  (for-each unload-surflet surflet-names)))
+		(begin
+		  (for-each unload-surflet surflet-names)
+		  (show-surflets req "SUrflets unloaded."))))))
       
     (define (no-surflets callback)
       `(p "Currently, there are no SUrflets loaded " 
@@ -79,6 +75,10 @@
 	  (url ,(callback show-sessions) "sessions")
 	  " you want to administer."))
 
+    (define (choose-an-action show)
+      (lambda (req _)
+	(show req "Choose an action.")))
+
     (define (show-surflets req . maybe-update-text)
       (let* ((update-text (:optional maybe-update-text ""))
 	     (loaded-surflets (sort-list! (get-loaded-surflets) string<?))
@@ -92,12 +92,20 @@
 		       (url ,(callback return-to-main-page)
 			    "Return to administration menu.")
 		       (br)
-		       (url "/" "Return to main menu.")))
+		       (url "/" "Return to main menu."))))
-	     (actions '("unload" "unload all")))
 	(if (null? loaded-surflets)
 	    (send-html `(html (title ,title) 
 			      (body ,header ,(no-surflets callback) ,footer)))
-	    (receive (action selected-surflets req)
+	    (let ((actions 
+		   (map (lambda (action-pair)
+			  (make-annotated-sel-if-option
+			   (car action-pair)
+			   (cdr action-pair)))
+			`(("Choose an action" . ,(choose-an-action show-surflets))
+			  ("unload" . ,(unload-surflets outdated?))
+			  ("unload all" . ,(lambda (req _)
+					     ((unload-surflets outdated?) 
+					      req loaded-surflets)))))))
 	      (select-table title	                 ; title
 			    header	                 ; header
 			    '((th "Name"))             ; table-header
@@ -112,21 +120,7 @@
 				 "This can be done on the " 
 				 (url ,(callback show-sessions) 
 				      "sessions adminstration page."))
-			       footer))
+			     footer))))))
-	      (if (not action)
-		  (show-surflets 'no-req "Choose an action.")
-		  (if (and (null? selected-surflets)
-			   (not (string=? action "unload all")))
-		      (show-surflets 'no-req "You must choose at least one element.")
-		      (cond 
-		       ((string=? action "unload")
-			(unload-surflets outdated? selected-surflets)
-			(show-surflets 'no-req "SUrflets unloaded."))
-		       ((string=? action "unload all")
-			(unload-surflets outdated? loaded-surflets)
-			(show-surflets 'no-req "SUrflets unloaded."))
-		       (else
-			(error "unknown action" action)))))))))
 
     (define (session-surflet-name<? session1 session2)
       (let ((name1 (session-surflet-name session1))
@@ -158,6 +152,31 @@
 	(real-sessions current-sessions update-text 
 		       (my-session-id req))))
 
+    (define (kill-sessions outdated? sessions-callback)
+      (lambda (req selected-sessions)
+	(if-outdated outdated?
+	    (show-outdated sessions-callback)
+	    (for-each delete-session! 
+		      selected-sessions))
+	(show-sessions req "Sessions killed.")))
+
+    (define (adjust-session-timeout outdated? sessions-callback)
+      (lambda (req selected-sessions)
+	(if-outdated outdated?
+	    (show-outdated sessions-callback)
+	    (for-each session-adjust-timeout! 
+		      selected-sessions))
+	(show-sessions req "Timeout adjusted.")))
+
+    (define (view-continuations outdated? sessions-callback)
+      (lambda (req selected-sessions)
+	(if-outdated outdated?
+	    (show-outdated sessions-callback)
+	    (if (zero? (length selected-sessions))
+		(show-sessions req "You must choose at least one session.")
+		;; this does not return
+		(show-continuations req selected-sessions)))))
+
     (define (real-sessions current-sessions update-text this-session-id)
       (let* ((outdated? (make-outdater))
 	     (callback (make-annotated-callback callback-functor))
@@ -175,14 +194,23 @@
 		       (br) (url ,(callback return-to-main-page)
 				 "Return to administration menu.")
 		       (br) (url "/" "Return to main menu.")))
-	     (actions '("kill"
-			"adjust timeout" 
-			"view continuations"))
 	     (sessions-callback (callback show-sessions)))
 	(if (null? current-sessions)
 	    (send-html `(html (title ,title) 
 			      (body ,@header ,(no-current-sessions) ,footer)))
-	    (receive (action selected-sessions req)
+	    (let ((actions 
+		   (map (lambda (action-pair)
+			  (make-annotated-sel-if-option
+			   (car action-pair)
+			   (cdr action-pair)))
+			`(("Choose an action" . ,(choose-an-action show-sessions))
+			  ("kill" . ,(kill-sessions outdated?  sessions-callback))
+			  ("adjust timeout" . 
+			   ,(adjust-session-timeout outdated?
+						    sessions-callback))
+			  ("view continuations" . 
+			   ,(view-continuations outdated? 
+						sessions-callback))))))
 	      (select-table title 
 			    header
 			    `((th "SUrflet Name") (th "Session-Id"))
@@ -192,35 +220,7 @@
 				(td (@ (align "right")) 
 				    ,(session-session-id session))))
 			    actions
-			      footer)
+			    footer)))))
-	      (if (not action)
-		  (show-sessions current-sessions "Choose an action.")
-		  (let ((new-update-text
-			 (cond
-			  ((string=? action "kill")
-			   (if-outdated outdated?
-			       (show-outdated sessions-callback)
-			       (for-each delete-session! 
-					 selected-sessions))
-			   "Sessions killed.")
-			  ((string=? action "adjust timeout")
-			   (if-outdated outdated?
-			       (show-outdated sessions-callback)
-			       (for-each session-adjust-timeout! 
-					 selected-sessions))
-			   "Timeout adjusted.")
-			  ((string=? action "view continuations")
-			   (if-outdated outdated?
-			       (show-outdated sessions-callback)
-			       (if (zero? (length selected-sessions))
-				   "You must choose at least one session."
-				   ;; this does not return
-				   (show-continuations req selected-sessions))))
-			  (else
-			   (error "unknown action" action)))))
-		    (show-sessions req new-update-text)))))))
-    
-
 
     (define (no-current-continuations callback session req)
       `((p "Currently, there are no continuations for this session. ")
@@ -285,14 +285,13 @@
 			       "continuation (id: " ,this-continuation-id ").")
 			   #f)
 		      (hr)
-		      (url ,(callback show-surflets)
+		      (url ,(callback show-sessions) 
-			   "Return to SUrflets menu.") 
-		      (br) (url ,(callback show-sessions) 
 			   "Return to sessions menu.")
+		      (br) (url ,(callback show-surflets)
+				"Return to SUrflets menu.")
 		      (br) (url ,(callback return-to-main-page) 
 				"Return to administration menu.")
 		      (br) (url "/" "Return to main menu.")))
-		   (actions '("delete" "delete all"))
 		   (continuations-callback (callback show-continuations sessions)))
 	      (if (null? current-continuations)
 		  (send-html 
@@ -300,7 +299,29 @@
 			  (body ,header 
 				,(no-current-continuations callback session req)
 				,footer)))
-		  (receive (action selected-continuations req)
+		  (let ((actions
+			 (map (lambda (action-pair)
+				(make-annotated-sel-if-option
+				 (car action-pair)
+				 (cdr action-pair)))
+			      `(("Choose an action" . 
+				 ,(lambda (req _)
+				    (show-continuations req sessions
+							"Choose an action.")))
+				("delete" . 
+				 ,(lambda (req selected-continuations)
+				    (delete-continuations outdated? 
+							  continuations-callback 
+							  selected-continuations)
+				    (show-continuations req sessions
+							"Deleted.")))
+				("delete all" . 
+				 ,(lambda (req _)
+				    (delete-continuations outdated? 
+							  continuations-callback
+							  current-continuations)
+				    (show-continuations req sessions
+							"Deleted.")))))))
 		    (select-table title
 				  header
 				  '((th "Continuation-Id"))
@@ -309,25 +330,10 @@
 				    `((td (@ (align "right")) 
 					  ,(continuation-id continuation))))
 				  actions
-				    footer)
+				  footer)))))))
-		    (if (not action)
-			(show-continuations req sessions
-					    "Choose an action.")
-			(begin
-			  (cond 
-			   ((string=? action "delete")
-			    (delete-continuations outdated? continuations-callback 
-						  session-id selected-continuations))
-			   ((string=? action "delete all")
-			    (delete-continuations outdated? continuations-callback
-						  session-id current-continuations))
-			   (else
-			    (error "unknown action" action)))
-			  (show-continuations req sessions
-					      "Deleted.")))))))))
 
   (define (delete-continuations outdated? continuations-callback
-				session-id continuations)
+				continuations)
     (if-outdated outdated?
 	(show-outdated continuations-callback)
 	;; Do it this way to easily expand to more sessions in the