#
# The httpd_ procedures implement a stub http server.
#
# Copyright (c) 1997-1998 Sun Microsystems, Inc.
# Copyright (c) 1999-2000 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) httpd 1.2 98/02/20 14:51:59
#set httpLog 1
proc httpd_init {{port 8015}} {
socket -server httpdAccept $port
}
proc httpd_log {args} {
global httpLog
if {[info exists httpLog] && $httpLog} {
puts stderr "httpd: [join $args { }]"
}
}
array set httpdErrors {
204 {No Content}
400 {Bad Request}
401 {Authorization Required}
404 {Not Found}
503 {Service Unavailable}
504 {Service Temporarily Unavailable}
}
proc httpdError {sock code args} {
global httpdErrors
puts $sock "$code $httpdErrors($code)"
httpd_log "error: [join $args { }]"
}
proc httpdAccept {newsock ipaddr port} {
global httpd
upvar #0 httpd$newsock data
fconfigure $newsock -blocking 0 -translation {auto crlf}
httpd_log $newsock Connect $ipaddr $port
set data(ipaddr) $ipaddr
fileevent $newsock readable [list httpdRead $newsock]
}
# read data from a client request
proc httpdRead { sock } {
upvar #0 httpd$sock data
if {[eof $sock]} {
set readCount -1
} elseif {![info exists data(state)]} {
# Read the protocol line and parse out the URL and query
set readCount [gets $sock line]
if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/(1.[01])} \
$line x data(proto) data(url) data(query) data(httpversion)] {
set data(state) mime
httpd_log $sock Query $line
} else {
httpdError $sock 400
httpd_log $sock Error "bad first line:$line"
httpdSockDone $sock
}
return
} elseif {$data(state) == "mime"} {
# Read the HTTP headers
set readCount [gets $sock line]
} elseif {$data(state) == "query"} {
# Read the query data
if {![info exists data(length_orig)]} {
set data(length_orig) $data(length)
}
set line [read $sock $data(length)]
set readCount [string length $line]
incr data(length) -$readCount
}
# string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
set state [string compare $readCount 0],$data(state),$data(proto)
httpd_log $sock $state
switch -- $state {
-1,mime,HEAD -
-1,mime,GET -
-1,mime,POST {
# gets would block
return
}
0,mime,HEAD -
0,mime,GET -
0,query,POST {
# Empty line at end of headers,
# or eof after query data
httpdRespond $sock
}
0,mime,POST {
# Empty line between headers and query data
if {![info exists data(mime,content-length)]} {
httpd_log $sock Error "No Content-Length for POST"
httpdError $sock 400
httpdSockDone $sock
} else {
set data(state) query
set data(length) $data(mime,content-length)
# Special case to simulate servers that respond
# without reading the post data.
if {[string match *droppost* $data(url)]} {
fileevent $sock readable {}
httpdRespond $sock
}
}
}
1,mime,HEAD -
1,mime,POST -
1,mime,GET {
# A line of HTTP headers
if {[regexp {([^:]+):[ ]*(.*)} $line dummy key value]} {
set data(mime,[string tolower $key]) $value
}
}
-1,query,POST {
httpd_log $sock Error "unexpected eof on <$data(url)> request"
httpdError $sock 400
httpdSockDone $sock
}
1,query,POST {
append data(query) $line
if {$data(length) <= 0} {
set data(length) $data(length_orig)
httpdRespond $sock
}
}
default {
if {[eof $sock]} {
httpd_log $sock Error "unexpected eof on <$data(url)> request"
} else {
httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
}
httpdError $sock 404
httpdSockDone $sock
}
}
}
proc httpdSockDone { sock } {
upvar #0 httpd$sock data
unset data
catch {close $sock}
}
# Respond to the query.
proc httpdRespond { sock } {
global httpd bindata port
upvar #0 httpd$sock data
switch -glob -- $data(url) {
*binary* {
set html "$bindata[info hostname]:$port$data(url)"
set type application/octet-stream
}
*post* {
set html "Got [string length $data(query)] bytes"
set type text/plain
}
default {
set type text/html
set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>$data(proto) $data(url)</h2>
"
if {[info exists data(query)] && [string length $data(query)]} {
append html "<h2>Query</h2>\n<dl>\n"
foreach {key value} [split $data(query) &=] {
append html "<dt>$key<dd>$value\n"
if {$key == "timeout"} {
after $value ;# pause
}
}
append html </dl>\n
}
append html </body></html>
}
}
# Catch errors from premature client closes
catch {
if {$data(proto) == "HEAD"} {
puts $sock "HTTP/1.0 200 OK"
} else {
puts $sock "HTTP/1.0 200 Data follows"
}
puts $sock "Date: [clock format [clock clicks]]"
puts $sock "Content-Type: $type"
puts $sock "Content-Length: [string length $html]"
puts $sock ""
flush $sock
if {$data(proto) != "HEAD"} {
fconfigure $sock -translation binary
puts -nonewline $sock $html
}
}
httpd_log $sock Done ""
httpdSockDone $sock
}