From a01015cc440e4468292e37e7d3e325c57264756d Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Wed, 2 Oct 2002 13:39:55 +0000
Subject: [PATCH] + internal restructuring + nicer interface

---
 .../root/surflets/admin-servlets.scm          | 424 +++++++++++-------
 1 file changed, 251 insertions(+), 173 deletions(-)

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 0030bd9..3c76b56 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
@@ -4,6 +4,9 @@
 	servlets
 	servlet-handler/admin
 	httpd-responses
+	handle-fatal-error
+	let-opt
+	srfi-1				;filter-map
 	sort
 	)
   (begin
@@ -16,61 +19,127 @@
 	    (if match
 		(match:substring match 1)
 		file-name)))))
-      
+
+    ;; returns two values: an action to perform out of ACTIONS and a
+    ;; list of selected elements out of TABLE-ELEMENTS.
+    (define (select-table title header header-row 
+			  table-elements selector actions footer)
+      (let* ((checkboxes (map (lambda (_) 
+				(make-checkbox-input-field)) 
+			      table-elements))
+	     (action-title "Choose an action")
+	     (select (make-select-input-field (cons action-title actions) 
+					      '(@ (size 1))))
+	     (req
+	      (send-html/suspend
+	       (lambda (new-url)
+		 `(html 
+		   (title ,title)
+		   (body
+		    ,header
+		    (servlet-form
+		     ,new-url
+		     (table
+		      ,@(cons '(th) header-row)
+		      ,@(map (lambda (checkbox table-element)
+			       `(tr 
+				 (td ,checkbox) 
+				 ,@(selector table-element)))
+			     checkboxes
+			     table-elements))
+		     (p ,select
+			,(make-submit-button "Do it")))
+		    ,footer)))))
+	     (bindings (get-bindings req))
+	     (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)))))
 
     (define (unload-servlets outdated? servlet-names)
-      (lambda (req)
-	(if-outdated outdated?
-	    (show-outdated (make-callback servlets))
-	    (begin
-	      (for-each unload-servlet servlet-names)
-	      (servlets req)))))
+      (if-outdated outdated?
+	  (show-outdated (make-callback servlets))
+	  (for-each unload-servlet servlet-names)))
 
     (define (no-servlets)
       `(p "Currently, there are no servlets loaded " 
 	  (URL ,(make-callback servlets) "(reload).")))
 
-    (define (show-servlets loaded-servlets outdated?)
-      `((p "This is a list of all loaded servlets:")
-	(table 
-	 (@ (border 1))
-	 (tr (th "Name") (th "Action"))
-	 ,@(map 
-	    (lambda (servlet-name)
-	      `(servlet-form
-		,(make-callback (unload-servlets outdated? (list servlet-name)))
-		(tr (td ,(remove-servlet-path servlet-name))
-		    (td ,(make-submit-button '(@ ((value "unload"))))))))
-	    loaded-servlets))
-	(servlet-form
-	 ,(make-callback (unload-servlets outdated? loaded-servlets))
-	 ,(make-submit-button "unload all"))
-	(p "Note that unloading the servlets does not imply "
-	   "the unloading of instances of this servlet." 
-	   (br)
-	   "This can be done on the " 
-	   (URL ,(make-callback instances) 
-		"instances adminstration page."))))
+    (define (servlets req . maybe-update-text)
+      (let* ((update-text (:optional maybe-update-text ""))
+	     (loaded-servlets (sort-list! (get-loaded-servlets) string<?))
+	     (outdated? (make-outdater))
+	     (title "Servlet-Administration -- Servlets")
+	     (header `((h1 "Servlet Administration")
+		       (h2 "Servlets")
+		       (p (font (@ (color "red")) ,update-text))))
+	     (footer `((hr)
+		       (URL ,(make-callback return-to-main-page) "Return to main page")))
+	     (actions '("unload" "unload all" "view instances")))
+	(if (null? loaded-servlets)
+	    (send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer)))
+	    (receive (action selected-servlets)
+		(select-table title	                 ; title
+			      header	                 ; header
+			      '((th "Name"))             ; table-header
+			      loaded-servlets            ; list of elements
+			      (lambda (servlet)          ; selector
+				`((td
+				   ,(remove-servlet-path servlet))))
+			      actions                    ; actions to perform
+			      (cons                      ; footer
+			       `(p "Note that unloading the servlets does not imply "
+				   "the unloading of instances of this servlet." 
+				   "This can be done on the " 
+				   (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))))))))
 
-    (define (servlets req)
-      (let ((loaded-servlets (sort-list! (get-loaded-servlets) string<?))
-	    (outdated? (make-outdater)))
-	(send-html
-	 `(html (title "Servlet Adminstration - Servlets")
-		(body (h1 "Servlet Administration")
-		      (h2 "Servlets")
-		      ,(if (null? loaded-servlets)
-			   (no-servlets)
-			   (show-servlets loaded-servlets outdated?))
-		      (hr)
-		      (URL ,(make-callback return-to-main-page) "Return to main page"))))))
-
-
-    (define (instance-id<? entry1 entry2)
-      (< (car entry1) (car entry2)))
     (define (instance-servlet-name<? entry1 entry2)
-      (string<? (instance-servlet-name (cdr entry1))
-		(instance-servlet-name (cdr entry2))))
+      (let ((name1 (instance-servlet-name (cdr entry1)))
+	    (name2 (instance-servlet-name (cdr entry2))))
+	;; handle multiple instance names
+	(if (string=? name1 name2)
+	    (instance-id<? entry1 entry2)
+	    (string<? name1 name2))))
+    (define (instance-id<? entry1 entry2)
+      ;; there are no multiple instance-ids
+      (< (car entry1) (car entry2)))
     (define (instance-id>? entry1 entry2)
       (instance-id<? entry2 entry1))
     (define (instance-servlet-name>? entry1 entry2)
@@ -84,141 +153,150 @@
 	  ;; Can't use callback here, as there are no valid instances left.
 	  (URL "admin.scm" "Go back to main page.")))
 
