/PuttyKnife/dist/sdx-new.vfs/lib/app-sdx/httpd.tcl
TCL | 350 lines | 264 code | 50 blank | 36 comment | 42 complexity | e60e45e6a8557d3db495a26a71175f0c MD5 | raw file
Possible License(s): GPL-3.0
- # Simple Sample httpd/1.0 server in 250 lines of Tcl
- # Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems
- # See the file "license.terms" for information on usage and redistribution
- # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- # This is a working sample httpd server written entirely in TCL with the
- # CGI and imagemap capability removed. It has been tested on the Mac, PC
- # and Unix. It is intended as sample of how to write internet servers in
- # Tcl. This sample server was derived from a full-featured httpd server,
- # also written entirely in Tcl.
- # Comments or questions welcome (stephen.uhler@sun.com)
- # Httpd is a global array containing the global server state
- # root: the root of the document directory
- # port: The port this server is serving
- # listen: the main listening socket id
- # accepts: a count of accepted connections so far
- array set Httpd {
- -version "Tcl Httpd-Lite 1.0"
- -launch 0
- -port 8080
- -ipaddr ""
- -default index.html
- -root /wwwroot
- -bufsize 32768
- -sockblock 0
- -config ""
- }
- set Httpd(-host) [info hostname]
- # HTTP/1.0 error codes (the ones we use)
- array set HttpdErrors {
- 204 {No Content}
- 400 {Bad Request}
- 404 {Not Found}
- 503 {Service Unavailable}
- 504 {Service Temporarily Unavailable}
- }
- # Start the server by listening for connections on the desired port.
- proc Httpd_Server {args} {
- global Httpd
- if {[llength $args] == 1} {
- set args [lindex $args 0]
- }
- array set Httpd $args
- if {![file isdirectory $Httpd(-root)]} {
- return -code error "Bad root directory \"$Httpd(-root)\""
- }
- if {![file exists [file join $Httpd(-root) $Httpd(-default)]]} {
- # Try and find a good default
- foreach idx {index.htm index.html default.htm contents.htm} {
- if {[file exists [file join $Httpd(-root) $idx]]} {
- set Httpd(-default) $idx
- break
- }
- }
- }
- if {![file exists [file join $Httpd(-root) $Httpd(-default)]]} {
- return -code error "Bad index page \"$Httpd(-default)\""
- }
- if {$Httpd(-ipaddr) != ""} {
- set Httpd(listen) [socket -server HttpdAccept \
- -myaddr $Httpd(-ipaddr) $Httpd(-port)]
- } else {
- set Httpd(listen) [socket -server HttpdAccept $Httpd(-port)]
- }
- set Httpd(accepts) 0
- if {$Httpd(-port) == 0} {
- set Httpd(-port) [lindex [fconfigure $Httpd(listen) -sockname] 2]
- }
- return $Httpd(-port)
- }
- # Accept a new connection from the server and set up a handler
- # to read the request from the client.
- proc HttpdAccept {newsock ipaddr port} {
- global Httpd
- upvar #0 Httpd$newsock data
- incr Httpd(accepts)
- fconfigure $newsock -blocking $Httpd(-sockblock) \
- -buffersize $Httpd(-bufsize) \
- -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) ([^?]+)\??([^ ]*) HTTP/1.[01]} \
- $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)
- switch -- $state {
- 0,mime,GET -
- 0,query,POST { HttpdRespond $sock }
- 0,mime,POST { set data(state) query }
- 1,mime,POST -
- 1,mime,GET {
- if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] {
- set data(mime,[string tolower $key]) $value
- }
- }
- 1,query,POST {
- set 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 HttpdCopyDone { in sock bytes {error ""}} {
- #tclLog "CopyDone $sock $bytes $error"
- catch {close $in}
- HttpdSockDone $sock
- }
- # Close a socket.
- # We'll use this to implement keep-alives some day.
- proc HttpdSockDone { sock } {
- upvar #0 Httpd$sock data
- unset data
- close $sock
- }
- # Respond to the query.
- proc HttpdRespond { sock } {
- global Httpd
- upvar #0 Httpd$sock data
- set mypath [HttpdUrl2File $Httpd(-root) $data(url)]
- if {[string length $mypath] == 0} {
- HttpdError $sock 400
- Httpd_Log $sock Error "$data(url) invalid path"
- HttpdSockDone $sock
- return
- }
- if {![catch {open $mypath} in]} {
- puts $sock "HTTP/1.0 200 Data follows"
- puts $sock "Date: [HttpdDate [clock seconds]]"
- puts $sock "Server: $Httpd(-version)"
- puts $sock "Last-Modified: [HttpdDate [file mtime $mypath]]"
- puts $sock "Content-Type: [HttpdContentType $mypath]"
- puts $sock "Content-Length: [file size $mypath]"
- puts $sock ""
- fconfigure $sock -translation binary -blocking $Httpd(-sockblock)
- fconfigure $in -translation binary -blocking 0
- flush $sock
- fileevent $sock readable {}
- fcopy $in $sock -command [list HttpdCopyDone $in $sock]
- #HttpdSockDone $sock
- } else {
- HttpdError $sock 404
- Httpd_Log $sock Error "$data(url) $in"
- HttpdSockDone $sock
- }
- }
- # convert the file suffix into a mime type
- # add your own types as needed
- array set HttpdMimeType {
- {} text/plain
- .txt text/plain
- .htm text/html
- .html text/html
- .gif image/gif
- .jpg image/jpeg
- .xbm image/x-xbitmap
- }
- proc HttpdContentType {path} {
- global HttpdMimeType
- set type text/plain
- catch {set type $HttpdMimeType([string tolower [file extension $path]])}
- return $type
- }
- # Generic error response.
- set HttpdErrorFormat {
- <title>Error: %1$s</title>
- Got the error: <b>%2$s</b><br>
- while trying to obtain <b>%3$s</b>
- }
- proc HttpdError {sock code} {
- upvar #0 Httpd$sock data
- global HttpdErrors HttpdErrorFormat Httpd
- append data(url) ""
- set message [format $HttpdErrorFormat $code $HttpdErrors($code) $data(url)]
- puts $sock "HTTP/1.0 $code $HttpdErrors($code)"
- puts $sock "Date: [HttpdDate [clock seconds]]"
- puts $sock "Server: $Httpd(-version)"
- puts $sock "Content-Length: [string length $message]"
- puts $sock ""
- puts -nonewline $sock $message
- }
- # Generate a date string in HTTP format.
- proc HttpdDate {clicks} {
- return [clock format $clicks -format {%a, %d %b %Y %T %Z}]
- }
- # Log an Httpd transaction.
- # This should be replaced as needed.
- proc Httpd_Log {sock reason args} {
- global httpdLog httpClicks
- if {[info exists httpdLog]} {
- if ![info exists httpClicks] {
- set last 0
- } else {
- set last $httpClicks
- }
- set httpClicks [clock seconds]
- set ts [clock format [clock seconds] -format {%Y%m%d %T}]
- puts $httpdLog "$ts ([expr $httpClicks - $last])\t$sock\t$reason\t[join $args { }]"
- }
- }
- # Convert a url into a pathname.
- # This is probably not right.
- proc HttpdUrl2File {root url} {
- global HttpdUrlCache Httpd
- if {![info exists HttpdUrlCache($url)]} {
- lappend pathlist $root
- set level 0
- foreach part [split $url /] {
- set part [HttpdCgiMap $part]
- if [regexp {[:/]} $part] {
- return [set HttpdUrlCache($url) ""]
- }
- switch -- $part {
- . { }
- .. {incr level -1}
- default {incr level}
- }
- if {$level <= 0} {
- return [set HttpdUrlCache($url) ""]
- }
- lappend pathlist $part
- }
- set file [eval file join $pathlist]
- if {[file isdirectory $file]} {
- set file [file join $file $Httpd(-default)]
- }
- set HttpdUrlCache($url) $file
- }
- return $HttpdUrlCache($url)
- }
- # Decode url-encoded strings.
- proc HttpdCgiMap {data} {
- regsub -all {([][$\\])} $data {\\\1} data
- regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
- return [subst $data]
- }
- proc bgerror {msg} {
- global errorInfo
- puts stderr "bgerror: $errorInfo"
- }
- proc openurl url {
- global tcl_platform
- if {[lindex $tcl_platform(os) 1] == "NT"} {
- exec cmd /c start $url &
- } else {
- exec start $url &
- }
- }
- set httpdLog stderr
- upvar #0 Httpd opts
- while {[llength $argv] > 0} {
- set option [lindex $argv 0]
- if {![info exists opts($option)] || [llength $argv] == 1} {
- puts stderr "usage: httpd ?options?"
- puts stderr "\nwhere options are any of the following:\n"
- foreach opt [lsort [array names opts -*]] {
- puts stderr [format "\t%-15s default: %s" $opt $opts($opt)]
- }
- exit 1
- }
- set opts($option) [lindex $argv 1]
- set argv [lrange $argv 2 end]
- }
- catch {
- package require vfs
- vfs::auto $opts(-root) -readonly
- }
- if {$opts(-config) != ""} {
- source $opts(-config)
- }
- Httpd_Server [array get opts]
- puts stderr "Accepting connections on http://$Httpd(-host):$Httpd(-port)/"
- if {$Httpd(-launch)} {
- openurl "http://$Httpd(-host):$Httpd(-port)/"
- }
- if {![info exists tcl_service]} {
- vwait forever ;# start the Tcl event loop
- }