From 20821bdfb5e90f4d7173349542ad51d7535e5e77 Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Wed, 16 Apr 2003 16:03:06 +0000
Subject: [PATCH] Adapt to recent change of session-interface in
 surflet-handler

---
 .../root/surflets/admin-surflets.scm          | 231 +++++++++---------
 1 file changed, 117 insertions(+), 114 deletions(-)

diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm
index 8e67eb0..85a5570 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm
@@ -72,28 +72,31 @@
 	  (show-outdated (make-callback show-surflets))
 	  (for-each unload-surflet surflet-names)))
 
-    (define (no-surflets)
+    (define (no-surflets callback)
       `(p "Currently, there are no SUrflets loaded " 
-	  (url ,(make-callback show-surflets) "(reload)")
+	  (url ,(callback show-surflets) "(reload)")
 	  ", but there may be "
-	  (url ,(make-callback show-sessions) "sessions")
+	  (url ,(callback show-sessions) "sessions")
 	  " you want to administer."))
 
     (define (show-surflets req . maybe-update-text)
       (let* ((update-text (:optional maybe-update-text ""))
 	     (loaded-surflets (sort-list! (get-loaded-surflets) string<?))
 	     (outdated? (make-outdater))
+	     (callback (make-annotated-callback callback-functor))
 	     (title "SUrflet-Administration -- SUrflets")
 	     (header `((h1 "SUrflet Administration")
 		       (h2 "SUrflets")
 		       (p (font (@ (color "red")) ,update-text))))
 	     (footer `((hr)
-		       (url ,(make-callback return-to-main-page) "Return to administration menu.")
+		       (url ,(callback return-to-main-page)
+			    "Return to administration menu.")
 		       (br)
 		       (url "/" "Return to main menu.")))
 	     (actions '("unload" "unload all")))
 	(if (null? loaded-surflets)
-	    (send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer)))
+	    (send-html `(html (title ,title) 
+			      (body ,header ,(no-surflets callback) ,footer)))
 	    (receive (action selected-surflets req)
 		(select-table title	                 ; title
 			      header	                 ; header
@@ -107,7 +110,7 @@
 			       `(p "Note that unloading the SUrflets does not imply "
 				   "the unloading of sessions of this SUrflet. " (br)
 				   "This can be done on the " 
-				   (url ,(make-callback show-sessions) 
+				   (url ,(callback show-sessions) 
 					"sessions adminstration page."))
 			       footer))
 	      (if (not action)
@@ -125,20 +128,21 @@
 		       (else
 			(error "unknown action" action)))))))))
 
-    (define (session-surflet-name<? entry1 entry2)
-      (let ((name1 (session-surflet-name (cdr entry1)))
-	    (name2 (session-surflet-name (cdr entry2))))
+    (define (session-surflet-name<? session1 session2)
+      (let ((name1 (session-surflet-name session1))
+	    (name2 (session-surflet-name session2)))
 	;; handle multiple session names
 	(if (string=? name1 name2)
-	    (session-id<? entry1 entry2)
+	    (session-id<? session1 session2)
 	    (string<? name1 name2))))
-    (define (session-id<? entry1 entry2)
+    (define (session-id<? session1 session2)
       ;; there are no multiple session-ids
-      (< (car entry1) (car entry2)))
-    (define (session-id>? entry1 entry2)
-      (session-id<? entry2 entry1))
-    (define (session-surflet-name>? entry1 entry2)
-      (session-surflet-name<? entry2 entry1))
+      (< (session-session-id session1)
+	 (session-session-id session2)))
+    (define (session-surflet-name>? session1 session2)
+      (session-surflet-name<? session2 session1))
+    (define (session-id>? session1 session2)
+      (session-id<? session2 session1))
 
     (define (no-current-sessions)
       ;; Avoid using send/suspend in this context as there
@@ -155,24 +159,26 @@
 		       (my-session-id req))))
 
     (define (real-sessions current-sessions update-text this-session-id)
-      (let ((outdated? (make-outdater))
-	     (title  "SUrflet Adminstration - Sessions")
-	     (header `((h1 "SUrflet Administration")
-		       (h2 "Sessions")
-		       (p (font (@ (color "red")) ,update-text))))
-	     (footer `(,(if (not (null? current-sessions))
-			    `(p "Be careful not to kill this adminstration's "
-				"session (id: " ,this-session-id ").")
-			    #f)
-		       (hr)
-		       (url ,(make-callback show-surflets) "Return to SUrflets menu.") (br)
-		       (url ,(make-callback return-to-main-page) "Return to administration menu.")
-		       (br)
-		       (url "/" "Return to main menu.")))
+      (let* ((outdated? (make-outdater))
+	    (callback (make-annotated-callback callback-functor))
+	    (title  "SUrflet Adminstration - Sessions")
+	    (header `((h1 "SUrflet Administration")
+		      (h2 "Sessions")
+		      (p (font (@ (color "red")) ,update-text))))
+	    (footer `(,(if (not (null? current-sessions))
+			   `(p "Be careful not to kill this adminstration's "
+			       "session (id: " ,this-session-id ").")
+			   #f)
+		      (hr)
+		      (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 '("kill"
 			"adjust timeout" 
 			"view continuations"))
-	     (sessions-callback (make-callback show-sessions)))
+	     (sessions-callback (callback show-sessions)))
 	(if (null? current-sessions)
 	    (send-html `(html (title ,title) 
 			      (body ,@header ,(no-current-sessions) ,footer)))
@@ -181,11 +187,10 @@
 			      header
 			      `((th "SUrflet Name") (th "Session-Id"))
 			      current-sessions
-			      (lambda (session-pair)
-				(let ((session-id (car session-pair))
-				      (session-entry (cdr session-pair)))
-				  `((td ,(session-surflet-name session-entry))
-				    (td (@ (align "right")) ,session-id))))
+			      (lambda (session)
+				`((td ,(session-surflet-name session))
+				  (td (@ (align "right")) 
+				      ,(session-session-id session))))
 			      actions
 			      footer)
 	      (if (not action)
@@ -196,13 +201,13 @@
 			   (if-outdated outdated?
 			       (show-outdated sessions-callback)
 			       (for-each delete-session! 
-					 (map car selected-sessions)))
+					 selected-sessions))
 			   "Sessions killed.")
 			  ((string=? action "adjust timeout")
 			   (if-outdated outdated?
 			       (show-outdated sessions-callback)
 			       (for-each session-adjust-timeout! 
-					 (map car selected-sessions)))
+					 selected-sessions))
 			   "Timeout adjusted.")
 			  ((string=? action "view continuations")
 			   (if-outdated outdated?
@@ -210,20 +215,19 @@
 			       (if (zero? (length selected-sessions))
 				   "You must choose at least one session."
 				   ;; this does not return
-				   (show-continuations selected-sessions req))))
+				   (show-continuations req selected-sessions))))
 			  (else
 			   (error "unknown action" action)))))
 		    (show-sessions req new-update-text)))))))
     
 
 
-    (define (no-current-continuations session req)
+    (define (no-current-continuations callback session req)
       `((p "Currently, there are no continuations for this session. ")
-	(p "You may " (url ,(make-callback 
-			     (lambda (req) (show-continuations (list session) req)))
+	(p "You may " (url ,(callback show-continuations (list session))
 			   "reload")
 	   " this page or go back to the "
-	   (url ,(make-callback show-sessions) "session table overview."))))
+	   (url ,(callback show-sessions) "session table overview."))))
 
     (define (no-more-than-one-session title header1 sessions req)
       (let* ((address (make-annotated-address))
@@ -242,83 +246,85 @@
 			   " where you can select one session"
 			   " or select one session from your chosen sessions:" (br)
 			   (ul
-			    ,@(map (lambda (session)
-				     `(li (url ,(address k-url session)
-					       ,(session-surflet-name (cdr session))
-					       " (" ,(car session) ")")))
+			    ,@(map 
+			       (lambda (session)
+				 `(li (url ,(address k-url session)
+					   ,(session-surflet-name session)
+					   " (" ,(session-session-id session) ")")))
 				   sessions))))))))
 	     (bindings (get-bindings req))
 	     (chosen-session (returned-via address bindings)))