-    (define (show-current-instances current-instances outdated?)
-      (let ((instances-callback (make-callback instances)))
-	`((p "This is a list of all current instances")
-	  (table
-	   (@ (border 1))
-	   (tr (th "Servlet Name") (th "Instance-Id") (th "Action"))
-	   ,@(map
-	      (lambda (instance-pair)
-		(let ((instance-id (car instance-pair))
-		      (instance-entry (cdr instance-pair)))
-		  `(tr 
-		    (td ,(instance-servlet-name instance-entry))
-		    (td ,instance-id)
-		    (td 
-		     (table
-		      (tr
-		       (td
-			(servlet-form
-			 ,(make-callback
-			   (lambda (req)
-			     (if-outdated outdated?
-				 (show-outdated instances-callback)
-				 (begin
-				   (delete-instance! instance-id)
-				   (instances req)))))
-			 ,(make-submit-button "kill")))
-			 (td
-			  (servlet-form
-			  ,(make-callback
-			    (lambda (req)
-			      (if-outdated outdated?
-				  (show-outdated instances-callback)
-				  (begin
-				    (format #t "adjusting ~a~%" instance-id)
-				    (instance-adjust-timeout! instance-id)
-				    (instances req)))))
-			  ,(make-submit-button "adjust timeout")))
-			 (td
-			  (URL
-			  ,(make-callback
-			    (lambda (req)
-			      (if-outdated outdated?
-				  (show-outdated instances-callback)
-				  (continuations instance-id instance-entry))))
-			  "view continuations"))))))))
-	      current-instances))
-	  (servlet-form
-	   ,(make-callback
-	     (lambda (req)
-	       (if-outdated outdated?
-		   (show-outdated instances-callback)
-		   (begin
-		     (for-each delete-instance! (map car current-instances))
-		     (instances req)))))
-	   ,(make-submit-button "kill all"))
-	  (p "Note that killing an instance implies the killing of all associated continuations. Furthermore, killing all instances implies the killing of instances of this adminstration servlet, i.e. you must restart the servlet from the "
-	     (URL ,(make-callback return-to-main-page) "main page") "."))))
+    (define (instances req . maybe-update-text)
+      (let* ((update-text (:optional maybe-update-text ""))
+	     (current-instances (sort-list! (get-instances) instance-servlet-name<?)))
+	(real-instances current-instances update-text)))
 
-    (define (instances req)
-      (let ((current-instances (sort-list! (get-instances) instance-servlet-name<?))
-	    (outdated? (make-outdater)))
-	(send-html
-	 `(html (title "Servlet Adminstration - Instances")
-		(body (h1 "Servlet Administration")
-		      (h2 "Instances")
-		      ,(if (null? current-instances)
-			   (no-current-instances)
-			   (show-current-instances current-instances outdated?))
-		      (hr)
-		      (URL ,(make-callback return-to-main-page) "Return to main page"))))))
+    (define (real-instances current-instances update-text)
+      (let ((outdated? (make-outdater))
+	     (title  "Servlet Adminstration - Instances")
+	     (header `((h1 "Servlet Administration")
+		       (h2 "Instances")
+		       (p (font (@ (color "red")) ,update-text))))
+	     (footer `((hr)
+		       (URL ,(make-callback return-to-main-page) "Return to main page")))
+	     (actions '("kill"
+			"adjust timeout" 
+			"view continuations"))
+	     (instances-callback (make-callback instances)))
+	(if (null? current-instances)
+	    (send-html `(html (title ,title) 
+			      (body ,@header ,(no-current-instances) ,footer)))
+	    (receive (action selected-instances)
+		(select-table title 
+			      header
+			      `((th "Servlet Name") (th "Instance-Id"))
+			      current-instances
+			      (lambda (instance-pair)
+				(let ((instance-id (car instance-pair))
+				      (instance-entry (cdr instance-pair)))
+				  `((td ,(instance-servlet-name instance-entry))
+				    (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))))))
+    
 
