From 422a1db09f3940d1178d15b8062568f171d3b524 Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Thu, 16 Jan 2003 12:53:10 +0000
Subject: [PATCH] Add note about danger of killing / deleting current
 continuation. Add current session's id and current session's continuation's
 id in this message.

---
 scheme/httpd/surflets/packages.scm            |   6 +-
 scheme/httpd/surflets/surflet-handler.scm     |   5 +-
 .../root/surflets/admin-servlets.scm          | 103 +++++++++++-------
 3 files changed, 70 insertions(+), 44 deletions(-)

diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index 09bf3f7..3f67f7f 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -99,7 +99,11 @@
 	  adjust-timeout
 	  get-continuations
 	  delete-continuation!
-	  instance-session-id))
+	  instance-session-id
+	  resume-url?
+	  resume-url-ids
+	  resume-url-session-id
+	  resume-url-continuation-id))
 
 (define-structures
   ((servlet-handler servlet-handler-interface)
diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm
index 83edbd5..93eda25 100644
--- a/scheme/httpd/surflets/surflet-handler.scm
+++ b/scheme/httpd/surflets/surflet-handler.scm
@@ -489,6 +489,7 @@
 (define (instance-session-id)
   (really-instance-session-id (thread-cell-ref *instance*)))
 
+;; unused
 (define (instance-return-continuation)
   (really-instance-return-continuation (thread-cell-ref *instance*)))
 
@@ -519,13 +520,13 @@
     (if match
 	(values (string->number (match:substring match 2))
 		(string->number (match:substring match 3)))
-	(error "resume-url-ids: no session/continuation id" id-url))))
+	(values #f #f))))
 
 (define (resume-url-servlet-name id-url)
   (let ((match (regexp-search *resume-url-regexp* id-url)))
     (if match
 	(match:substring match 1)
-	(error "resume-url-servlet-name: no servlet-name found"))))
+	(values #f #f))))
 
 (define (resume-url? id-url)
   (regexp-search? *resume-url-regexp* id-url))
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 820885c..aee6ba9 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
@@ -3,9 +3,11 @@
 	servlets
 	servlet-handler/admin
 	httpd-responses
+	httpd-requests
+	url
 	handle-fatal-error
 	let-opt
-	srfi-1				;filter-map
+	srfi-1				;filter-map, last
 	sort
 	)
   (begin
@@ -54,14 +56,15 @@
 	     (action (input-field-value select bindings)))
 
 	(if (string=? action action-title)
-	    (values #f #f)
+	    (values #f #f req)
 	    (values action
 		    (filter-map (lambda (checkbox table-element)
 				  (if (input-field-value checkbox bindings)
 				      table-element
 				      #f))
 				checkboxes
-				table-elements)))))
+				table-elements)
+		    req))))
 
     (define (unload-servlets outdated? servlet-names)
       (if-outdated outdated?
@@ -70,7 +73,10 @@
 
     (define (no-servlets)
       `(p "Currently, there are no servlets loaded " 
-	  (URL ,(make-callback show-servlets) "(reload).")))
+	  (URL ,(make-callback show-servlets) "(reload)")
+	  ", but there may be "
+	  (URL ,(make-callback show-sessions) "sessions")
+	  " you want to administer."))
 
     (define (show-servlets req . maybe-update-text)
       (let* ((update-text (:optional maybe-update-text ""))
@@ -87,7 +93,7 @@
 	     (actions '("unload" "unload all")))
 	(if (null? loaded-servlets)
 	    (send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer)))
-	    (receive (action selected-servlets)
+	    (receive (action selected-servlets req)
 		(select-table title	                 ; title
 			      header	                 ; header
 			      '((th "Name"))             ; table-header
@@ -98,7 +104,7 @@
 			      actions                    ; actions to perform
 			      (cons                      ; footer
 			       `(p "Note that unloading the servlets does not imply "
-				   "the unloading of sessions of this servlet." 
+				   "the unloading of sessions of this servlet. " (br)
 				   "This can be done on the " 
 				   (URL ,(make-callback show-sessions) 
 					"sessions adminstration page."))
@@ -144,15 +150,21 @@
     (define (show-sessions req . maybe-update-text)
       (let* ((update-text (:optional maybe-update-text ""))
 	     (current-sessions (sort-list! (get-sessions) session-servlet-name<?)))
-	(real-sessions current-sessions update-text)))
+	(real-sessions current-sessions update-text 
+		       (resume-url-session-id 
+			(last (http-url-path (request-url req)))))))
 
-    (define (real-sessions current-sessions update-text)
+    (define (real-sessions current-sessions update-text this-session-id)
       (let ((outdated? (make-outdater))
 	     (title  "Servlet Adminstration - Sessions")
 	     (header `((h1 "Servlet Administration")
 		       (h2 "Sessions")
 		       (p (font (@ (color "red")) ,update-text))))
-	     (footer `((hr)
+	     (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-servlets) "Return to servlets menu.") (br)
 		       (URL ,(make-callback return-to-main-page) "Return to administration menu.")
 		       (br)
@@ -164,7 +176,7 @@
 	(if (null? current-sessions)
 	    (send-html `(html (title ,title) 
 			      (body ,@header ,(no-current-sessions) ,footer)))
-	    (receive (action selected-sessions)
+	    (receive (action selected-sessions req)
 		(select-table title 
 			      header
 			      `((th "Servlet Name") (th "Session-Id"))
@@ -198,22 +210,22 @@
 			       (if (zero? (length selected-sessions))
 				   "You must choose at least one session."
 				   ;; this does not return
-				   (show-continuations selected-sessions))))
+				   (show-continuations selected-sessions req))))
 			  (else
 			   (error "unknown action" action)))))
 		    (show-sessions current-sessions new-update-text)))))))
     
 
 
