90 lines
4.7 KiB
Scheme
90 lines
4.7 KiB
Scheme
(module parse-table mzscheme
|
|
(require (lib "list.ss")
|
|
(lib "contract.ss"))
|
|
(require "configuration-table-structs.ss"
|
|
"bindings.ss")
|
|
|
|
(define (get-binding key bindings default)
|
|
(first (get-binding* key bindings (list default))))
|
|
|
|
(define (get-binding* key bindings default)
|
|
(with-handlers ([exn? (lambda _ default)])
|
|
(extract-binding/single key bindings)))
|
|
|
|
; parse-configuration-table : tst -> configuration-table
|
|
(define (parse-configuration-table t)
|
|
(define port (get-binding 'port t 80))
|
|
(define max-waiting (get-binding 'max-waiting t 40))
|
|
(define initial-connection-timeout (get-binding 'initial-connection-timeout t 30))
|
|
(define default-host-table (get-binding* 'default-host-table t `()))
|
|
(define virtual-host-table (get-binding* 'virtual-host-table t `()))
|
|
(if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout)
|
|
; more here - list? isn't really picky enough
|
|
(list? virtual-host-table))
|
|
(make-configuration-table
|
|
port max-waiting initial-connection-timeout
|
|
(parse-host default-host-table)
|
|
(map (lambda (h)
|
|
(if (and (pair? h) (pair? (cdr h)) (null? (cddr h)))
|
|
(cons (car h) (parse-host (cdr h)))
|
|
(error 'parse-configuration-table "invalid virtual-host entry ~s" h)))
|
|
virtual-host-table))
|
|
(error 'parse-configuration-table "invalid configuration values ~s"
|
|
(list port max-waiting initial-connection-timeout default-host-table virtual-host-table))))
|
|
|
|
; parse-host : tst -> host-table
|
|
(define (parse-host t)
|
|
(define host-table (get-binding* 'host-table t `()))
|
|
(define default-indices (get-binding* 'default-indices host-table `("index.html" "index.htm")))
|
|
(define log-format (get-binding 'log-format host-table 'parenthesized-default))
|
|
(define messages (get-binding* 'messages host-table `()))
|
|
(define servlet-message (get-binding 'servlet-message messages "servlet-error.html"))
|
|
(define authentication-message (get-binding 'authentication-message messages "forbidden.html"))
|
|
(define servlets-refreshed (get-binding 'servlets-refreshed messages "servlet-refresh.html"))
|
|
(define passwords-refreshed (get-binding 'passwords-refreshed messages "passwords-refresh.html"))
|
|
(define file-not-found-message (get-binding 'file-not-found-message messages "not-found.html"))
|
|
(define protocol-message (get-binding 'protocol-message messages "protocol-error.html"))
|
|
(define collect-garbage (get-binding 'collect-garbage messages "collect-garbage.html"))
|
|
(define timeouts (get-binding* 'timeouts host-table `()))
|
|
(define default-servlet-timeout (get-binding 'default-servlet-timeout timeouts 30))
|
|
(define password-connection-timeout (get-binding 'password-connection-timeout timeouts 300))
|
|
(define servlet-connection-timeout (get-binding 'servlet-connection-timeout timeouts (* 60 60 24)))
|
|
(define file-per-byte-connection-timeout (get-binding 'file-per-byte-connection-timeout timeouts 1/20))
|
|
(define file-base-connection-timeout (get-binding 'file-base-connection-timeout timeouts 30))
|
|
(define paths (get-binding* 'paths host-table `()))
|
|
(define configuration-root (get-binding 'configuration-root paths "conf"))
|
|
(define host-root (get-binding 'host-root paths "default-web-root"))
|
|
(define log-file-path (get-binding 'log-file-path paths "log"))
|
|
(define file-root (get-binding 'file-root paths "htdocs"))
|
|
(define servlet-root (get-binding 'servlet-root paths "."))
|
|
(define mime-types (get-binding 'mime-types paths "mime.types"))
|
|
(define password-authentication (get-binding 'password-authentication paths "passwords"))
|
|
(make-host-table
|
|
default-indices log-format
|
|
(make-messages servlet-message
|
|
authentication-message
|
|
servlets-refreshed
|
|
passwords-refreshed
|
|
file-not-found-message
|
|
protocol-message
|
|
collect-garbage)
|
|
(make-timeouts default-servlet-timeout
|
|
password-connection-timeout
|
|
servlet-connection-timeout
|
|
file-per-byte-connection-timeout
|
|
file-base-connection-timeout)
|
|
(make-paths configuration-root
|
|
host-root
|
|
log-file-path
|
|
file-root
|
|
servlet-root
|
|
mime-types
|
|
password-authentication)))
|
|
|
|
; nat? : tst -> bool
|
|
(define (nat? x)
|
|
(and (number? x) (exact? x) (integer? x) (<= 0 x)))
|
|
|
|
(provide/contract
|
|
; XXX contract
|
|
[parse-configuration-table (list? . -> . configuration-table?)])) |