example using servlet-data

This commit is contained in:
interp 2002-10-03 01:25:47 +00:00
parent 04ba0986d3
commit ab9c1ef642
1 changed files with 93 additions and 44 deletions

View File

@ -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))