-    (define (no-current-continuations instance-id instance-entry)
-      '((p "Currently, there are no continuations for this instance. ")
-	(p "You may " (URL ,(make-callback continuations instance-id instance-entry)
+
+    (define (no-current-continuations instance)
+      `((p "Currently, there are no continuations for this instance. ")
+	(p "You may " (URL ,(make-callback 
+			     (lambda (req) (continuations (list instance))))
 			   "reload")
-	   "this page or go back to the "
+	   " this page or go back to the "
 	   (URL ,(make-callback instances) "instance table overview."))))
 
-    (define (show-current-continuations current-continuations
-					instance-id instance-entry outdated?)
-      (let ((continuations-callback 
-	     (make-callback (lambda (req)
-			      (continuations instance-id instance-entry)))))
-	`((p "This is a list of all current continuations hold by the handler:")
-	  (table
-	   (@ (border 1))
-	   (tr (th "Continuation-Id") (th "Action"))
-	   ,@(map
-	      (lambda (continuation-pair)
-		(let ((continuation-id (car continuation-pair)))
-		  `(tr 
-		    (td ,continuation-id)
-		    (td (servlet-form
-			 ,(make-callback
-			   (lambda (req)
-			     (if-outdated outdated?
-				 (show-outdated continuations-callback)
-				 (begin
-				   (delete-continuation! instance-id continuation-id)
-				   (continuations instance-id instance-entry)))))
-			 ,(make-submit-button "delete"))))))
-	      current-continuations))
-	  (servlet-form
-	   ,(make-callback
-	     (lambda (req)
-	       (if-outdated outdated?
-		   (show-outdated continuations-callback)
-		   (begin
-		     (for-each delete-instance! (map car current-continuations))
-		     (continuations instance-id instance-entry)))))
-	   ,(make-submit-button "delete all"))
-	  (p "Note that deleting a continuation may turn the "
-	     "current servlet session unusable."))))
-
+    (define (no-more-than-one-instance title header1)
+      (send-html 
+       `(html (title ,title) 
+	      (body (h1 "Servlet Administration")
+		    (p "Currently, you may only view the continuations of "
+		       "one instance at a time. This will be changed in "
+		       "future revisions. Sorry for any inconvenience.")
+		    (p "You may choose to go back to the " 
+		       (URL ,(make-callback instances) 
+			    "instances administration page")
+		       " where you can choose one instance.")))))
+      
     (define (continuation-id<? entry1 entry2)
       (< (car entry1) (car entry2)))
 
-    (define (continuations instance-id instance-entry)
-      (let ((current-continuations (sort-list! (get-continuations instance-id)
-					       continuation-id<?))
-	    (outdated? (make-outdater)))
-	(send-html
-	 `(html (title "Servlet Adminstration - Instances")
-		(body (h1 "Servlet Administration")
-		      (h2 "Continuations of " ,instance-id)
-		      (p ,instance-id " belongs to the servlet " 
-			 (instance-servlet-name instance-entry))
-		      ,(if (null? current-continuations)
-			   (no-current-continuations instance-id instance-entry)
-			   (show-current-continuations current-continuations 
-						       instance-id instance-entry 
-						       outdated?))
-		      (hr)
-		      (URL ,(make-callback instances) "Return to instances page.") (br)
-		      (URL ,(make-callback return-to-main-page) "Return to main page."))))))
+    (define (continuations instances  . maybe-update-text)
+      (let ((title "Servlet Adminstration - Continuations")
+	    (header1 '(h1 "Servlet Administration")))
+	(if (not (= 1 (length instances)))
+	    (no-more-than-one-instance title header1)
+	    (let* ((instance-pair (car instances))
+		   (instance-id (car instance-pair))
+		   (instance-entry (cdr instance-pair))
+		   (update-text (:optional maybe-update-text "")))
+	      (let ((current-continuations 
+		     (sort-list! (get-continuations instance-id)
+				 continuation-id<?))
+		    (outdated? (make-outdater))
+		    
+		    (header (cons header1
+				  `((h2 "Continuations of " ,instance-id)
+				    (p "(belongs to the servlet '" 
+				       ,(instance-servlet-name instance-entry) "')")
+				    (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.")))
+		    (actions '("delete" "delete all"))
+		    (continuations-callback (make-callback (lambda (req)
+							     (continuations instances)))))
+		(if (null? current-continuations)
+		    (send-html `(html (title ,title) 
+				      (body ,header 
+					    ,(no-current-continuations instance-pair)
+					    ,footer)))
+		    (receive (action selected-continuations)
+			(select-table title
+				      header
+				      '((th "Continuation-Id"))
+				      current-continuations
+				      (lambda (continuation-pair)
+					(let ((continuation-id (car continuation-pair)))
+					  `((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."))))))))
+
+  (define (delete-continuations outdated? continuations-callback
+				instance-id continuations)
+    (if-outdated outdated?
+	(show-outdated continuations-callback)
+	;; Do it this way to easily expand to more instances in the
+	;; future.
+	(for-each delete-continuation! 
+		  (make-list (length continuations)
+			     instance-id)
+		  (map car continuations))))
 
     (define (return-to-main-page req)
       (send/finish (make-http-error-response http-status/moved-perm req