Version 0 of DustMote with Snit

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 version , namely,
Basic logging (to stdout);
Content-Type (only here detected with fileutil::magic::mimetype);
Custom route handlers.
On top of those it adds new features:
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`
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 "<!DOCTYPE html>"
        puts $socketChannel "<html><head><title>No such URL</title></head>"
        puts $socketChannel "<body><h1>"
        puts $socketChannel "The URL you requested does not exist."
        puts $socketChannel "</h1></body></html>"
        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 "<!DOCTYPE html>"
        puts $socketChannel "<html><head><title>Directory listing for\
                [::fileutil::relative [$self cget -root] $path]]\
                </title></head>"
        puts $socketChannel "<body>"
        puts $socketChannel {<a href="..">Up a level</a>}
        puts $socketChannel "<ul>"
        foreach filename [glob -nocomplain [file join $path *]] {
            puts $socketChannel [format {<li><a href="%s">%s</a></li>} \
                    [::fileutil::relative [$self cget -root] $filename] \
                    [file tail $filename]]
        }
        puts $socketChannel "</ul></body></html>"
        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]
}
Version 0 of DustMote with Snit

Code

Discussion

See also
