Updated 2015-09-02 17:35:59 by pooryorick

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 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 "<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 &copy; $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>"
 }