bug removal; add data table to result output
This commit is contained in:
parent
20ff8816a9
commit
4899ff0453
|
@ -6,11 +6,16 @@
|
|||
profiling
|
||||
handle-fatal-error
|
||||
httpd-responses
|
||||
(subset srfi-1 (iota))
|
||||
let-opt
|
||||
)
|
||||
(begin
|
||||
|
||||
(define file-name (create-temp-file "servlet-profiling"))
|
||||
;; This uses the filesystem heavily to not influence the
|
||||
;; 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)))
|
||||
|
@ -49,16 +54,18 @@
|
|||
"Delete files and reset profile state."))))
|
||||
(hr)
|
||||
(URL ,(return-address new-url)
|
||||
"Return to main page leaving profile state untouched.")
|
||||
"Return to main page leaving files and state untouched.")
|
||||
(br)
|
||||
(URL ,(reset-return-address new-url)
|
||||
"Return to main page reseting profile-state"))))))
|
||||
"Return to main page removing files and reseting state."))))))
|
||||
(bindings (get-bindings req)))
|
||||
(cond
|
||||
((returned-via? new-profile-address bindings)
|
||||
(new-profile req))
|
||||
((returned-via? result-address bindings)
|
||||
(result req))
|
||||
(if (zero? counter)
|
||||
(profile req "Now profiles created, currently. Select 'Create new profile' to create one.")
|
||||
(result req)))
|
||||
((returned-via? reset-address bindings)
|
||||
(reset req))
|
||||
((returned-via? return-address bindings)
|
||||
|
@ -78,17 +85,20 @@
|
|||
(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)))
|
||||
|
||||
(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")))
|
||||
(picture-file (create-temp-file "servlet-profiling.picture"))
|
||||
(get-total-bytes (lambda (space-info)
|
||||
(total-bytes (space-info-total space-info)))))
|
||||
(write-gnuplot-data-file gnuplot-data-file-name
|
||||
(lambda (space-info)
|
||||
(total-bytes (space-info-total space-info)))
|
||||
get-total-bytes
|
||||
results)
|
||||
(let ((status
|
||||
(run (,gnuplot -)
|
||||
|
@ -106,36 +116,48 @@ plot '~a' title 'Servlet Profiling ~a' with lines"
|
|||
(title "Servlet Administration -- Profiling Results")
|
||||
(body
|
||||
(h1 "Servlet-Administration")
|
||||
(h2 "Profiling")
|
||||
(h3 "Results")
|
||||
(p "This is the result of the profilings:")
|
||||
(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 " (pre "gnuplot")
|
||||
" installed at " (pre ,gnuplot) "?"))))))))
|
||||
"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))))))))
|
||||
|
||||
(define (reset req)
|
||||
(reset-profiling-state!)
|
||||
(profile req "Profiling state reseted."))
|
||||
|
||||
(define (delete-files)
|
||||
(for-each delete-filesys-object file-names-to-delete))
|
||||
|
||||
(define (reset-profiling-state!)
|
||||
(set! counter 0)
|
||||
(for-each delete-filesys-object file-names-to-delete)
|
||||
(delete-filesys-object file-name)
|
||||
(set! file-name (create-temp-file "servlet-profiling"))
|
||||
(set! file-names-to-delete '()))
|
||||
(delete-files)
|
||||
(set! file-name (absolute-file-name (create-temp-file "servlet-profiling")))
|
||||
(set! file-names-to-delete (list file-name)))
|
||||
|
||||
(define (reset-and-return-to-main-page req)
|
||||
(reset-profiling-state!)
|
||||
(return-to-main-page req))
|
||||
(delete-files)
|
||||
(return-to-main-page req))
|
||||
|
||||
(define (return-to-main-page req)
|
||||
(send/finish (make-http-error-response http-status/moved-perm req
|
||||
"admin.scm" "admin.scm")))
|
||||
|
||||
(define (main req)
|
||||
(reset-profiling-state!)
|
||||
(profile req))
|
||||
|
||||
))
|
Loading…
Reference in New Issue