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 "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|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 "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 "
    " } if { "$cmd" == "count" } { incr data(bullet_level) set data(first)($data(bullet_level)) 1 set data(count)($data(bullet_level)) 1 return "
      " } if { "$cmd" == "end" } { set result "" if { ! [set data(first)($data(bullet_level))] } { set result "
      " } incr data(bullet_level) -1 return "$result
    " } 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 "
  • $args" } return "

  • $args" } proc table { cmd {width 100%} {bgcolor #FFFFFF} } { if { "$cmd" == "start" } { return "
    " } if { "$cmd" == "end" } { return "
    " } } proc col { } { return "" } proc row { } { return "" } proc intro { args } { return "

    [ join $args " " ]

    " } proc chapter { args } { upvar data data incr data(chapter_count) set title "- Chapter $data(chapter_count) -" if { "$args" != "" } { set title "$title
    [ join $args { } ]" } puts "$title" return "


    $title

    " } # Start a man page section proc section {args} { set tagName [textToID [join $args '-' ] ] set args [ join $args " " ] return "

    $args" } # Format a horizontal rule proc rule {} { return "\n



    \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 "
    " } 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 "$args" } # Format a link to another section in the manpage. proc refer {title args} { set tagName [textToID $title] set args [ join $args " " ] return "$title $args" } # Format an email URL proc mailto { address args } { set args [ join $args " " ] return "$args" } proc image { link args } { if { "$args" == "" } { return "

    " } else { set args [ join $args " " ] return "
    $args
    " } } # Format the copyright notice proc copyright { {year 2000} } { set notice [rule] append notice "
    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.
    \n" return "$notice

    \n" } proc end { } { return "" } #---------------------------------------------------------------------- # 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 "" } else { set data(lock)($which) 1 return "<$which>" } } else { return "<$which>$args" } } proc indent {} { return "

    " } proc outdent {} { return "
    " } proc pause { } { return "

    * * *


    " } 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 "
    " } proc p {} { return "\n

    " } proc up { args } { set args [ join $args " " ] return "$args" } proc dn { args } { set args [ join $args " " ] return "$args" } proc ow {} { return "OmegaWar" } proc golem {} { return "Golem" } proc forum { args } { return "forum: $args" } proc version { what } { set f [ open /home/larry/publish/smith-house/software/$what/version "r" ] set version [ gets $f ] close $f return "version $version" } ====== <> Application | Internet | Webserver