example using servlet-data

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-record state
-    (define file-names-to-delete '())
+      file-name
-    (define (add-file-name-to-delete! file-name)
+      file-names-to-delete
-      (set! file-names-to-delete (cons file-name file-names-to-delete)))
+      (counter 0))
-    (define 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...~%")
+      (let ((state (get-servlet-data)))
-      (profile-space file-name)
+	(format #t "profiling...~%")
-      (format #t "profile recorded in ~s~%" file-name)
+	(obtain-lock lock)
-      (set! counter (+ 1 counter))
+	(profile-space (state:file-name state))
-      (profile req (format #f "Profile #~a generated" counter)))
+	(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
+	  (let* ((req (show-results status picture-file get-total-bytes results 
-	   `(html 
+				    return-address reset-return-address))
-	     (title "Servlet Administration -- Profiling Results")
+		 (bindings (get-bindings req)))
-	     (body
+	    (cond
-	      (h1 "Servlet-Administration")
+	     ((returned-via? return-address bindings)
-	      (h2 "Profiling Results")
+	      (profile req "You may continue to make profiles."))
-	      (h3 "Picture")
+	     ((returned-via? reset-return-address bindings)
-	      ,(if (zero? status)
+	      (reset-and-return-to-main-page req))
-		   `(image (@ (src ,picture-file)))
+	     (else
-		   `(p "An error occured while generating the profiling results picture."
+	      (error "unexpected return address")))))))
-		       (br)
+    
-		       "Are you sure, you have " (q "gnuplot") 
+    (define (show-results status picture-file get-total-bytes results
-		       " installed at " (q ,gnuplot) "?"))
+			  return-address reset-return-address)
-	      (hr)
+      (send-html/suspend
-	      (h3 "Data")
+       (lambda (new-url)
-	      (table
+	 `(html 
-	       (tr (th "#") (th "Total bytes occupied"))
+	   (title "Servlet Administration -- Profiling Results")
-	       ,@(map (lambda (num space-info)
+	   (body
-			`(tr (td ,(+ 1 num))
+	    (h1 "Servlet-Administration")
-			     (td ,(get-total-bytes space-info))))
+	    (h2 "Profiling Results")
-		      (iota (length results))
+	    (h3 "Picture")
-		      results))))))))
+	    ,(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)
+    (define (add-file-name-to-delete! file-name)
-      (for-each delete-filesys-object file-names-to-delete))
+      (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)
+      (let ((state (get-servlet-data)))
-      (delete-files)
+	(set-state:counter state 0)
-      (set! file-name (absolute-file-name (create-temp-file "servlet-profiling")))
+	(delete-files state)
-      (set! file-names-to-delete (list file-name)))
+	(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))