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

add further configurable option: cache servlets

This commit is contained in:
interp 2002-10-04 15:51:51 +00:00
parent a920462ba1
commit 23dfce1dc7
1 changed files with 36 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
View File

@ -9,7 +9,7 @@
) )
(begin (begin
(define (get-option-change number-field return-address update-text) (define (get-option-change return-address update-text options)
(send-html/suspend (send-html/suspend
(lambda (new-url) (lambda (new-url)
`(html `(html
@ -19,28 +19,41 @@
(h2 "Handler options") (h2 "Handler options")
,(and (pair? update-text) update-text) ,(and (pair? update-text) update-text)
(p "These are the runtime configurable options of the handler:") (p "These are the runtime configurable options of the handler:")
(table (servlet-form
(servlet-form ,new-url ,new-url
(tr (td "Current instance lifetime: ") POST
(td ,number-field) (table
(td ,(make-submit-button "Change"))))) ,@(map (lambda (option)
(let ((text (car option))
(input-field (cadr option))
(submit-button (caddr option)))
`(tr (td ,text)
(td ,input-field)
(td ,submit-button))))
options)))
(hr) (hr)
(URL ,(return-address new-url) "Return to main page"))) (URL ,(return-address new-url) "Return to main page")))
))) )))
(define submit-timeout (make-submit-button "Change"))
(define return-address (make-address))
(define submit-cache (make-submit-button "Change"))
(define (handler-options req . maybe-update-text) (define (handler-options req . maybe-update-text)
(let* ((update-text `(font (@ (color "red")) (let* ((update-text `(font (@ (color "red"))
,(:optional maybe-update-text ""))) ,(:optional maybe-update-text "")))
(number-field (number-field
(make-number-input-field `(@ ((value ,(options-instance-lifetime)))))) (make-number-input-field (options-instance-lifetime)))
(return-address (make-address)) (cache-checkbox (make-checkbox-input-field (options-cache-servlets?)))
(req (get-option-change number-field return-address update-text)) (options `(("Current instance lifetime: " ,number-field ,submit-timeout)
("Cache servlets?" ,cache-checkbox ,submit-cache)))
(req (get-option-change return-address update-text options))
(bindings (get-bindings req))) (bindings (get-bindings req)))
(cond (cond
((returned-via? return-address bindings) ((returned-via? return-address bindings)
(return-to-main-page req)) (return-to-main-page req))
(else ((input-field-binding submit-timeout bindings)
(with-fatal-error-handler (with-fatal-error-handler
(lambda (condition more) (lambda (condition more)
(handler-options req "Please enter a valid, positive integer number")) (handler-options req "Please enter a valid, positive integer number"))
@ -52,7 +65,18 @@
(handler-options req (handler-options req
(format #f "Instance lifetime changed to ~a." (format #f "Instance lifetime changed to ~a."
(options-instance-lifetime)))) (options-instance-lifetime))))
(error "not a positive integer")))))))) (error "not a positive integer")))))
((input-field-binding submit-cache bindings)
(let ((cache-plugins? (if (input-field-binding cache-checkbox bindings)
#t
#f)))
(set-options-cache-servlets? cache-plugins?)
(handler-options req
(format #f "Caching turned ~s"
(if cache-plugins? "on" "off")))))
(else
(error "unexpected return" bindings)))))
(define (return-to-main-page req) (define (return-to-main-page req)
(send/finish (make-http-error-response http-status/moved-perm req (send/finish (make-http-error-response http-status/moved-perm req