- Provides SSL support
- Does Basic authentication
- Does nothing else
Time passed, as with any code in active use, it evolved. I've updated the snippet below with the newer version. Please see revision history if you want the simpler but less generic version.
package require uri
package require base64
package require html
proc HTTPD {port certfile keyfile userpwds realm handler} {
if {![llength [info commands Log]]} { proc Log {args} { puts $args } }
namespace eval httpd [list set handlers $handler]
namespace eval httpd [list set realm $realm]
foreach up $userpwds { namespace eval httpd [list lappend auths [base64::encode $up]] }
namespace eval httpd {
proc respond {sock code body {head ""}} {
puts -nonewline $sock "HTTP/1.0 $code ???\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]\n$head\n$body"
}
proc checkauth {sock ip auth} {
variable auths
variable realm
if {[info exist auths] && [lsearch -exact $auths $auth]==-1} {
respond $sock 401 Unauthorized "WWW-Authenticate: Basic realm=\"$realm\"\n"
error "Unauthorized from $ip"
}
}
proc handler {sock ip reqstring auth} {
variable auths
variable handlers
checkauth $sock $ip $auth
array set req $reqstring
switch -glob $req(path) [concat $handlers [list default { respond $sock 404 "Error" }]]
}
proc accept {sock ip port} {
if {[catch {
gets $sock line
set auth ""
for {set c 0} {[gets $sock temp]>=0 && $temp ne "\r" && $temp ne ""} {incr c} {
regexp {Authorization: Basic ([^\r\n]+)} $temp -- auth
if {$c == 30} { error "Too many lines from $ip" }
}
if {[eof $sock]} { error "Connection closed from $ip" }
foreach {method url version} $line { break }
switch -exact $method {
GET { handler $sock $ip [uri::split $url] $auth }
default { error "Unsupported method '$method' from $ip" }
}
} msg]} {
Log "Error: $msg"
}
close $sock
}
}
if {$certfile ne ""} {
package require tls
::tls::init \
-certfile $certfile \
-keyfile $keyfile \
-ssl2 1 \
-ssl3 1 \
-tls1 0 \
-require 0 \
-request 0
::tls::socket -server httpd::accept $port
} else {
socket -server httpd::accept $port
}
}
# Generating SSL key is very easy, just use these two commands:
# openssl genrsa -out server-private.pem 1024
# openssl req -new -x509 -key server-private.pem -out server-public.pem -days 365
# Or just don't specify the key files to use HTTP instead of HTTPS
# HTTPD 9005 "" "" {mike:pwd} {AuthRealm} {
HTTPD 9005 server-public.pem server-private.pem {mike:pwd you:yourpwd} {AuthRealm} {
"" {
respond $sock 200 {Want to know the <a href="/time">time</a>?}
}
"time" {
respond $sock 200 "Time: [clock format [clock seconds]]" "Refresh: 6;URL=/\n"
}
}
vwait foreverIf this server is running, point your browser to https://localhost:9005/
(or http://localhost:9005/ if not using SSL). The username/pw is "mike"/"pwd" or "you"/"yourpwd".The last argument to HTTPD proc is switch syntax (uses glob matching). It provides a convenient interface for different urls, e.g. add "shutdown" { set ::forever 1 } to add a /shutdown location.JohnBuckmanI wanted to test various web servers, as I was moving off of tclhttpd, which has been a bit pokey in the software I've developed (Lyris ListManager and MailShield) for Magnatune and BookMooch, two other sites I maintain.What I found was that this trivial tcl based web server is screamingly fast.Benchmarks on my mac mini (a VERY slow machine):Requests per second handled with trivial tcl dynamic web page (hello world):
| Server | Request rate |
|---|---|
| lighttpd-cgi | 15/second |
| tclhttpd | 32/s |
| aolserver | between 640/s and 750/s |
| trivial all-tcl-web-server [1] | 1162/s |
| Server | Request rate |
|---|---|
| apache img fetch | 593 /s |
| aolserver img fetch | between 1019 and 1267/s |
| lighthttp img fetch | 1089/s |
| tclhttpd | 69/s |
| trivial http w/image cache | 1127/s |
BAS (2008/02/05) Perhaps logging has something to do with it? Was logging enabled for the other web servers? Also, I'm curious what you changed it the code sample to have it serve the images. I found using fcopy (where convenient) is quite a bit faster than [puts $sock ...]
XO (2006/12/04) - I played around with the script and came up a Snit version of it.
# myTrivialTclWeb.tcl - Snit version of Trivial Tcl Web Server
package require uri
package require base64
package require ncgi
package require snit
lappend auto_path ./tls
proc bgerror {msg} {puts "bgerror: $::errorInfo"}
proc respond {sock code body {head ""}} {
puts -nonewline $sock "HTTP/1.0 $code ???\nContent-Type: text/html; \
charset=Big-5\nConnection: close\nContent-length: [string length $body]\n$head\n$body"
}
snit::type HTTPD {
option -port "80"
option -pki {}
option -userpwds {}
option -realm {Trivial Tcl Web V2.0}
option -handler {default {respond $sock 200 "Invalid uri:$uri"}}
variable authList {}
variable listeningSocket
constructor {args} {
$self configurelist $args
foreach up $options(-userpwds) {lappend authList [base64::encode $up]}
if {$options(-pki) ne {}} {
package require tls
foreach {certfile keyfile} $options(-pki) {break}
tls::init -certfile $certfile -keyfile $keyfile \
-ssl2 1 -ssl3 1 -tls1 0 -require 0 -request 0
set listeningSocket [tls::socket -server [mymethod accept] $options(-port)]
} else {
set listeningSocket [socket -server [mymethod accept] $options(-port)]
}
puts "Listening socket: $listeningSocket started on port $options(-port) ..."
}
destructor {
catch {close $listeningSocket}
}
method authenticate {sock ip auth} {
if {[lsearch -exact $authList $auth]==-1} {
respond $sock 401 Unauthorized "WWW-Authenticate: Basic realm=\"$options(-realm)\"\n"
puts "Unauthorized from $ip"
return 0
} else {return 1}
}
method serve {sock ip uri auth} {
if {[llength $authList] ne 0 && [$self authenticate $sock $ip $auth] ne 1} return
array set request [uri::split $uri]
switch -glob $request(path) $options(-handler)
}
method accept {sock ip port} {
if {[catch {
gets $sock line
set auth ""
for {set c 0} {[gets $sock temp]>=0 && $temp ne "\r" && $temp ne ""} {incr c} {
regexp {Authorization: Basic ([^\r\n]+)} $temp -- auth
if {$c == 30} {error "Too many lines from $ip"}
}
if {[eof $sock]} {error "Connection closed from $ip"}
foreach {method uri version} $line {break}
switch -exact $method {
GET {$self serve $sock $ip $uri $auth}
default {error "Unsupported method '$method' from $ip"}
}
} msg]} {
puts "Error: $msg"
}
close $sock
}
}; # end of snit::type HTTPD
# Available variables for actionList
# sock - Server socket connecting to Browser
# uri - requested uri
# request - parsed uri in array format, with the following relevant elements
# request(path)
# request(query) - query string after path?
set actionList {
"" {
respond $sock 200 {Want to know the <a href="/time">time</a>?}
}
"time" {
respond $sock 200 "Time: [clock format [clock seconds]]" "Refresh: 6;URL=/\n"
}
"*.htm" {
set fd [open $request(path) r]
set content [read $fd]; close $fd
respond $sock 200 $content
}
"*.tcl" {
set ::env(QUERY_STRING) [ncgi::decode $request(query)]
set pipe [open "|tclsh $request(path)" r]
set result [read $pipe]
close $pipe
respond $sock 200 $result
}
"eval" {
catch {uplevel #0 [ncgi::decode $request(query)]} result
set result [string map {\n <br>\n} $result]
respond $sock 200 $result
}
"shutdown" {
respond $sock 200 "Server will be shutdown in 3 seconds ..."
after 3000 {set ::forever no}
}
default {
respond $sock 200 "Invalid uri:$uri"
}
}
# Generating SSL key is very easy, just use these two commands:
# openssl genrsa -out server-private.pem 1024
# openssl req -new -x509 -key server-private.pem -out server-public.pem -days 365
# Or just don't specify the -pki option to use HTTP instead of HTTPS
HTTPD webServer -port 9005 -userpwds {mike:pwd you:yourpwd} -handler $actionList
HTTPD securedWebServer -port 9006 -pki {server-public.pem server-private.pem} \
-userpwds {mike:pwd you:yourpwd} -handler $actionList
vwait forever
catch {webServer destroy}
catch {securedWebServer destroy}pcam I receive an error message "application Error" when I point my browser to the base URL that says :
unable to set certificate file server-public.pem: No such file or directory
unable to set certificate file server-public.pem: No such file or directory
while executing
"tls::import sock268 -server 1 -certfile server-public.pem -keyfile server-private.pem -ssl2 1 -ssl3 1 -tls1 0 -require 0 -request 0"
("eval" body line 1)
invoked from within
"eval [list tls::import $chan] $iopts"
(procedure "tls::_accept" line 4)
invoked from within
"tls::_accept {-server 1 -certfile server-public.pem -keyfile server-private.pem -ssl2 1 -ssl3 1 -tls1 0 -require 0 -request 0} httpd::accept sock268 1..."Can anyone tell me how can I create a valid server-public.pem file so that I can run the server with TLS (though I could probably do without it) ?Read the code. Embedded in the code is a comment that very clearly states how to do this.pcam Thanks! I was doing this in a hurry and missed it.George Peter Staplin Feb 5, 2008 - This is a cool server... But beware of the use of gets with this webserver. It's possible for someone to make your server run out of memory with:
puts -nonewline $sock [string repeat "bigstring" $bignumber]If you're using a fat pipe, then it should only take a brief period of time to exhaust all of the memory with garbage data in proc/method accept's gets call. An alternative is to use a non-blocking read, and limit the total length of a header, while carefully checking for the marker between a header and data.I ran into some bugs with TLS in Ubuntu that seem to be unresolved when using this server with openssl 0.9.8g. I think TLS is buggy and in need of some updates, for instance it hardcodes "8.2" stubs, and an error branch is #if 0'ed for some strange reason, and the sources are still in K&R C. I'm getting an ECONNRESET quite often when I try to use it.The code above has a bug. It is potentially overwriting a global variable due to the lack of usage of variable. For example:
$ tclsh8.5
% set ::g 123
123
% namespace eval ::foo {set g 456}
456
% set ::g
456This bug/feature has affected packages in tcllib too. It's non-obvious, and unfortunately some bad code depends on this behavior, so it can't be fixed yet, they say.Janka (2013/09/14)With Tcl-8.6's new features, it's time to revolve the "embedded web server" wheel another time. The following script uses coroutines to handle more than one connection at a time (so starvation because of uncooperative clients is less likely) and zlib compression for serving big HTML/Javascript over tight links.
## At least Tcl 8.6 because of coroutines and try/trap.
package require Tcl 8.6-
## Other required packages.
package require uri
package require base64
package require tls
## Tuning parameters.
set tuning {
header_lines_max 30
request_timeout 5000
zip_minimum 0
zip_level 9
}
## Put anything httpd into an own namespace.
namespace eval ::httpd {
## Accept incoming connection.
proc accept {sock ip port} {
## Start coroutine for client.
chan event $sock readable [coroutine ::httpd::reader$sock apply {{sock ip port} {
## Return the coroutine command on first call so "chan event" can remember it.
yield [info coroutine]
## This any the parts after subsequent "yields" are called automatically by the "chan event" mechanism.
try {
## Start a timeout for the requests.
set timeout [after [dict get $::tuning request_timeout] [list ::httpd::timeout $sock [info coroutine]]]
## Do nonblocking I/O on client socket.
chan configure $sock -blocking 0
## Read requests subsequently.
while {1} {
## HTTP headers are ascii encoded with CRLF line ends, line buffering is fine.
chan configure $sock -encoding ascii -translation crlf -buffering line
## Read the request line.
set request {}
while {$request eq {}} {
## Get request.
chan gets $sock request
## Return control to the event loop in the blocked case.
if {[chan blocked $sock]} yield
## End coroutine when client has closed the channel.
if {[chan eof $sock]} return
}
## Default header values.
set headers {}
dict set headers Accept-Encoding "identity;q=0.001"
## Read additional header lines.
for {set i 0} {$i < [dict get $::tuning header_lines_max]} {incr i} {
## Read header line.
chan gets $sock headerline
## Return control to the event loop in the blocked case.
if {[chan blocked $sock]} yield
## It's an error to have an eof before header end (empty line).
if {[chan eof $sock]} { throw {HTTPD REQUEST_HEADER CONNECTION_CLOSED} "connection closed by client during read of HTTP request header"}
## Break loop on last header line.
if {$headerline eq {}} break
## This is a regular header line.
## Remember field name and value. Repeated field values are lappended.
set sep [string first ":" $headerline]
dict lappend headers [string range $headerline 0 $sep-1] [string trim [string range $headerline $sep+1 end]]
}
## Complain about too many header lines.
if {$i == [dict get $::tuning header_lines_max]} { throw {HTTPD REQUEST_HEADER TOO_MANY_LINES} "too many header lines in HTTP request" }
## Join appended header fields with comma,space (RFC2616, section 4.2).
dict for {name values} $headers {
dict set headers $name [join $values ", "]
}
## Get HTTP method, protocol version and URL.
lassign $request method url version
## Parse "Accept-Encoding" header. Defaults to "identity" if none is present.
set accepted_encodings [parseHeaderList [dict get $headers Accept-Encoding]]
## Respond by method.
switch -- $method {
HEAD - GET {
## Handle the single request.
set data [handleRequest $method $url $version $headers {}]
## Sort out clients which don't accept zipped content at all.
if {$accepted_encodings ne "identity"} {
## Check if content is worth it (long enough, not already zipped internally).
if {[string length [dict get $data content]] >= [dict get $::tuning zip_minimum]} {
switch -glob -- [dict get $data content-type] {
"text/*" {
## Go through list of accepted encodings.
foreach enc $accepted_encodings {
switch -- $enc {
deflate - x-deflate {
## Zip content as raw LZW stream.
dict set data content [zlib deflate [dict get $data content] [dict get $::tuning zip_level]]
## Add header field.
dict set data headers Content-Encoding $enc
## Do not apply another encoding.
break
}
gzip - x-gzip {
## Zip content as GZIP stream (see RFC 1952).
dict set data content [zlib gzip [dict get $data content] -level [dict get $::tuning zip_level]]
## Add header field.
dict set data headers Content-Encoding $enc
## Do not apply another encoding.
break
}
compress {
## Zip content as ZLIB compressed stream.
dict set data content [zlib compress [dict get $data content] [dict get $::tuning zip_level]]
## Add header field.
dict set data headers Content-Encoding $enc
## Do not apply another encoding.
break
}
}
}
}
}
}
}
## Send result header.
chan configure $sock -encoding ascii -translation crlf -buffering full
puts $sock "$version [dict get $data code] ???"
puts $sock "Content-Type: [dict get $data content-type]"
puts $sock "Content-Length: [string length [dict get $data content]]"
foreach {field value} [dict get $data headers] {
puts $sock "$field: $value"
}
puts $sock ""
}
default {
throw {HTTPD REQUEST_METHOD UNSUPPORTED} "unsupported HTTP method in request"
}
}
switch -- $method {
GET {
## Send result.
chan configure $sock -translation binary
puts -nonewline $sock [dict get $data content]
}
}
## Flush output before reading next request.
chan flush $sock
}
} trap {HTTPD REQUEST_HEADER TOO_MANY_LINES} {} {
puts stderr "HTTPD REQUEST_HEADER TOO_MANY_LINES $ip"
} trap {HTTPD REQUEST_HEADER CONNECTION_CLOSED} {} {
puts stderr "HTTPD REQUEST_HEADER CONNECTION_CLOSED $ip"
} trap {HTTPD REQUEST_METHOD UNSUPPORTED} {} {
puts stderr "HTTPD REQUEST_METHOD UNSUPPORTED $ip"
} trap {POSIX ECONNABORTED} {} {
puts stderr "SSL ERROR $ip"
} on error {} {
puts stderr "$::errorCode $::errorInfo"
} finally {
close $sock
after cancel $timeout
}
} ::httpd} $sock $ip $port]
}
## Handle timeout.
proc timeout {sock coroutine_id} {
## Close the channel.
close $sock
## Remove the coroutine
rename $coroutine_id {}
}
## Parse lists in HTTP header fields.
proc parseHeaderList {list} {
## Go through all list items.
foreach item [split $list ","] {
## First subfield is a name.
set type [string trimleft [lindex [split $item ";"] 0]]
## Parse other subfields. RF2616 demands quality "q=..." is the second field, but we are more generous.
set q 1.0
set ext {}
foreach subfield [lrange [split $item ";"] 1 end] {
lassign [split $subfield "="] subfield_name subfield_value
switch -- [string trimleft $subfield_name] {
q {set q $subfield_value}
default {append ext $subfield}
}
}
## Remember item name by quality.
## Any extension is appended to the type.
dict lappend ql $q [concat $type $ext]
}
## Return list items sorted by q value. Remove "q=0" row
dict unset ql 0
set result {}
foreach {q types} [lsort -stride 2 -real -decreasing $ql] {
lappend result {*}$types
}
return $result
}
## Handle a single HTTP request.
proc handleRequest {method url version headers indata} {
dict set result code 200
dict set result content [encoding convertto "ÄÖÜäöüß"]
dict set result content-type "text/plain; charset=[encoding system]"
dict set result headers {}
return $result
}
}
## Prepare the server.
#::tls::init \
-certfile server-public.pem \
-keyfile server-private.pem \
-ssl2 1 -ssl3 1 -tls1 0 \
-require 0 -request 0
#::tls::socket -server ::httpd::accept 9005
socket -server ::httpd::accept 9005
## Start Tcl event loop.
vwait forever
