From ab9c1ef642bb13b826c0a10f6fcd8abedd541b6e Mon Sep 17 00:00:00 2001 From: interp Date: Thu, 3 Oct 2002 01:25:47 +0000 Subject: [PATCH] example using servlet-data --- .../root/surflets/admin-profiling.scm | 137 ++++++++++++------ 1 file changed, 93 insertions(+), 44 deletions(-) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm index bb580f7..eca0f5f 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm @@ -7,6 +7,8 @@ handle-fatal-error httpd-responses (subset srfi-1 (iota)) + defrec-package + locks let-opt ) (begin @@ -15,12 +17,21 @@ ;; profiling. Note to get the resulting picture, gnuplot must be ;; installed. - (define file-name #f) - (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-record state + file-name + file-names-to-delete + (counter 0)) + + (define (state-file-name) + (state:file-name (get-servlet-data))) + (define (state-file-names-to-delete) + (state:file-names-to-delete (get-servlet-data))) + (define (state-counter) + (state:counter (get-servlet-data))) + + ;; Leave this global. Server is running on a single system. (define gnuplot "/usr/bin/gnuplot") + (define lock (make-lock)) (define (profile req . maybe-update-text) (let* ((update-text (:optional maybe-update-text "")) @@ -39,7 +50,7 @@ (body (h1 "Serlvet Administration") (h2 "Profiling") (font (@ (color "red")) ,update-text) - (p "Currently, there are " ,counter " profiles saved.") + (p "Currently, there are " ,(state-counter) " profiles saved.") (ul (li (URL ,(new-profile-address new-url) "Create new profile") @@ -63,7 +74,7 @@ ((returned-via? new-profile-address bindings) (new-profile req)) ((returned-via? result-address bindings) - (if (zero? counter) + (if (zero? (state-counter)) (profile req "Now profiles created, currently. Select 'Create new profile' to create one.") (result req))) ((returned-via? reset-address bindings) @@ -85,18 +96,23 @@ (profile req "Please enter a file name of an existing executable."))))))) (define (new-profile req) - (format #t "profiling...~%") - (profile-space file-name) - (format #t "profile recorded in ~s~%" file-name) - (set! counter (+ 1 counter)) - (profile req (format #f "Profile #~a generated" counter))) + (let ((state (get-servlet-data))) + (format #t "profiling...~%") + (obtain-lock lock) + (profile-space (state:file-name state)) + (release-lock lock) + (format #t "profile recorded in ~s~%" (state:file-name state)) + (set-state:counter state (+ 1 (state:counter state))) + (profile req (format #f "Profile #~a generated" (state:counter state))))) (define (result req) - (let ((results (profile-results file-name)) + (let ((results (profile-results (state-file-name))) (gnuplot-data-file-name (create-temp-file "servlet-profiling.data")) (picture-file (create-temp-file "servlet-profiling.picture")) (get-total-bytes (lambda (space-info) - (total-bytes (space-info-total space-info))))) + (total-bytes (space-info-total space-info)))) + (return-address (make-address)) + (reset-return-address (make-address))) (write-gnuplot-data-file gnuplot-data-file-name get-total-bytes results) @@ -111,45 +127,76 @@ plot '~a' title 'Servlet Profiling ~a' with lines" ))))) (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 Results") - (h3 "Picture") - ,(if (zero? status) - `(image (@ (src ,picture-file))) - `(p "An error occured while generating the profiling results picture." - (br) - "Are you sure, you have " (q "gnuplot") - " installed at " (q ,gnuplot) "?")) - (hr) - (h3 "Data") - (table - (tr (th "#") (th "Total bytes occupied")) - ,@(map (lambda (num space-info) - `(tr (td ,(+ 1 num)) - (td ,(get-total-bytes space-info)))) - (iota (length results)) - results)))))))) + (let* ((req (show-results status picture-file get-total-bytes results + return-address reset-return-address)) + (bindings (get-bindings req))) + (cond + ((returned-via? return-address bindings) + (profile req "You may continue to make profiles.")) + ((returned-via? reset-return-address bindings) + (reset-and-return-to-main-page req)) + (else + (error "unexpected return address"))))))) + + (define (show-results status picture-file get-total-bytes results + return-address reset-return-address) + (send-html/suspend + (lambda (new-url) + `(html + (title "Servlet Administration -- Profiling Results") + (body + (h1 "Servlet-Administration") + (h2 "Profiling Results") + (h3 "Picture") + ,(if (zero? status) + `(image (@ (src ,picture-file))) + `(p "An error occured while generating the profiling results picture." + (br) + "Are you sure, you have " (q "gnuplot") + " installed at " (q ,gnuplot) "?")) + (hr) + (h3 "Data") + (table + (tr (th "#") (th "Total bytes occupied")) + ,@(map (lambda (num space-info) + `(tr (td ,(+ 1 num)) + (td ,(get-total-bytes space-info)))) + (iota (length results)) + results)) + (hr) + (p (URL ,(return-address new-url) "Return to previous page") (br) + (URL ,(reset-return-address new-url) + "Delete files, reset state and return to main page."))))))) (define (reset req) (reset-profiling-state!) (profile req "Profiling state reseted.")) - (define (delete-files) - (for-each delete-filesys-object file-names-to-delete)) + (define (add-file-name-to-delete! file-name) + (let ((state (get-servlet-data))) + (set-state:file-names-to-delete + state + (cons file-name + (state:file-names-to-delete state))))) + + (define (delete-files state) + (let ((file-names-to-delete (state:file-names-to-delete state))) + (if file-names-to-delete + (for-each delete-filesys-object file-names-to-delete)))) (define (reset-profiling-state!) - (set! counter 0) - (delete-files) - (set! file-name (absolute-file-name (create-temp-file "servlet-profiling"))) - (set! file-names-to-delete (list file-name))) - + (let ((state (get-servlet-data))) + (set-state:counter state 0) + (delete-files state) + (set-state:file-name state + (absolute-file-name (create-temp-file "servlet-profiling"))) + (set-state:file-names-to-delete state + (list (state:file-name state))))) + (define (reset-and-return-to-main-page req) + ;; Overhead included :-| (reset-profiling-state!) - (delete-files) + (delete-files (get-servlet-data)) (return-to-main-page req)) (define (return-to-main-page req) @@ -157,6 +204,8 @@ plot '~a' title 'Servlet Profiling ~a' with lines" "admin.scm" "admin.scm"))) (define (main req) + ;; We'll fill this out soon. + (set-servlet-data! (make-state #f #f)) (reset-profiling-state!) (profile req))