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'';
* Custom route handlers.
On top of it 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);
* [TLS] support;
* Command line options when run as the [main script];
* Server reloading when run as the main script.
Known bugs:
* Unicode URLs do not work.
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? ?-certfile public.pem? ?-keyfile private.pem? ?-tls 0?`
You can use the following shell command to generate a set of temporary SSL certificates with [OpenSSL]:
`openssl req -x509 -newkey rsa:2048 -nodes -keyout private.pem -out public.pem -subj '/CN=localhost' -days 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 snit 2
package require textutil
namespace eval ::dmsnit {
variable version 0.7.2
}
::snit::type ::dmsnit::httpd {
# Basic web server configuration.
option -root \
-default "" \
-configuremethod Set-normalized
option -host localhost
option -port 8080
option -default "index.html"
option -verbose 1
option -dirlists 1
# TLS options.
option -certfile \
-default public.pem \
-configuremethod Set-normalized \
-validatemethod File-exists
option -keyfile \
-default private.pem \
-configuremethod Set-normalized \
-validatemethod File-exists
option -tls \
-default 0 \
-configuremethod Set-tls
# The "done" variable. Whoever creates the server object can vwait on this
# variable using [vwait [$obj wait-var-name]] until a handler changes it to
# signal that the server's work is done. Setting the variable to a true
# value does not stop the server. It needs to be explicitly destroyed with
# [$obj destroy] for that.
variable done 0
# Custom route handlers.
variable handlers {}
# The command used to create a new server socket.
variable socketCommand socket
# The server socket channel. Does not itself transfer data but can be closed
# to stop accepting new connections.
variable socketChannel
constructor {} {}
destructor {
variable socketChannel
$self log "shutting down"
close $socketChannel
}
# Private methods.
method File-exists {option value} {
if {![file isfile $value]} {
error "file \"$value\" used for option $option doesn't exist"
}
}
method Set-normalized {option value} {
set options($option) [::fileutil::fullnormalize $value]
}
method Set-tls {option value} {
if {$option ne "-tls"} {
error "Set-tls is only for setting the option -tls"
}
if {$value} {
package require tls
::tls::init \
-certfile [$self cget -certfile] \
-keyfile [$self cget -keyfile] \
-ssl2 0 \
-ssl3 0 \
-tls1 1 \
-require 0 \
-request 1
set socketCommand ::tls::socket
} else {
set socketCommand socket
}
set options(-tls) $value
}
# Public methods.
# Create a server socket and start accepting connections.
method serve {} {
variable socketCommand
variable socketChannel
set root [$self cget -root]
set host [$self cget -host]
set port [$self cget -port]
set tls [$self cget -tls]
if {$root eq ""} {
error "no root set"
}
set message "serving path $root on $host port $port"
if {$tls} {
append message " with TLS"
}
$self log $message
set socketChannel [$socketCommand \
-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
}
}
# Handle a new connection.
method answer {connectChannel host2 port2} {
fileevent $connectChannel readable \
[list $self read-request $connectChannel]
}
method return-file {connectChannel filename} {
set fileChannel [open $filename RDONLY]
fconfigure $fileChannel -translation binary
fconfigure $connectChannel -translation binary -buffering full
puts $connectChannel "HTTP/1.0 200 OK"
puts $connectChannel "Content-Type: [::mime::type $filename]"
puts $connectChannel ""
fcopy $fileChannel $connectChannel \
-command [list $self close-channels \
$fileChannel $connectChannel]
}
method return-404 {connectChannel} {
puts -nonewline $connectChannel [::template::expand {
HTTP/1.0 404 Not found
Content-Type: text/html
404 Not found
The URL you requested does not exist.
}]
close $connectChannel
}
# Write to the channel $connectChannel the list of files and directories at
# the local path $path formatted as HTML. $path should be an absolute path
# and *not* one relative to -root.
method return-dir-list {connectChannel path} {
set links {}
foreach url [glob -tails -nocomplain -directory $path *] {
if {[file isdir [file join $path $url]]} {
append url /
}
append links "\n $url"
}
set titlePath [file join / \
[::fileutil::relative [$self cget -root] $path]]
if {$titlePath eq "/."} {
set titlePath /
}
puts -nonewline $connectChannel [::template::expand {
HTTP/1.0 200 OK
Content-Type: text/html
Directory listing for %1$s
Up a level
} $titlePath $links]
close $connectChannel
}
# Read an HTTP request from a channel and respond once it can be processed.
method read-request {connectChannel} {
variable handlers
fconfigure $connectChannel -blocking 0
# Parse the request to extract the filename.
set gotLine [gets $connectChannel]
if { [fblocked $connectChannel] } {
return
}
fileevent $connectChannel 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] $connectChannel
} 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 $connectChannel $wholeName
} elseif {[$self cget -dirlists] && [file isdir $wholeName]} {
$self log "200 $shortName"
$self return-dir-list $connectChannel $wholeName
} else {
$self log "404 $shortName"
$self return-404 $connectChannel
}
}
}
# 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 new handler $lambda to be called when a client requests the URL
# $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 fully qualified name of the "done" variable for the current
# object.
method wait-var-name {} {
return "${selfns}::done"
}
}
namespace eval ::mime {
variable mimeDataInverted {
text/plain {
makefile
COPYING
LICENSE
README
Makefile
.c
.conf
.h
.log
.md
.sh
.tcl
.terms
.tm
.txt
.wiki
.HOWTO
.LICENSE
.README
}
text/css .css
text/csv .csv
image/gif .gif
application/gzip {
.gz
.tgz
}
text/html {
.htm
.html
}
image/jpeg {
.jpg
.jpeg
}
application/javascript .js
application/json .json
application/pdf .pdf
image/png .png
application/postscript .ps
application/xhtml .xhtml
application/xml .xml
application/zip .zip
}
variable byFilename {}
variable byExtension {}
foreach {mimeType files} $mimeDataInverted {
foreach file $files {
if {[string index $file 0] eq "."} {
lappend byExtension $file $mimeType
} else {
lappend byFilename $file $mimeType
}
}
}
unset mimeDataInverted
proc ::mime::type {filename} {
variable byFilename
variable byExtension
set tail [file tail $filename]
set ext [file extension $filename]
if {[dict exists $byFilename $tail]} {
return [dict get $byFilename $tail]
} elseif {[dict exists $byExtension $ext]} {
return [dict get $byExtension $ext]
} else {
return application/octet-stream
}
}
}
namespace eval ::template {
proc ::template::expand {template args} {
return [format [::textutil::undent $template] {*}$args]
}
}
proc ::dmsnit::main {argv0 argv} {
variable reload 0
set httpd [::dmsnit::httpd create %AUTO%]
# Process command line arguments.
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
}
# Sample custom handlers that are used for development.
if 1 {
$httpd add-handler /quit {
{connectChannel} {
upvar 1 self self
puts -nonewline $connectChannel [::template::expand {
HTTP/1.0 200 OK
Content-Type: text/html
}]
close $connectChannel
set [$self wait-var-name] 1
}
}
$httpd add-handler /reload {
{connectChannel} {
upvar 1 self self
puts -nonewline $connectChannel [::template::expand {
HTTP/1.0 202 Accepted
Refresh: 2000; url=/
Content-Type: text/html
Reloading...
}]
close $connectChannel
set [$self wait-var-name] 1
set ::dmsnit::reload 1
}
}
}
$httpd configure {*}$argv
$httpd serve
vwait [$httpd wait-var-name]
$httpd destroy
if {$reload} {
# Reload the server script and restart the server.
uplevel #0 [list source [info script]]
if {[info commands tailcall] eq "tailcall"} {
tailcall ::dmsnit::main $argv0 $argv
} else {
::dmsnit::main $argv0 $argv
}
}
}
# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
# If this is not a reload...
if {![info exists ::dmsnit::reload] || !$::dmsnit::reload} {
::dmsnit::main $argv0 $argv
}
}
======
**Discussion**
**See also**
* [DustMote]
<>Application | Webserver