417 lines
10 KiB
Tcl
417 lines
10 KiB
Tcl
#
|
|
# uhttpd.tcl --
|
|
#
|
|
# Simple Sample httpd/1.0 server in 250 lines of Tcl.
|
|
# Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems.
|
|
#
|
|
# Modified to use namespaces and direct url-to-procedure access (zv).
|
|
# Eh, due to this, and nicer indenting, it's now 150 lines longer :-)
|
|
#
|
|
# Usage:
|
|
# phttpd::create port
|
|
#
|
|
# port Tcp port where the server listens
|
|
#
|
|
# Example:
|
|
#
|
|
# # tclsh8.6
|
|
# % source uhttpd.tcl
|
|
# % uhttpd::create 5000
|
|
# % vwait forever
|
|
#
|
|
# Starts the server on the port 5000. Also, look at the Httpd array
|
|
# definition in the "uhttpd" namespace declaration to find out
|
|
# about other options you may put on the command line.
|
|
#
|
|
# You can use: http://localhost:5000/monitor URL to test the
|
|
# server functionality.
|
|
#
|
|
# Copyright (c) Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems.
|
|
# Copyright (c) 2002 by Zoran Vasiljevic.
|
|
#
|
|
# See the file "license.terms" for information on usage and
|
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
# -----------------------------------------------------------------------------
|
|
|
|
namespace eval uhttpd {
|
|
|
|
variable Httpd; # Internal server state and config params
|
|
variable MimeTypes; # Cache of file-extension/mime-type
|
|
variable HttpCodes; # Portion of well-known http return codes
|
|
variable ErrorPage; # Format of error response page in html
|
|
|
|
array set Httpd {
|
|
-name uhttpd
|
|
-vers 1.0
|
|
-root ""
|
|
-index index.htm
|
|
}
|
|
array set HttpCodes {
|
|
400 "Bad Request"
|
|
401 "Not Authorized"
|
|
404 "Not Found"
|
|
500 "Server error"
|
|
}
|
|
array set MimeTypes {
|
|
{} "text/plain"
|
|
.txt "text/plain"
|
|
.htm "text/html"
|
|
.htm "text/html"
|
|
.gif "image/gif"
|
|
.jpg "image/jpeg"
|
|
.png "image/png"
|
|
}
|
|
set ErrorPage {
|
|
<title>Error: %1$s %2$s</title>
|
|
<h1>%3$s</h1>
|
|
<p>Problem in accessing "%4$s" on this server.</p>
|
|
<hr>
|
|
<i>%5$s/%6$s Server at %7$s Port %8$s</i>
|
|
}
|
|
}
|
|
|
|
proc uhttpd::create {port args} {
|
|
|
|
# @c Start the server by listening for connections on the desired port.
|
|
|
|
variable Httpd
|
|
set arglen [llength $args]
|
|
|
|
if {$arglen} {
|
|
if {$arglen % 2} {
|
|
error "wrong \# arguments, should be: key1 val1 key2 val2..."
|
|
}
|
|
set opts [array names Httpd]
|
|
foreach {arg val} $args {
|
|
if {[lsearch $opts $arg] == -1} {
|
|
error "unknown option \"$arg\""
|
|
}
|
|
set Httpd($arg) $val
|
|
}
|
|
}
|
|
|
|
set Httpd(port) $port
|
|
set Httpd(host) [info hostname]
|
|
|
|
socket -server [namespace current]::Accept $port
|
|
}
|
|
|
|
proc uhttpd::respond {s status contype data {length 0}} {
|
|
|
|
puts $s "HTTP/1.0 $status"
|
|
puts $s "Date: [Date]"
|
|
puts $s "Content-Type: $contype"
|
|
|
|
if {$length} {
|
|
puts $s "Content-Length: $length"
|
|
} else {
|
|
puts $s "Content-Length: [string length $data]"
|
|
}
|
|
|
|
puts $s ""
|
|
puts $s $data
|
|
}
|
|
|
|
proc uhttpd::Accept {newsock ipaddr port} {
|
|
|
|
# @c Accept a new connection from the client.
|
|
|
|
variable Httpd
|
|
upvar \#0 [namespace current]::Httpd$newsock data
|
|
|
|
fconfigure $newsock -blocking 0 -translation {auto crlf}
|
|
|
|
set data(ipaddr) $ipaddr
|
|
fileevent $newsock readable [list [namespace current]::Read $newsock]
|
|
}
|
|
|
|
proc uhttpd::Read {s} {
|
|
|
|
# @c Read data from client
|
|
|
|
variable Httpd
|
|
upvar \#0 [namespace current]::Httpd$s data
|
|
|
|
if {[catch {gets $s line} readCount] || [eof $s]} {
|
|
return [Done $s]
|
|
}
|
|
if {$readCount == -1} {
|
|
return ;# Insufficient data on non-blocking socket !
|
|
}
|
|
if {![info exists data(state)]} {
|
|
set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]}
|
|
if {[regexp $pat $line x data(proto) data(url) data(query)]} {
|
|
return [set data(state) mime]
|
|
} else {
|
|
Log error "bad request line: %s" $line
|
|
Error $s 400
|
|
return [Done $s]
|
|
}
|
|
}
|
|
|
|
# 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" {
|
|
Respond $s
|
|
}
|
|
"0,mime,POST" {
|
|
set data(state) query
|
|
set data(query) ""
|
|
}
|
|
"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
|
|
set clen $data(mime,content-length)
|
|
if {($clen - [string length $data(query)]) <= 0} {
|
|
Respond $s
|
|
}
|
|
}
|
|
default {
|
|
if [eof $s] {
|
|
Log error "unexpected eof; client closed connection"
|
|
return [Done $s]
|
|
} else {
|
|
Log error "bad http protocol state: %s" $state
|
|
Error $s 400
|
|
return [Done $s]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc uhttpd::Done {s} {
|
|
|
|
# @c Close the connection socket and discard token
|
|
|
|
close $s
|
|
unset [namespace current]::Httpd$s
|
|
}
|
|
|
|
proc uhttpd::Respond {s} {
|
|
|
|
# @c Respond to the query.
|
|
|
|
variable Httpd
|
|
upvar \#0 [namespace current]::Httpd$s data
|
|
|
|
if {[uplevel \#0 info proc $data(url)] == $data(url)} {
|
|
|
|
#
|
|
# Service URL-procedure first
|
|
#
|
|
|
|
if {[catch {
|
|
puts $s "HTTP/1.0 200 OK"
|
|
puts $s "Date: [Date]"
|
|
puts $s "Last-Modified: [Date]"
|
|
} err]} {
|
|
Log error "client closed connection prematurely: %s" $err
|
|
return [Done $s]
|
|
}
|
|
set data(sock) $s
|
|
if {[catch {$data(url) data} err]} {
|
|
Log error "%s: %s" $data(url) $err
|
|
}
|
|
|
|
} else {
|
|
|
|
#
|
|
# Service regular file path next.
|
|
#
|
|
|
|
set mypath [Url2File $data(url)]
|
|
if {![catch {open $mypath} i]} {
|
|
if {[catch {
|
|
puts $s "HTTP/1.0 200 OK"
|
|
puts $s "Date: [Date]"
|
|
puts $s "Last-Modified: [Date [file mtime $mypath]]"
|
|
puts $s "Content-Type: [ContentType $mypath]"
|
|
puts $s "Content-Length: [file size $mypath]"
|
|
puts $s ""
|
|
fconfigure $s -translation binary -blocking 0
|
|
fconfigure $i -translation binary
|
|
fcopy $i $s
|
|
close $i
|
|
} err]} {
|
|
Log error "client closed connection prematurely: %s" $err
|
|
}
|
|
} else {
|
|
Log error "%s: %s" $data(url) $i
|
|
Error $s 404
|
|
}
|
|
}
|
|
|
|
Done $s
|
|
}
|
|
|
|
proc uhttpd::ContentType {path} {
|
|
|
|
# @c Convert the file suffix into a mime type.
|
|
|
|
variable MimeTypes
|
|
|
|
set type "text/plain"
|
|
catch {set type $MimeTypes([file extension $path])}
|
|
|
|
return $type
|
|
}
|
|
|
|
proc uhttpd::Error {s code} {
|
|
|
|
# @c Emit error page.
|
|
|
|
variable Httpd
|
|
variable HttpCodes
|
|
variable ErrorPage
|
|
|
|
upvar \#0 [namespace current]::Httpd$s data
|
|
|
|
append data(url) ""
|
|
set msg \
|
|
[format $ErrorPage \
|
|
$code \
|
|
$HttpCodes($code) \
|
|
$HttpCodes($code) \
|
|
$data(url) \
|
|
$Httpd(-name) \
|
|
$Httpd(-vers) \
|
|
$Httpd(host) \
|
|
$Httpd(port) \
|
|
]
|
|
if {[catch {
|
|
puts $s "HTTP/1.0 $code $HttpCodes($code)"
|
|
puts $s "Date: [Date]"
|
|
puts $s "Content-Length: [string length $msg]"
|
|
puts $s ""
|
|
puts $s $msg
|
|
} err]} {
|
|
Log error "client closed connection prematurely: %s" $err
|
|
}
|
|
}
|
|
|
|
proc uhttpd::Date {{seconds 0}} {
|
|
|
|
# @c Generate a date string in HTTP format.
|
|
|
|
if {$seconds == 0} {
|
|
set seconds [clock seconds]
|
|
}
|
|
clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1
|
|
}
|
|
|
|
proc uhttpd::Log {reason format args} {
|
|
|
|
# @c Log an httpd transaction.
|
|
|
|
set messg [eval format [list $format] $args]
|
|
set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"]
|
|
|
|
puts stderr "\[$stamp\] $reason: $messg"
|
|
}
|
|
|
|
proc uhttpd::Url2File {url} {
|
|
|
|
# @c Convert a url into a pathname (this is probably not right)
|
|
|
|
variable Httpd
|
|
|
|
lappend pathlist $Httpd(-root)
|
|
set level 0
|
|
|
|
foreach part [split $url /] {
|
|
set part [CgiMap $part]
|
|
if [regexp {[:/]} $part] {
|
|
return ""
|
|
}
|
|
switch -- $part {
|
|
"." { }
|
|
".." {incr level -1}
|
|
default {incr level}
|
|
}
|
|
if {$level <= 0} {
|
|
return ""
|
|
}
|
|
lappend pathlist $part
|
|
}
|
|
|
|
set file [eval file join $pathlist]
|
|
|
|
if {[file isdirectory $file]} {
|
|
return [file join $file $Httpd(-index)]
|
|
} else {
|
|
return $file
|
|
}
|
|
}
|
|
|
|
proc uhttpd::CgiMap {data} {
|
|
|
|
# @c Decode url-encoded strings
|
|
|
|
regsub -all {\+} $data { } 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 uhttpd::QueryMap {query} {
|
|
|
|
# @c Decode url-encoded query into key/value pairs
|
|
|
|
set res [list]
|
|
|
|
regsub -all {[&=]} $query { } query
|
|
regsub -all { } $query { {} } query; # Othewise we lose empty values
|
|
|
|
foreach {key val} $query {
|
|
lappend res [CgiMap $key] [CgiMap $val]
|
|
}
|
|
return $res
|
|
}
|
|
|
|
proc /monitor {array} {
|
|
|
|
upvar $array data ; # Holds the socket to remote client
|
|
|
|
#
|
|
# Emit headers
|
|
#
|
|
|
|
puts $data(sock) "HTTP/1.0 200 OK"
|
|
puts $data(sock) "Date: [uhttpd::Date]"
|
|
puts $data(sock) "Content-Type: text/html"
|
|
puts $data(sock) ""
|
|
|
|
#
|
|
# Emit body
|
|
#
|
|
|
|
puts $data(sock) [subst {
|
|
<html>
|
|
<body>
|
|
<h3>[clock format [clock seconds]]</h3>
|
|
}]
|
|
|
|
after 1 ; # Simulate blocking call
|
|
|
|
puts $data(sock) [subst {
|
|
</body>
|
|
</html>
|
|
}]
|
|
}
|
|
|
|
# EOF $RCSfile: uhttpd.tcl,v $
|
|
# Emacs Setup Variables
|
|
# Local Variables:
|
|
# mode: Tcl
|
|
# indent-tabs-mode: nil
|
|
# tcl-basic-offset: 4
|
|
# End:
|
|
|