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