CASTLE - Castle Application Server/Tcl Language Environment.
A complete web application server in just 300 lines of Tcl!
http://www.smith-house.org:8000/open.html
20050210 -- link is dead.
20050215 -- no it isn't. =) [larry]
[TP] I have a copy snagged. See also [scwsd]
----
* Doc
Castle - Clever Application Server/Tcl Language Environment
Castle is a web application server - it serves static content, but
it can also execute tcl scripts that can generate dynamic web page
content. One such application, macro.tcl, is included in this
distribution. This application will execute any tcl expressions
found in .src files and insert their results back in the source
file. macro.tcl provides a set of markup commands similar in many
respects to expand (http://www.wjduquette.com/tcl/index.html).
Like expand, macro.tcl allows you to use macros to maintain a
consistant set of web pages, but unlike expand, it does so on
the fly, and does not require pre-processing to create .html
files.
Castle uses the file extension to determine which application
to use. You can define your own set of macros in a new file
(for example, myapp.tcl) and then inform castle how to use it
by adding your new extension (.mya) to the servicetypes array
at the begining of castle program thusly:
array set servicetypes {
.src {macro}
.mya {myapp}
}
and restart the server. Now whenever the server gets a request
for a .mya file, any tcl expression it contains will be executed
using myapp as a library.
Castle also has a more general system of accessing applications.
Whenever the specified url does not exist as a static file,
castle will clip off the first subdirectory and look for an
application by that name with a .tcl extension. If it exists,
it is called, with succeeding subdirectories turned into named
parameters. Thus:
/test/a=2/b=c
Will result in the call: [[::test::process a=2 b=c]]
These parameters can be scanned using Castle's "getparams"
function. Here is a simple example you can use with the
above "test" app:
proc init { } {
return 1
}
proc process { args } {
getparams { sock 0 a 1 b 2 c 3 } $args
puts $sock "HTTP/1.0 200 Data follows"
puts $sock "Date: [fmtdate [clock clicks]]"
puts $sock "Content-Type: text/html"
puts $sock ""
puts $sock "
Service: Test"
puts $sock "Service: Test.\n"
puts $sock "parameters: sock=$sock, a=\"$a\", b=\"$b\", c=\"$c\""
if [ info exists d ] {
puts " d is defined as well: \"$d\""
}
puts $sock ""
disconnect "" "" $sock 0
return 0
}
You will notice that getparams takes an arbitrary number of arguments,
the first being a list of vars it should accept (and their default
values) and the rest being pairs in the form var=val.
----
* castle
#!/usr/bin/tclsh
# Static Content Web Server Daemon
# config is a global array containing the global server state
# root: the root of the document directory
# port: The port this server is serving
# listen: the main listening socket id
# accepts: a count of accepted connections so far
array set servicetypes {
.src {macro}
.yak {yakdot}
}
array set config {
services {}
bufsize 32768
sockblock 0
}
# HTTP/1.0 error codes (the ones we use)
array set errors {
204 {No Content}
400 {Bad Request}
404 {Not Found}
503 {Service Unavailable}
504 {Service Temporarily Unavailable}
}
array set statistics {
}
proc count { url } {
global statistics
if [ info exists statistics($url) ] {
incr statistics($url)
} else {
set statistics($url) 1
}
}
proc parray {a {save 1} {pattern *} } {
upvar 1 $a array
if {![array exists array]} {
error "\"$a\" isn't an array"
}
set maxl 0
foreach name [lsort [array names array $pattern]] {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + [string length $a] + 2}]
set answer ""
foreach name [lsort [array names array $pattern]] {
set nameString [format %s(%s) $a $name]
if { $save } {
append answer [format "set %-*s %s\n" $maxl $nameString $array($name)]
} else {
append answer [format "%-*s %s\n" $name $array($name)]
}
}
return $answer
}
proc savestats { } {
global statistics
set f [ open stats.data w ]
puts $f [ parray statistics ]
close $f
exec sort -n -k 3 -r stats.data
after 600000 savestats
}
# Start the server by listening for connections on the desired port.
proc server {root { port 0 } { default "" } } {
global config
if { $port == 0 } { set port 8080 }
if { "$default" == "" } { set default index.html }
puts "Starting webserver, root at $root, port $port, default page $default"
array set config [list root $root default $default]
if {![info exists config(port)]} {
set config(port) $port
set config(listen) [socket -server accept_connect $port]
set config(accepts) 0
}
return $config(port)
}
# Accept a new connection from the server and set up a handler
# to read the request from the client.
proc accept_connect {newsock ipaddr port} {
global config
upvar #0 config$newsock data
incr config(accepts)
fconfigure $newsock -blocking $config(sockblock) \
-buffersize $config(bufsize) \
-translation {auto crlf}
putlog $newsock Connect $ipaddr $port
set data(ipaddr) $ipaddr
fileevent $newsock readable [list pull $newsock]
}
# read data from a client request
proc pull { sock } {
upvar #0 config$sock data
set readCount [gets $sock line]
if {![info exists data(state)]} {
if [regexp {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1.0} $line x data(proto) data(url) data(query)] {
set data(state) mime
putlog $sock Query $line
} else {
push-error $sock 400 "bad first line: $line"
}
return
}
set state [string compare $readCount 0],$data(state),$data(proto)
switch -- $state {
0,mime,GET -
0,query,POST { push $sock }
0,mime,POST { set data(state) query }
1,mime,POST -
1,mime,GET {
if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] {
set data(mime,[string tolower $key]) $value
}
}
1,query,POST {
set data(query) $line
push $sock
}
default {
if [eof $sock] {
putlog $sock Error "unexpected eof on <$data(url)> request"
push-error $sock 404 "unexpected eof on <$data(url)> request"
} else {
putlog $sock Error "unhandled state <$state> fetching <$data(url)>"
}
}
}
}
# Close a socket.
proc disconnect { mypath in sock bytes { error {} } } {
upvar #0 config$sock data
global config
if { "$in" != ""} { close $in }
unset data
flush $sock
close $sock
if { "$error" != "" } {
putlog $sock Error "$error"
} else {
putlog $sock Done "$mypath"
}
}
proc load_service { sock service } {
upvar #0 config$sock data
global config
if { "$service" == "" } { return 0 }
if { [lsearch -exact $config(services) $service ] == -1 } {
if [ file readable ${service}.tcl ] {
putlog $sock Info Loading service: $service
namespace eval $service source ${service}.tcl
if { [ namespace eval $service init ] } {
lappend config(services) $service
} else {
push-error $sock 503 "unable to start service \"$service\"" ; return 0
}
} else {
push-error $sock 503 "no such service \"$service\"" ; return 0
}
}
return 1
}
proc getparams { vars args } {
upvar args arglist
if { [ llength $arglist ] == 1 } {
# braced set of args
eval set arglist $arglist
}
foreach { var val } $vars {
uplevel 1 set $var \"$val\"
}
foreach arg $arglist {
set param [ split $arg "=" ]
set var [ lindex $param 0 ]
set val [ join [ lreplace $param 0 0 ] "=" ]
if { [ lsearch $vars $var ] != -1 } {
uplevel 1 set $var \{$val\}
}
}
}
# Respond to the query.
proc push { sock } {
global config
upvar #0 config$sock data
set data(url) [ URLtoString $data(url)]
set mypath "$config(root)$data(url)"
regsub -all "\\.\\./" $mypath "" mypath
if {[file isdirectory $mypath]} { append mypath $config(default) }
if {[string length $mypath] == 0} {
push-error $sock 400 "$data(url) invalid path"
return
}
set mime [ mime-type $sock $mypath ]
if {![catch { open "$data(filter)$mypath" } in]} {
fconfigure $sock -translation binary -blocking $config(sockblock)
if [ load_service $sock $data(service) ] {
set buffer [ read $in ]
if { [ ::$data(service)::process $sock buffer ] == 0 } {
count $data(url)
puts $sock $buffer
disconnect $mypath $in $sock [ string length $buffer ]
} else {
puts $sock $buffer
push-error $sock 400 "unable to process"
}
} else {
puts $sock "HTTP/1.0 200 Data follows"
puts $sock "Date: [fmtdate [clock clicks]]"
puts $sock "Last-Modified: [fmtdate [file mtime $mypath]]"
puts $sock "Content-Type: $mime"
puts $sock ""
count $data(url)
fconfigure $in -translation binary -blocking 1
fcopy $in $sock -command [list disconnect $mypath $in $sock]
}
} else {
if [ regexp "/(\[^/]*)/(.*\$)" $data(url) junk name params ] {
if [ load_service $sock $name ] {
if { [eval ::${name}::process sock=$sock [ split $params / ] ] == 0 } {
count $name
} else {
push-error $sock 400 "unable to process"
}
}
}
}
}
# convert the file suffix into a mime type
array set mimetypes {
{} text/plain
.txt text/plain
.htm text/html
.html text/html
.src text/html
.gif image/gif
.png image/png
.jpg image/jpeg
.xbm image/x-xbitmap
.tar application/x-tar
}
array set filtertypes {
.gz {| zcat }
.bz2 {| bzcat }
.src {| sed {s/^$/[p]/g} }
}
proc mime-type {sock path} {
global mimetypes
global filtertypes
global servicetypes
upvar #0 config$sock data
set type text/plain
set ext [file extension $path]
set data(filter) ""
catch { set data(filter) $filtertypes($ext)}
if { [info exists filtertypes($ext)] != [info exists servicetypes($ext)] } {
regsub "$ext\$" $path "" path
}
set nextext [file extension $path]
if { "$nextext" != "" } { set ext $nextext }
if { "$ext" == ".tar" } { set data(filter) "" }
catch {set type $mimetypes($ext)}
set data(service) ""
catch { set data(service) $servicetypes($ext) }
return $type
}
proc push-error {sock code errmsg } {
upvar #0 config$sock data
global errors
set message "Error: $codeError $code $data(url): $errors($code)."
puts $sock "HTTP/1.0 $code $errors($code)"
puts $sock "Date: [fmtdate [clock clicks]]"
puts $sock ""
puts $sock $message
disconnect "" "" $sock 0 $errmsg
}
# Generate a date string in HTTP format.
proc fmtdate {clicks} {
return [clock format $clicks -format {%a, %d %b %Y %T %Z}]
}
# Log a transaction.
proc putlog {sock reason args} {
puts "[clock format [clock seconds]]\t$sock\t$reason\t[join $args { }]"
}
# Decode url-encoded strings.
proc URLtoString {data} {
regsub -all {([][$\\])} $data {\\\1} data
regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
return [subst $data]
}
proc bgerror {msg} {
global errorInfo
puts stderr "bgerror: $msg\n$errorInfo"
}
if { $argc < 1 } { puts "castle "; exit }
eval server $argv
if [ file readable stats.data ] { source stats.data }
savestats
vwait forever ;# start the Tcl event loop
----
* macro.tcl (as referred in docs)
proc init { } {
return 1
}
proc init-run { } {
upvar data data
set data(first_page) 1
set data(bullet_level) 0
set data(chapter_count) 0
set data(first)(0) 0
set data(count)(0) ""
set data(lock)(i) 0
set data(lock)(b) 0
set data(lock)(u) 0
set data(lock)(x) 0
}
proc process { sock workbuffer } {
upvar #0 config$sock data
upvar $workbuffer buffer
init-run
set result [ catch { eval set buffer \"$buffer\" } err ]
if { $result != 0 } {
set buffer "processing error: $result. $err"
}
return $result
}
proc parray {a {pattern *}} {
upvar 1 $a array
if {![array exists array]} {
error "\"$a\" isn't an array"
}
set maxl 0
foreach name [lsort [array names array $pattern]] {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + [string length $a] + 2}]
set answer ""
foreach name [lsort [array names array $pattern]] {
set nameString [format %s(%s) $a $name]
append answer [format "%-*s = %s\n" $maxl $nameString $array($name)]
}
return $answer
}
#----------------------------------------------------------------------
# Rules
proc title { args } {
set head "\n"
append head " \n"
append head " [join $args " "]\n"
append head "\n\n"
append head ""
return $head
}
# Format the HTML header and document title
proc page { args } {
append head ""
append head ""
append head "[join $args " "]"
append head " |
"
return $head
}
proc bullet { cmd } {
upvar data data
if { "$cmd" == "start" } {
incr data(bullet_level)
set data(first)($data(bullet_level)) 1
set data(count)($data(bullet_level)) ""
return "