#
# 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 "<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"
	    }
	    append html </dl>\n
	}
	append html </body></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
}