source: downloads/tcl8.5.2/tests/httpd @ 42

# -*- tcl -*-
#
# 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 \
                -> 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 seconds] \
                              -format {%a, %d %b %Y %H:%M:%S %Z}]"
        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
}