A simple webserver based on DustMote with a few changes.

I'm learning Tcl and thought it would be handy to write something that can handle basic directory structures and serve files via http.  Much of this came from DustMote, with a few ideas from scwsd.  It doesn't offer any particular features not offered up in other webservers, but I figured I'd upload it here for anyone interested.

No guarantees regarding performance or standards compliance.
======

# tcliki: a small and basic portable http server
#
# Inspired by DustMote (wiki.tcl.tk/4333)
#         and scwsd    (wiki.tcl.tk/3900)
#
# All _necessary_ configuration is in the "Configuration" section
#
# Written by Wade Nelson (wade.nels@gmail.com)
# with heavy reliance on DustMote by Harold Kaplan

## Configuration
#  sitename   : Your website/server's name
#  docroot    : The default document directory.
#               IMPORTANT: Use "/" or "\\" as directory delimiters, not "\"
#  defaultdoc : The default document to serve, typically index.html
#  port       : The port for the server to accept connections on
#  httpVer    : HTTP protocol version we use; editing not recommended.
array set config {
  sitename "Unconfigured Webserver"
  docroot ".\\docroot"
  defaultdoc "index.html"
  port 80
  httpVer "HTTP/1.0"
}




## HTTP/1.0 Codes we use
set httpCodes(200) "$config(httpVer) 200 OK"
set httpCodes(404) "$config(httpVer) 404 Not Found"

## Initial Configuration
#  Set file paths from config array to match local filesystem standards.
proc preConfig {} {
  global config
  set $config(docroot) [file nativename $config(docroot)]
  set $config(defaultdoc) [file nativename $config(defaultdoc)]
}

## Start Service
proc startService {} {
  global config
  preConfig
  puts "Staring service on port $config(port)."
  set runService [socket -server accepting $config(port)]
  vwait forever
}

## Accept Connection
#  csock: the socket connection from the client
#  caddr: client IP address
#  cport: client port number
proc accepting {csock caddr cport} {
  puts "Accepting $csock from $caddr on port $cport."
  fileevent $csock readable [list handle $csock]
}

## Handle Requests
#  csock: the socket connection from the client
proc handle {csock} {
  global config
  global httpCodes
  fconfigure $csock -blocking 0
  set dataIn [gets $csock]
  if { [fblocked $csock] } {
    return
  }
  fileevent $csock readable ""
  # Gather document requested
  regexp {/[^ ]*} $dataIn docrequest
  # Decide document to serve
  regexp {.$} $docrequest lastchar
  if { $lastchar eq "/" && [string length $docrequest] == 1 } {
    # root dir "/" requested, serve defaultdoc
    set docserve $config(defaultdoc)
  } else {
    # root dir "/" not requested, serve requested doc
    regexp {^/(.*)} $docrequest "" docserve
  }
  # Attempt to serve requested doc
  set docserve [file nativename [file join $config(docroot) $docserve]]
  if { ![catch {set fileserve [open $docserve r]}] } {
    # Document found, serve document
    serveDoc $csock $fileserve
    return
  }
  # Document wasn't found as requested, perhaps client requested
  # a directory.  Attempt to serve client_request/defaultdoc
  elseif { ![catch {set fileserve [open \
    [file nativename [file join $docserve $config(defaultdoc)]]]}] } {
    # found client_request/defaultdoc
    if { $lastchar ne "/" } {
      # redirect client_req_dir to client_req_dir/
      # Doing this prevents relative paths in served documents from breaking.
      puts $csock "$httpCodes(200)"
      puts $csock "Refresh: 0; url=$docrequest/"
    }
    # Serve Document
    serveDoc $csock $fileserve
    return
  }
  # Document still wasn't found as requested, serve error
  else {
    serve404 $csock
    return
  }
}

## Serve Document
#  csock    : client socket to serve document on
#  fileserve: $docroot/path/to/document open file to serve
proc serveDoc {csock fileserve} {
  global httpCodes
  fconfigure $fileserve -translation binary
  fconfigure $csock -translation binary -buffering full
  puts $csock "$httpCodes(200)"
  puts $csock ""
  fcopy $fileserve $csock -command [list closeConnection $fileserve $csock]
} 

## Serve 404 Error
#  csock: client socket to receive 404
proc serve404 {csock} {
  global config
  global httpCodes
  puts $csock "$httpCodes(404)"
  puts $csock ""
  puts $csock "<html>"
  puts $csock "<head><title>$config(sitename) - 404 Error</title></head>"
  puts $csock "<body>"
  puts $csock "HTTP Error 404: The document requested is not available"
  puts $csock "</body>"
  puts $csock "</html>"
  close $csock
}

## Close Connections
#  file  : local file to close
#  socket: client socket to close
proc closeConnection {file socket args} {
  close $file
  close $socket
}


# Engage!
startService


======

A couple notes:

The script works as-is tested on Tcl 8.5 on Windows.  To get it to work under 8.4 on Linux the "else" and "elseif" had to come directly after the } on the preceding statements, so remove the extraneous comments there.

Using "/" and "\\" as delimiters for docroot works under Tcl 8.5 on Windows.  To get it to work under 8.4 on Linux only the "/" delimiter seems to work properly.


!!!!!!
%| [Category Application]|[Category Internet]|[Category Networking]|[Category Webserver] |%
!!!!!!