1 # httpd.tcl --
2 #
3 # This is the OTcl version of tcl-only HTTP server included in
4 # tcllib distribution.
5 #
6 # Copyright (c) 1996-2002 The Regents of the University of California.
7 # All rights reserved.
8 #
9 # Redistribution and use in source and binary forms, with or without
10 # modification, are permitted provided that the following conditions are met:
11 #
12 # A. Redistributions of source code must retain the above copyright notice,
13 # this list of conditions and the following disclaimer.
14 # B. Redistributions in binary form must reproduce the above copyright notice,
15 # this list of conditions and the following disclaimer in the documentation
16 # and/or other materials provided with the distribution.
17 # C. Neither the names of the copyright holders nor the names of its
18 # contributors may be used to endorse or promote products derived from this
19 # software without specific prior written permission.
20 #
21 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
22 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
25 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
26 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
28 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
29 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 #
32 # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/httpd/httpd.tcl,v 1.1 2002/05/28 19:53:41 weitsang Exp $
33
34 # Simple Sample httpd/1.[01] server
35 # Stephen Uhler (c) 1996-1997 Sun Microsystems
36
37 # Httpd is a $self instvar array containing the global server state
38 # root: the root of the document directory
39 # port: The port this server is serving
40 # listen: the main listening socket id
41 # accepts: a count of accepted connections so far
42 # maxtime: The max time (msec) allowed to complete an http request
43 # maxused: The max # of requests for a socket
44
45 # HTTP/1.[01] error codes (the ones we use)
46
47 # Start the server by listening for connections on the desired port.
48
49 Class Httpd
50
51 Httpd instproc init {root {port 80} {default index.html}} {
52 $self instvar config_ errors_
53
54 $self set errorfmt_ {
55 <title>Error: %1$s</title>
56 Got the error: <b>%2$s</b><br>
57 while trying to obtain <b>%3$s</b>
58 }
59
60 array set config_ {
61 bufsize 32768
62 maxtime 600000
63 maxused 25
64 }
65 array set errors_ {
66 204 {No Content}
67 400 {Bad Request}
68 404 {Not Found}
69 408 {Request Timeout}
70 411 {Length Required}
71 419 {Expectation Failed}
72 503 {Service Unavailable}
73 504 {Service Temporarily Unavailable}
74 }
75 array set mimetype_ {
76 {} text/plain
77 .txt text/plain
78 .html text/html
79 .gif image/gif
80 .jpg image/jpeg
81 }
82
83 catch {close config_(port)} ;# it might already be running
84 array set config_ [list root $root default $default port $port]
85 array set config_ [list accepts 0 requests 0 errors 0]
86 set config_(listen) [socket -server "$self accept" $port]
87 return $config_(port)
88 }
89
90 # Accept a new connection from the server and set up a handler
91 # to read the request from the client.
92
93 Httpd instproc accept {sock ipaddr {port {}}} {
94 $self instvar config_
95 upvar #0 Httpd$sock data
96
97 incr config_(accepts)
98 $self reset $sock $config_(maxused)
99 $self log $sock Connect $ipaddr $port
100 }
101
102 # Initialize or reset the socket state
103
104 Httpd instproc reset {sock left} {
105 $self instvar config_
106 upvar #0 Httpd$sock data
107
108 array set data [list state start linemode 1 version 0 left $left]
109 set data(cancel) [after $config_(maxtime) [list $self timeout $sock]]
110 fconfigure $sock -blocking 0 -buffersize $config_(bufsize) \
111 -translation {auto crlf}
112 fileevent $sock readable [list $self read $sock]
113 }
114
115 # Read data from a client request
116 # 1) read the request line
117 # 2) read the mime headers
118 # 3) read the additional data (if post && content-length not satisfied)
119
120 Httpd instproc read {sock} {
121 $self instvar config_
122 upvar #0 Httpd$sock data
123
124 # Use line mode to read the request and the mime headers
125
126 if {$data(linemode)} {
127 set readCount [gets $sock line]
128 set state [string compare $readCount 0],$data(state)
129 switch -glob -- $state {
130 1,start {
131 if {[regexp {(HEAD|POST|GET) ([^?]+)\??([^ ]*) HTTP/1.([01])} $line \
132 x data(proto) data(url) data(query) data(version)]} {
133 set data(state) mime
134 incr config_(requests)
135 $self log $sock Request $data(left) $line
136 } else {
137 $self error $sock 400 $line
138 }
139 }
140 0,start {
141 $self log $sock Warning "Initial blank line fetching request"
142 }
143 1,mime {
144 if {[regexp {([^:]+):[ ]*(.*)} $line {} key value]} {
145 set key [string tolower $key]
146 set data(key) $key
147 if {[info exists data(mime,$key)]} {
148 append data(mime,$key) ", $value"
149 } else {
150 set data(mime,$key) $value
151 }
152 } elseif {[regexp {^[ ]+(.+)} $line {} value] && \
153 [info exists data(key)]} {
154 append data(mime,$data($key)) " " $value
155 } else {
156 $self error $sock 400 $line
157 }
158 }
159 0,mime {
160 if {$data(proto) == "POST" && \
161 [info exists data(mime,content-length)]} {
162 set data(linemode) 0
163 set data(count) $data(mime,content-length)
164 if {$data(version) && [info exists data(mime,expect]} {
165 if {$data(mime,expect) == "100-continue"} {
166 puts $sock "100 Continue HTTP/1.1\n"
167 flush $sock
168 } else {
169 $self error $sock 419 $data(mime,expect)
170 }
171 }
172 fconfigure $sock -translation {binary crlf}
173 } elseif {$data(proto) != "POST"} {
174 $self respond $sock
175 } else {
176 $self error $sock 411 "Confusing mime headers"
177 }
178 }
179 -1,* {
180 if {[eof $sock]} {
181 $self log $sock Error "Broken connection fetching request"
182 $self sockdone $sock 1
183 } else {
184 puts stderr "Partial read, retrying"
185 }
186 }
187 default {
188 $self error $sock 404 "Invalid http state: $state,[eof $sock]"
189 }
190 }
191
192 # Use counted mode to get the post data
193
194 } elseif {![eof $sock]} {
195 append data(postdata) [read $sock $data(count)]
196 set data(count) [expr {$data(mime,content-length) - \
197 [string length $data(postdata)]}]
198 if {$data(count) == 0} {
199 $self respond $sock
200 }
201 } else {
202 $self log $sock Error "Broken connection reading POST data"
203 $self sockdone $sock 1
204 }
205 }
206
207 # Done with the socket, either close it, or set up for next fetch
208 # sock: The socket I'm done with
209 # close: If true, close the socket, otherwise set up for reuse
210
211 Httpd instproc sockdone {sock close} {
212 $self instvar config_
213 upvar #0 Httpd$sock data
214 after cancel $data(cancel)
215 set left [incr data(left) -1]
216 unset data
217 if {$close} {
218 close $sock
219 } else {
220 $self reset $sock $left
221 }
222 return ""
223 }
224
225 # A timeout happened
226
227 Httpd instproc timeout {sock} {
228 $self instvar config_
229 upvar #0 Httpd$sock data
230 $self error $sock 408
231 }
232
233 # Handle file system queries. This is a place holder for a more
234 # generic dispatch mechanism.
235
236 Httpd instproc respond {sock} {
237 $self instvar config_ urlcache_
238 upvar #0 Httpd$sock data
239 #puts [array get data]
240
241 regsub {(^http://[^/]+)?} $data(url) {} url
242 if {[info exists urlcache_($url)]} {
243 set mypath $urlcache_($url)
244 } else {
245 set mypath [$self url2file $config_(root) $url]
246 if {[file isdirectory $mypath]} {
247 append mypath / $config_(default)
248 }
249 set urlcache_($url) $mypath
250 }
251 if {[string length $mypath] == 0} {
252 $self error $sock 400
253 } elseif {![file readable $mypath]} {
254 $self error $sock 404 $mypath
255 } else {
256 puts $sock "HTTP/1.$data(version) 200 Data follows"
257 puts $sock "Date: [$self date [clock seconds]]"
258 puts $sock "Last-Modified: [$self date [file mtime $mypath]]"
259 puts $sock "Content-Type: [$self contenttype $mypath]"
260 puts $sock "Content-Length: [file size $mypath]"
261
262 ## Should also close socket if recvd connection close header
263 set close [expr {$data(left) == 0}]
264
265 if {$close} {
266 puts $sock "Connection close:"
267 } elseif {$data(version) == 0 && [info exists data(mime,connection)]} {
268 if {$data(mime,connection) == "Keep-Alive"} {
269 set close 0
270 puts $sock "Connection: Keep-Alive"
271 }
272 }
273 puts $sock ""
274 flush $sock
275
276 if {$data(proto) != "HEAD"} {
277 set in [open $mypath]
278 fconfigure $sock -translation binary
279 fconfigure $in -translation binary
280 fcopy $in $sock -command [list $self copydone $in $sock $close]
281 } else {
282 $self sockdone $sock $close
283 }
284 }
285 }
286
287 # Callback when file is done being output to client
288 # in: The fd for the file being copied
289 # sock: The client socket
290 # close: close the socket if true
291 # bytes: The # of bytes copied
292 # error: The error message (if any)
293
294 Httpd instproc copydone {in sock close bytes {error {}}} {
295 $self instvar config_
296 upvar #0 Httpd$sock data
297 close $in
298 $self log $sock Done $bytes bytes
299 $self sockdone $sock $close
300 }
301
302 # convert the file suffix into a mime type
303 # add your own types as needed
304
305 Httpd instproc contenttype {path} {
306 $self instvar mimetype_
307
308 set type text/plain
309 catch {set type $mimetype_([file extension $path])}
310 return $type
311 }
312
313 # Generic error response.
314
315 # Respond with an error reply
316 # sock: The socket handle to the client
317 # code: The httpd error code
318 # args: Additional information for error logging
319
320 Httpd instproc error {sock code args} {
321 upvar #0 Httpd$sock data
322 $self instvar config_ errors_ errorfmt_
323
324 append data(url) ""
325 incr config_(errors)
326 set message [format $errorfmt_ $code $errors_($code) $data(url)]
327 append head "HTTP/1.$data(version) $code $errors_($code)" \n
328 append head "Date: [$self date [clock seconds]]" \n
329 append head "Connection: close" \n
330 append head "Content-Length: [string length $message]" \n
331
332 # Because there is an error condition, the socket may be "dead"
333
334 catch {
335 fconfigure $sock -translation crlf
336 puts -nonewline $sock $head\n$message
337 flush $sock
338 } reason
339 $self sockdone $sock 1
340 $self log $sock Error $code $errors_($code) $args $reason
341 }
342
343 # Generate a date string in HTTP format.
344
345 Httpd instproc date {seconds} {
346 return [clock format $seconds -format {%a, %d %b %Y %T %Z}]
347 }
348
349 # Log an Httpd transaction.
350 # This should be replaced as needed.
351
352 Httpd instproc log {sock args} {
353 #puts stderr "LOG: $sock $args"
354 }
355
356 # Convert a url into a pathname. (UNIX version only)
357 # This is probably not right, and belongs somewhere else.
358 # - Remove leading http://... if any
359 # - Collapse all /./ and /../ constructs
360 # - expand %xx sequences -> disallow "/"'s and "."'s due to expansions
361
362 Httpd instproc url2file {root url} {
363 regsub -all {//+} $url / url ;# collapse multiple /'s
364 while {[regsub -all {/\./} $url / url]} {} ;# collapse /./
365 while {[regsub -all {/\.\.(/|$)} $url /\x81\\1 url]} {} ;# mark /../
366 while {[regsub "/\[^/\x81]+/\x81/" $url / url]} {} ;# collapse /../
367 if {![regexp "\x81|%2\[eEfF]" $url]} { ;# invalid /../, / or . ?
368 return $root[$self cgimap $url]
369 } else {
370 return ""
371 }
372 }
373
374 # Decode url-encoded strings.
375
376 Httpd instproc cgimap {data} {
377 regsub -all {([][$\\])} $data {\\\1} data
378 regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
379 return [subst $data]
380 }
381
382 #proc bgerror {msg} {
383 # global errorInfo
384 # puts stderr "bgerror: $msg\n$errorInfo"
385 #}
386
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.