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.