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]

[HaO] 2020-08-18: With TCLTLS 1.7.18 on Windows 64 bit using BAWT 32 bit distribution and Firefox client, I may report the following:

   *   The ::tls::init options "-ssl2 1 -ssl3 1 -tls1 0" raise a lot of calles to bgerror with error "protocol not supported".
   *   Removing the ::tls::init options "-ssl2 1 -ssl3 1 -tls1 0" cures the issue and successful communication is possible.

----

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 [http://wiki.tcl.tk/15244] | 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.

----
[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
======

----
**See Also**

   * [DustMote]
   * [Wibble]

<<categories>> Application | Networking | Webserver