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.


<<categories>> Application | Internet | Networking | Webserver