sunet/scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm

(define-structure servlet servlet-interface
  (open scheme-with-scsh
	servlets
	servlet-handler/admin
	httpd-responses
	handle-fatal-error
	let-opt
	srfi-1				;filter-map
	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)))))

    ;; 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 (input-field-value checkbox bindings)
			       table-element
			       #f))
			 checkboxes
			 table-elements)))))

    (define (unload-servlets outdated? servlet-names)
      (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 (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 sessions")))
	(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 sessions of this servlet." 
				   "This can be done on the " 
				   (URL ,(make-callback sessions) 
					"sessions 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 sessions")
		    (format #t "~s~%" selected-servlets)
		    (let* ((path-stripped-selected-servlets
			    (map remove-servlet-path selected-servlets))
			   (selected-sessions
			    (filter (lambda (session-pair) 
				      (member (session-servlet-name (cdr session-pair))
					      path-stripped-selected-servlets))
				    (get-sessions))))
		      ;; this does not return
		      (real-sessions (sort-list! selected-sessions 
						  session-servlet-name<?)
				      "")))
		   (else
		    (error "unknown action" action))))))))

    (define (session-servlet-name<? entry1 entry2)
      (let ((name1 (session-servlet-name (cdr entry1)))
	    (name2 (session-servlet-name (cdr entry2))))
	;; handle multiple session names
	(if (string=? name1 name2)
	    (session-id<? entry1 entry2)
	    (string<? name1 name2))))
    (define (session-id<? entry1 entry2)
      ;; there are no multiple session-ids
      (< (car entry1) (car entry2)))
    (define (session-id>? entry1 entry2)
      (session-id<? entry2 entry1))
    (define (session-servlet-name>? entry1 entry2)
      (session-servlet-name<? entry2 entry1))

    (define (no-current-sessions)
      ;; Avoid using send/suspend in this context as there
      ;; are no sessions available any more.
      '(p "Currently, there are no sessions, "
	  "i.e. the administration servlet is no longer running. "
	  ;; Can't use callback here, as there are no valid sessions left.
	  (URL "admin.scm" "Go back to main page.")))

    (define (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)))

    (define (real-sessions current-sessions update-text)
      (let ((outdated? (make-outdater))
	     (title  "Servlet Adminstration - Sessions")
	     (header `((h1 "Servlet Administration")
		       (h2 "Sessions")
		       (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"))
	     (sessions-callback (make-callback sessions)))
	(if (null? current-sessions)
	    (send-html `(html (title ,title) 
			      (body ,@header ,(no-current-sessions) ,footer)))
	    (receive (action selected-sessions)
		(select-table title 
			      header
			      `((th "Servlet Name") (th "Session-Id"))
			      current-sessions
			      (lambda (session-pair)
				(let ((session-id (car session-pair))
				      (session-entry (cdr session-pair)))
				  `((td ,(session-servlet-name session-entry))
				    (td ,session-id))))
			      actions
			      footer)
	      (let ((new-update-text
		     (cond
		      ((string=? action "kill")
		       (if-outdated outdated?
			   (show-outdated sessions-callback)
			   (for-each delete-session! 
				     (map car selected-sessions)))
		       "Sessions killed.")
		      ((string=? action "adjust timeout")
		       (if-outdated outdated?
			   (show-outdated sessions-callback)
			   (for-each session-adjust-timeout! 
				     (map car selected-sessions)))
		       "Sessions killed.")
		      ((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
			       (continuations selected-sessions))))
		      (else
		       (error "unknown action" action)))))
		(sessions 'no-req new-update-text))))))
    


    (define (no-current-continuations session)
      `((p "Currently, there are no continuations for this session. ")
	(p "You may " (URL ,(make-callback 
			     (lambda (req) (continuations (list session))))
			   "reload")
	   " this page or go back to the "
	   (URL ,(make-callback sessions) "session table overview."))))

    (define (no-more-than-one-session title header1)
      (send-html 
       `(html (title ,title) 
	      (body (h1 "Servlet Administration")
		    (p "Currently, you may only view the continuations of "
		       "one session 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 sessions) 
			    "sessions administration page")
		       " where you can choose one session.")))))
      
    (define (continuation-id<? entry1 entry2)
      (< (car entry1) (car entry2)))

    (define (continuations sessions  . maybe-update-text)
      (let ((title "Servlet Adminstration - Continuations")
	    (header1 '(h1 "Servlet Administration")))
	(if (not (= 1 (length sessions)))
	    (no-more-than-one-session title header1)
	    (let* ((session-pair (car sessions))
		   (session-id (car session-pair))
		   (session-entry (cdr session-pair))
		   (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 sessions) "Return to sessions page.") (br)
		       (URL ,(make-callback return-to-main-page) "Return to main page.")))
		    (actions '("delete" "delete all"))
		    (continuations-callback (make-callback (lambda (req)
							     (continuations sessions)))))
		(if (null? current-continuations)
		    (send-html `(html (title ,title) 
				      (body ,header 
					    ,(no-current-continuations session-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 
					      session-id selected-continuations))
		       ((string=? action "delete all")
			(delete-continuations outdated? continuations-callback
					      session-id current-continuations))
		       (else
			(error "unknown action" action)))
		      (continuations sessions "Deleted."))))))))

  (define (delete-continuations outdated? continuations-callback
				session-id continuations)
    (if-outdated outdated?
	(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))))

    (define (return-to-main-page req)
      (send/finish (make-error-response (status-code moved-perm) req
					"admin.scm" "admin.scm")))
    
    (define (main req)
      (servlets req))
    
    ))