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 @@
  • Simple Calculator
  • Byte Input Widget
  • +
  • Servlet Administration
  • This file

  • @@ -21,7 +22,7 @@
    -Last modified: Fri Sep 27 19:34:15 CEST 2002 +Last modified: Tue Oct 1 11:48:55 CEST 2002 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? entry1 entry2) + (instance-id? entry1 entry2) + (instance-servlet-name