1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
#lang racket/base
(require racket/contract
racket/list
(for-syntax racket/base)
racket/pretty
racket/runtime-path
"configuration-table-structs.rkt"
web-server/http/bindings)
(define configuration-table-sexpr? list?)
(provide/contract
[configuration-table-sexpr? (any/c . -> . boolean?)]
[read-configuration-table (path-string? . -> . configuration-table?)]
[write-configuration-table (configuration-table? path-string? . -> . void)]
[configuration-table->sexpr (configuration-table? . -> . configuration-table-sexpr?)]
[sexpr->configuration-table (configuration-table-sexpr? . -> . configuration-table?)]
[default-configuration-table-path path?])
(define-runtime-path default-configuration-table-path
"../default-web-root/configuration-table.rkt")
(define (get-binding key bindings default)
(first (get-binding* key bindings (list default))))
(define (get-binding* key bindings default)
(with-handlers ([exn:fail? (lambda _ default)])
(extract-binding/single key bindings)))
(define (read-configuration-table table-file-name)
(sexpr->configuration-table (call-with-input-file table-file-name read)))
; parse-configuration-table : tst -> configuration-table
(define (sexpr->configuration-table t)
(define port (get-binding 'port t 80))
(define max-waiting (get-binding 'max-waiting t 511))
(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 `()))
(make-configuration-table
port max-waiting initial-connection-timeout
(parse-host default-host-table)
(map (lambda (h)
(cons (car h) (parse-host (cdr h))))
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)))
(define (configuration-table->sexpr new)
`((port ,(configuration-table-port new))
(max-waiting ,(configuration-table-max-waiting new))
(initial-connection-timeout ,(configuration-table-initial-connection-timeout new))
(default-host-table
,(host-table->sexpr (configuration-table-default-host new)))
(virtual-host-table
. ,(map (lambda (h) (list (car h) (host-table->sexpr (cdr h))))
(configuration-table-virtual-hosts new)))))
; write-configuration-table : configuration-table path -> void
; writes out the new configuration file
(define (write-configuration-table new configuration-path)
(define sexpr (configuration-table->sexpr new))
(call-with-output-file configuration-path
(lambda (out) (pretty-write sexpr out))
#:exists 'truncate))
; host-table->sexpr : host-table
(define (host-table->sexpr host)
(let ([t (host-table-timeouts host)]
[p (host-table-paths host)]
[m (host-table-messages host)])
`(host-table
(default-indices "index.html" "index.htm")
(log-format parenthesized-default)
(messages
(servlet-message ,(messages-servlet m))
(authentication-message ,(messages-authentication m))
(servlets-refreshed ,(messages-servlets-refreshed m))
(passwords-refreshed ,(messages-passwords-refreshed m))
(file-not-found-message ,(messages-file-not-found m))
(protocol-message ,(messages-protocol m))
(collect-garbage ,(messages-collect-garbage m)))
(timeouts
(default-servlet-timeout ,(timeouts-default-servlet t))
(password-connection-timeout ,(timeouts-password t))
(servlet-connection-timeout ,(timeouts-servlet-connection t))
(file-per-byte-connection-timeout ,(timeouts-file-per-byte t))
(file-base-connection-timeout ,(timeouts-file-base t)))
(paths
(configuration-root ,(paths-conf p))
(host-root ,(paths-host-base p))
(log-file-path ,(paths-log p))
(file-root ,(paths-htdocs p))
(servlet-root ,(paths-servlet p))
(mime-types ,(paths-mime-types p))
(password-authentication ,(paths-passwords p))))))
|
