+ 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.
This commit is contained in:
interp
parent
d3827d8e72
commit
c85bcfc502
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
))
|
||||
|
|
@ -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))
|
||||
|
||||
))
|
||||
|
|
@ -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))
|
||||
|
||||
))
|
||||
|
|
@ -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)))
|
||||
|
||||
))
|
||||
Loading…
Reference in New Issue