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

(define-structure surflet surflet-interface
  (open scheme-with-scsh
	surflets
	surflet-handler/admin
	httpd-responses
	httpd-requests
	url
	handle-fatal-error
	let-opt
	srfi-1				;filter-map, last
	sort
	)
  (begin

    (define remove-surflet-path
      (let ((regexp (rx ,(file-name-as-directory (options-surflet-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
		    (surflet-form
		     ,new-url
		     POST
		     (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)
	    (values #f #f req)
	    (values action
		    (filter-map (lambda (checkbox table-element)
				  (if (input-field-value checkbox bindings)
				      table-element
				      #f))
				checkboxes
				table-elements)
		    req))))

    (define (unload-surflets outdated? surflet-names)
      (if-outdated outdated?
	  (show-outdated (make-callback show-surflets))
	  (for-each unload-surflet surflet-names)))

    (define (no-surflets)
      `(p "Currently, there are no SUrflets loaded " 
	  (URL ,(make-callback show-surflets) "(reload)")
	  ", but there may be "
	  (URL ,(make-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))
	     (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.")
		       (br)
		       (URL "/" "Return to main menu.")))
	     (actions '("unload" "unload all")))
	(if (null? loaded-surflets)
	    (send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer)))
	    (receive (action selected-surflets req)
		(select-table title	                 ; title
			      header	                 ; header
			      '((th "Name"))             ; table-header
			      loaded-surflets            ; list of elements
			      (lambda (surflet)          ; selector
				`((td
				   ,(remove-surflet-path surflet))))
			      actions                    ; actions to perform
			      (cons                      ; footer
			       `(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) 
					"sessions adminstration page."))
			       footer))
	      (if (not action)
		  (show-surflets 'no-req "Choose an action.")
		  (if (and (null? selected-surflets)
			   (not (string=? action "unload all")))
		      (show-surflets 'no-req "You must choose at least one element.")
		      (cond 
		       ((string=? action "unload")
			(unload-surflets outdated? selected-surflets)
			(show-surflets 'no-req "SUrflets unloaded."))
		       ((string=? action "unload all")
			(unload-surflets outdated? loaded-surflets)
			(show-surflets 'no-req "SUrflets unloaded."))
		       (else
			(error "unknown action" action)))))))))

    (define (session-surflet-name<? entry1 entry2)
      (let ((name1 (session-surflet-name (cdr entry1)))
	    (name2 (session-surflet-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-surflet-name>? entry1 entry2)
      (session-surflet-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 SUrflet 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 (show-sessions req . maybe-update-text)
      (let* ((update-text (:optional maybe-update-text ""))
	     (current-sessions (sort-list! (get-sessions) session-surflet-name<?)))
	(real-sessions current-sessions update-text 
		       (resume-url-session-id 
			(last (http-url-path (request-url 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.")))
	     (actions '("kill"
			"adjust timeout" 
			"view continuations"))
	     (sessions-callback (make-callback show-sessions)))
	(if (null? current-sessions)
	    (send-html `(html (title ,title) 
			      (body ,@header ,(no-current-sessions) ,footer)))
	    (receive (action selected-sessions req)
		(select-table title 
			      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))))
			      actions
			      footer)
	      (if (not action)
		  (show-sessions current-sessions "Choose an action.")
		  (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)))
			   "Timeout adjusted.")
			  ((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
				   (show-continuations selected-sessions req))))
			  (else
			   (error "unknown action" action)))))
		    (show-sessions req new-update-text)))))))
    


    (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) 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 req)
      (send-html 
       `(html (title ,title) 
	      (body (h1 "SUrflet 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 show-sessions) 
			    "sessions administration page")
		       " where you can select one session"
		       " or select one session from your chosen sessions:" (br)
		       (ul
			,@(map (lambda (session)
				 `(li (URL ,(make-callback 
					     (lambda (req)
					       (show-continuations (list session) req)))
					   ,(session-surflet-name (cdr session))
					   " (" ,(car session) ")")))
			       sessions)))))))
      
    (define (continuation-id<? entry1 entry2)
      (< (car entry1) (car entry2)))

    (define (show-continuations sessions req . 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))
		   (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 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."))))))))))

  (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)
      (show-surflets req))
    
    ))