+ Outhouse some components of surflet-handler.

+ Textual restructuring of surflet-handler.
+ Comments added.

scheme/httpd/surflets/handle-fatal.scm

@@ -0,0 +1,24 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Error-Handler
+;; 
+;; Adopted from WITH-FATAL-ERROR-HANDLER, but handles everything that
+;; is catchable. We must catch everything because we also want
+;; exceptions (and warnings) to be catched (e.g. when the surflet is
+;; loaded.)
+(define (with-fatal-handler* handler thunk)
+  (call-with-current-continuation
+    (lambda (accept)
+      ((call-with-current-continuation
+         (lambda (k)
+	   (with-handler (lambda (condition more)
+			   (call-with-current-continuation
+			    (lambda (decline)
+			      (k (lambda () (handler condition decline)))))
+			   (more))	; Keep looking for a handler.
+	      (lambda () (call-with-values thunk accept)))))))))
+		  
+(define-syntax with-fatal-handler 
+  (syntax-rules ()
+    ((with-fatal-handler handler body ...)
+     (with-fatal-handler* handler
+       (lambda () body ...)))))

scheme/httpd/surflets/packages.scm

@@ -128,22 +128,19 @@
 	rt-module-language		;get structures dynamically
 ;	srfi-13				;string
 	srfi-14				;CHAR-SET:DIGIT
-	handle-fatal-error		;WITH-FATAL-ERROR-HANDLER* et al.
+	handle-fatal    		;WITH-FATAL-ERROR-HANDLER* et al.
 	srfi-27				;random numbers
 	locks				;MAKE-LOCK et al.
 	thread-cells			;THREAD-CELL et al.
 	profiling			;PROFILE-SPACE
 	httpd-logging			;HTTP-SYSLOG
 	shift-reset			;SHIFT and RESET
-	conditions			;exception
 	threads				;SLEEP
 	thread-fluids			;FORK-THREAD
 	sxml-to-html			;SXML->HTML
-	scsh				;regexp et al.
+	scheme-with-scsh		;regexp et al.
-;	httpd-file-directory-handlers	;send-file-response
 	srfi-6				;string-ports
-	handle
+	thread-safe-counter
-	scheme
 	)
   (files surflet-handler))
 
@@ -297,3 +294,24 @@
 	handle-fatal-error
 	)
   (files simple-surflet-api))
+
+(define-interface handle-fatal-interface
+  (export with-fatal-handler*
+	  (with-fatal-handler :syntax)))
+
+(define-structure handle-fatal handle-fatal-interface
+  (open scheme conditions handle)
+  (files handle-fatal))
+	
+
+(define-interface thread-safe-counter-interface
+  (export make-thread-safe-counter
+	  thread-safe-counter-value
+	  thread-safe-counter-next!
+	  thread-safe-counter?))
+
+(define-structure thread-safe-counter thread-safe-counter-interface
+  (open scheme 
+	locks
+	define-record-types)
+  (files thread-safe-counter))

scheme/httpd/surflets/surflet-handler.scm

@@ -1,115 +1,39 @@
-;; the surflet handler
+;; The SUrflet handler
 ;; Copyright Andreas Bernauer, 2002
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; GLOBALS
 
