Version 5 of tcliki - a webserver based on DustMote

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.


# tcliki2: 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 ([email protected])
# 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.
#  verbose    : How verbose tcliki's output to stdout is.
array set config {
  sitename "Unconfigured Webserver"
  docroot ".\\docroot"
  defaultdoc "index.html"
  port 80
  httpVer "HTTP/1.0"
  verbose 0
}






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

## Start Service
proc startService {} {
  global config
  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} {
  global config
  if {$config(verbose) >= 1} {
    puts "Accepting $csock from $caddr on port $cport."
  }
  fileevent $csock readable [list handle $csock]
  return
}

## 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
  if {$config(verbose) >= 2} {
    puts "SOCK $csock REQ $docrequest"
  }

  # Decide document to serve
  regexp {.$} $docrequest lastchar
  if { $lastchar eq "/" } {
    # Directory Requested
    serveDir $csock $docrequest
    return
  }

  # File or Directory not ending in "/" Requested
  if {[catch {set fileserve [open \
      [file nativename $config(docroot)$docrequest]]}]} {
    # docroot/docrequest not found, maybe client intended for directory
    # redirect client from "/foo" to "/foo/" to protect relative paths
    puts $csock "$httpCodes(200)"
    puts $csock "Refresh: 0; url=$docrequest/"
    serveDir $csock "$docrequest/"
    return
  } else {
    serveDoc $csock $fileserve
    return
  }
}

## Serve Directory
#  csock     : client socket to serve document on
#  docrequest: directory (/foo/) requested
proc serveDir {csock docrequest} {
  global config
  if {[catch {set fileserve [open [file nativename \
      [file join $config(docroot)$docrequest $config(defaultdoc)]] r]}]} {
    # docroot/docrequest/defaultdoc not found
    serve404
    return
  } else {
    serveDoc $csock $fileserve
    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]
  return
} 

## 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
  return
}

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


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