Updated 2011-09-04 21:10:17 by RLE

http://www.smith-house.org:8000/open.html

scwsd stands for Static Content Web Server Daemon - a complete web server for static files in less than 200 lines of Tcl!

TP I have a copy snagged. See also castle "Clever Application Server/Tcl Language Environment"

EF The TIL also has another fork of this implementation (see [1]). It is longer, but cleaned up and provided as a package. The main difference is probably an implementation of directory listing (for selected directories) and the ability to log to a file.

Doc

scwsd is a bare-bones Static Content Web Server Daemon. It has no extra features, but serves as a minimal implementation from which to build other web applications. It is written in Tcl, requires only the vanilla tclsh interpreter to run, and is less than 200 lines. It is derived from Steve Uhlers minihttpd.tcl, somewhat streamlined and updated, with identifiers changed to be more readable.

To operate it, you use:
 scwsd <root directory> <port> <default file> > log-file

for example:
 scwsd ~/public_html 8080 index.html > web.log

scwsd will serve any file in the hierarchy at or under root. It ignores "../" in files and so refuses to serve files outside that hierarchy unless they are pointed to by links within the hierarchy.

scwsd
 #!/usr/bin/tclsh
 # Static Content Web Server Daemon
 # config is a global array containing the global server state
 #  root:    the root of the document directory
 #  port:    The port this server is serving
 #  listen:  the main listening socket id
 #  accepts: a count of accepted connections so far

 array set config {
   bufsize  32768
   sockblock  0
 }

 # HTTP/1.0 error codes (the ones we use)
 array set errors {
   204 {No Content}
   400 {Bad Request}
   404 {Not Found}
   503 {Service Unavailable}
   504 {Service Temporarily Unavailable}
 }

 # Start the server by listening for connections on the desired port.
 proc server {root { port 0 } { default "" } } {
   global config

   if { $port == 0 } { set port 8080 }
   if { "$default" == "" } { set default index.html }
   puts "Starting webserver, root at $root, port $port, default page $default"
   array set config [list root $root default $default]
   if {![info exists config(port)]} {
     set config(port) $port
     set config(listen) [socket -server accept_connect $port]
     set config(accepts) 0
   }
   return $config(port)
 }

 # Accept a new connection from the server and set up a handler
 # to read the request from the client.

 proc accept_connect {newsock ipaddr port} {
   global config
   upvar #0 config$newsock data

   incr config(accepts)
   fconfigure $newsock -blocking $config(sockblock) \
     -buffersize $config(bufsize) \
     -translation {auto crlf}
   putlog $newsock Connect $ipaddr $port
   set data(ipaddr) $ipaddr
   fileevent $newsock readable [list pull $newsock]
 }
 # read data from a client request
 proc pull { sock } {
   upvar #0 config$sock data

   set readCount [gets $sock line]
   if {![info exists data(state)]} {
     if [regexp {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1.(0|1)} $line x data(proto) data(url) data(query)] {
       set data(state) mime
       putlog $sock Query $line
     } else {
       push-error $sock 400 "bad first line: $line"
     }
     return
   }

   set state [string compare $readCount 0],$data(state),$data(proto)
   switch -- $state {
     0,mime,GET  -
     0,query,POST  { push $sock }
     0,mime,POST   { set data(state) query }
     1,mime,POST   -
     1,mime,GET    {
       if [regexp {([^:]+):[   ]*(.*)}  $line dummy key value] {
         set data(mime,[string tolower $key]) $value
       }
     }
     1,query,POST  {
       set data(query) $line
       push $sock
     }
     default {
       if [eof $sock] {
         putlog $sock Error "unexpected eof on <$data(url)> request"
       } else {
         putlog $sock Error "unhandled state <$state> fetching <$data(url)>"
       }
       push-error $sock 404 ""
     }
   }
 }

 # Close a socket.
 proc disconnect { sock } {
   upvar #0 config$sock data
   unset data
   flush $sock
   close $sock
 }

 proc finish { mypath in out bytes { error {} } } {
   close $in
   disconnect $out
   putlog $out Done "$mypath"
 }

 # Respond to the query.
 proc push { sock } {
   global config
   upvar #0 config$sock data

   set mypath [ URLtoString "$config(root)$data(url)"]
   regsub -all "\\.\\./" $mypath "" mypath
   if {[file isdirectory $mypath]} { append mypath $config(default) }

   if {[string length $mypath] == 0} {
     push-error $sock 400 "$data(url) invalid path"
     return
   }

   if {![catch {open $mypath r} in]} {
     puts $sock "HTTP/1.0 200 Data follows"
     puts $sock "Date: [fmtdate [clock seconds]]"
     puts $sock "Last-Modified: [fmtdate [file mtime $mypath]]"
     puts $sock "Content-Type: [mime-type $mypath]"
     puts $sock "Content-Length: [file size $mypath]"
     puts $sock ""
     fconfigure $sock -translation binary -blocking $config(sockblock)
     fconfigure $in -translation binary -blocking 1
     fcopy $in $sock -command [list finish $mypath $in $sock]
   } else {
     push-error $sock 404 "$data(url) $in"
   }
 }

 # Convert the file suffix into a mime type
 array set mimetypes {
   {}    text/plain
   .txt  text/plain
   .htm  text/html
   .html text/html
   .gif  image/gif
   .jpg  image/jpeg
   .xbm  image/x-xbitmap
 }

 proc mime-type {path} {
   global mimetypes

   set type text/plain
   catch {set type $mimetypes([file extension $path])}
   return $type
 }

 proc push-error {sock code errmsg } {
   upvar #0 config$sock data
   global errors

   append data(url) ""
   set message "<title>Error: $code</title>Error <b>$data(url): $errors($code)</b>."
   puts $sock "HTTP/1.0 $code $errors($code)"
   puts $sock "Date: [fmtdate [clock seconds]]"
   puts $sock "Content-Length: [string length $message]"
   puts $sock ""
   puts $sock $message
   flush $sock
   putlog $sock Error $message
   disconnect $sock
 }

 # Generate a date string in HTTP format.
 proc fmtdate {seconds} {
   return [clock format $seconds -format {%a, %d %b %Y %T %Z}]
 }

 # Log a transaction.
 proc putlog {sock reason args} {
   puts "[clock format [clock seconds]]\t$sock\t$reason\t[join $args { }]"
 }

 # Decode url-encoded strings.
 proc URLtoString {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 bgerror {msg} {
     global errorInfo
     puts stderr "bgerror: $msg\n$errorInfo"
 }

 if { $argc < 1 } { puts "swsd <root directory> <port number> <default page name>"; exit }
 eval server $argv
 vwait forever    ;# start the Tcl event loop

As it stands, scswd refuses rather confusingly any requests from HTTP/1.1 browsers. One of us should fix that some time ...

ZB 2009-08-27 Fixed.

daapp: Fix bug in "catch {open name}" and replace "clock clicks" with "clock seconds".