remove FIXMEs:

* respect presence of threads - use locks for table accesses
  (*instance-table*, continuation-table, *plugin-table*)
  * return 404 Not found if servlet does not exist
  * neglect POST request (will do this later)
  * reload plugin if timestamp has changed

scheme/httpd/surflets/surflet-handler.scm

@@ -4,25 +4,24 @@
 
 ;;; instance-table: entry for every new request on a servlet page
 (define-record-type instance :instance
-  (make-instance servlet-name continuation-table continuation-counter)
+  (make-instance servlet-name continuation-table continuation-table-lock
+		 continuation-counter)
   instance?
-  (servlet-name really-instance-servlet-name
+  (servlet-name instance-servlet-name)
-		set-instance-servlet-name!)
+  (continuation-table instance-continuation-table)
-  (continuation-table really-instance-continuation-table 
+  (continuation-table-lock instance-continuation-table-lock)
-		      set-instance-continuation-table!)
+  (continuation-counter instance-continuation-counter))
-  (continuation-counter really-instance-continuation-counter
-			set-instance-continuation-counter!))
 
 (define-record-type session :session
-  (really-make-session instance-id return-continuation)
+  (make-session instance-id return-continuation)
   session?
   (instance-id really-session-instance-id 
 	       set-session-instance-id!)
   (return-continuation really-session-return-continuation 
 		       set-session-return-continuation!))
 
-;; FIXME: Make this thread-safe
 (define *instance-table* (make-integer-table)) ; instance-id is index
