scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added options for surflet-handler.

This commit is contained in:
mainzelm 2003-03-17 10:17:55 +00:00
parent 573e980f33
commit 3de0a9c480
2 changed files with 58 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scheme/httpd/surflets/packages.scm
View File

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

89
scheme/httpd/surflets/surflet-handler.scm
View File

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