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