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
20110225 -- Dead Again
JSI 15feb05 -- Exactly: It was and isn't anymore. Welcome back in the virtual world, castle!
TP I have a copy snagged. See also scwsd "Static Content Web Server Daemon"
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 consistent 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 "<html><head><title>Service: Test</title></head>"
puts $sock "<body>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 "</body></html>"
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|1)} $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 "<title>Error: $code</title>Error $code <b>$data(url):</b> $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 <root directory> <port number> <default page name>"; exit }
eval server $argv
if [ file readable stats.data ] { source stats.data }
savestats
vwait forever ;# start the Tcl event loopmacro.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 "<html><head>\n"
append head " <META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=iso-8859-1\">\n"
append head " <title>[join $args " "]</title>\n"
append head "</head>\n\n"
append head "<BODY TEXT=\"#000000\" BGCOLOR=\"#FFFFFF\">"
return $head
}
# Format the HTML header and document title
proc page { args } {
append head "<table width=\"100%\" cellspacing=0 border=0 cellpadding=2>"
append head "<tr><td align=\"center\" valign=\"middle\" bgcolor=\"#8888FF\">"
append head "<i><b><font size=\"+3\" color=\"#000000\">[join $args " "]</font></b></i>"
append head "</td></tr></table>"
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 "<ul>"
}
if { "$cmd" == "count" } {
incr data(bullet_level)
set data(first)($data(bullet_level)) 1
set data(count)($data(bullet_level)) 1
return "<ul>"
}
if { "$cmd" == "end" } {
set result ""
if { ! [set data(first)($data(bullet_level))] } {
set result "<br></li>"
}
incr data(bullet_level) -1
return "$result</ul>"
}
set data(bullet_level) 0
}
proc item { args } {
upvar data data
set args [ join $args " " ]
set num ""
if { [set data(count)($data(bullet_level))] > 0 } {
set num $data(count)($data(bullet_level))
incr data(count)($data(bullet_level))
set args "$num. $args"
}
if { [set data(first)($data(bullet_level))] } {
set data(first)($data(bullet_level)) 0
return "<li><p><font size=+1><b>$args</b></font>"
}
return "</li><li><p><font size=+1><b>$args</b></font>"
}
proc table { cmd {width 100%} {bgcolor #FFFFFF} } {
if { "$cmd" == "start" } {
return "<table width=\"100%\" cellspacing=0 border=0 cellpadding=2><tr><td align=\"center\" valign=\"middle\" bgcolor=\"#FFFFFF\">"
}
if { "$cmd" == "end" } {
return "</td></tr></table>"
}
}
proc col { } {
return "</td><td align=\"center\" valign=\"middle\" bgcolor=\"#FFFFFF\">"
}
proc row { } {
return "</td></tr><tr><td align=\"center\" valign=\"middle\" bgcolor=\"#FFFFFF\">"
}
proc intro { args } {
return "<center><i><h2>[ join $args " " ]</h2></i></center>"
}
proc chapter { args } {
upvar data data
incr data(chapter_count)
set title "- Chapter $data(chapter_count) -"
if { "$args" != "" } {
set title "$title<br>[ join $args { } ]"
}
puts "$title"
return "<br><br><br><center><h2><i>$title</i></h2></center>"
}
# Start a man page section
proc section {args} {
set tagName [textToID [join $args '-' ] ]
set args [ join $args " " ]
return "<p><font size=+1><a name=\"$tagName\"><b>$args</b></a></font>"
}
# Format a horizontal rule
proc rule {} {
return "\n<br><hr><br>\n"
}
# Format a link. If text is given, use it as the displayed text;
# otherwise use the url.
proc link {url opt args} {
global ::config
if { "$opt" == "-image" } {
return "<center><a href=\"$url\"><img bgcolor=\"#000000\" src=\"images/$args\"></a></center>"
}
set args [ concat $opt $args ]
if {$args == ""} {
set args $url
}
set args [ join $args " " ]
set type ""
regexp -nocase "(\.\[a-zA-Z\]*$)" $url ignore type
if { [ string index $type 0 ] != "." } {
if { "[ string index $url [ expr [ string length $url] - 1 ] ]" != "/" } {
set url "$url.html"
}
}
if { ! [ string match -nocase "^http:" $url ] } {
set ext [ file extension $url ]
if { "$ext" == ".html" } {
regsub "$ext\$" $url ".src" tmp
if [ file readable $config(root)/$tmp ] {
set url $tmp
}
}
}
return "<a href=\"$url\">$args</a>"
}
# Format a link to another section in the manpage.
proc refer {title args} {
set tagName [textToID $title]
set args [ join $args " " ]
return "<a href=\"#$tagName\">$title $args</a>"
}
# Format an email URL
proc mailto { address args } {
set args [ join $args " " ]
return "<a href=\"mailto:$address\">$args</a>"
}
proc image { link args } {
if { "$args" == "" } {
return "<br><center><img bgcolor=\"#000000\" src=\"/images/${link}\"></center><br>"
} else {
set args [ join $args " " ]
return "<br><img bgcolor=\"#000000\" src=\"/images/${link}\"><font size=+1><b>$args</b></font><br>"
}
}
# Format the copyright notice
proc copyright { {year 2000} } {
set notice [rule]
append notice "<center><font size=-1>Copyright © $year by Larry Smith. "
append notice "All Rights Reserved except as indicated for certain items."
append notice "Use under other terms available under contract "
append notice "with the author.</font></center>\n"
return "$notice<p>\n</body></html>"
}
proc end { } {
return "</body></html>"
}
#----------------------------------------------------------------------
# Utility functions
proc mode { which args } {
upvar data data
set args [ join $args " " ]
if { "$args" == "" } {
if { [set data(lock)($which)] } {
set data(lock)($which) 0
return "</$which>"
} else {
set data(lock)($which) 1
return "<$which>"
}
} else {
return "<$which>$args</$which>"
}
}
proc indent {} {
return "<BLOCKQUOTE>"
}
proc outdent {} {
return "</BLOCKQUOTE>"
}
proc pause { } {
return "<br><br><center>* * *</center><br><br>"
}
proc i { args } {
set args [ join $args " " ]
mode i $args
}
proc b { args } {
set args [ join $args " " ]
mode b $args
}
proc u { args } {
set args [ join $args " " ]
mode u $args
}
proc br { } {
return "<br>"
}
proc p {} {
return "\n<p>"
}
proc up { args } {
set args [ join $args " " ]
return "<sup>$args</sup>"
}
proc dn { args } {
set args [ join $args " " ]
return "<sub>$args</sub>"
}
proc ow {} {
return "<b><i>OmegaWar</i></b>"
}
proc golem {} {
return "<b><i>Golem</i></b>"
}
proc forum { args } {
return "<i>forum: $args</i>"
}
proc version { what } {
set f [ open /home/larry/publish/smith-house/software/$what/version "r" ]
set version [ gets $f ]
close $f
return "<font=\"-1\"><i>version $version</i></font>"
}