Add surflet-path to options (needed by admin-surflets.scm)
This commit is contained in:
parent
6f46e17b11
commit
5581383962
|
@ -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))
|
||||
|
||||
|
|
|
@ -39,7 +39,8 @@
|
|||
;; (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)
|
||||
|
@ -52,8 +53,8 @@
|
|||
(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)))))
|
||||
(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
|
||||
|
@ -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!
|
||||
|
|
Loading…
Reference in New Issue