diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index efeec8d..bfa7e6f 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -116,6 +116,7 @@ adjust-timeout! session-alive? session-surflet-name + options-surflet-path options-session-lifetime options-cache-surflets? options-make-session-timeout-text))) @@ -143,12 +144,15 @@ (define-interface surflet-handler/options-interface (export make-surflet-options + with-surflet-path with-session-lifetime with-cache-surflets? with-make-session-timeout-text + options-surflet-path options-session-lifetime options-cache-surflets? options-make-session-timeout-text + set-options-surflet-path! set-options-session-lifetime! set-options-cache-surflets?! set-options-make-session-timeout-text)) @@ -395,6 +399,7 @@ threads ;SLEEP uri ;URI-PATH-LIST->PATH with-locks ;WITH-LOCK +; inspect-exception ;WITH-INSPECTING-HANDLER ) (files surflet-handler)) diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 155a255..fc3a265 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -39,25 +39,26 @@ ;; (HTTP-)RESPONSE. SURFLET-PATH is a string pointing to the real ;; directory where the SUrflets are searched. (define (surflet-handler surflet-path . maybe-options) - (let-optionals maybe-options ((options (make-default-surflet-options))) + (let-optionals maybe-options + ((options (with-surflet-path surflet-path (make-default-surflet-options)))) (set-thread-fluid! *options* options) (spawn surveillance-thread) (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)))))) + (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 (options-surflet-path) s-req) + (launch-new-session path-string (options-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 @@ -84,6 +85,7 @@ #f ; session-data lifetime)) (values session-id lifetime))) + ;; no access to session table until new session-id is saved (register-instance! session-id) @@ -117,6 +119,8 @@ ;;; SESSION-SURVEILLANCE +(define *timeout-queue*) + (define (timeout-queue-register-session! session-id timeout) (search-tree-set! *timeout-queue* (cons session-id timeout) 'ignore)) @@ -126,7 +130,6 @@ (define (timeout-queue-adjust-session-timeout! session-id new-timeout) (search-tree-set! *timeout-queue* (cons session-id new-timeout) 'ignore)) -(define *timeout-queue*) (define (surveillance-thread) (set! *timeout-queue* (make-search-tree (lambda (p q) (eq? (car p) (car q))) @@ -603,8 +606,10 @@ ;;; OPTIONS: options for the surflet-handler (define-record-type surflet-options :suflet-options - (really-make-surflet-options cache-surflets? session-lifetime make-session-timeout-text) + (really-make-surflet-options surflet-path cache-surflets? + session-lifetime make-session-timeout-text) surflet-options? + (surflet-path surflet-options-surflet-path set-surflet-options-surflet-path!) (cache-surflets? surflet-options-cache-surflets? set-surflet-options-cache-surflets?!) ;; session lifetime is in seconds (session-lifetime surflet-options-session-lifetime set-surflet-options-session-lifetime!) @@ -625,10 +630,13 @@ ;; Constructor with defaults. (define (make-default-surflet-options) - (really-make-surflet-options #t 600 default-make-session-timeout-text)) + (really-make-surflet-options #f #t 600 default-make-session-timeout-text)) (define (copy-surflet-options options) (let ((new-options (make-default-surflet-options))) + (set-surflet-options-surflet-path! + new-options + (surflet-options-surflet-path options)) (set-surflet-options-cache-surflets?! new-options (surflet-options-cache-surflets? options)) @@ -658,6 +666,9 @@ (loop (transformer value options) (cddr stuff)))))) +(define with-surflet-path + (make-surflet-options-transformer + set-surflet-options-surflet-path!)) (define with-cache-surflets? (make-surflet-options-transformer set-surflet-options-cache-surflets?!)) @@ -674,12 +685,16 @@ (define (make-fluid-setter setter) (lambda (value) (setter (thread-fluid *options*) value))) +(define options-surflet-path + (make-fluid-selector surflet-options-surflet-path)) (define options-cache-surflets? (make-fluid-selector surflet-options-cache-surflets?)) (define options-session-lifetime (make-fluid-selector surflet-options-session-lifetime)) (define options-make-session-timeout-text (make-fluid-selector surflet-options-make-session-timeout-text)) +(define set-options-surflet-path! + (make-fluid-setter set-surflet-options-surflet-path!)) (define set-options-cache-surflets?! (make-fluid-setter set-surflet-options-cache-surflets?!)) (define set-options-session-lifetime!