Posted to tcl by hypnotoad at Thu Feb 01 22:02:46 GMT 2018view raw

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