Posted to tcl by hypnotoad at Thu Feb 01 22:02:46 GMT 2018view pretty
### # send_listen.tcl # Run this from the examples/httpd folder in tcllib ### ### # "Simple" webserver example ### set DIR [file dirname [file normalize [info script]]] set DEMOROOT [file join $DIR htdocs] set tcllibroot [file normalize [file join $DIR .. ..]] set auto_path [linsert $auto_path 0 [file normalize [file join $tcllibroot modules]]] package require httpd 4.1 ### # This script creates two toplevel domains: # * Hosting the tcllib embedded documentation as static content # * Hosting a local fossil mirror of the tcllib repository ### package require httpd proc ::fossil-list {} { return [::fossil all list] } proc ::fossil args { if {![info exists ::fossil_exe]} { set ::fossil_exe fossil } if {[llength $args]==0} { return $::fossil_exe } return [exec ${::fossil_exe} {*}$args] } tool::class create httpd::content::fossil_root { method content {} { my reset my puts "<HTML><HEAD><TITLE>Local Fossil Repositories</TITLE></HEAD><BODY>" global recipe my puts "<UL>" set dbfiles [::fossil-list] foreach file [lsort -dictionary $dbfiles] { dict set result [file rootname [file tail $file]] $file } foreach {module dbfile} [lsort -dictionary -stride 2 $result] { my puts "<li><a HREF=/fossil/$module>$module</a>" } my puts {</UL></BODY></HTML>} } } ### # This driver for fossil is not a standard SCGI module # it's more or less cargo culted from a working prototype # developed for the GORT project. You'll note it does some # things that are non-standard for SCGI, and that's to work # around quirks in Fossil SCGI implementation. # # (Either that or my reading of SCGI specs is way, way off. # I'm 75% sure I'm doing something wrong.) # # Actually, according to DRH we should really be using CGI # because that is better supported. So until we get the # CGI functions fleshed out, here's FOSSIL... # # --Sean "The Hypnotoad" Woods ### tool::class create httpd::content::fossil_node_scgi { superclass httpd::content::scgi method scgi_info {} { set uri [my http_info get REQUEST_URI] set prefix [my http_info get prefix] set module [lindex [split $uri /] 2] file mkdir ~/tmp if {![info exists ::fossil_process($module)]} { package require processman package require nettool set port [::nettool::allocate_port 40000] set handle fossil:$port set dbfiles [::fossil-list] foreach file [lsort -dictionary $dbfiles] { dict set result [file rootname [file tail $file]] $file } set dbfile [dict get $result $module] if {![file exists $dbfile]} { tailcall my error 400 {Not Found} } set mport [my <server> port_listening] set cmd [list [::fossil] server $dbfile --port $port --localhost --scgi 2>~/tmp/$module.err >~/tmp/$module.log] dict set ::fossil_process($module) port $port dict set ::fossil_process($module) handle $handle dict set ::fossil_process($module) cmd $cmd dict set ::fossil_process($module) SCRIPT_NAME $prefix/$module } dict with ::fossil_process($module) {} if {![::processman::running $handle]} { set process [::processman::spawn $handle {*}$cmd] my varname paused after 500 } return [list localhost $port $SCRIPT_NAME] } } tool::class create ::docserver::server { superclass ::httpd::server method log args { puts [list {*}$args] } } tool::define ::docserver::dynamic { method content {} { my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>" my puts "<TABLE width=100%>" foreach {f v} [my request dump] { my puts "<tr><th>$f</th><td>$v</td></tr>" } my puts "<tr><td colspan=10><hr></td></tr>" foreach {f v} [my http_info dump] { my puts "<tr><th>$f</th><td>$v</td></tr>" } my puts "<tr><th>File Size</th><td>[my http_info get CONTENT_LENGTH]</td></tr>" my puts </TABLE> my puts </BODY></HTML> } } tool::define ::docserver::upload { superclass ::docserver::dynamic method content {} { my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>" my puts "<TABLE width=100%>" set FORMDAT [my FormData] foreach {f v} [my FormData] { my puts "<tr><th>$f</th><td>$v</td></tr>" } my puts "<tr><td colspan=10><hr></td></tr>" foreach {f v} [my http_info dump] { my puts "<tr><th>$f</th><td>$v</td></tr>" } my puts "<tr><td colspan=10><hr></td></tr>" foreach part [dict getnull $FORMDAT MIME_PARTS] { my puts "<tr><td colspan=10><hr></td></tr>" foreach f [::mime::getheader $part -names] { my puts "<tr><th>$f</th><td>[mime::getheader $part $f]</td></tr>" } my puts "<tr><td colspan=10>[::mime::getbody $part -decode]</td></tr>" } my puts "<tr><th>File Size</th><td>[my http_info get CONTENT_LENGTH]</td></tr>" my puts </TABLE> my puts </BODY></HTML> } } ### # A test suggested by # tool::define ::docserver::listen { method content {} { while {![info exists ::MESSAGE]} { puts "[info coroutine] WAITING" ::cron::sleep 6000 } my variable reply_body my reply set Content-Type $::MESSAGE_TYPE set reply_body $::MESSAGE unset ::MESSAGE } } tool::define ::docserver::send { method content {} { set length 0 if {[my request exists Content-Length]} { set length [my request get Content-Length] } if {$length>0} { puts "MESSAGE RCVD" set ::MESSAGE_TYPE [my request get Content-Type] set ::MESSAGE [my PostData $length] puts "MESSAGE $::MESSAGE" my puts "<HTML><BODY><h1>Sent</h1><pre>$::MESSAGE</PRE></BODY></HTML>" } else { my puts { <HTML><BODY><FORM action=/send method=POST><TEXTEAREA name=text rows="4" cols="50"> </TEXTEAREA> <input name=foo> <input type=submit /></FORM></BODY></HTML> } } } } set opts [::tool::args_to_options {*}$argv] set serveropts {} set optinfo [::docserver::server meta getnull option] foreach {f v} $opts { if {[dict exists $optinfo $f]} { dict set serveropts $f $v } } puts $serveropts set fossilopts {} set optinfo [::httpd::content::fossil_root meta getnull option] foreach {f v} $opts { if {[dict exists $optinfo $f]} { dict set fossilopts $f $v } } if {[dict exists $opts fossil]} { set ::fossil_exe [dict get $opts fossil] } puts "Server Options: $serveropts" puts "Fossil Options: $fossilopts" ::docserver::server create appmain doc_root $DEMOROOT {*}$argv appmain add_uri /tcllib* [list mixin httpd::content::file path [file join $tcllibroot embedded www]] appmain add_uri /fossil [list mixin httpd::content::fossil_root {*}$fossilopts] appmain add_uri /fossil/* [list mixin httpd::content::fossil_node_scgi {*}$fossilopts] appmain add_uri /upload [list mixin ::docserver::upload] appmain add_uri /dynamic [list mixin ::docserver::dynamic] appmain add_uri /listen [list mixin ::docserver::listen] appmain add_uri /send [list mixin ::docserver::send] puts [list LISTENING] tool::main