1# Simple Sample httpd/1.0 server in 250 lines of Tcl
2# Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems
3# See the file "license.terms" for information on usage and redistribution
4# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
5
6# This is a working sample httpd server written entirely in TCL with the
7# CGI and imagemap capability removed.  It has been tested on the Mac, PC
8# and Unix.  It is intended as sample of how to write internet servers in
9# Tcl. This sample server was derived from a full-featured httpd server,
10# also written entirely in Tcl.
11# Comments or questions welcome (stephen.uhler@sun.com)
12
13# Httpd is a global array containing the global server state
14#  root:	the root of the document directory
15#  port:	The port this server is serving
16#  listen:	the main listening socket id
17#  accepts:	a count of accepted connections so far
18
19array set Httpd {
20    -version	"Tcl Httpd-Lite 1.0"
21    -launch	0
22    -port	8080
23    -ipaddr	""
24    -default	index.html
25    -root	/wwwroot
26    -bufsize	32768
27    -sockblock	0
28    -config	""
29}
30set Httpd(-host)	[info hostname]
31
32# HTTP/1.0 error codes (the ones we use)
33
34array set HttpdErrors {
35    204 {No Content}
36    400 {Bad Request}
37    404 {Not Found}
38    503 {Service Unavailable}
39    504 {Service Temporarily Unavailable}
40    }
41
42
43# Start the server by listening for connections on the desired port.
44
45proc Httpd_Server {args} {
46    global Httpd
47
48    if {[llength $args] == 1} {
49	set args [lindex $args 0]
50    }
51    array set Httpd $args
52
53    if {![file isdirectory $Httpd(-root)]} {
54	return -code error "Bad root directory \"$Httpd(-root)\""
55    }
56    if {![file exists [file join $Httpd(-root) $Httpd(-default)]]} {
57	# Try and find a good default
58	foreach idx {index.htm index.html default.htm contents.htm} {
59	    if {[file exists [file join $Httpd(-root) $idx]]} {
60		set Httpd(-default) $idx
61		break
62	    }
63	}
64    }
65    if {![file exists [file join $Httpd(-root) $Httpd(-default)]]} {
66	return -code error "Bad index page \"$Httpd(-default)\""
67    }
68    if {$Httpd(-ipaddr) != ""} {
69	set Httpd(listen) [socket -server HttpdAccept \
70				-myaddr $Httpd(-ipaddr) $Httpd(-port)]
71    } else {
72	set Httpd(listen) [socket -server HttpdAccept $Httpd(-port)]
73    }
74    set Httpd(accepts) 0
75    if {$Httpd(-port) == 0} {
76	set Httpd(-port) [lindex [fconfigure $Httpd(listen) -sockname] 2]
77    }
78    return $Httpd(-port)
79}
80
81# Accept a new connection from the server and set up a handler
82# to read the request from the client.
83
84proc HttpdAccept {newsock ipaddr port} {
85    global Httpd
86    upvar #0 Httpd$newsock data
87
88    incr Httpd(accepts)
89    fconfigure $newsock -blocking $Httpd(-sockblock) \
90	-buffersize $Httpd(-bufsize) \
91	-translation {auto crlf}
92    Httpd_Log $newsock Connect $ipaddr $port
93    set data(ipaddr) $ipaddr
94    fileevent $newsock readable [list HttpdRead $newsock]
95}
96
97# read data from a client request
98
99proc HttpdRead { sock } {
100    upvar #0 Httpd$sock data
101
102    set readCount [gets $sock line]
103    if {![info exists data(state)]} {
104	if [regexp {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1.[01]} \
105		$line x data(proto) data(url) data(query)] {
106	    set data(state) mime
107	    Httpd_Log $sock Query $line
108	} else {
109	    HttpdError $sock 400
110	    Httpd_Log $sock Error "bad first line:$line"
111	    HttpdSockDone $sock
112	}
113	return
114    }
115
116    # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
117
118    set state [string compare $readCount 0],$data(state),$data(proto)
119    switch -- $state {
120	0,mime,GET	-
121	0,query,POST	{ HttpdRespond $sock }
122	0,mime,POST	{ set data(state) query }
123	1,mime,POST	-
124	1,mime,GET	{
125	    if [regexp {([^:]+):[ 	]*(.*)}  $line dummy key value] {
126		set data(mime,[string tolower $key]) $value
127	    }
128	}
129	1,query,POST	{
130	    set data(query) $line
131	    HttpdRespond $sock
132	}
133	default {
134	    if [eof $sock] {
135		Httpd_Log $sock Error "unexpected eof on <$data(url)> request"
136	    } else {
137		Httpd_Log $sock Error "unhandled state <$state> fetching <$data(url)>"
138	    }
139	    HttpdError $sock 404
140	    HttpdSockDone $sock
141	}
142    }
143}
144
145proc HttpdCopyDone { in sock bytes {error ""}} {
146#tclLog "CopyDone $sock $bytes $error"
147    catch {close $in}
148    HttpdSockDone $sock
149}
150# Close a socket.
151# We'll use this to implement keep-alives some day.
152
153proc HttpdSockDone { sock } {
154    upvar #0 Httpd$sock data
155    unset data
156    close $sock
157}
158
159# Respond to the query.
160
161proc HttpdRespond { sock } {
162    global Httpd
163    upvar #0 Httpd$sock data
164
165    set mypath [HttpdUrl2File $Httpd(-root) $data(url)]
166    if {[string length $mypath] == 0} {
167	HttpdError $sock 400
168	Httpd_Log $sock Error "$data(url) invalid path"
169	HttpdSockDone $sock
170	return
171    }
172
173    if {![catch {open $mypath} in]} {
174	puts $sock "HTTP/1.0 200 Data follows"
175	puts $sock "Date: [HttpdDate [clock seconds]]"
176	puts $sock "Server: $Httpd(-version)"
177	puts $sock "Last-Modified: [HttpdDate [file mtime $mypath]]"
178	puts $sock "Content-Type: [HttpdContentType $mypath]"
179	puts $sock "Content-Length: [file size $mypath]"
180	puts $sock ""
181	fconfigure $sock -translation binary -blocking $Httpd(-sockblock)
182	fconfigure $in -translation binary -blocking 0
183	flush $sock
184	fileevent $sock readable {}
185	fcopy $in $sock -command [list HttpdCopyDone $in $sock]
186	#HttpdSockDone $sock
187    } else {
188	HttpdError $sock 404
189	Httpd_Log $sock Error "$data(url) $in"
190	HttpdSockDone $sock
191    }
192}
193# convert the file suffix into a mime type
194# add your own types as needed
195
196array set HttpdMimeType {
197    {}		text/plain
198    .txt	text/plain
199    .htm	text/html
200    .html	text/html
201    .gif	image/gif
202    .jpg	image/jpeg
203    .xbm	image/x-xbitmap
204}
205
206proc HttpdContentType {path} {
207    global HttpdMimeType
208
209    set type text/plain
210    catch {set type $HttpdMimeType([string tolower [file extension $path]])}
211    return $type
212}
213
214# Generic error response.
215
216set HttpdErrorFormat {
217    <title>Error: %1$s</title>
218    Got the error: <b>%2$s</b><br>
219    while trying to obtain <b>%3$s</b>
220}
221
222proc HttpdError {sock code} {
223    upvar #0 Httpd$sock data
224    global HttpdErrors HttpdErrorFormat Httpd
225
226    append data(url) ""
227    set message [format $HttpdErrorFormat $code $HttpdErrors($code)  $data(url)]
228    puts $sock "HTTP/1.0 $code $HttpdErrors($code)"
229    puts $sock "Date: [HttpdDate [clock seconds]]"
230    puts $sock "Server: $Httpd(-version)"
231    puts $sock "Content-Length: [string length $message]"
232    puts $sock ""
233    puts -nonewline $sock $message
234}
235
236# Generate a date string in HTTP format.
237
238proc HttpdDate {clicks} {
239    return [clock format $clicks -format {%a, %d %b %Y %T %Z}]
240}
241
242# Log an Httpd transaction.
243# This should be replaced as needed.
244
245proc Httpd_Log {sock reason args} {
246    global httpdLog httpClicks
247    if {[info exists httpdLog]} {
248	if ![info exists httpClicks] {
249	    set last 0
250	} else {
251	    set last $httpClicks
252	}
253	set httpClicks [clock seconds]
254	set ts [clock format [clock seconds] -format {%Y%m%d %T}]
255	puts $httpdLog "$ts ([expr $httpClicks - $last])\t$sock\t$reason\t[join $args { }]"
256    }
257}
258
259# Convert a url into a pathname.
260# This is probably not right.
261
262proc HttpdUrl2File {root url} {
263    global HttpdUrlCache Httpd
264
265    if {![info exists HttpdUrlCache($url)]} {
266    	lappend pathlist $root
267    	set level 0
268	foreach part  [split $url /] {
269	    set part [HttpdCgiMap $part]
270	    if [regexp {[:/]} $part] {
271		return [set HttpdUrlCache($url) ""]
272	    }
273	    switch -- $part {
274		.  { }
275		.. {incr level -1}
276		default {incr level}
277	    }
278	    if {$level <= 0} {
279		return [set HttpdUrlCache($url) ""]
280	    }
281	    lappend pathlist $part
282	}
283    	set file [eval file join $pathlist]
284	if {[file isdirectory $file]} {
285	    set file [file join $file $Httpd(-default)]
286	}
287    	set HttpdUrlCache($url) $file
288    }
289    return $HttpdUrlCache($url)
290}
291
292# Decode url-encoded strings.
293
294proc HttpdCgiMap {data} {
295    regsub -all {([][$\\])} $data {\\\1} data
296    regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
297    return [subst $data]
298}
299
300proc bgerror {msg} {
301    global errorInfo
302    puts stderr "bgerror: $errorInfo"
303}
304proc openurl url {
305   global tcl_platform
306   if {[lindex $tcl_platform(os) 1] == "NT"} {
307       exec cmd /c start $url &
308   } else {
309       exec start $url &
310   }
311}
312
313set httpdLog stderr
314
315upvar #0 Httpd opts
316
317while {[llength $argv] > 0} {
318    set option [lindex $argv 0]
319    if {![info exists opts($option)] || [llength $argv] == 1} {
320	puts stderr "usage: httpd ?options?"
321	puts stderr "\nwhere options are any of the following:\n"
322	foreach opt [lsort [array names opts -*]] {
323	    puts stderr [format "\t%-15s default: %s" $opt $opts($opt)]
324	}
325	exit 1
326    }
327    set opts($option) [lindex $argv 1]
328    set argv [lrange $argv 2 end]
329}
330catch {
331    package require vfs
332    vfs::auto $opts(-root) -readonly
333}
334
335if {$opts(-config) != ""} {
336    source $opts(-config)
337}
338
339Httpd_Server [array get opts]
340
341
342puts stderr "Accepting connections on http://$Httpd(-host):$Httpd(-port)/"
343
344if {$Httpd(-launch)} {
345    openurl "http://$Httpd(-host):$Httpd(-port)/"
346}
347
348if {![info exists tcl_service]} {
349    vwait forever		;# start the Tcl event loop
350}
351