1 # mash-server.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1997-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/applications/pathfinder/mash-server.tcl,v 1.7 2002/02/03 04:22:06 lim Exp $
32
33
34 import HTTP_Server
35
36
37 #
38 # The MASH_Server class is a basic HTTP server that is geared towards
39 # simplifying the Webifying of MASH tools. The server can contain any
40 # number of HTTP_Agent objects each of which handle certain client
41 # requests. These agents are added through the add_agent method. Refer
42 # to the abstract HTTP_Agent class for specifics on implementing agents.
43 #
44 Class HTTP_Server/MASH_Server -superclass HTTP_Server
45
46
47 HTTP_Server/MASH_Server public init { } {
48
49 $self next
50 $self instvar html_dir_
51
52 # Initialize the html directory.
53 #set html_dir_ ~/mash/tcl/applications/mash_server/html/
54 #set o [$self options]
55 #$o load_preferences "mserver"
56 set html_dir_ [$self get_option html_dir]
57 }
58
59
60 #
61 # The add_agent method takes an HTTP_Agent object and adds it to the
62 # current list of agents managed by the MASH_Server.
63 #
64 HTTP_Server/MASH_Server public add_agent { agent } {
65 $self instvar agents_
66 lappend agents_ $agent
67 }
68
69
70 #
71 # When the MASH_Server receives a client HTTP request, the handle_request
72 # method is called. In turn, the server looks to each of its agents and
73 # has each process the request until one of the agents handles the
74 # request. The data returned by the agent is then returned to the client
75 # in the form of an HTTP response.
76 #
77 HTTP_Server/MASH_Server public handle_request { socket hdr_var data } {
78 $self instvar agents_ html_dir_
79 upvar $hdr_var headers
80
81 set u [$self extract_key $headers(url)]
82 set url [lindex $u 0]
83 set key [lindex $u 1]
84
85 if { $url == "/" } {
86 set url /index.html
87 }
88
89 set data ""
90 set isRawData 0
91 set page { }
92 set type "text/html"
93
94 # Find out the source of this request.
95 set source [$self find_source $socket]
96
97 # create a reply array
98 set reply(headers) {}
99 set reply(data) {}
100 set reply(status) -1
101
102 foreach a $agents_ {
103 # A page is returned if the url was recognized by the
104 # agent. In this case, break out of the for loop.
105 set r [$a handle_request $url $key $source reply]
106 puts "[$a info class] returned $r"
107 if $r {
108 puts "headers: $reply(headers)\nstatus $reply(status)"
109 break
110 }
111 }
112
113 if { $reply(status) == -1 } {
114 # none of the agents managed to handle this URL
115 # return the error page
116
117 # assume the last agent in the list was the static agent
118 if ![$a handle_request /notfound.html "" $source reply] {
119 set reply(headers) [list content-type text/html]
120 set reply(data) "<HTML><HEAD><TITLE>404 Not found\
121 </TITLE></HEAD>\
122 \n<BODY><h1>404 Not found</h1></BODY>\
123 \n</HTML>"
124 }
125 set reply(status) 404
126 }
127
128 $self send_reply $socket reply
129 }
130
131
132 #
133 # The get_data method extracts the data portion of the page returned
134 # by the agent.
135 #
136 HTTP_Server/MASH_Server private get_data { page } {
137 return [lindex $page 0]
138 }
139
140
141 #
142 # The get_status method extracts the status portion of the page
143 # returned by the agent.
144 #
145 HTTP_Server/MASH_Server private get_status { page } {
146 return [lindex $page 1]
147 }
148
149
150 #
151 # The get_type method extracts the status portion of the page
152 # returned by the agent.
153 #
154 HTTP_Server/MASH_Server private get_type { page } {
155 return [lindex $page 2]
156 }
157
158
159 #
160 # The extract_key method extracts the key from the magic urls. The
161 # standard form of a magic URL is [description]^[unique key].
162 #
163 HTTP_Server/MASH_Server private extract_key { url } {
164 set offset [string last ^ $url]
165 if { $offset < 0 } { return [list $url {}] }
166 set key [string range $url [expr $offset + 1] end]
167 set url [string range $url 0 [expr $offset-1]]
168 return [list $url [string trimleft [string tolower $key] -:]]
169 }
170
171
172 #
173 # The find_source method uses the socket to determine the source
174 # of a HTTP request.
175 #
176 HTTP_Server/MASH_Server private find_source { socket } {
177
178 # Find the hostname of the client.
179 set chan [$socket channel]
180 set host [lindex [fconfigure $chan -peername] 1]
181 mtrace trcNet "-> Client hostname: $host"
182
183 return $host
184 }
185
186 # -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
187
188
189 proc write_to_file { filename string } {
190 set fileid [open $filename "WRONLY CREAT TRUNC"]
191 puts $fileid $string
192 close $fileid
193 }
194
195
196 proc file_dump { filename } {
197 set fileid [open $filename "r"]
198 set data [read $fileid]
199 close $fileid
200 return $data
201 }
202
203
204 proc prepend_to_file { filename string } {
205
206 # Read the original data in the file
207 set orig [read_file $filename]
208
209 # Truncate all the data in the file
210 set fileid [open $filename "WRONLY CREAT TRUNC"]
211 close $fileid
212
213 # Prepend string to the file
214 set fileid [open $filename "WRONLY CREAT APPEND"]
215 puts $fileid $string
216 puts $fileid $orig
217 close $fileid
218 }
219
220
221 proc read_file { filename } {
222 set exists [file exists $filename]
223 set data ""
224 if { $exists == 1 } {
225 set fileid [open $filename "r"]
226 set data [read $fileid]
227 close $fileid
228 }
229 return $data
230 }
231
232
233 proc get_key { program } {
234 return [string tolower [string trimleft [$program unique_key] -:]]
235 }
236
237
238 proc edit_html { str } {
239
240 # Replace "<" and ">" so that they are not specially treated if
241 # there is an email address within them.
242 # regsub -all -- (<)(\[^>\]*)(@)(\[^>\]*)(>) $str {\<\2\3\4\>} str
243 regsub -all -- < $str {\<} str
244 regsub -all -- > $str {\>} str
245
246 return $str
247 }
248
249
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.