Version 18 of Embedded TCL Web Server

Updated 2006-12-03 16:29:48

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):

- lighttpd-cgi: 15/second

- tclhttpd: 32/s

- aolserver: between 640/s and 750/s

- trivial all-tcl-web-server http://wiki.tcl.tk/15244 : 1162/s

900 byte image fetch benchmark:

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


XO (2006/12/04) - I played around 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 "Invaid 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}



Category Application - Category Networking - Category Webserver