Posted to tcl by hypnotoad at Thu Feb 01 20:52:50 GMT 2018view raw

  1. ###
  2. # "Simple" webserver example
  3. ###
  4.  
  5. set DIR [file dirname [file normalize [info script]]]
  6. set DEMOROOT [file join $DIR htdocs]
  7. set tcllibroot [file normalize [file join $DIR .. ..]]
  8. set auto_path [linsert $auto_path 0 [file normalize [file join $tcllibroot modules]]]
  9. package require httpd 4.1
  10. ###
  11. # This script creates two toplevel domains:
  12. # * Hosting the tcllib embedded documentation as static content
  13. # * Hosting a local fossil mirror of the tcllib repository
  14. ###
  15. package require httpd
  16.  
  17. proc ::fossil-list {} {
  18. return [::fossil all list]
  19. }
  20. proc ::fossil args {
  21. if {![info exists ::fossil_exe]} {
  22. set ::fossil_exe fossil
  23. }
  24. if {[llength $args]==0} {
  25. return $::fossil_exe
  26. }
  27. return [exec ${::fossil_exe} {*}$args]
  28. }
  29.  
  30. tool::class create httpd::content::fossil_root {
  31.  
  32. method content {} {
  33. my reset
  34. my puts "<HTML><HEAD><TITLE>Local Fossil Repositories</TITLE></HEAD><BODY>"
  35. global recipe
  36. my puts "<UL>"
  37. set dbfiles [::fossil-list]
  38. foreach file [lsort -dictionary $dbfiles] {
  39. dict set result [file rootname [file tail $file]] $file
  40. }
  41. foreach {module dbfile} [lsort -dictionary -stride 2 $result] {
  42. my puts "<li><a HREF=/fossil/$module>$module</a>"
  43. }
  44. my puts {</UL></BODY></HTML>}
  45. }
  46. }
  47.  
  48. ###
  49. # This driver for fossil is not a standard SCGI module
  50. # it's more or less cargo culted from a working prototype
  51. # developed for the GORT project. You'll note it does some
  52. # things that are non-standard for SCGI, and that's to work
  53. # around quirks in Fossil SCGI implementation.
  54. #
  55. # (Either that or my reading of SCGI specs is way, way off.
  56. # I'm 75% sure I'm doing something wrong.)
  57. #
  58. # Actually, according to DRH we should really be using CGI
  59. # because that is better supported. So until we get the
  60. # CGI functions fleshed out, here's FOSSIL...
  61. #
  62. # --Sean "The Hypnotoad" Woods
  63. ###
  64. tool::class create httpd::content::fossil_node_scgi {
  65.  
  66. superclass httpd::content::scgi
  67. method scgi_info {} {
  68. set uri [my http_info get REQUEST_URI]
  69. set prefix [my http_info get prefix]
  70. set module [lindex [split $uri /] 2]
  71. file mkdir ~/tmp
  72. if {![info exists ::fossil_process($module)]} {
  73. package require processman
  74. package require nettool
  75. set port [::nettool::allocate_port 40000]
  76. set handle fossil:$port
  77. set dbfiles [::fossil-list]
  78. foreach file [lsort -dictionary $dbfiles] {
  79. dict set result [file rootname [file tail $file]] $file
  80. }
  81. set dbfile [dict get $result $module]
  82. if {![file exists $dbfile]} {
  83. tailcall my error 400 {Not Found}
  84. }
  85. set mport [my <server> port_listening]
  86. set cmd [list [::fossil] server $dbfile --port $port --localhost --scgi 2>~/tmp/$module.err >~/tmp/$module.log]
  87.  
  88. dict set ::fossil_process($module) port $port
  89. dict set ::fossil_process($module) handle $handle
  90. dict set ::fossil_process($module) cmd $cmd
  91. dict set ::fossil_process($module) SCRIPT_NAME $prefix/$module
  92. }
  93. dict with ::fossil_process($module) {}
  94. if {![::processman::running $handle]} {
  95. set process [::processman::spawn $handle {*}$cmd]
  96. my varname paused
  97. after 500
  98. }
  99. return [list localhost $port $SCRIPT_NAME]
  100. }
  101. }
  102.  
  103. tool::class create ::docserver::server {
  104. superclass ::httpd::server
  105.  
  106. method log args {
  107. puts [list {*}$args]
  108. }
  109.  
  110. }
  111.  
  112. tool::define ::docserver::dynamic {
  113.  
  114. method content {} {
  115. my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
  116. my puts "<TABLE width=100%>"
  117. foreach {f v} [my request dump] {
  118. my puts "<tr><th>$f</th><td>$v</td></tr>"
  119. }
  120. my puts "<tr><td colspan=10><hr></td></tr>"
  121. foreach {f v} [my http_info dump] {
  122. my puts "<tr><th>$f</th><td>$v</td></tr>"
  123. }
  124. my puts "<tr><th>File Size</th><td>[my http_info get CONTENT_LENGTH]</td></tr>"
  125. my puts </TABLE>
  126. my puts </BODY></HTML>
  127. }
  128.  
  129. }
  130.  
  131. tool::define ::docserver::upload {
  132. superclass ::docserver::dynamic
  133.  
  134. method content {} {
  135. my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
  136. my puts "<TABLE width=100%>"
  137. set FORMDAT [my FormData]
  138. foreach {f v} [my FormData] {
  139. my puts "<tr><th>$f</th><td>$v</td></tr>"
  140. }
  141. my puts "<tr><td colspan=10><hr></td></tr>"
  142. foreach {f v} [my http_info dump] {
  143. my puts "<tr><th>$f</th><td>$v</td></tr>"
  144. }
  145. my puts "<tr><td colspan=10><hr></td></tr>"
  146. foreach part [dict getnull $FORMDAT MIME_PARTS] {
  147. my puts "<tr><td colspan=10><hr></td></tr>"
  148. foreach f [::mime::getheader $part -names] {
  149. my puts "<tr><th>$f</th><td>[mime::getheader $part $f]</td></tr>"
  150. }
  151. my puts "<tr><td colspan=10>[::mime::getbody $part -decode]</td></tr>"
  152. }
  153. my puts "<tr><th>File Size</th><td>[my http_info get CONTENT_LENGTH]</td></tr>"
  154. my puts </TABLE>
  155. my puts </BODY></HTML>
  156. }
  157.  
  158. }
  159.  
  160.  
  161. tool::define ::docserver::listen {
  162.  
  163. method content {} {
  164. while {![info exists ::MESSAGE]} {
  165. puts "[info coroutine] WAITING"
  166. ::cron::sleep 6000
  167. }
  168. my variable reply_body
  169. my reply set Content-Type $::MESSAGE_TYPE
  170. set reply_body $::MESSAGE
  171. unset ::MESSAGE
  172. }
  173.  
  174. }
  175.  
  176. tool::define ::docserver::send {
  177.  
  178. method content {} {
  179. set length 0
  180. if {[my request exists Content-Length]} {
  181. set length [my request get Content-Length]
  182. }
  183. if {$length>0} {
  184. puts "MESSAGE RCVD"
  185. set ::MESSAGE_TYPE [my request get Content-Type]
  186. # NOTE: THIS IS A BUG, WE SEEM TO BE SENDING TOO SHORT A POSTDATA
  187. set ::MESSAGE [my PostData [expr $length - 2]]
  188. puts "MESSAGE $::MESSAGE"
  189. my puts "<HTML><BODY><h1>Sent</h1><pre>$::MESSAGE</PRE></BODY></HTML>"
  190. } else {
  191. my puts {
  192. <HTML><BODY><FORM action=/send method=POST><TEXTEAREA name=text rows="4" cols="50">
  193. </TEXTEAREA>
  194. <input name=foo>
  195. <input type=submit /></FORM></BODY></HTML>
  196. }
  197. }
  198. }
  199.  
  200. }
  201.  
  202.  
  203. set opts [::tool::args_to_options {*}$argv]
  204. set serveropts {}
  205. set optinfo [::docserver::server meta getnull option]
  206. foreach {f v} $opts {
  207. if {[dict exists $optinfo $f]} {
  208. dict set serveropts $f $v
  209. }
  210. }
  211. puts $serveropts
  212. set fossilopts {}
  213. set optinfo [::httpd::content::fossil_root meta getnull option]
  214. foreach {f v} $opts {
  215. if {[dict exists $optinfo $f]} {
  216. dict set fossilopts $f $v
  217. }
  218. }
  219. if {[dict exists $opts fossil]} {
  220. set ::fossil_exe [dict get $opts fossil]
  221. }
  222. puts "Server Options: $serveropts"
  223. puts "Fossil Options: $fossilopts"
  224.  
  225.  
  226. ::docserver::server create appmain doc_root $DEMOROOT {*}$argv
  227. appmain add_uri /tcllib* [list mixin httpd::content::file path [file join $tcllibroot embedded www]]
  228. appmain add_uri /fossil [list mixin httpd::content::fossil_root {*}$fossilopts]
  229. appmain add_uri /fossil/* [list mixin httpd::content::fossil_node_scgi {*}$fossilopts]
  230. appmain add_uri /upload [list mixin ::docserver::upload]
  231. appmain add_uri /dynamic [list mixin ::docserver::dynamic]
  232. appmain add_uri /listen [list mixin ::docserver::listen]
  233. appmain add_uri /send [list mixin ::docserver::send]
  234. puts [list LISTENING]
  235. tool::main
  236.