2003-01-19 11:57:27 -05:00
|
|
|
(define-structure surflet surflet-interface
|
2002-12-08 10:49:27 -05:00
|
|
|
(open scheme-with-scsh
|
2002-10-02 11:14:53 -04:00
|
|
|
handle-fatal-error
|
|
|
|
let-opt
|
2003-01-19 11:57:27 -05:00
|
|
|
surflets
|
2003-03-13 06:36:49 -05:00
|
|
|
surflets/error
|
|
|
|
surflet-handler/options
|
2002-10-01 13:44:58 -04:00
|
|
|
)
|
|
|
|
(begin
|
|
|
|
|
2004-07-29 13:24:52 -04:00
|
|
|
(define (get-option-change update-text options)
|
2002-10-01 13:44:58 -04:00
|
|
|
(send-html/suspend
|
|
|
|
(lambda (new-url)
|
|
|
|
`(html
|
2003-01-19 11:57:27 -05:00
|
|
|
(title "SUrflet Adminstration - Handler options")
|
2002-10-01 13:44:58 -04:00
|
|
|
(body
|
2003-01-19 11:57:27 -05:00
|
|
|
(h1 "SUrflet Administration")
|
2002-10-01 13:44:58 -04:00
|
|
|
(h2 "Handler options")
|
|
|
|
,(and (pair? update-text) update-text)
|
|
|
|
(p "These are the runtime configurable options of the handler:")
|
2003-01-19 11:57:27 -05:00
|
|
|
(surflet-form
|
2002-10-04 11:51:51 -04:00
|
|
|
,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)))
|
2002-10-01 13:44:58 -04:00
|
|
|
(hr)
|
2004-07-29 13:24:52 -04:00
|
|
|
(p (url "admin.scm" "Return to adminstration menu.") (br)
|
2003-03-09 15:15:08 -05:00
|
|
|
(url "/" "Return to main menu."))))
|
2002-10-01 13:44:58 -04:00
|
|
|
)))
|
2002-10-04 11:51:51 -04:00
|
|
|
|
|
|
|
(define submit-timeout (make-submit-button "Change"))
|
|
|
|
(define submit-cache (make-submit-button "Change"))
|
2002-10-01 13:44:58 -04:00
|
|
|
|
2002-10-02 11:14:53 -04:00
|
|
|
(define (handler-options req . maybe-update-text)
|
|
|
|
(let* ((update-text `(font (@ (color "red"))
|
|
|
|
,(:optional maybe-update-text "")))
|
|
|
|
(number-field
|
2003-07-08 17:22:06 -04:00
|
|
|
(make-number-field (options-session-lifetime)))
|
|
|
|
(cache-checkbox (make-checkbox (options-cache-surflets?)))
|
2002-12-07 17:26:40 -05:00
|
|
|
(options `(("Current session lifetime: " ,number-field ,submit-timeout)
|
2003-01-19 11:57:27 -05:00
|
|
|
("Cache SUrflets?" ,cache-checkbox ,submit-cache)))
|
2004-07-29 13:24:52 -04:00
|
|
|
(req (get-option-change update-text options))
|
2002-10-02 15:13:14 -04:00
|
|
|
(bindings (get-bindings req)))
|
|
|
|
(cond
|
2003-02-19 13:42:45 -05:00
|
|
|
((returned-via? submit-timeout bindings)
|
2002-10-02 15:13:14 -04:00
|
|
|
(let ((result (input-field-value number-field bindings)))
|
2002-11-07 15:41:35 -05:00
|
|
|
(if result
|
|
|
|
(if (and (integer? result)
|
|
|
|
(> result 0))
|
|
|
|
(begin
|
2003-03-09 13:49:09 -05:00
|
|
|
(set-options-session-lifetime! result)
|
2002-11-07 15:41:35 -05:00
|
|
|
(handler-options req
|
2002-12-07 17:26:40 -05:00
|
|
|
(format #f "Session lifetime changed to ~a."
|
|
|
|
(options-session-lifetime))))
|
2002-11-07 15:41:35 -05:00
|
|
|
(error "not a positive integer"))
|
|
|
|
(handler-options req "Please enter a valid, positive integer number"))))
|
2003-02-19 13:42:45 -05:00
|
|
|
((returned-via? submit-cache bindings)
|
2003-02-19 13:48:24 -05:00
|
|
|
(let ((cache-plugins? (input-field-value cache-checkbox bindings)))
|
2003-03-09 13:49:09 -05:00
|
|
|
(set-options-cache-surflets?! cache-plugins?)
|
2002-10-04 11:51:51 -04:00
|
|
|
(handler-options req
|
2002-10-21 04:38:46 -04:00
|
|
|
(format #f "Caching turned ~s."
|
2002-10-04 11:51:51 -04:00
|
|
|
(if cache-plugins? "on" "off")))))
|
|
|
|
(else
|
|
|
|
(error "unexpected return" bindings)))))
|
|
|
|
|
2002-10-01 13:44:58 -04:00
|
|
|
(define (main req)
|
|
|
|
(handler-options req))
|
|
|
|
|
|
|
|
))
|