+;;; DEBUGging
 (define *debug* #t)
 
-;;; session-table: entry for every new request on a surflet page
+;;; OPTIONS for the SUrflet handler.
-(define-record-type session :session
+;; Preserved thread fluid because between different calls to
-  (make-session surflet-name memo 
+;; surflet-handler the options shall remain the same. SURFLET-HANDLER
-		 continuation-table continuation-table-lock
+;; sets the value (an option record, see end of file)
-		 continuation-counter
-		 surflet-data)
-  session?
-  (surflet-name session-surflet-name)
-  (memo session-memo set-session-memo!)
-  (continuation-table session-continuation-table)
-  (continuation-table-lock session-continuation-table-lock)
-  (continuation-counter session-continuation-counter)
-  (surflet-data session-surflet-data set-session-surflet-data!))
-
-(define-record-type memo :memo
-  (make-memo message value new-memo)
-  memo?
-  (message memo:message set-memo:message) ;kill, killed, adjust-timeout
-  (value memo:value set-memo:value)
-  (new-memo memo:new-memo set-memo:new-memo))
-
-(define (make-default-memo)
-  (make-memo 'kill #f #f))
-
-;; caller must do locking stuff
-(define (memo-killed! memo)
-  (set-memo:message memo 'killed))
-
-(define-record-type instance :instance
-  (make-instance session-id return-continuation)
-  instance?
-  (session-id really-instance-session-id 
-	       set-instance-session-id!)
-  (return-continuation really-instance-return-continuation 
-		       set-instance-return-continuation!))
-
-(define-record-type options :options
-  (make-options surflet-path surflet-prefix cache-surflets? session-lifetime)
-  options?
-  (surflet-path options:surflet-path set-options:surflet-path)
-  (surflet-prefix options:surflet-prefix set-options:surflet-prefix)
-  (cache-surflets? options:cache-surflets? set-options:cache-surflets?)
-  ;; session lifetime is in seconds
-  (session-lifetime options:session-lifetime set-options:session-lifetime))
-
-;;; STATUS is the status code, an exact integer. See httpd/response.scm
-;;;  e.g. (status-code ok)
-;;; CONTENT-TYPE is a string, most probably "text/html".
-;;; HEADERS is a (maybe empty) list of pairs of (string or symbol);
-;;;   Additional headers to send, e.g. '(("Cache-Control" . "no-cache")) or
-;;;   '((Cache-Control . "no-cache")) etc.
-;;; DATA is either
-;;; * a string
-;;; * a list of strings
-;;; This list maybe extended to vectors later.
-(define-record-type surflet-response :surflet-response
-  (make-surflet-response status content-type headers data)
-  surflet-response?
-  (status surflet-response-status)
-  (content-type surflet-response-content-type)
-  (headers surflet-response-headers)
-  (data surflet-response-data))
-
-(define (valid-surflet-response-data? data)
-  (or (string? data) (list? data)))
-
-(define (surflet-response->string surflet-response)
-  (format #f "#{Surflet-response Status: ~a Content-Type: ~s Headers: ~s~%~s~%"
-	  (surflet-response-status surflet-response)
-	  (surflet-response-content-type surflet-response)
-	  (surflet-response-headers surflet-response)
-	  (surflet-response-data surflet-response)))
-
-
-;; Surflet-prefix is unused now. Formerly, it contained the virtual
-;; path prefix for the handler.
-(define (make-default-options surflet-path surflet-prefix)
-  (make-options surflet-path surflet-prefix #t 600))
-
 (define *options* (make-preserved-thread-fluid #f))
-;; preserved thread fluid because between different calls to
-;; surflet-handler the options shall remain the same.
 
-(define (make-fluid-selector selector)
+;;; SURFLET-TABLE cache
-  (lambda () (selector (thread-fluid *options*))))
+(define *surflet-table* (make-string-table)) ; path-string is index
-(define (make-fluid-setter setter)
+(define *surflet-table-lock* (make-lock))
-  (lambda (value)
-    (setter (thread-fluid *options*) value)))
-(define options-surflet-path (make-fluid-selector options:surflet-path))
-(define options-surflet-prefix (make-fluid-selector options:surflet-prefix))
-(define options-cache-surflets? (make-fluid-selector options:cache-surflets?))
-(define options-session-lifetime (make-fluid-selector options:session-lifetime))
-(define set-options-cache-surflets? (make-fluid-setter set-options:cache-surflets?))
-(define set-options-session-lifetime (make-fluid-setter set-options:session-lifetime))
 
+;;; SESSION-TABLE
+;; Every session gets an entry in the hash table. Entries are session
+;; records.
 (define *session-table* (make-integer-table)) ; session-id is index
 (define *session-table-lock* (make-lock))
 
-(define random
+;; INSTANCE is the session that is handled currently.
-  (let* ((source  (make-random-source))
+(define *instance* (make-thread-cell #f))
-	 (random-integer (begin
-			   (random-source-randomize! source)
-			   (random-source-make-integers source))))
-    (lambda ()
-      (random-integer 1073741824))))	; I hope, 1+ billion is enough....
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; SURFLET-HANDLER
+
+;;; SURFLET-HANDLER
+;; Loads a new or resumes a suspended SUrflet; returns a
+;; (HTTP-)RESPONSE. SURFLET-PATH is a string pointing to the real
+;; directory where the SUrflets are searched.
 (define (surflet-handler surflet-path)
   (set-thread-fluid! *options* (make-default-options surflet-path #f))
   (lambda (path req)
@@ -126,10 +50,18 @@
 	(make-error-response (status-code bad-request) req 
 				  (format #f "Bad path: ~s" path)))))
 
+;;; LAUNCH-NEW-SESSION
+;; Loads and runs a new session of a SUrflet installing the RESET
+;; boundary; returns a (HTTP-)RESPONSE. PATH-STRING is the virtual
+;; path of the request, SURFLET-PATH is a string pointing to the real
+;; directory of the SUrflets, and REQ the request of the browser.
 (define (launch-new-session path-string surflet-path req)
+
   (cond 
+
    ((file-not-exists? (absolute-file-name path-string surflet-path))
     (make-error-response (status-code not-found) req path-string))
+
    ((string=? (file-name-extension path-string) ".scm")
     (obtain-lock *session-table-lock*)
     ;; no access to session table until new session-id is saved
@@ -168,6 +100,7 @@
 	     (with-names-from-rt-structure 
 	      surflet surflet-interface 
 	      (main req)))))))))	; Launch serlvet's main procedure.
+
    (else				; We'll serve every non-scm file.
     ;; We need access to SEND-FILE-RESPONSE of
     ;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we
@@ -181,6 +114,11 @@
 			      path-string))
    ))
 
+
+;;; SESSION-SURVEILLANCE
+;; Returns surveillance procedure to be fork-threaded, that kills a
+;; session after TIME-TO-DIE (seconds) has expired. MEMO contains
+;; current status of session.
 (define (session-surveillance session-id time-to-die memo)
   (lambda ()
     (let loop ((time-to-die time-to-die)
@@ -211,8 +149,10 @@
 		 "session-surveillance[~s]: unknown message ~s; dieing"
 		 session-id (memo:message memo)))))))
       
-
+;;; RESUME-URL
-;; try to get continuation-table and then the continuation
+;; Resumes a suspended URL and returns a (HTTP-)RESPONSE. PATH-STRING
+;; is the virtual path, SURFLET-PATH a string pointing to the real
+;; directory of the SUrflets and REQ the request of the browser.
 (define resume-url
   (let ((bad-request 
 	 (lambda (path-string req)
@@ -240,6 +180,7 @@
     (lambda (path-string surflet-path req)
       (receive (session-id continuation-id)
 	  (resume-url-ids path-string)
+	;; try to get continuation-table and then the continuation
 	(let ((session (session-lookup session-id)))
 	  (if session
 	      (let* ((continuation-table (session-continuation-table session))
@@ -256,7 +197,14 @@
 	))))
 
 
-;; RESPONSE-MAKER is a procedure returnig a SURFLET-RESPONSE.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; SURFLET-INTERFACE
+
+;;; SEND/SUSPEND
+;; Suspends current computation, saves current continuation, and
+;; leaves current continuation via SHIFT with a (HTTP-)RESPONSE.
+;; RESPONSE-MAKER is a procedure returnig a SURFLET-RESPONSE (that is,
+;; eventually converted to a HTTP-RESPONSE).
 (define (send/suspend response-maker)
   (shift return
 	 (let* ((session-id (instance-session-id))
@@ -280,19 +228,33 @@
 	       (make-error-response (status-code not-found) #f
 					 "The URL refers to a SUrflet, whose session is no longer alive.")))))
 
+;;; SEND/FINISH
+;; Kills current session, and leaves current continuation returning
+;; via SHIFT with a (HTTP-)RESPONSE. RESPONSE is a SURFLET-RESPONSE.
 (define (send/finish response)
   (delete-session! (instance-session-id))
   (shift unused (make-http-response response)))
 
+
+;;; SEND
+;; Leaves current continuation via SHIFT with a
+;; (HTTP-)RESPONSE. RESPONSE is a SURFLET-RESPONSE.
 (define (send response)
   (shift unused (make-http-response response)))
 
-;; REQ may be #f in some (most) cases.
+;;; SEND-ERROR
+;; Stops current computation, and leaves current continuation via
+;; SHIFT with a (HTTP-)(ERROR-)RESPONSE. STATUS-CODE is a status code
+;; from HTTP-RESPONSES, REQ a request (may be #f) and MESSAGES
+;; contains further informations (arbitrary types).
 (define (send-error status-code req . messages)
   (shift unused (apply make-error-response 
 		       (cons status-code 
 			     (cons #f messages)))))
 
+;;; MAKE-HTTP-RESPONSE
+;; Converts a SURFLET-RESPONSE to a (HTTP-)RESPONSE. Returns a
+;; (HTTP-)RESPONSE.
 (define (make-http-response response)
   (cond
    ((surflet-response? response)
@@ -321,19 +283,28 @@
     (make-error-response (status-code bad-gateway) #f
 			 "The SUrflet returned an invalid response object (no surflet-response)."))))
 
-    
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; access to session-table
+;;; SESSIONS
+
+;;; SESSION-LOOKUP
+;; Looks up SESSION-ID in the *SESSION-TABLE* (locking) and returns
+;; the SESSION record, if anby (#f otherwise).
 (define (session-lookup session-id)
   (obtain-lock *session-table-lock*)
   (let ((result (table-ref *session-table* session-id)))
     (release-lock *session-table-lock*)
     result))
 
+;;; SESSION-NEXT-CONTINUATION-COUNTER
+;; Increases the SESSION-CONTINUATION-COUNTER in the SESSION record by
+;; one.
 (define (session-next-continuation-counter session)
   (thread-safe-counter-next! 
    (session-continuation-counter session)))
 
+;;; DELETE-SESSION!
+;; Deletes the session indicated by its number SESSION-ID from the
+;; *SESSION-TABLE* (locking).
 (define (delete-session! session-id)
   (obtain-lock *session-table-lock*)
   ;; notify surveillance of session being alread killed (prevents
@@ -345,6 +316,8 @@
   (table-set! *session-table* session-id #f)
   (release-lock *session-table-lock*))
  
+;;; SESSION-ADJUST-TIMEOUT!
+;; Resets time-to-die of session indicated by its SESSION-ID number.
 (define (session-adjust-timeout! session-id)
   (obtain-lock *session-table-lock*)
   (let* ((session (table-ref *session-table* session-id))
@@ -360,25 +333,31 @@
     (set-memo:message memo 'adjust-timeout))
   (release-lock *session-table-lock*))
 
-;; adjusts the timeout of the current session
+;;; ADJUST-TIMEOUT
+;; Resets time-to-die of current session.
 (define (adjust-timeout)
   (session-adjust-timeout! (instance-session-id)))
 
+;;; RESET-SESSION-TABLE!
+;; Clears the *SESSION-TABLE* (locking)
 (define (reset-session-table!)
-  (with-fatal-error-handler
+  (with-fatal-handler
    (lambda (condtion decline)
      (release-lock *session-table-lock*)
      (decline))
-   (lambda ()
+   (obtain-lock *session-table-lock*)
-     (obtain-lock *session-table-lock*)
+   ;; notify session killing
-     ;; notify session killing
+   (table-walk 
-     (table-walk 
+    (lambda (session-id session)
-      (lambda (session-id session)
+      (memo-killed! (session-memo session)))
-	(memo-killed! (session-memo session)))
+    *session-table*)
-      *session-table*)
+   (set! *session-table* (make-integer-table))
-     (set! *session-table* (make-integer-table))
+   (release-lock *session-table*)))
-     (release-lock *session-table*))))
 
+;;; GET-SESSIONS
+;; Returns a list of all active sessions in *SESSION-TABLE*
+;; (locking). The list elements are pairs of session-id and session
+;; record.
 (define (get-sessions)
   (obtain-lock *session-table-lock*)
   (let ((sessions '()))
@@ -389,6 +368,10 @@
     (release-lock *session-table-lock*)
     sessions))
 
+;;; GET-CONTINUATIONS
+;; Returns a list of all continuations of the session indicated by the
+;; SESSION-ID number (locking). The list elements are pairs of
+;; continuation id and continuation.
 (define (get-continuations session-id)
   (let ((session (session-lookup session-id)))
     (if session
@@ -405,6 +388,8 @@
 	  continuations)
 	'())))
 
+;;; DELETE-CONTINUATION
+;; Deletes continuation SESSION-ID, CONTINUATION-ID (locking).
 (define (delete-continuation! session-id continuation-id)
   (let ((session (session-lookup session-id)))
     (if session
@@ -415,7 +400,10 @@
 	  (if (table-ref continuation-table continuation-id)
 	      (table-set! continuation-table continuation-id #f))
 	  (release-lock continuation-table-lock)))))
-	
+
+;;; SET-SURFLET-DATA!, GET-SURFLET-DATA
+;; Access to arbitrary data stored along with current session (no
+;; locking!).
 (define (set-surflet-data! new-data)
   (let ((session (session-lookup (instance-session-id))))
     (if session
@@ -431,21 +419,26 @@
 	(error "Instance no longer alive."))))
 	
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ID generation  
+;;; ID generation  
-;; locking must be done by caller
+
-;; FIXME?: this may loop forever, if the table is full (can this happen?)
+;;; GENERATE-NEW-TABLE-ID
+;; Returns a random integer not used in the hash TABLE (no
+;; locking!). The locking has to happe elsewhere. 
 (define (generate-new-table-id table)
   (let loop ((id (random)))
     (if (table-ref table id)
+	;; FIXME?: this may loop forever, if the table is full (can
+	;; this ever happen?)
 	(loop (random))
 	id)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; SURFLETs CACHE
-(define *surflet-table* (make-string-table)) ; path-string is index
-(define *surflet-table-lock* (make-lock))
 
-;; SURFLET-NAME is like "news-dir/latest-news.scm"
+;;; GET-SURFLET-RT-STRUCTURE
+;; Returns SUrflet's RT-STRUCTURE indicated by SURFLET-NAME (a virtual
+;; path string) while managing the SUrflet cache *SURFLET-TABLE*
+;; (locking).
 (define (get-surflet-rt-structure surflet-name directory)
   (let* ((full-surflet-name (absolute-file-name surflet-name directory))
 	 (load-surflet 
@@ -487,6 +480,8 @@
 		(load-surflet #t))))
 	(load-surflet #f))))
 
+;;; GET-LOADED-SURFLETS
+;; Returns list of all loaded surflets (real path strings).
 (define (get-loaded-surflets)
   (obtain-lock *surflet-table-lock*)
   (let ((loaded-surflets '()))
@@ -497,35 +492,37 @@
     (release-lock *surflet-table-lock*)
     loaded-surflets))
 
+;;; UNLOAD-SURFLET
+;; Removes SURFLET-NAME from the *SURFLET-TABLE* cache (locking).
 (define (unload-surflet surflet-name)
   (obtain-lock *surflet-table-lock*)
   (if (table-ref *surflet-table* surflet-name)
       (table-set! *surflet-table* surflet-name #f))
   (release-lock *surflet-table-lock*))
 
+;;; RESET-SURFLET-CACHE!
+;; Clears *SURFLET-TABLE* (locking).
 (define (reset-surflet-cache!)
-  (with-fatal-error-handler*
+  (with-fatal-handler
    (lambda (condition decline)
      (release-lock *surflet-table-lock*)
      (decline))
-   (lambda ()
+   (obtain-lock *surflet-table-lock*)
-     (obtain-lock *surflet-table-lock*)
+   (set! *surflet-table* (make-string-table))
-     (set! *surflet-table* (make-string-table))
+   (release-lock *surflet-table-lock*)))
-     (release-lock *surflet-table-lock*))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; INSTANCE
+;;; INSTANCE
-(define *instance* (make-thread-cell #f))
 
+;;; REGISTER-INSTANCE!
+;; Saves values for current session (in a record).
 (define (register-instance! session-id return-continuation)
   (thread-cell-set! *instance* 
 		    (make-instance session-id return-continuation)))
 
 
-;(define (save-instance-return-continuation! return-continuation)
+;;; INSTANCE-SESSION-ID
-;  (set-instance-session-id! (thread-cell-ref *instance*)
+;; Returns session-id of current *INSTANCE*.
-;			    return-continuation))
-
 (define (instance-session-id)
   (really-instance-session-id (thread-cell-ref *instance*)))
 
@@ -534,93 +531,49 @@
   (really-instance-return-continuation (thread-cell-ref *instance*)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; RESUME-URL
+;;; RESUME-URL
+
+;; Functions and constants for generating and parsing Continuation
+;; URLs (= resume URLs). Resume URLs look like
+;; http://localhost:8088/surflet/admin-handler.scm;k757033335;c1-684902143?return54=
 (define *resume-url-regexp* (rx (submatch (* (- printing ";"))) 
 				";k" (submatch (* digit)) ; Instance-ID
-				";c" (+ digit) "-" (submatch (* digit)))) ; Continuation-ID
+				";c" (+ digit)            ; Continuation Counter
+				"-" (submatch (* digit)))) ; Continuation-ID
 
+;; All arguments are numbers except PATH-STRING, which is a string.
 (define (make-resume-url path-string session-id continuation-counter continuation-id)
   (string-append path-string
 		 ";k" (number->string (instance-session-id)) 
 		 ";c" (number->string continuation-counter)
 		 "-" (number->string continuation-id)))
 
-(define (resume-url-session-id id-url)
+;; Return various parts of RESUME-URL
+(define (resume-url-session-id resume-url)
   (receive (session-id continuation-id)
-      (resume-url-ids id-url)
+      (resume-url-ids resume-url)
     session-id))
 
-(define (resume-url-continuation-id id-url)
+(define (resume-url-continuation-id resume-url)
   (receive (session-id continuation-id)
-      (resume-url-ids id-url)
+      (resume-url-ids resume-url)
     continuation-id))
 
-(define (resume-url-ids id-url)
+(define (resume-url-ids resume-url)
-  (let ((match (regexp-search *resume-url-regexp* id-url)))
+  (let ((match (regexp-search *resume-url-regexp* resume-url)))
     (if match
 	(values (string->number (match:substring match 2))
 		(string->number (match:substring match 3)))
 	(values #f #f))))
 
-(define (resume-url-surflet-name id-url)
+(define (resume-url-surflet-name resume-url)
-  (let ((match (regexp-search *resume-url-regexp* id-url)))
+  (let ((match (regexp-search *resume-url-regexp* resume-url)))
     (if match
 	(match:substring match 1)
 	(values #f #f))))
 
-(define (resume-url? id-url)
+(define (resume-url? resume-url)
-  (regexp-search? *resume-url-regexp* id-url))
+  (regexp-search? *resume-url-regexp* resume-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))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Error-Handler
-;; 
-;; Adopted from WITH-FATAL-ERROR-HANDLER, but handles everything that
-;; is catchable. We must catch everything because we also want
-;; exceptions (and warnings) to be catched (e.g. when the surflet is
-;; loaded.)
-(define (with-fatal-handler* handler thunk)
-  (call-with-current-continuation
-    (lambda (accept)
-      ((call-with-current-continuation
-         (lambda (k)
-	   (with-handler (lambda (condition more)
-			   (call-with-current-continuation
-			    (lambda (decline)
-			      (k (lambda () (handler condition decline)))))
-			   (more))	; Keep looking for a handler.
-	      (lambda () (call-with-values thunk accept)))))))))
-		  
-(define-syntax with-fatal-handler 
-  (syntax-rules ()
-    ((with-fatal-handler handler body ...)
-     (with-fatal-handler* handler
-       (lambda () body ...)))))
 
 (define (bad-gateway-error-response req path-string condition)
   (make-error-response 
@@ -628,6 +581,119 @@
    (format #f "Error in surflet ~s." path-string)
    condition))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Record types
+
+;;; SESSION: session-table entry for every new request on a surflet page
+(define-record-type session :session
+  (make-session surflet-name memo 
+		 continuation-table continuation-table-lock
+		 continuation-counter
+		 surflet-data)
+  session?
+  (surflet-name session-surflet-name)
+  (memo session-memo set-session-memo!)
+  (continuation-table session-continuation-table)
+  (continuation-table-lock session-continuation-table-lock)
+  (continuation-counter session-continuation-counter)
+  (surflet-data session-surflet-data set-session-surflet-data!))
+
+;;; MEMO: Information for session surveiller about session status
+(define-record-type memo :memo
+  (make-memo message value new-memo)
+  memo?
+  (message memo:message set-memo:message) ;kill, killed, adjust-timeout
+  (value memo:value set-memo:value)
+  (new-memo memo:new-memo set-memo:new-memo))
+
+(define (make-default-memo)
+  (make-memo 'kill #f #f))
+
+;; caller must do locking stuff
+(define (memo-killed! memo)
+  (set-memo:message memo 'killed))
+
+
+;;; INSTANCE: Every request corresponds to an instance.
+(define-record-type instance :instance
+  (make-instance session-id return-continuation)
+  instance?
+  (session-id really-instance-session-id 
+	       set-instance-session-id!)
+  (return-continuation really-instance-return-continuation 
+		       set-instance-return-continuation!))
+
+
+;;; OPTIONS: options for the surflet-handler
+(define-record-type options :options
+  (make-options surflet-path surflet-prefix cache-surflets? session-lifetime)
+  options?
+  (surflet-path options:surflet-path set-options:surflet-path)
+  (surflet-prefix options:surflet-prefix set-options:surflet-prefix)
+  (cache-surflets? options:cache-surflets? set-options:cache-surflets?)
+  ;; session lifetime is in seconds
+  (session-lifetime options:session-lifetime set-options:session-lifetime))
+
+;; Constructor with defaults.
+(define (make-default-options surflet-path surflet-prefix)
+  (make-options surflet-path surflet-prefix #t 600))
+
+;; Selectors for *options* (preserved-thread-fluid)
+(define (make-fluid-selector selector)
+  (lambda () (selector (thread-fluid *options*))))
+(define (make-fluid-setter setter)
+  (lambda (value)
+    (setter (thread-fluid *options*) value)))
+(define options-surflet-path (make-fluid-selector options:surflet-path))
+(define options-surflet-prefix (make-fluid-selector options:surflet-prefix))
+(define options-cache-surflets? (make-fluid-selector options:cache-surflets?))
+(define options-session-lifetime (make-fluid-selector options:session-lifetime))
+(define set-options-cache-surflets? (make-fluid-setter set-options:cache-surflets?))
+(define set-options-session-lifetime (make-fluid-setter set-options:session-lifetime))
+
+
+;;; SURFLET-RESPONSE: Surflets are expected to return this object type.
+;;; STATUS is the status code, an exact integer. See httpd/response.scm
+;;;  e.g. (status-code ok)
+;;; CONTENT-TYPE is a string, most probably "text/html".
+;;; HEADERS is a (maybe empty) list of pairs of (string or symbol);
+;;;   Additional headers to send, e.g. '(("Cache-Control" . "no-cache")) or
+;;;   '((Cache-Control . "no-cache")) etc.
+;;; DATA is either
+;;; * a string
+;;; * a list of strings
+;;; This list maybe extended to vectors later.
+(define-record-type surflet-response :surflet-response
+  (make-surflet-response status content-type headers data)
+  surflet-response?
+  (status surflet-response-status)
+  (content-type surflet-response-content-type)
+  (headers surflet-response-headers)
+  (data surflet-response-data))
+
+;; Allowed type for the data field.
+(define (valid-surflet-response-data? data)
+  (or (string? data) (list? data)))
+
+;; For debug purposes
+(define (surflet-response->string surflet-response)
+  (format #f "#{Surflet-response Status: ~a Content-Type: ~s Headers: ~s~%~s~%"
+	  (surflet-response-status surflet-response)
+	  (surflet-response-content-type surflet-response)
+	  (surflet-response-headers surflet-response)
+	  (surflet-response-data surflet-response)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; RANDOM SOURCE
+
+(define random
+  (let* ((source  (make-random-source))
+	 (random-integer (begin
+			   (random-source-randomize! source)
+			   (random-source-make-integers source))))
+    (lambda ()
+      (random-integer 1073741824))))	; I hope, 1+ billion is enough....
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; DEBUGGING

scheme/httpd/surflets/thread-safe-counter.scm

@@ -0,0 +1,26 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; thread-safe counter
+
+(define-record-type counter :counter
+  (really-make-counter counter lock)
+  thread-safe-counter?
+  (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-value 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))