#
# The httpd_ procedures implement a stub http server.
#
# Copyright (c) 1997-1998 Sun Microsystems, Inc.
#
# 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
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}
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
set readCount [gets $sock line]
if {![info exists data(state)]} {
if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \
$line x data(proto) data(url) data(query)] {
set data(state) mime
httpd_log $sock Query $line
} else {
httpdError $sock 400
httpd_log $sock Error "bad first line:$line"
httpdSockDone $sock
}
return
}
# 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 { httpdRespond $sock }
0,mime,POST { set data(state) query }
1,mime,HEAD -
1,mime,POST -
1,mime,GET {
if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] {
set data(mime,[string tolower $key]) $value
}
}
1,query,POST {
append data(query) $line
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
close $sock
}
# Respond to the query.
proc httpdRespond { sock } {
global httpd bindata port
upvar #0 httpd$sock data
if {[string match *binary* $data(url)]} {
set html "$bindata[info hostname]:$port$data(url)"
set type application/octet-stream
} else {
set type text/html
set html "HTTP/1.0 TEST
Hello, World!
$data(proto) $data(url)
"
if {[info exists data(query)] && [string length $data(query)]} {
append html "Query
\n\n"
foreach {key value} [split $data(query) &=] {
append html "- $key
- $value\n"
}
append html
\n
}
append html
}
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 ""
if {$data(proto) != "HEAD"} {
fconfigure $sock -translation binary
puts -nonewline $sock $html
}
httpd_log $sock Done ""
httpdSockDone $sock
}