Posted to tcl by hypnotoad at Thu Feb 01 20:26:30 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. if {![info exists ::MESSAGE]} {
  165. yield
  166. }
  167. my variable reply_body
  168. set reply_body $::MESSAGE
  169. unset ::MESSAGE
  170. }
  171.  
  172. }
  173.  
  174. tool::define ::docserver::send {
  175.  
  176. method content {} {
  177. set ::MESSAGE [my PostData]
  178. }
  179.  
  180. }
  181.  
  182.  
  183. set opts [::tool::args_to_options {*}$argv]
  184. set serveropts {}
  185. set optinfo [::docserver::server meta getnull option]
  186. foreach {f v} $opts {
  187. if {[dict exists $optinfo $f]} {
  188. dict set serveropts $f $v
  189. }
  190. }
  191. puts $serveropts
  192. set fossilopts {}
  193. set optinfo [::httpd::content::fossil_root meta getnull option]
  194. foreach {f v} $opts {
  195. if {[dict exists $optinfo $f]} {
  196. dict set fossilopts $f $v
  197. }
  198. }
  199. if {[dict exists $opts fossil]} {
  200. set ::fossil_exe [dict get $opts fossil]
  201. }
  202. puts "Server Options: $serveropts"
  203. puts "Fossil Options: $fossilopts"
  204.  
  205.  
  206. ::docserver::server create appmain doc_root $DEMOROOT {*}$argv
  207. appmain add_uri /tcllib* [list mixin httpd::content::file path [file join $tcllibroot embedded www]]
  208. appmain add_uri /fossil [list mixin httpd::content::fossil_root {*}$fossilopts]
  209. appmain add_uri /fossil/* [list mixin httpd::content::fossil_node_scgi {*}$fossilopts]
  210. appmain add_uri /upload [list mixin ::docserver::upload]
  211. appmain add_uri /dynamic [list mixin ::docserver::dynamic]
  212. puts [list LISTENING]
  213. tool::main
  214.