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 (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.
# 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 ""
puts $csock "$config(sitename) - 404 Error"
puts $csock ""
puts $csock "HTTP Error 404: The document requested is not available"
puts $csock ""
puts $csock ""
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.
<> Application | Internet | Networking | Webserver