From c85bcfc502503f6ace53aed5a65c11d3c425bbfd Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Tue, 1 Oct 2002 17:44:58 +0000
Subject: [PATCH] + serlvet administration tool   Note that the picture
 generation in admin-profiling.scm   currently fails because of current
 restrictions in the   servlet-handler (that cannot serve data files).   No
 error capturing on wrong input in input-fields.

---
 .../web-server/root/htdocs/index.html         |   3 +-
 .../root/surflets/admin-handler.scm           |  48 ++++
 .../root/surflets/admin-profiling.scm         | 120 +++++++++
 .../root/surflets/admin-servlets.scm          | 230 ++++++++++++++++++
 .../web-server/root/surflets/admin.scm        |  24 ++
 5 files changed, 424 insertions(+), 1 deletion(-)
 create mode 100644 scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
 create mode 100644 scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
 create mode 100644 scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
 create mode 100644 scheme/httpd/surflets/web-server/root/surflets/admin.scm

diff --git a/scheme/httpd/surflets/web-server/root/htdocs/index.html b/scheme/httpd/surflets/web-server/root/htdocs/index.html
index 00f5724..c80b2ad 100644
--- a/scheme/httpd/surflets/web-server/root/htdocs/index.html
+++ b/scheme/httpd/surflets/web-server/root/htdocs/index.html
@@ -13,6 +13,7 @@
       <li><a href="servlet/calculate.scm">Simple Calculator</a></li>
       <li><a href="servlet/byte-input.scm">Byte Input Widget</a></li>
 <!--       <li><a href=/servlet/test.scm>A test servlet</a></li> -->
+      <li><a href="servlet/admin.scm">Servlet Administration</a></li>
       <li><a href=index.html>This file</a></li>
     </ul>
     <br>
@@ -21,7 +22,7 @@
     <hr>
     <!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
     <!-- hhmts start -->
-Last modified: Fri Sep 27 19:34:15 CEST 2002
+Last modified: Tue Oct  1 11:48:55 CEST 2002
 <!-- hhmts end -->
   </body>
 </html>
diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
new file mode 100644
index 0000000..d214ef1
--- /dev/null
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
@@ -0,0 +1,48 @@
+(define-structure servlet servlet-interface
+  (open scsh
+	scheme
+	servlets
+	servlet-handler/admin
+	httpd-responses
+	)
+  (begin
+
+    (define (get-option-change number-field update-text)
+      (send-html/suspend
+       (lambda (new-url)
+	 `(html 
+	   (title "Servlet Adminstration - Handler options")
+	   (body 
+	    (h1 "Servlet Administration")
+	    (h2 "Handler options")
+	    ,(and (pair? update-text) update-text)
+	    (p "These are the runtime configurable options of the handler:")
+	    (table
+	     (servlet-form ,new-url
+			   (tr (td "Current instance lifetime: ") 
+			       (td ,number-field) 
+			       (td ,(make-submit-button "Change")))))
+	    (hr)
+	    (URL ,(make-callback return-to-main-page) "Return to main page")))
+	 )))
+
+    (define (handler-options req . update-text)
+      (let* ((number-field 
+	      (make-number-input-field `(@ ((value ,(options-instance-lifetime))))))
+	     (req (get-option-change number-field update-text)))
+
+	(set-options-instance-lifetime! 
+	 (input-field-value number-field (get-bindings req)))
+	(handler-options req 
+			 `(font (@ (color "red"))
+				,(format #f "Instance lifetime changed to ~a." 
+					 (options-instance-lifetime))))))
+
+    (define (return-to-main-page req)
+      (send/finish (make-http-error-response http-status/moved-perm req
+					     "admin.scm" "admin.scm")))
+
+    (define (main req)
+      (handler-options req))
+
+    ))
\ No newline at end of file
diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
new file mode 100644
index 0000000..e1e4c18
--- /dev/null
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
@@ -0,0 +1,120 @@
+(define-structure servlet servlet-interface
+  (open scsh
+	scheme
+	servlets
+	servlet-handler/admin
+	profiling
+	handle-fatal-error
+	httpd-responses
+	let-opt
+	)
+  (begin
+
+    (define file-name (create-temp-file "servlet-profiling"))
+    (define file-names-to-delete '())
+    (define (add-file-name-to-delete! file-name)
+      (set! file-names-to-delete (cons file-name file-names-to-delete)))
+    (define counter 0)
+    (define gnuplot "/usr/bin/gnuplot")
+
+    (define (reset-profiling-state!)
+      (set! counter 0)
+      (for-each delete-file file-names-to-delete)
+      (delete-file file-name)
+      (set! file-name (create-temp-file "servlet-profiling"))
+      (set! file-names-to-delete '()))
+
+    (define (profile req . maybe-update-text)
+      (let* ((update-text (:optional maybe-update-text ""))
+	     (input-field (make-text-input-field gnuplot '(@ (size 20))))
+	     (req 
+	      (send-html/suspend
+	       (lambda (new-url)
+		 `(html 
+		   (title "Servlet Administration -- Profiling")
+		   (body (h1 "Serlvet Administration")
+			 (h2 "Profiling")
+			 (font (@ (color "red")) ,update-text)
+			 (p "Currently, there are " ,counter " profiles saved.")
+			 (ul
+			  (li (URL ,(make-callback new-profile) "Create new profile"))
+			  (li (URL ,(make-callback result) "Show profile results")
+			      (br)
+			      (servlet-form
+			       ,new-url
+			       (p "This uses " (pre "gnuplot") " that is searched at "
+				  ,input-field ,(make-submit-button "Change"))))
+			       (li (URL ,(make-callback reset) "Delete files and reset profile state.")))
+			      (hr)
+			      (URL ,(make-callback return-to-main-page) 
+				   "Return to main page leaving profile state untouched.")
+			      (br)
+			      (URL ,(make-callback reset-and-return-to-main-page)
+				   "Return to main page reseting profile-state"))))))
+	     (bindings (get-bindings req)))
+	(let ((new-gnuplot-location (with-fatal-error-handler
+				     (lambda (condition more)
+				       #f)
+				     (input-field-value input-field bindings))))
+	  (if new-gnuplot-location
+	      (begin
+		(set! gnuplot new-gnuplot-location)
+		(profile req (format #f "Gnuplot is now searched at ~a." gnuplot)))
+	      (profile req)))))
+
+    (define (new-profile req)
+      (profile-space file-name)
+      (set! counter (+ 1 counter))
+      (profile req (format #f "Profile #~a generated" counter)))
+
+    (define (result req)
+      (let ((results (profile-results file-name))
+	    (gnuplot-data-file-name (create-temp-file "servlet-profiling.data"))
+	    (picture-file (create-temp-file "servlet-profiling.picture")))
+	(format #t "results: ~a~%" results)
+	(write-gnuplot-data-file gnuplot-data-file-name 
+				 (lambda (space-info)
+				   (total-bytes (space-info-total space-info)))
+				 results)
+	(let ((status 
+	       (run (,gnuplot -)
+		    (<< ,(format #f "set terminal png
+set output '~a'
+plot '~a' title 'Servlet Profiling ~a' with lines"
+				 picture-file
+				 gnuplot-data-file-name
+				 (format-date "~c" (date))
+				 )))))
+	  (delete-file gnuplot-data-file-name)
+	  (add-file-name-to-delete! picture-file)
+	  (send-html
+	   `(html 
+	     (title "Servlet Administration -- Profiling Results")
+	     (body
+	      (h1 "Servlet-Administration")
+	      (h2 "Profiling")
+	      (h3 "Results")
+	      (p "This is the result of the profilings:")
+	      ,(if (zero? status)
+		   `(image (@ (src ,picture-file)))
+		   `(p "An error occured while generating the profiling results picture."
+		       (br)
+		       "Are you sure, you have " (pre "gnuplot") 
+		       " installed at " (pre ,gnuplot) "?"))))))))
+
+    (define (reset req)
+      (reset-profiling-state!)
+      (profile req))
+
+    (define (return-to-main-page req)
+      (send/finish (make-http-error-response http-status/moved-perm req
+					     "admin.scm" "admin.scm")))    
+
+    (define (reset-and-return-to-main-page req)
+      (reset-profiling-state!)
+      (return-to-main-page req))
+
+    (define (main req)
+      (profile req))
+
+    ))
\ No newline at end of file
diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
new file mode 100644
index 0000000..0030bd9
--- /dev/null
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
@@ -0,0 +1,230 @@
+(define-structure servlet servlet-interface
+  (open scsh
+	scheme
+	servlets
+	servlet-handler/admin
+	httpd-responses
+	sort
+	)
+  (begin
+
+    (define remove-servlet-path
+      (let ((regexp (rx ,(file-name-as-directory (options-servlet-path)) 
+			(submatch (* any)))))
+	(lambda (file-name)
+	  (let ((match (regexp-search regexp file-name)))
+	    (if match
+		(match:substring match 1)
+		file-name)))))
+      
+
+    (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)))))
+
+    (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)
+      (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))))
+    (define (instance-id>? entry1 entry2)
+      (instance-id<? entry2 entry1))
+    (define (instance-servlet-name>? entry1 entry2)
+      (instance-servlet-name<? entry2 entry1))
+
+    (define (no-current-instances)
+      ;; Avoid using send/suspend in this context as there
+      ;; are no instances available any more.
+      '(p "Currently, there are no instances, "
+	  "i.e. the administration servlet is no longer running. "
+	  ;; 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)
+      (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 (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)
+			   "reload")
+	   "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 (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 (return-to-main-page req)
+      (send/finish (make-http-error-response http-status/moved-perm req
+					     "admin.scm" "admin.scm")))
+    
+    (define (main req)
+      (servlets req))
+    
+    ))
\ No newline at end of file
diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin.scm b/scheme/httpd/surflets/web-server/root/surflets/admin.scm
new file mode 100644
index 0000000..17b1ca2
--- /dev/null
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin.scm
@@ -0,0 +1,24 @@
+(define-structure servlet servlet-interface
+  (open scsh
+	scheme
+	servlets
+	servlet-handler/admin
+	sort
+	)
+  (begin
+
+    (define (main-page)
+      `(html (title "Servlet Administration")
+	     (body (h1 "Servlet Administration")
+		   (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...")))))))
+
+    (define (main req)
+      (send-html (main-page)))
+
+    ))
\ No newline at end of file