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
        if { [file exists \
                 [file join $config(docroot)$docrequest $config(defaultdoc)]]} {
            # redirect client from "/foo" to "/foo/" to protect relative paths
            puts $csock "$httpCodes(200)"
            puts $csock "Refresh: 0; url=$docrequest/"
            serveDir $csock "$docrequest/"
        } else {
            serve404 $csock
        }
        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 $csock
        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 note:

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.