The following code is a version of the [DustMote] web server wrapped in a [Snit] type. It has all the functionality added in the [Tclssg] [https://github.com/tclssg/tclssg/blob/master/lib/tclssg/webserver/webserver.tcl%|%version], namely,
* Basic logging (to stdout);
* ''Content-Type'' (only here detected with [fileutil::magic::mimetype]);
* Custom route handlers.
On top of it it adds new features:
* Command line options when run as the [main script];
* Directory listings;
* Every server being a Snit object, which means you can have multiple servers running at a time;
* Path jailing (albeit not seriously tested for security).
You can download this server with [wiki-reaper]: `wiki-reaper -x 41336 0 | tee dustmote-snit.tcl`
**Usage (from the command line)**
`usage: dustmote-snit.tcl -root value ?-host localhost? ?-port 8080? ?-default index.html? ?-verbose 1? ?-dirlists 1?`
**Code**
======
#!/usr/bin/env tclsh
# DustMote HTTP server originally developed by Harold Kaplan
# (http://wiki.tcl.tk/4333). Modified by Danyil Bohdan.
# This code is in the public domain.
package require Tcl 8.5
package require fileutil
package require fileutil::magic::mimetype
package require snit 2
namespace eval ::dmsnit {
variable version 0.3.0
}
::snit::type ::dmsnit::httpd {
option -root -default "" -configuremethod Set-root
option -host localhost
option -port 8080
option -default "index.html"
option -verbose 1
option -dirlists 1
variable done 0
variable handlers {}
constructor {} {}
method Set-root {option value} {
if {$option ne "-root"} {
error "Set-root is only for setting the option -root"
}
set options(-root) [::fileutil::fullnormalize $value]
}
method serve {} {
set root [$self cget -root]
set host [$self cget -host]
set port [$self cget -port]
if {$root eq ""} {
error "no root set"
}
$self log "serving path $root on $host port $port"
socket -server "$self answer" -myaddr $host $port
}
# Print $message to standard output if logging is enabled.
method log {message} {
variable verbose
if {[$self cget -verbose]} {
puts $message
}
}
# Handles a new connection.
method answer {socketChannel host2 port2} {
fileevent $socketChannel readable \
[list $self read-request $socketChannel]
}
method return-file {socketChannel filename} {
set fileChannel [open $filename RDONLY]
fconfigure $fileChannel -translation binary
fconfigure $socketChannel -translation binary -buffering full
puts $socketChannel "HTTP/1.0 200 OK"
puts $socketChannel "Content-Type: [::fileutil::magic::mimetype \
$filename]"
puts $socketChannel ""
fcopy $fileChannel $socketChannel \
-command [list $self close-channels \
$fileChannel $socketChannel]
}
method return-404 {socketChannel} {
puts $socketChannel "HTTP/1.0 404 Not found"
puts $socketChannel "Content-Type: text/html"
puts $socketChannel ""
puts $socketChannel ""
puts $socketChannel "No such URL"
puts $socketChannel ""
puts $socketChannel "The URL you requested does not exist."
puts $socketChannel "
"
close $socketChannel
}
method return-dir-list {socketChannel path} {
puts $socketChannel "HTTP/1.0 200 OK"
puts $socketChannel "Content-Type: text/html"
puts $socketChannel ""
puts $socketChannel ""
puts $socketChannel "Directory listing for\
[::fileutil::relative [$self cget -root] $path]]\
"
puts $socketChannel ""
puts $socketChannel {Up a level}
puts $socketChannel ""
foreach filename [glob -nocomplain [file join $path *]] {
puts $socketChannel [format {- %s
} \
[::fileutil::relative [$self cget -root] $filename] \
[file tail $filename]]
}
puts $socketChannel "
"
close $socketChannel
}
# Read an HTTP request from a channel and respond once it can be processed.
method read-request {socketChannel} {
variable handlers
fconfigure $socketChannel -blocking 0
# Parse the request to extract the filename.
set gotLine [gets $socketChannel]
if { [fblocked $socketChannel] } {
return
}
fileevent $socketChannel readable ""
set shortName "/"
regexp {GET (/[^ ]*)} $gotLine _ shortName
set wholeName [::fileutil::jail [$self cget -root] $shortName]
# Return data.
if {[dict exists $handlers $shortName]} {
$self log "Hnd $shortName"
apply [dict get $handlers $shortName] $socketChannel
} else {
# Default file.
if {[file isdir $wholeName]} {
set defaultFile [file join $wholeName [$self cget -default]]
if {[file isfile $defaultFile]} {
set $wholeName $defaultFile
}
}
if {[file isfile $wholeName]} {
$self log "200 $shortName"
$self return-file $socketChannel $wholeName
} elseif {[$self cget -dirlists] && [file isdir $wholeName]} {
$self log "200 $shortName"
$self return-dir-list $socketChannel $wholeName
} else {
$self log "404 $shortName"
$self return-404 $socketChannel
}
}
}
# Called from read-request to clean up when a file request is completed.
method close-channels {inChan outChan args} {
close $inChan
close $outChan
}
# Add a handler $lambda to be called when a client navigates to $route.
# $lambda should be an [apply]-style anonymous function that takes a channel
# name as its only argument. It is up to the handler to close the channel.
method add-handler {route lambda} {
variable handlers
dict set handlers $route $lambda
}
# Return the "done" variable of the current object.
method wait-var {} {
return "${selfns}::done"
}
}
# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
set httpd [::dmsnit::httpd create %AUTO%]
if {$argv eq ""} {
set usageString "usage: $argv0"
foreach option [$httpd info options] {
set defaultValue [$httpd cget $option]
if {$defaultValue eq ""} {
append usageString " $option value"
} else {
append usageString " ?$option $defaultValue?"
}
}
puts $usageString
exit 0
}
$httpd configure {*}$argv
$httpd serve
vwait [$httpd wait-var]
}
======
**Discussion**
**See also**
* [DustMote]
<>Application | Webserver