+(define *instance-table-lock* (make-lock))
 (define random
   (let* ((source  (make-random-source))
 	 (random-integer (begin
@@ -48,7 +47,8 @@
 	    (reset-plugin-cache!)
 	    (make-http-error-response http-status/accepted req "plugin cache cleared"))
 	   ((or (string=? request-method "GET")
-		(string=? request-method "PUT"))
+;		(string=? request-method "POST"))        ; do this at later time
+		)
 	    (with-cwd
 	     servlet-path
 	     (if (resume-url? full-path)
@@ -60,65 +60,95 @@
 	(make-http-error-response http-status/bad-request req 
 				  (format #f "Bad path: ~s" path)))))
 
-;; FIXME: test for file existance
 (define (launch-new-instance full-path req)
-  (let ((instance-id (generate-new-instance-id))
+  (if (file-not-exists? full-path)
-	(plugin (get-plugin-rt-structure full-path)))
+      (make-http-error-response http-status/not-found req full-path)
-    (save-instance! full-path instance-id)	; make entry in instance-table
+      (begin
-    (reset
+	(obtain-lock *instance-table-lock*)
-     (begin
+	;; no access to instance table until new instance-id is saved
-       (register-session! instance-id 'no-return)
+	(let ((instance-id (generate-new-table-id *instance-table*)))
-       (with-names-from-rt-structure 
+	  (table-set! *instance-table* instance-id
-	plugin plugin-interface 
+		      (make-instance full-path    ; used to make
-	(main req))))))
+						  ; redirections to origin
+				     (make-integer-table) ; continuation table
+				     (make-lock)          ; continuation table lock
+				     (make-thread-safe-counter))) ; continuation counter
+	  (release-lock *instance-table-lock*)
+	  (let ((plugin (with-fatal-error-handler*
+			 (lambda (condition decline)
+			   (instance-delete! instance-id)
+			   (decline)) 
+			 (lambda () 
+			   (get-plugin-rt-structure full-path)))))
+	    (reset
+	     (begin
+	       (register-session! instance-id 'no-return)
+	       (with-names-from-rt-structure 
+		plugin plugin-interface 
+		(main req)))))))))
 
 ;; try to get continuation-table and then the continuation
-(define (resume-url full-path req)
+(define resume-url
-  (call-with-current-continuation
+  (let ((bad-request 
-   (lambda (return)
+	 (lambda (full-path req)
-     (with-fatal-error-handler*
+	   (make-http-error-response
-      (lambda (condition decline)
+	    http-status/bad-request req
-	(return (make-http-error-response
+	    (format #f "The servlet does not accept any requests any more or your URL is illformed.<BR>
-		 http-status/bad-request req
-		 (format #f "The servlet does not accept any requests any more or your URL is illformed.<BR>
 You can try starting at the <A HREF=~a>beginning</a>."
-			 (resume-url-servlet-name full-path)))))
+		    (resume-url-servlet-name full-path)))))
-      (lambda ()
+	(lookup-continuation-table
-	(receive (instance-id continuation-id)
+	  (lambda (instance continuation-table continuation-id)
-	    (resume-url-ids full-path)
+	    (let ((continuation-table-lock (instance-continuation-table-lock instance)))
+	      (obtain-lock continuation-table-lock)
+	      (let ((result (table-ref continuation-table continuation-id)))
+		(release-lock continuation-table-lock)
+		result)))))
+
+    (lambda (full-path req)
+      (receive (instance-id continuation-id)
+	  (resume-url-ids full-path)
+	(let ((instance (instance-lookup instance-id)))
+	  (if instance
+	      (let* ((continuation-table (instance-continuation-table instance))
+		     (resume (lookup-continuation-table instance continuation-table 
+							continuation-id)))
+		(if resume
+		    (reset
+		     (begin
+		       (register-session! instance-id 'no-return)
+;		       (error "This may never return." ; for debugging
+		       (resume req)))
+		    (bad-request full-path req)))
+	      (bad-request full-path req)))
+      ))))
+    
 
-	  (let* ((continuation-table (instance-continuation-table instance-id))
-		 (resume (table-ref continuation-table continuation-id)))
-	    (if resume
-		(reset
-		 (begin
-		   (register-session! instance-id 'no-return)
-;		   (error "This may never return." ; for debugging
-		   (resume req)))))))))))
-  
-	
 (define (send-html/suspend html-tree-maker)
   (shift return
 	 (let* ((instance-id (session-instance-id))
-		(continuations-table (instance-continuation-table instance-id))
+		(instance (instance-lookup instance-id))
-		(continuation-counter (instance-next-continuation-counter instance-id))
+		(continuations-table (instance-continuation-table instance))
-		(continuation-id (generate-new-continuation-id instance-id)))
+		(continuation-table-lock (instance-continuation-table-lock instance))
-	   (table-set! continuations-table continuation-id return)
+		(continuation-counter (instance-next-continuation-counter instance)))
-	   (let ((new-url (make-resume-url (instance-servlet-name instance-id)
+	   (obtain-lock continuation-table-lock)
-					   instance-id 
+	   (let ((continuation-id (generate-new-table-id continuations-table)))
-					   continuation-counter
+	     (table-set! continuations-table continuation-id return)
-					   continuation-id)))
+	     (release-lock continuation-table-lock)
-	     (make-usual-html-response
+	     (let ((new-url (make-resume-url (instance-servlet-name instance)
-	      (lambda (out options)
+					     instance-id 
-		(with-current-output-port*
+					     continuation-counter
-		 out
+					     continuation-id)))
-		 (lambda () (SXML->HTML (html-tree-maker new-url))))))))))
+	       (make-usual-html-response
+		(lambda (out options)
+		  (with-current-output-port*
+		   out
+		   (lambda () (SXML->HTML (html-tree-maker new-url)))))))))))
 
 (define (send-html/finish html-tree)
-  (instance-delete (session-instance-id))
+  (instance-delete! (session-instance-id))
   (make-usual-html-response
    (lambda (out options)
-     (with-current-output-port*		; don't want to blame Oleg, but...
+     (with-current-output-port*		; FIXME: will change in further revision
       out
       (lambda ()  (SXML->HTML html-tree))))))
 
@@ -133,92 +163,80 @@ You can try starting at the <A HREF=~a>beginning</a>."
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; access to instance-table
-(define (save-instance! servlet-name instance-id)
+(define (instance-lookup instance-id)
-  (table-set! *instance-table* instance-id
+  (obtain-lock *instance-table-lock*)
-	      (make-instance servlet-name (make-integer-table) 0)))
+  (let ((result (table-ref *instance-table* instance-id)))
-;; FIXME: make continuation-table thread-safe
+    (release-lock *instance-table-lock*)
+    result))
 
-(define (instance instance-id)
+(define (instance-next-continuation-counter instance)
-  (table-ref *instance-table* instance-id))
+  (thread-safe-counter-next! 
-
+   (instance-continuation-counter instance)))
-(define (instance-servlet-name instance-id)
-  (really-instance-servlet-name (instance instance-id)))
-
-(define (instance-continuation-table instance-id)
-  (really-instance-continuation-table (instance instance-id)))
-
-(define (instance-continuation-counter instance-id)
-  (really-instance-continuation-counter (instance instance-id)))
-
-(define (instance-next-continuation-counter instance-id)
-  (let ((instance (instance instance-id)))
-    (set-instance-continuation-counter!
-     instance
-     (+ 1 (really-instance-continuation-counter instance)))
-    (really-instance-continuation-counter instance)))
-
-(define (instance-delete instance-id)
-  (table-set! *instance-table* instance-id #f))
 
+(define (instance-delete! instance-id)
+  (obtain-lock *instance-table-lock*)
+  ;; why can't table entries be deleted correctly?
+  (table-set! *instance-table* instance-id #f)
+  (release-lock *instance-table-lock*))
+ 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; ID generation  
-;; FIXME: make this thread safe
+;; locking must be done by caller
-;; FIXME: this may loop forever, if the table is full (can this happen?)
+;; FIXME?: this may loop forever, if the table is full (can this happen?)
-(define (generate-new-instance-id)
+(define (generate-new-table-id table)
-  (let loop ((instance-id (random)))
+  (let loop ((id (random)))
-    (if (instance instance-id)
+    (if (table-ref table id)
 	(loop (random))
-	instance-id)))
+	id)))
-
-
-;; FIXME make this thread-safe (locks)
-;; FIXME this may loop forever, if the table is full (can this happen?)
-(define (generate-new-continuation-id instance-id)
-  (let ((continuation-table (instance-continuation-table instance-id)))
-    (let loop ((continuation-id (random)))
-      (if (table-ref continuation-table continuation-id)
-	  (loop (random))
-	  continuation-id))))
-				    
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; PLUGINs CACHE
-;; FIXME: make this thread-safe
 (define *plugin-table* (make-string-table)) ; full-path is index
-(define plugin-table-lock (make-lock))
+(define *plugin-table-lock* (make-lock))
 
-;; FIXME: reload  plugin if timestamp has changed
 ;; PLUGIN-NAME is like "news-dir/latest-news.scm"
 (define (get-plugin-rt-structure plugin-name)
+  (let ((load-plugin 
+	 (lambda ()
+	   (with-fatal-error-handler*
+	    (lambda (condition decline)
+	      (release-lock *plugin-table-lock*)
+	      (decline))
+	    (lambda ()
+	      ;; load-config-file does not care about cwd(?)
+	      ;; --> absolute file name needed
+	      (load-config-file (absolute-file-name plugin-name))
+	      ;; plugin-structure to load must be named "plugin"
+	      (let ((plugin-structure (reify-structure 'plugin)))
+		(load-structure plugin-structure)
+		(table-set! *plugin-table* plugin-name 
+			    (cons plugin-structure
+				  (file-last-mod plugin-name)))
+		;; only now the lock may be released
+		(release-lock *plugin-table-lock*)
+		plugin-structure))))))
+
+  (obtain-lock *plugin-table-lock*)
   (let ((plugin (table-ref *plugin-table* plugin-name)))
     (if plugin
-	plugin
+	(if (equal? (file-last-mod plugin-name) 
-	(with-fatal-error-handler*
+		    (cdr plugin))
-	 (lambda (condition decline)
+	    (begin
-	   (release-lock plugin-table-lock)
+	      (release-lock *plugin-table-lock*)
-	   (decline))
+	      (car plugin))
-	 (lambda ()
+	    (load-plugin))
-	   (obtain-lock plugin-table-lock)
+	(load-plugin)))))
-	   ;; load-config-file does not care about cwd(?)
-	   ;; --> absolute file name needed
-	   (load-config-file (absolute-file-name plugin-name))
-	   ;; plugin-structure to load must be named "plugin"
-	   (let ((plugin-structure (reify-structure 'plugin)))
-	     (load-structure plugin-structure)
-	     (table-set! *plugin-table* plugin-name plugin-structure)
-	     (release-lock plugin-table-lock)
-	     plugin-structure))))))
 
 (define (reset-plugin-cache!)
   (with-fatal-error-handler*
    (lambda (condition decline)
-     (release-lock plugin-table-lock)
+     (release-lock *plugin-table-lock*)
      (decline))
    (lambda ()
-     (obtain-lock plugin-table-lock)
+     (obtain-lock *plugin-table-lock*)
      (set! *plugin-table* (make-string-table))
-     (release-lock plugin-table-lock))))
+     (release-lock *plugin-table-lock*))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; SESSION
@@ -226,7 +244,7 @@ You can try starting at the <A HREF=~a>beginning</a>."
 
 (define (register-session! instance-id return-continuation)
   (thread-cell-set! *session* 
-		    (really-make-session instance-id return-continuation)))
+		    (make-session instance-id return-continuation)))
 
 
 ;(define (save-session-return-continuation! return-continuation)
@@ -278,3 +296,38 @@ You can try starting at the <A HREF=~a>beginning</a>."
   (regexp-search? *resume-url-regexp* id-url))
 
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; thread-safe counter
+
+(define-record-type counter :counter
+  (really-make-counter counter lock)
+  (counter counter-counter set-counter-counter!)
+  (lock counter-lock))
+
+(define (make-thread-safe-counter)
+  (really-make-counter 0 (make-lock)))
+
+;;; read current value
+(define (thread-safe-counter counter)
+  (obtain-lock (counter-lock counter))
+  (let ((result (counter-counter counter)))
+    (release-lock (counter-lock counter))
+    result))
+
+;;; make next value and return it
+(define (thread-safe-counter-next! counter)
+  (obtain-lock (counter-lock counter))
+  (let ((result (+ 1 (counter-counter counter))))
+    (set-counter-counter! counter result)
+    (release-lock (counter-lock counter))
+    result))
+
+
+
+
+
+; instance-table thread safe
+; continuation-table thread safe
+; generate-new-instance-id only called if thread safe
+; generate-new-continuation-id only called if thread safe
+; respect plugin timestamp