-    (define (no-current-continuations session)
+    (define (no-current-continuations session req)
       `((p "Currently, there are no continuations for this session. ")
 	(p "You may " (URL ,(make-callback 
-			     (lambda (req) (show-continuations (list session))))
+			     (lambda (req) (show-continuations (list session) req)))
 			   "reload")
 	   " this page or go back to the "
 	   (URL ,(make-callback show-sessions) "session table overview."))))
 
-    (define (no-more-than-one-session title header1 sessions)
+    (define (no-more-than-one-session title header1 sessions req)
       (send-html 
        `(html (title ,title) 
 	      (body (h1 "Servlet Administration")
@@ -229,7 +241,7 @@
 			,@(map (lambda (session)
 				 `(li (URL ,(make-callback 
 					     (lambda (req)
-					       (show-continuations (list session))))
+					       (show-continuations (list session) req)))
 					   ,(session-servlet-name (cdr session))
 					   " (" ,(car session) ")")))
 			       sessions)))))))
@@ -237,41 +249,48 @@
     (define (continuation-id<? entry1 entry2)
       (< (car entry1) (car entry2)))
 
-    (define (show-continuations sessions  . maybe-update-text)
+    (define (show-continuations sessions req . maybe-update-text)
       (let ((title "Servlet Adminstration - Continuations")
 	    (header1 '(h1 "Servlet Administration")))
 	(if (not (= 1 (length sessions)))
-	    (no-more-than-one-session title header1 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))
+		   (this-continuation-id (resume-url-continuation-id 
+					  (last (http-url-path (request-url 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 servlet '" 
-				       ,(session-servlet-name session-entry) "')")
-				    (p (font (@ (color "red")) ,update-text)))))
-		    (footer 
-		     `((hr)
-		       (URL ,(make-callback show-servlets) "Return to servlets 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)))))
+	      (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 servlet '" 
+					,(session-servlet-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-servlets) "Return to servlets 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)
+					    ,(no-current-continuations session-pair req)
 					    ,footer)))
-		    (receive (action selected-continuations)
+		    (receive (action selected-continuations req)
 			(select-table title
 				      header
 				      '((th "Continuation-Id"))
@@ -282,7 +301,8 @@
 				      actions
 				      footer)
 		      (if (not action)
-			  (show-continuations sessions "Choose an action.")
+			  (show-continuations sessions req
+					      "Choose an action.")
 			  (begin
 			    (cond 
 			     ((string=? action "delete")
@@ -293,7 +313,8 @@
 						    session-id current-continuations))
 			     (else
 			      (error "unknown action" action)))
-			    (show-continuations sessions "Deleted."))))))))))
+			    (show-continuations sessions req
+						"Deleted."))))))))))
 
   (define (delete-continuations outdated? continuations-callback
 				session-id continuations)