Added options for surflet-handler.

scheme/httpd/surflets/packages.scm

@@ -143,7 +143,6 @@
 (define-interface surflet-handler/options-interface
   (export options-session-lifetime
 	  options-cache-surflets?
-	  options-surflet-path
 	  set-options-session-lifetime!
 	  set-options-cache-surflets?!))
 

scheme/httpd/surflets/surflet-handler.scm

@@ -38,24 +38,25 @@
 ;; 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))
-  (lambda (path req)
-    (if (pair? path)			; need at least one element
-	(let ((request-method (request-method req))
-	      (path-string (uri-path->uri path)))
-	  (if (or (string=? request-method "GET")
-		  (string=? request-method "POST"))
-	      (make-input-response
-	       (lambda (input-port)
-		 (let ((s-req (make-surflet-request req input-port)))
-		   (if (resume-url? path-string)
-		       (resume-url path-string surflet-path s-req)
-		       (launch-new-session path-string surflet-path s-req)))))
-	      (make-error-response (status-code method-not-allowed) req 
-				   request-method)))
-	(make-error-response (status-code bad-request) req 
-				  (format #f "Bad path: ~s" path)))))
+(define (surflet-handler surflet-path . maybe-options)
+  (let-optionals maybe-options ((options (make-default-surflet-options)))
+    (set-thread-fluid! *options* options)
+    (lambda (path req)
+      (if (pair? path)			; need at least one element
+          (let ((request-method (request-method req))
+                (path-string (uri-path->uri path)))
+            (if (or (string=? request-method "GET")
+                    (string=? request-method "POST"))
+                (make-input-response
+                 (lambda (input-port)
+                   (let ((s-req (make-surflet-request req input-port)))
+                     (if (resume-url? path-string)
+                         (resume-url path-string surflet-path s-req)
+                         (launch-new-session path-string surflet-path s-req)))))
+                (make-error-response (status-code method-not-allowed) req 
+                                     request-method)))
+          (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
@@ -653,17 +654,40 @@
 
 
 ;;; OPTIONS: options for the surflet-handler
-(define-record-type options :options
-  (make-options surflet-path cache-surflets? session-lifetime)
-  options?
-  (surflet-path options:surflet-path set-options:surflet-path!)
-  (cache-surflets? options:cache-surflets? set-options:cache-surflets?!)
+(define-record-type surflet-options :suflet-options
+  (make-surflet-options cache-surflets? session-lifetime)
+  surflet-options?
+  (cache-surflets? surflet-options-cache-surflets? set-surflet-options-cache-surflets?!)
   ;; session lifetime is in seconds
-  (session-lifetime options:session-lifetime set-options:session-lifetime!))
+  (session-lifetime surflet-options-session-lifetime set-surflet-options-session-lifetime!))
 
 ;; Constructor with defaults.
-(define (make-default-options surflet-path)
-  (make-options surflet-path #t 600))
+(define (make-default-surflet-options)
+  (make-surflet-options #t 600))
+
+(define (copy-surflet-options options)
+  (let ((new-options (make-default-surflet-options)))
+    (set-surflet-options-cache-surflets?!
+     new-options
+     (surflet-options-cache-surflets? options))
+    (set-surflet-options-session-lifetime!
+     new-options
+     (surflet-options-session-lifetime options))))
+
+(define (make-surflet-options-transformer set-option!)
+  (lambda (new-value . stuff)
+    (let ((new-options (if (not (null? stuff))
+			   (copy-surflet-options (car stuff))
+			   (make-default-surflet-options))))
+      (set-option! new-options new-value)
+      new-options)))
+
+(define with-cache-surflets?
+  (make-surflet-options-transformer
+   set-surflet-options-cache-surflets?!))
+(define with-session-lifetime
+  (make-surflet-options-transformer
+   set-surflet-options-session-lifetime!))
 
 ;; Selectors for *options* (preserved-thread-fluid)
 (define (make-fluid-selector selector)
@@ -671,11 +695,14 @@
 (define (make-fluid-setter setter)
   (lambda (value)
     (setter (thread-fluid *options*) value)))
-(define options-surflet-path (make-fluid-selector options:surflet-path))
-(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!))
+(define options-cache-surflets? 
+  (make-fluid-selector surflet-options-cache-surflets?))
+(define options-session-lifetime 
+  (make-fluid-selector surflet-options-session-lifetime))
+(define set-options-cache-surflets?! 
+  (make-fluid-setter set-surflet-options-cache-surflets?!))
+(define set-options-session-lifetime! 
+  (make-fluid-setter set-surflet-options-session-lifetime!))
 
 
 ;;; SURFLET-RESPONSE: Surflets are expected to return this object type.