Version 32 of Embedded TCL Web Server

Updated 2009-06-06 11:03:15 by dkf

I wanted a trivial web server to embed into my TCL application to show status / provide minor control. Doing this with Tclhttpd turned out to be too difficult / cumbersome, so I came up with this.

Features:

  • Provides SSL support
  • Does Basic authentication
  • Does nothing else

I hope it'll be useful to someone.


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 forever

If 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.


JohnBuckman

I 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 [L1 ] 1162/s

900 byte image fetch benchmark:

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

Notice the amazing speeds from the trivial tcl server. Those aren't mistakes, I verified them. I passed these results onto the Lyris folks, and I'm hoping they figure out what's so fab about this algorithm vs. the http loop in tclhttpd.


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
 456

This 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.