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
(define (get-option-change number-field return-address update-text)
(define (get-option-change return-address update-text options)
(send-html/suspend
(lambda (new-url)
`(html
@ -19,28 +19,41 @@
(h2 "Handler options")
,(and (pair? update-text) update-text)
(p "These are the runtime configurable options of the handler:")
(table
(servlet-form ,new-url
(tr (td "Current instance lifetime: ")
(td ,number-field)
(td ,(make-submit-button "Change")))))
(servlet-form
,new-url
POST
(table
,@(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)
(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)
(let* ((update-text `(font (@ (color "red"))
,(:optional maybe-update-text "")))
(number-field
(make-number-input-field `(@ ((value ,(options-instance-lifetime))))))
(return-address (make-address))
(req (get-option-change number-field return-address update-text))
(make-number-input-field (options-instance-lifetime)))
(cache-checkbox (make-checkbox-input-field (options-cache-servlets?)))
(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)))
(cond
((returned-via? return-address bindings)
(return-to-main-page req))
(else
((input-field-binding submit-timeout bindings)
(with-fatal-error-handler
(lambda (condition more)
(handler-options req "Please enter a valid, positive integer number"))
@ -52,7 +65,18 @@
(handler-options req
(format #f "Instance lifetime changed to ~a."
(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)
(send/finish (make-http-error-response http-status/moved-perm req