diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index 7e80758..86afde7 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/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?!)) diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 1a94e34..05ab43f 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/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.