-	(show-continuations (list chosen-session) req)))
+	(show-continuations req (list chosen-session))))
       
-    (define (continuation-id<? entry1 entry2)
-      (< (car entry1) (car entry2)))
+    (define (continuation-id<? cont1 cont2)
+      (< (continuation-id cont1) 
+	 (continuation-id cont2)))
 
-    (define (show-continuations sessions req . maybe-update-text)
+    (define (show-continuations req sessions . maybe-update-text)
       (let ((title "SUrflet Adminstration - Continuations")
 	    (header1 '(h1 "SUrflet Administration")))
 	(if (not (= 1 (length sessions)))
 	    (no-more-than-one-session title header1 sessions req)
-	    (let* ((session-pair (car sessions))
-		   (session-id (car session-pair))
-		   (session-entry (cdr session-pair))
+	    (let* ((session (car sessions))
+		   (session-id (session-session-id session))
 		   (this-continuation-id (my-continuation-id req))
-		   (update-text (:optional maybe-update-text "")))
-	      (let* ((current-continuations 
-		      (sort-list! (get-continuations session-id)
-				  continuation-id<?))
-		     (outdated? (make-outdater))
-		     
-		     (header (cons header1
-				   `((h2 "Continuations of " ,session-id)
-				     (p "(belongs to the SUrflet '" 
-					,(session-surflet-name session-entry) "')")
-				     (p (font (@ (color "red")) ,update-text)))))
-		     (footer 
-		      `(,(if (not (null? current-continuations))
-			     `(p "Be careful not to delete this adminstration's "
-				 "continuation (id: " ,this-continuation-id ").")
-			     #f)
-			(hr)
-			(url ,(make-callback show-surflets) "Return to SUrflets menu.") (br)
-			(url ,(make-callback show-sessions) "Return to sessions 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)
-				       (show-continuations sessions req)))))
-		(if (null? current-continuations)
-		    (send-html `(html (title ,title) 
-				      (body ,header 
-					    ,(no-current-continuations session-pair req)
-					    ,footer)))
-		    (receive (action selected-continuations req)
-			(select-table title
-				      header
-				      '((th "Continuation-Id"))
-				      current-continuations
-				      (lambda (continuation-pair)
-					(let ((continuation-id (car continuation-pair)))
-					  `((td (@ (align "right")) ,continuation-id))))
-				      actions
-				      footer)
-		      (if (not action)
-			  (show-continuations sessions req
-					      "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 sessions req
-						"Deleted."))))))))))
+		   (update-text (:optional maybe-update-text ""))
+		   (current-continuations 
+		    (sort-list! (get-continuations session-id)
+				continuation-id<?))
+		   (outdated? (make-outdater))
+		   (callback (make-annotated-callback callback-functor))
+		   (header (cons header1
+				 `((h2 "Continuations of " ,session-id)
+				   (p "(belongs to the SUrflet '" 
+				      ,(session-surflet-name session) "')")
+				   (p (font (@ (color "red")) ,update-text)))))
+		   (footer 
+		    `(,(if (not (null? current-continuations))
+			   `(p "Be careful not to delete this adminstration's "
+			       "continuation (id: " ,this-continuation-id ").")
+			   #f)
+		      (hr)
+		      (url ,(callback show-surflets)
+			   "Return to SUrflets menu.") 
+		      (br) (url ,(callback show-sessions) 
+				"Return to sessions 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 
+		   `(html (title ,title) 
+			  (body ,header 
+				,(no-current-continuations callback session req)
+				,footer)))
+		  (receive (action selected-continuations req)
+		      (select-table title
+				    header
+				    '((th "Continuation-Id"))
+				    current-continuations
+				    (lambda (continuation)
+				      `((td (@ (align "right")) 
+					    ,(continuation-id continuation))))
+				    actions
+				    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)
@@ -326,10 +332,7 @@
 	(show-outdated continuations-callback)
 	;; Do it this way to easily expand to more sessions in the
 	;; future.
-	(for-each delete-continuation! 
-		  (make-list (length continuations)
-			     session-id)
-		  (map car continuations))))
+	(for-each delete-continuation! continuations)))
 
     (define (return-to-main-page req)
       (send-error (status-code moved-perm) req