1 # http-server.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1998-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 #
31 # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/net/http-server.tcl,v 1.7 2002/02/03 04:28:05 lim Exp $
32
33
34 import TCP MTrace
35
36 #
37 # The HTTP_Server class is an <b>abstract base class</b> that handles
38 # general HTTP requests. Usage:<p>
39 # set myServer [new TCP/Server]<br>
40 # $myServer open [port] TCP/HTTP_Server/[child class]
41 #
42 Class TCP/HTTP_Server -superclass TCP
43
44 #
45 # TCP/HTTP_Server constructor
46 #
47 TCP/HTTP_Server public init { http_server } {
48 $self next
49 $self set http_server_ $http_server
50 $self init_vars
51 }
52
53
54 #
55 # The init_vars method initializes class variables; this method
56 # should be invoked prior to each HTTP request received.
57 #
58 TCP/HTTP_Server private init_vars { } {
59
60 $self instvar headers_done_ num_data_bytes_ headers_ data_
61
62 # Set the headers_done_ boolean to false indicating that
63 # the headers have not yet been completely read.
64 set headers_done_ 0
65
66 # Initialize num_data_bytes_ to 0.
67 set num_data_bytes_ 0
68
69 # Initialize / reset the headers_ and data_ variables.
70 if [info exists headers_] { unset headers_ }
71 set data_ ""
72 }
73
74
75 #
76 # The readable method reads input from a channel, and invokes
77 # either TCP::readable to handle header information or
78 # HTTP_Server::recv to handle data. When the entire request has
79 # been received, this method invokes the handle_request method.
80 #
81 TCP/HTTP_Server private readable { } {
82
83 $self instvar chan_ headers_done_ num_data_bytes_
84
85 # Configure the socket to binary, non-blocking mode.
86 #fconfigure $chan_ -blocking 0
87 #fconfigure $chan_ -translation binary
88
89 if { $headers_done_ == 0 } {
90
91 # Call TCP::readable, which calls recv to read in the headers.
92 $self next
93
94 } elseif { $num_data_bytes_ > 0 } {
95
96 # Call recv to get the data from the HTTP request.
97 set socket [read $chan_ $num_data_bytes_]
98
99 # Check for eof; note that in handling headers, TCP::readable
100 # does this check.
101 if { [string length $socket] == 0 } {
102 if { [eof $chan_] } {
103 mtrace trcNet "-> eof reached"
104 mtrace trcNet $socket
105 $self close
106 $self shutdown
107 }
108 return
109 } else {
110 $self recv $socket
111 }
112
113 } else {
114 mtrace trcNet "** Error: readable called with no data to read."
115 mtrace trcNet "** closing this socket"
116 catch {
117 $self close
118 $self shutdown
119 }
120 }
121 }
122
123
124 #
125 # The recv method parses the portion of an HTTP request that is
126 # currently on the socket.
127 #
128 TCP/HTTP_Server private recv { sock_data } {
129
130 $self instvar num_data_bytes_ headers_done_ headers_ data_
131
132 # Handle the next line of headers if they have not all
133 # been read yet.
134 if { $headers_done_ == 0 } {
135 if { [string compare "" [string trim $sock_data] ] == 0 } {
136 # If this is an empty line indicating the end of the
137 # headers, set headers_done_ to true and return.
138 set headers_done_ 1
139 mtrace trcNet "-> End of headers"
140 } else {
141 # Otherwise, this line contains a normal header;
142 # parse the header.
143 mtrace trcNet $sock_data
144 $self parse_header $sock_data
145 }
146 } elseif { $num_data_bytes_ > 0 } {
147 # Append data received to data_ and update num_bytes_read_.
148 set num_bytes_read [string length $sock_data]
149 set num_data_bytes_ [expr $num_data_bytes_ - $num_bytes_read]
150 append data_ $sock_data
151 mtrace trcNet "-> Bytes read / bytes left: $num_bytes_read /\
152 $num_data_bytes_"
153 } else {
154 mtrace "-> Nothing received"
155 }
156
157 # If the headers have been read and there is no more data to
158 # read, then call handle_request.
159 if { [expr $headers_done_ == 1 && $num_data_bytes_ == 0] } {
160 mtrace trcNet "-> Calling handle_request"
161 $self instvar http_server_
162
163 set delete_sock 1
164 if [info exists headers_] {
165 # we must have at least the first header line that
166 # contains the method, url, and version fields
167 # note that we are sending the headers_ array by
168 # reference
169 set delete_sock [$http_server_ handle_request $self \
170 headers_ $data_]
171 if { $delete_sock == {} } { set delete_sock 1 }
172 }
173
174 if $delete_sock {
175 $self init_vars
176
177 # since we are assuming HTTP/1.0, we will just close the
178 # socket here
179 catch {$self close}
180 catch {$self shutdown}
181 delete $self
182 }
183 }
184 }
185
186
187 #
188 # The parse_header method extracts the title and value of a header,
189 # handles special information headers, and appends the title/value
190 # pair to the list, headers_.
191 #
192 TCP/HTTP_Server private parse_header { header } {
193 $self instvar headers_
194
195 # Check if header contains the request line. This line must
196 # be handled specially since it does not follow the standard
197 # format, <header-title>: <header-value>.
198 if { ![info exists headers_] } {
199 # this is the first header line
200 # it is of the form "METHOD URL HTTP/VER"
201 set header [split $header]
202 set headers_(method) [lindex $header 0]
203 set headers_(url) [lindex $header 1]
204 set headers_(version) [lindex $header 2]
205 } else {
206 # this line is of the form "<header-title>: <header-value>"
207 set colon_pos [string first ":" $header]
208
209 # Extract the header title, remove whitespace, if any,
210 # and convert the string to lower-case.
211 set title [string range $header 0 [expr $colon_pos - 1] ]
212 set title [string tolower [string trim $title] ]
213
214 # Extract the header value and take out whitespace at the ends.
215 set value [string range $header [expr $colon_pos + 1] end]
216 set value [string trim $value]
217
218 # Handle special information headers.
219 if { $title == "content-length" } {
220 # If this line contains the Content-Length header,
221 # set num_data_bytes_
222 $self instvar num_data_bytes_
223 set num_data_bytes_ $value
224 mtrace trcNet "-> Number of data bytes expected:\
225 $num_data_bytes_"
226 }
227
228 # Append the title/value pair to the list, headers_.
229 mtrace trcNet "-> Header title: $title"
230 mtrace trcNet "-> Header value: $value"
231 set headers_($title) $value
232 }
233 }
234
235 # -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
236
237 import Class
238
239 Class HTTP_Server -configuration {
240 server_port 4444
241 }
242
243
244
245 HTTP_Server public init { } {
246
247 $self instvar status_table_
248
249 # Create the status table.
250 set status_table_(200) "OK"
251 set status_table_(204) "No Content"
252 set status_table_(400) "Bad Request"
253 set status_table_(404) "Not found"
254 set status_table_(500) "Internal Server Error"
255 }
256
257
258 HTTP_Server public destroy { } {
259 $self close
260 $self next
261 }
262
263
264 HTTP_Server public open { port } {
265 $self instvar server_
266 set server_ [new TCP/Server]
267 $server_ open $port "$self create_channel"
268 $self set port_ $port
269 puts stderr "opened server at port '$port'"
270 }
271
272
273 HTTP_Server public close { } {
274 $self instvar server_
275 if [info exists server_] {
276 delete $server_
277 unset server_
278 }
279 }
280
281
282 HTTP_Server public port { } {
283 return [$self set port_]
284 }
285
286
287 HTTP_Server private create_channel { chan } {
288 set socket [new TCP/HTTP_Server $self]
289 $socket open $chan
290
291 # set the socket to binary mode
292 # it will automatically get set to non-blocking inside tcp.tcl
293 $socket set_binary
294 return $socket
295 }
296
297
298 #
299 # The handle_request method is a pure virtual function; it is
300 # called when an entire HTTP request has been received by
301 # readable. Thus, this method can assume that the header_ and
302 # data_ variables have been set accordingly prior to its
303 # invokation. Note that the implementor of this method has
304 # the responsibility of closing the socket.
305 #
306 HTTP_Server public handle_request { socket headers data } {
307 mtrace trcNet "Error: HTTP_Server is an abstract base class."
308 error "HTTP_Server is an abstract base class."
309 $self close
310 $self shutdown
311 }
312
313
314
315 # #
316 # # sets members of an array 'result':
317 # # result(method) GET/PUT etc
318 # # result(url) the url
319 # # all other headers are stored as elements of this array
320 # HTTP_Server public headers_to_array { headers result_var } {
321 # upvar $result_var result
322 # array set result [lrange $headers 2 end]
323 # set result(method) [lindex $headers 0]
324 # set result(url) [lindex $headers 1]
325 # }
326
327
328 # HTTP_Server private extract_url { headers } {
329 # # Convert headers into an associative array and extract the
330 # # GET header/value pair.
331 # array set hdr_array $headers
332 # set get_pair [array get hdr_array "get"]
333 # set url ""
334 #
335 # # The SDP objects only care about GET requests with certain
336 # # "magic" URLs.
337 # if { [llength $get_pair] > 0 } {
338 # # Extract the URL from the GET request.
339 # set url [lindex $get_pair 1]
340 # mtrace trcNet "-> URL received: $url"
341 # }
342 # return $url
343 # }
344
345
346 #
347 # The send_html method sends a OK reply with text/html data.
348 #
349 HTTP_Server public send_html { socket data } {
350 mtrace trcNet "-> Sending generic reply"
351 set reply(data) $data
352 set reply(headers) [list content-type text/html]
353 set reply(status) 200
354 $self send_reply $socket reply
355 }
356
357
358 #
359 # The send_reply method sends a general reply with the given error
360 # code and text/html data.
361 #
362 HTTP_Server public send_reply { socket reply_var } {
363 mtrace trcNet "-> Sending reply"
364 # This whole section is a hack since otcl cannot handle binary data.
365 upvar $reply_var reply
366 set status_msg [$self get_status_msg $reply(status)]
367 set status "HTTP/1.0 $reply(status) $status_msg"
368 set h $reply(headers)
369 lappend h content-length [string length $reply(data)]
370 catch {
371 $socket send [$self construct_headers $status $h]
372 set chan [$socket channel]
373 puts -nonewline $chan $reply(data)
374 flush $chan
375 }
376 }
377
378
379 #
380 # The construct_headers method takes a list of header pairs and
381 # status to construct the headers to be returned by the server.
382 #
383 HTTP_Server private construct_headers { status header_list } {
384
385 set headers $status
386 append headers "\r\n"
387
388 foreach {title value} $header_list {
389 append headers "$title: $value\r\n"
390 }
391
392 append headers "\r\n"
393 mtrace trcNet "-> Constructed headers:"
394 mtrace trcNet $headers
395 return $headers
396 }
397
398
399 HTTP_Server private get_status_msg { status_code } {
400 $self instvar status_table_
401 if [info exists status_table_($status_code)] {
402 return $status_table_($status_code)
403 } else {
404 return "Unknown error"
405 }
406 }
407
408
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.