Posted to tcl by mjanssen at Sun Jan 24 09:12:40 GMT 2021view raw

  1. # Copyright (c) 2017 D. Richard Hipp
  2. #
  3. # This program is free software; you can redistribute it and/or
  4. # modify it under the terms of the Simplified BSD License (also
  5. # known as the "2-Clause License" or "FreeBSD License".)
  6. #
  7. # This program is distributed in the hope that it will be useful,
  8. # but without any warranty; without even the implied warranty of
  9. # merchantability or fitness for a particular purpose.
  10. #
  11. #---------------------------------------------------------------------------
  12. #
  13. # Design rules:
  14. #
  15. # (1) All identifiers in the global namespace begin with "wapp"
  16. #
  17. # (2) Indentifiers intended for internal use only begin with "wappInt"
  18. #
  19. package require Tcl 8.6
  20.  
  21. # Add text to the end of the HTTP reply. No interpretation or transformation
  22. # of the text is performs. The argument should be enclosed within {...}
  23. #
  24. proc wapp {txt} {
  25. global wapp
  26. dict append wapp .reply $txt
  27. }
  28.  
  29. # Add text to the page under construction. Do no escaping on the text.
  30. #
  31. # Though "unsafe" in general, there are uses for this kind of thing.
  32. # For example, if you want to return the complete, unmodified content of
  33. # a file:
  34. #
  35. # set fd [open content.html rb]
  36. # wapp-unsafe [read $fd]
  37. # close $fd
  38. #
  39. # You could do the same thing using ordinary "wapp" instead of "wapp-unsafe".
  40. # The difference is that wapp-safety-check will complain about the misuse
  41. # of "wapp", but it assumes that the person who write "wapp-unsafe" understands
  42. # the risks.
  43. #
  44. # Though occasionally necessary, the use of this interface should be minimized.
  45. #
  46. proc wapp-unsafe {txt} {
  47. global wapp
  48. dict append wapp .reply $txt
  49. }
  50.  
  51. # Add text to the end of the reply under construction. The following
  52. # substitutions are made:
  53. #
  54. # %html(...) Escape text for inclusion in HTML
  55. # %url(...) Escape text for use as a URL
  56. # %qp(...) Escape text for use as a URI query parameter
  57. # %string(...) Escape text for use within a JSON string
  58. # %unsafe(...) No transformations of the text
  59. #
  60. # The substitutions above terminate at the first ")" character. If the
  61. # text of the TCL string in ... contains ")" characters itself, use instead:
  62. #
  63. # %html%(...)%
  64. # %url%(...)%
  65. # %qp%(...)%
  66. # %string%(...)%
  67. # %unsafe%(...)%
  68. #
  69. # In other words, use "%(...)%" instead of "(...)" to include the TCL string
  70. # to substitute.
  71. #
  72. # The %unsafe substitution should be avoided whenever possible, obviously.
  73. # In addition to the substitutions above, the text also does backslash
  74. # escapes.
  75. #
  76. # The wapp-trim proc works the same as wapp-subst except that it also removes
  77. # whitespace from the left margin, so that the generated HTML/CSS/Javascript
  78. # does not appear to be indented when delivered to the client web browser.
  79. #
  80. if {$tcl_version>=8.7} {
  81. proc wapp-subst {txt} {
  82. global wapp
  83. regsub -all -command \
  84. {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt
  85. dict append wapp .reply [subst -novariables -nocommand $txt]
  86. }
  87. proc wapp-trim {txt} {
  88. global wapp
  89. regsub -all {\n\s+} [string trim $txt] \n txt
  90. regsub -all -command \
  91. {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt
  92. dict append wapp .reply [subst -novariables -nocommand $txt]
  93. }
  94. proc wappInt-enc {all mode nu1 txt} {
  95. return [uplevel 2 "wappInt-enc-$mode \"$txt\""]
  96. }
  97. } else {
  98. proc wapp-subst {txt} {
  99. global wapp
  100. regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \
  101. {[wappInt-enc-\1 "\3"]} txt
  102. dict append wapp .reply [uplevel 1 [list subst -novariables $txt]]
  103. }
  104. proc wapp-trim {txt} {
  105. global wapp
  106. regsub -all {\n\s+} [string trim $txt] \n txt
  107. regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \
  108. {[wappInt-enc-\1 "\3"]} txt
  109. dict append wapp .reply [uplevel 1 [list subst -novariables $txt]]
  110. }
  111. }
  112.  
  113. # There must be a wappInt-enc-NAME routine for each possible substitution
  114. # in wapp-subst. Thus there are routines for "html", "url", "qp", and "unsafe".
  115. #
  116. # wappInt-enc-html Escape text so that it is safe to use in the
  117. # body of an HTML document.
  118. #
  119. # wappInt-enc-url Escape text so that it is safe to pass as an
  120. # argument to href= and src= attributes in HTML.
  121. #
  122. # wappInt-enc-qp Escape text so that it is safe to use as the
  123. # value of a query parameter in a URL or in
  124. # post data or in a cookie.
  125. #
  126. # wappInt-enc-string Escape ", ', \, and < for using inside of a
  127. # javascript string literal. The < character
  128. # is escaped to prevent "</script>" from causing
  129. # problems in embedded javascript.
  130. #
  131. # wappInt-enc-unsafe Perform no encoding at all. Unsafe.
  132. #
  133. proc wappInt-enc-html {txt} {
  134. return [string map {& &amp; < &lt; > &gt; \" &quot; \\ &#92;} $txt]
  135. }
  136. proc wappInt-enc-unsafe {txt} {
  137. return $txt
  138. }
  139. proc wappInt-enc-url {s} {
  140. if {[regsub -all {[^-{}@~?=#_.:/a-zA-Z0-9]} $s {[wappInt-%HHchar {&}]} s]} {
  141. set s [subst -novar -noback $s]
  142. }
  143. if {[regsub -all {[{}]} $s {[wappInt-%HHchar \\&]} s]} {
  144. set s [subst -novar -noback $s]
  145. }
  146. return $s
  147. }
  148. proc wappInt-enc-qp {s} {
  149. if {[regsub -all {[^-{}_.a-zA-Z0-9]} $s {[wappInt-%HHchar {&}]} s]} {
  150. set s [subst -novar -noback $s]
  151. }
  152. if {[regsub -all {[{}]} $s {[wappInt-%HHchar \\&]} s]} {
  153. set s [subst -novar -noback $s]
  154. }
  155. return $s
  156. }
  157. proc wappInt-enc-string {s} {
  158. return [string map {\\ \\\\ \" \\\" ' \\' < \\u003c \n \\n \r \\r
  159. \f \\f \t \\t \x01 \\u0001 \x02 \\u0002 \x03 \\u0003
  160. \x04 \\u0004 \x05 \\u0005 \x06 \\u0006 \x07 \\u0007
  161. \x0b \\u000b \x0e \\u000e \x0f \\u000f \x10 \\u0010
  162. \x11 \\u0011 \x12 \\u0012 \x13 \\u0013 \x14 \\u0014
  163. \x15 \\u0015 \x16 \\u0016 \x17 \\u0017 \x18 \\u0018
  164. \x19 \\u0019 \x1a \\u001a \x1b \\u001b \x1c \\u001c
  165. \x1d \\u001d \x1e \\u001e \x1f \\u001f} $s]
  166. }
  167.  
  168. # This is a helper routine for wappInt-enc-url and wappInt-enc-qp. It returns
  169. # an appropriate %HH encoding for the single character c. If c is a unicode
  170. # character, then this routine might return multiple bytes: %HH%HH%HH
  171. #
  172. proc wappInt-%HHchar {c} {
  173. if {$c==" "} {return +}
  174. return [regsub -all .. [binary encode hex [encoding convertto utf-8 $c]] {%&}]
  175. }
  176.  
  177.  
  178. # Undo the www-url-encoded format.
  179. #
  180. # HT: This code stolen from ncgi.tcl
  181. #
  182. proc wappInt-decode-url {str} {
  183. set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str]
  184. regsub -all -- \
  185. {%([Ee][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \
  186. $str {[encoding convertfrom utf-8 [binary decode hex \1\2\3]]} str
  187. regsub -all -- \
  188. {%([CDcd][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \
  189. $str {[encoding convertfrom utf-8 [binary decode hex \1\2]]} str
  190. regsub -all -- {%([0-7][A-Fa-f0-9])} $str {\\u00\1} str
  191. return [subst -novar $str]
  192. }
  193.  
  194. # Reset the document back to an empty string.
  195. #
  196. proc wapp-reset {} {
  197. global wapp
  198. dict set wapp .reply {}
  199. }
  200.  
  201. # Change the mime-type of the result document.
  202. #
  203. proc wapp-mimetype {x} {
  204. global wapp
  205. dict set wapp .mimetype $x
  206. }
  207.  
  208. # Change the reply code.
  209. #
  210. proc wapp-reply-code {x} {
  211. global wapp
  212. dict set wapp .reply-code $x
  213. }
  214.  
  215. # Set a cookie
  216. #
  217. proc wapp-set-cookie {name value} {
  218. global wapp
  219. dict lappend wapp .new-cookies $name $value
  220. }
  221.  
  222. # Unset a cookie
  223. #
  224. proc wapp-clear-cookie {name} {
  225. wapp-set-cookie $name {}
  226. }
  227.  
  228. # Add extra entries to the reply header
  229. #
  230. proc wapp-reply-extra {name value} {
  231. global wapp
  232. dict lappend wapp .reply-extra $name $value
  233. }
  234.  
  235. # Specifies how the web-page under construction should be cached.
  236. # The argument should be one of:
  237. #
  238. # no-cache
  239. # max-age=N (for some integer number of seconds, N)
  240. # private,max-age=N
  241. #
  242. proc wapp-cache-control {x} {
  243. wapp-reply-extra Cache-Control $x
  244. }
  245.  
  246. # Redirect to a different web page
  247. #
  248. proc wapp-redirect {uri} {
  249. wapp-reply-code {307 Redirect}
  250. wapp-reply-extra Location $uri
  251. }
  252.  
  253. # Return the value of a wapp parameter
  254. #
  255. proc wapp-param {name {dflt {}}} {
  256. global wapp
  257. if {![dict exists $wapp $name]} {return $dflt}
  258. return [dict get $wapp $name]
  259. }
  260.  
  261. # Return true if a and only if the wapp parameter $name exists
  262. #
  263. proc wapp-param-exists {name} {
  264. global wapp
  265. return [dict exists $wapp $name]
  266. }
  267.  
  268. # Set the value of a wapp parameter
  269. #
  270. proc wapp-set-param {name value} {
  271. global wapp
  272. dict set wapp $name $value
  273. }
  274.  
  275. # Return all parameter names that match the GLOB pattern, or all
  276. # names if the GLOB pattern is omitted.
  277. #
  278. proc wapp-param-list {{glob {*}}} {
  279. global wapp
  280. return [dict keys $wapp $glob]
  281. }
  282.  
  283. # By default, Wapp does not decode query parameters and POST parameters
  284. # for cross-origin requests. This is a security restriction, designed to
  285. # help prevent cross-site request forgery (CSRF) attacks.
  286. #
  287. # As a consequence of this restriction, URLs for sites generated by Wapp
  288. # that contain query parameters will not work as URLs found in other
  289. # websites. You cannot create a link from a second website into a Wapp
  290. # website if the link contains query planner, by default.
  291. #
  292. # Of course, it is sometimes desirable to allow query parameters on external
  293. # links. For URLs for which this is safe, the application should invoke
  294. # wapp-allow-xorigin-params. This procedure tells Wapp that it is safe to
  295. # go ahead and decode the query parameters even for cross-site requests.
  296. #
  297. # In other words, for Wapp security is the default setting. Individual pages
  298. # need to actively disable the cross-site request security if those pages
  299. # are safe for cross-site access.
  300. #
  301. proc wapp-allow-xorigin-params {} {
  302. global wapp
  303. if {![dict exists $wapp .qp] && ![dict get $wapp SAME_ORIGIN]} {
  304. wappInt-decode-query-params
  305. }
  306. }
  307.  
  308. # Set the content-security-policy.
  309. #
  310. # The default content-security-policy is very strict: "default-src 'self'"
  311. # The default policy prohibits the use of in-line javascript or CSS.
  312. #
  313. # Provide an alternative CSP as the argument. Or use "off" to disable
  314. # the CSP completely.
  315. #
  316. proc wapp-content-security-policy {val} {
  317. global wapp
  318. if {$val=="off"} {
  319. dict unset wapp .csp
  320. } else {
  321. dict set wapp .csp $val
  322. }
  323. }
  324.  
  325. # Examine the bodys of all procedures in this program looking for
  326. # unsafe calls to various Wapp interfaces. Return a text string
  327. # containing warnings. Return an empty string if all is ok.
  328. #
  329. # This routine is advisory only. It misses some constructs that are
  330. # dangerous and flags others that are safe.
  331. #
  332. proc wapp-safety-check {} {
  333. set res {}
  334. foreach p [info command] {
  335. set ln 0
  336. foreach x [split [info body $p] \n] {
  337. incr ln
  338. if {[regexp {^[ \t]*wapp[ \t]+([^\n]+)} $x all tail]
  339. && [string index $tail 0]!="\173"
  340. && [regexp {[[$]} $tail]
  341. } {
  342. append res "$p:$ln: unsafe \"wapp\" call: \"[string trim $x]\"\n"
  343. }
  344. if {[regexp {^[ \t]*wapp-(subst|trim)[ \t]+[^\173]} $x all cx]} {
  345. append res "$p:$ln: unsafe \"wapp-$cx\" call: \"[string trim $x]\"\n"
  346. }
  347. }
  348. }
  349. return $res
  350. }
  351.  
  352. # Return a string that descripts the current environment. Applications
  353. # might find this useful for debugging.
  354. #
  355. proc wapp-debug-env {} {
  356. global wapp
  357. set out {}
  358. foreach var [lsort [dict keys $wapp]] {
  359. if {[string index $var 0]=="."} continue
  360. append out "$var = [list [dict get $wapp $var]]\n"
  361. }
  362. append out "\[pwd\] = [list [pwd]]\n"
  363. return $out
  364. }
  365.  
  366. # Tracing function for each HTTP request. This is overridden by wapp-start
  367. # if tracing is enabled.
  368. #
  369. proc wappInt-trace {} {}
  370.  
  371. # Start up a listening socket. Arrange to invoke wappInt-new-connection
  372. # for each inbound HTTP connection.
  373. #
  374. # port Listen on this TCP port. 0 means to select a port
  375. # that is not currently in use
  376. #
  377. # wappmode One of "scgi", "remote-scgi", "server", or "local".
  378. #
  379. # fromip If not {}, then reject all requests from IP addresses
  380. # other than $fromip
  381. #
  382. proc wappInt-start-listener {port wappmode fromip} {
  383. if {[string match *scgi $wappmode]} {
  384. set type SCGI
  385. set server [list wappInt-new-connection \
  386. wappInt-scgi-readable $wappmode $fromip]
  387. } else {
  388. set type HTTP
  389. set server [list wappInt-new-connection \
  390. wappInt-http-readable $wappmode $fromip]
  391. }
  392. if {$wappmode=="local" || $wappmode=="scgi"} {
  393. set x [socket -server $server -myaddr 127.0.0.1 $port]
  394. } else {
  395. set x [socket -server $server $port]
  396. }
  397. set coninfo [chan configure $x -sockname]
  398. set port [lindex $coninfo 2]
  399. if {$wappmode=="local"} {
  400. wappInt-start-browser http://127.0.0.1:$port/
  401. } elseif {$fromip!=""} {
  402. puts "Listening for $type requests on TCP port $port from IP $fromip"
  403. } else {
  404. puts "Listening for $type requests on TCP port $port"
  405. }
  406. }
  407.  
  408. # Start a web-browser and point it at $URL
  409. #
  410. proc wappInt-start-browser {url} {
  411. global tcl_platform
  412. if {$tcl_platform(platform)=="windows"} {
  413. exec cmd /c start $url &
  414. } elseif {$tcl_platform(os)=="Darwin"} {
  415. exec open $url &
  416. } elseif {[catch {exec xdg-open $url}]} {
  417. exec firefox $url &
  418. }
  419. }
  420.  
  421. # This routine is a "socket -server" callback. The $chan, $ip, and $port
  422. # arguments are added by the socket command.
  423. #
  424. # Arrange to invoke $callback when content is available on the new socket.
  425. # The $callback will process inbound HTTP or SCGI content. Reject the
  426. # request if $fromip is not an empty string and does not match $ip.
  427. #
  428. proc wappInt-new-connection {callback wappmode fromip chan ip port} {
  429. if {$fromip!="" && ![string match $fromip $ip]} {
  430. close $chan
  431. return
  432. }
  433. set W [dict create REMOTE_ADDR $ip REMOTE_PORT $port WAPP_MODE $wappmode \
  434. .header {}]
  435. fconfigure $chan -blocking 0 -translation binary
  436. fileevent $chan readable [list $callback $W $chan]
  437. }
  438.  
  439. # Close an input channel
  440. #
  441. proc wappInt-close-channel {chan} {
  442. if {$chan=="stdout"} {
  443. # This happens after completing a CGI request
  444. exit 0
  445. } else {
  446. close $chan
  447. }
  448. }
  449.  
  450. # Process new text received on an inbound HTTP request
  451. #
  452. proc wappInt-http-readable {W chan} {
  453. if {[catch [list wappInt-http-readable-unsafe $W $chan] msg]} {
  454. puts stderr "$msg\n$::errorInfo"
  455. wappInt-close-channel $chan
  456. }
  457. }
  458. proc wappInt-http-readable-unsafe {W chan} {
  459. upvar #0 wapp wapp
  460. if {![dict exists $W .toread]} {
  461. # If the .toread key is not set, that means we are still reading
  462. # the header
  463. set line [string trimright [gets $chan]]
  464. set n [string length $line]
  465. if {$n>0} {
  466. if {[dict get $W .header]=="" || [regexp {^\s+} $line]} {
  467. dict append W .header $line
  468. } else {
  469. dict append W .header \n$line
  470. }
  471. if {[string length [dict get $W .header]]>100000} {
  472. error "HTTP request header too big - possible DOS attack"
  473. }
  474. } elseif {$n==0} {
  475. # We have reached the blank line that terminates the header.
  476. global argv0
  477. if {[info exists ::argv0]} {
  478. set a0 [file normalize $argv0]
  479. } else {
  480. set a0 /
  481. }
  482. dict set W SCRIPT_FILENAME $a0
  483. dict set W DOCUMENT_ROOT [file dir $a0]
  484. set W [wappInt-parse-header $chan]
  485. set len 0
  486. if {[dict exists $W CONTENT_LENGTH]} {
  487. set len [dict get $W CONTENT_LENGTH]
  488. }
  489. if {$len>0} {
  490. # Still need to read the query content
  491. dict set W .toread $len
  492. } else {
  493. # There is no query content, so handle the request immediately
  494. set wapp $W
  495. wappInt-handle-request $chan
  496. return
  497. }
  498. }
  499. } else {
  500. # If .toread is set, that means we are reading the query content.
  501. # Continue reading until .toread reaches zero.
  502. set got [read $chan [dict get $W .toread]]
  503. dict append W CONTENT $got
  504. dict set W .toread [expr {[dict get $W .toread]-[string length $got]}]
  505. if {[dict get $W .toread]<=0} {
  506. # Handle the request as soon as all the query content is received
  507. set wapp $W
  508. wappInt-handle-request $chan
  509. return
  510. }
  511. }
  512. fileevent $chan readable [list wappInt-http-readable $W $chan]
  513. }
  514.  
  515. # Decode the HTTP request header.
  516. #
  517. # This routine is always running inside of a [catch], so if
  518. # any problems arise, simply raise an error.
  519. #
  520. proc wappInt-parse-header {W} {
  521. set hdr [split [dict get $W .header] \n]
  522. if {$hdr==""} {return 1}
  523. set req [lindex $hdr 0]
  524. dict set W REQUEST_METHOD [set method [lindex $req 0]]
  525. if {[lsearch {GET HEAD POST} $method]<0} {
  526. error "unsupported request method: \"[dict get $W REQUEST_METHOD]\""
  527. }
  528. set uri [lindex $req 1]
  529. set split_uri [split $uri ?]
  530. set uri0 [lindex $split_uri 0]
  531. if {![regexp {^/[-.a-z0-9_/]*$} $uri0]} {
  532. error "invalid request uri: \"$uri0\""
  533. }
  534. dict set W REQUEST_URI $uri0
  535. dict set W PATH_INFO $uri0
  536. set uri1 [lindex $split_uri 1]
  537. dict set W QUERY_STRING $uri1
  538. set n [llength $hdr]
  539. for {set i 1} {$i<$n} {incr i} {
  540. set x [lindex $hdr $i]
  541. if {![regexp {^(.+): +(.*)$} $x all name value]} {
  542. error "invalid header line: \"$x\""
  543. }
  544. set name [string toupper $name]
  545. switch -- $name {
  546. REFERER {set name HTTP_REFERER}
  547. USER-AGENT {set name HTTP_USER_AGENT}
  548. CONTENT-LENGTH {set name CONTENT_LENGTH}
  549. CONTENT-TYPE {set name CONTENT_TYPE}
  550. HOST {set name HTTP_HOST}
  551. COOKIE {set name HTTP_COOKIE}
  552. ACCEPT-ENCODING {set name HTTP_ACCEPT_ENCODING}
  553. default {set name .hdr:$name}
  554. }
  555. dict set W $name $value
  556. }
  557. return $W
  558. }
  559.  
  560. # Decode the QUERY_STRING parameters from a GET request or the
  561. # application/x-www-form-urlencoded CONTENT from a POST request.
  562. #
  563. # This routine sets the ".qp" element of the ::wapp dict as a signal
  564. # that query parameters have already been decoded.
  565. #
  566. proc wappInt-decode-query-params {} {
  567. global wapp
  568. dict set wapp .qp 1
  569. if {[dict exists $wapp QUERY_STRING]} {
  570. foreach qterm [split [dict get $wapp QUERY_STRING] &] {
  571. set qsplit [split $qterm =]
  572. set nm [lindex $qsplit 0]
  573. if {[regexp {^[a-z][a-z0-9]*$} $nm]} {
  574. dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]]
  575. }
  576. }
  577. }
  578. if {[dict exists $wapp CONTENT_TYPE] && [dict exists $wapp CONTENT]} {
  579. set ctype [dict get $wapp CONTENT_TYPE]
  580. if {$ctype=="application/x-www-form-urlencoded"} {
  581. foreach qterm [split [string trim [dict get $wapp CONTENT]] &] {
  582. set qsplit [split $qterm =]
  583. set nm [lindex $qsplit 0]
  584. if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} {
  585. dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]]
  586. }
  587. }
  588. } elseif {[string match multipart/form-data* $ctype]} {
  589. regexp {^(.*?)\r\n(.*)$} [dict get $wapp CONTENT] all divider body
  590. set ndiv [string length $divider]
  591. while {[string length $body]} {
  592. set idx [string first $divider $body]
  593. set unit [string range $body 0 [expr {$idx-3}]]
  594. set body [string range $body [expr {$idx+$ndiv+2}] end]
  595. if {[regexp {^Content-Disposition: form-data; (.*?)\r\n\r\n(.*)$} \
  596. $unit unit hdr content]} {
  597. if {[regexp {name="(.*)"; filename="(.*)"\r\nContent-Type: (.*?)$}\
  598. $hdr hr name filename mimetype]} {
  599. dict set wapp $name.filename \
  600. [string map [list \\\" \" \\\\ \\] $filename]
  601. dict set wapp $name.mimetype $mimetype
  602. dict set wapp $name.content $content
  603. } elseif {[regexp {name="(.*)"} $hdr hr name]} {
  604. dict set wapp $name $content
  605. }
  606. }
  607. }
  608. }
  609. }
  610. }
  611.  
  612. # Invoke application-supplied methods to generate a reply to
  613. # a single HTTP request.
  614. #
  615. # This routine uses the global variable ::wapp and so must not be nested.
  616. # It must run to completion before the next instance runs. If a recursive
  617. # instances of this routine starts while another is running, the the
  618. # recursive instance is added to a queue to be invoked after the current
  619. # instance finishes. Yes, this means that WAPP IS SINGLE THREADED. Only
  620. # a single page rendering instance my be running at a time. There can
  621. # be multiple HTTP requests inbound at once, but only one my be processed
  622. # at a time once the request is full read and parsed.
  623. #
  624. set wappIntPending {}
  625. set wappIntLock 0
  626. proc wappInt-handle-request {chan} {
  627. global wappIntPending wappIntLock
  628. fileevent $chan readable {}
  629. if {$wappIntLock} {
  630. # Another instance of request is already running, so defer this one
  631. lappend wappIntPending [list wappInt-handle-request $chan]
  632. return
  633. }
  634. set wappIntLock 1
  635. catch [list wappInt-handle-request-unsafe $chan]
  636. set wappIntLock 0
  637. if {[llength $wappIntPending]>0} {
  638. # If there are deferred requests, then launch the oldest one
  639. after idle [lindex $wappIntPending 0]
  640. set wappIntPending [lrange $wappIntPending 1 end]
  641. }
  642. }
  643. proc wappInt-handle-request-unsafe {chan} {
  644. global wapp
  645. dict set wapp .reply {}
  646. dict set wapp .mimetype {text/html; charset=utf-8}
  647. dict set wapp .reply-code {200 Ok}
  648. dict set wapp .csp {default-src 'self'}
  649.  
  650. # Set up additional CGI environment values
  651. #
  652. if {![dict exists $wapp HTTP_HOST]} {
  653. dict set wapp BASE_URL {}
  654. } elseif {[dict exists $wapp HTTPS]} {
  655. dict set wapp BASE_URL https://[dict get $wapp HTTP_HOST]
  656. } else {
  657. dict set wapp BASE_URL http://[dict get $wapp HTTP_HOST]
  658. }
  659. if {![dict exists $wapp REQUEST_URI]} {
  660. dict set wapp REQUEST_URI /
  661. } elseif {[regsub {\?.*} [dict get $wapp REQUEST_URI] {} newR]} {
  662. # Some servers (ex: nginx) append the query parameters to REQUEST_URI.
  663. # These need to be stripped off
  664. dict set wapp REQUEST_URI $newR
  665. }
  666. if {[dict exists $wapp SCRIPT_NAME]} {
  667. dict append wapp BASE_URL [dict get $wapp SCRIPT_NAME]
  668. } else {
  669. dict set wapp SCRIPT_NAME {}
  670. }
  671. if {![dict exists $wapp PATH_INFO]} {
  672. # If PATH_INFO is missing (ex: nginx) then construct it
  673. set URI [dict get $wapp REQUEST_URI]
  674. set skip [string length [dict get $wapp SCRIPT_NAME]]
  675. dict set wapp PATH_INFO [string range $URI $skip end]
  676. }
  677. if {[regexp {^/([^/]+)(.*)$} [dict get $wapp PATH_INFO] all head tail]} {
  678. dict set wapp PATH_HEAD $head
  679. dict set wapp PATH_TAIL [string trimleft $tail /]
  680. } else {
  681. dict set wapp PATH_INFO {}
  682. dict set wapp PATH_HEAD {}
  683. dict set wapp PATH_TAIL {}
  684. }
  685. dict set wapp SELF_URL [dict get $wapp BASE_URL]/[dict get $wapp PATH_HEAD]
  686.  
  687. # Parse query parameters from the query string, the cookies, and
  688. # POST data
  689. #
  690. if {[dict exists $wapp HTTP_COOKIE]} {
  691. foreach qterm [split [dict get $wapp HTTP_COOKIE] {;}] {
  692. set qsplit [split [string trim $qterm] =]
  693. set nm [lindex $qsplit 0]
  694. if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} {
  695. dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]]
  696. }
  697. }
  698. }
  699. set same_origin 0
  700. if {[dict exists $wapp HTTP_REFERER]} {
  701. set referer [dict get $wapp HTTP_REFERER]
  702. set base [dict get $wapp BASE_URL]
  703. if {$referer==$base || [string match $base/* $referer]} {
  704. set same_origin 1
  705. }
  706. }
  707. dict set wapp SAME_ORIGIN $same_origin
  708. if {$same_origin} {
  709. wappInt-decode-query-params
  710. }
  711.  
  712. # Invoke the application-defined handler procedure for this page
  713. # request. If an error occurs while running that procedure, generate
  714. # an HTTP reply that contains the error message.
  715. #
  716. wapp-before-dispatch-hook
  717. wappInt-trace
  718. set mname [dict get $wapp PATH_HEAD]
  719. if {[catch {
  720. if {$mname!="" && [llength [info command wapp-page-$mname]]>0} {
  721. wapp-page-$mname
  722. } else {
  723. wapp-default
  724. }
  725. } msg]} {
  726. if {[wapp-param WAPP_MODE]=="local" || [wapp-param WAPP_MODE]=="server"} {
  727. puts "ERROR: $::errorInfo"
  728. }
  729. wapp-reset
  730. wapp-reply-code "500 Internal Server Error"
  731. wapp-mimetype text/html
  732. wapp-trim {
  733. <h1>Wapp Application Error</h1>
  734. <pre>%html($::errorInfo)</pre>
  735. }
  736. dict unset wapp .new-cookies
  737. }
  738. wapp-before-reply-hook
  739.  
  740. # Transmit the HTTP reply
  741. #
  742. if {$chan=="stdout"} {
  743. puts $chan "Status: [dict get $wapp .reply-code]\r"
  744. } else {
  745. puts $chan "HTTP/1.1 [dict get $wapp .reply-code]\r"
  746. puts $chan "Server: wapp\r"
  747. puts $chan "Connection: close\r"
  748. }
  749. if {[dict exists $wapp .reply-extra]} {
  750. foreach {name value} [dict get $wapp .reply-extra] {
  751. puts $chan "$name: $value\r"
  752. }
  753. }
  754. if {[dict exists $wapp .csp]} {
  755. puts $chan "Content-Security-Policy: [dict get $wapp .csp]\r"
  756. }
  757. set mimetype [dict get $wapp .mimetype]
  758. puts $chan "Content-Type: $mimetype\r"
  759. if {[dict exists $wapp .new-cookies]} {
  760. foreach {nm val} [dict get $wapp .new-cookies] {
  761. if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} {
  762. if {$val==""} {
  763. puts $chan "Set-Cookie: $nm=; HttpOnly; Path=/; Max-Age=1\r"
  764. } else {
  765. set val [wappInt-enc-url $val]
  766. puts $chan "Set-Cookie: $nm=$val; HttpOnly; Path=/\r"
  767. }
  768. }
  769. }
  770. }
  771. if {[string match text/* $mimetype]} {
  772. set reply [encoding convertto utf-8 [dict get $wapp .reply]]
  773. if {[regexp {\ygzip\y} [wapp-param HTTP_ACCEPT_ENCODING]]} {
  774. catch {
  775. set x [zlib gzip $reply]
  776. set reply $x
  777. puts $chan "Content-Encoding: gzip\r"
  778. }
  779. }
  780. } else {
  781. set reply [dict get $wapp .reply]
  782. }
  783. puts $chan "Content-Length: [string length $reply]\r"
  784. puts $chan \r
  785. puts -nonewline $chan $reply
  786. flush $chan
  787. wappInt-close-channel $chan
  788. }
  789.  
  790. # This routine runs just prior to request-handler dispatch. The
  791. # default implementation is a no-op, but applications can override
  792. # to do additional transformations or checks.
  793. #
  794. proc wapp-before-dispatch-hook {} {return}
  795.  
  796. # This routine runs after the request-handler dispatch and just
  797. # before the reply is generated. The default implementation is
  798. # a no-op, but applications can override to do validation and security
  799. # checks on the reply, such as verifying that no sensitive information
  800. # such as an API key or password is accidentally included in the
  801. # reply text.
  802. #
  803. proc wapp-before-reply-hook {} {return}
  804.  
  805. # Process a single CGI request
  806. #
  807. proc wappInt-handle-cgi-request {} {
  808. global wapp env
  809. foreach key [array names env {[A-Z]*}] {dict set wapp $key $env($key)}
  810. set len 0
  811. if {[dict exists $wapp CONTENT_LENGTH]} {
  812. set len [dict get $wapp CONTENT_LENGTH]
  813. }
  814. if {$len>0} {
  815. fconfigure stdin -translation binary
  816. dict set wapp CONTENT [read stdin $len]
  817. }
  818. dict set wapp WAPP_MODE cgi
  819. fconfigure stdout -translation binary
  820. wappInt-handle-request-unsafe stdout
  821. }
  822.  
  823. # Process new text received on an inbound SCGI request
  824. #
  825. proc wappInt-scgi-readable {W chan} {
  826. if {[catch [list wappInt-scgi-readable-unsafe $W $chan] msg]} {
  827. puts stderr "$msg\n$::errorInfo"
  828. wappInt-close-channel $chan
  829. }
  830. }
  831. proc wappInt-scgi-readable-unsafe {W chan} {
  832. if {![dict exists $W .toread]} {
  833. # If the .toread key is not set, that means we are still reading
  834. # the header.
  835. #
  836. # An SGI header is short. This implementation assumes the entire
  837. # header is available all at once.
  838. #
  839. dict set W .remove_addr [dict get $W REMOTE_ADDR]
  840. set req [read $chan 15]
  841. set n [string length $req]
  842. scan $req %d:%s len hdr
  843. incr len [string length "$len:,"]
  844. append hdr [read $chan [expr {$len-15}]]
  845. foreach {nm val} [split $hdr \000] {
  846. if {$nm==","} break
  847. dict set W $nm $val
  848. }
  849. set len 0
  850. if {[dict exists $W CONTENT_LENGTH]} {
  851. set len [dict get $W CONTENT_LENGTH]
  852. }
  853. if {$len>0} {
  854. # Still need to read the query content
  855. dict set W .toread $len
  856. } else {
  857. # There is no query content, so handle the request immediately
  858. dict set W SERVER_ADDR [dict get $W .remove_addr]
  859. set wapp $W
  860. wappInt-handle-request $chan
  861. return
  862. }
  863. } else {
  864. # If .toread is set, that means we are reading the query content.
  865. # Continue reading until .toread reaches zero.
  866. set got [read $chan [dict get $W .toread]]
  867. dict append W CONTENT $got
  868. dict set W .toread [expr {[dict get $W .toread]-[string length $got]}]
  869. if {[dict get $W .toread]<=0} {
  870. # Handle the request as soon as all the query content is received
  871. dict set W SERVER_ADDR [dict get $W .remove_addr]
  872. set wapp $W
  873. wappInt-handle-request $chan
  874. return
  875. }
  876. }
  877. fileevent $chan readable [list wappInt-scgi-readable $W $chan]
  878. }
  879.  
  880. # Start up the wapp framework. Parameters are a list passed as the
  881. # single argument.
  882. #
  883. # -server $PORT Listen for HTTP requests on this TCP port $PORT
  884. #
  885. # -local $PORT Listen for HTTP requests on 127.0.0.1:$PORT
  886. #
  887. # -scgi $PORT Listen for SCGI requests on 127.0.0.1:$PORT
  888. #
  889. # -remote-scgi $PORT Listen for SCGI requests on TCP port $PORT
  890. #
  891. # -cgi Handle a single CGI request
  892. #
  893. # With no arguments, the behavior is called "auto". In "auto" mode,
  894. # if the GATEWAY_INTERFACE environment variable indicates CGI, then run
  895. # as CGI. Otherwise, start an HTTP server bound to the loopback address
  896. # only, on an arbitrary TCP port, and automatically launch a web browser
  897. # on that TCP port.
  898. #
  899. # Additional options:
  900. #
  901. # -fromip GLOB Reject any incoming request where the remote
  902. # IP address does not match the GLOB pattern. This
  903. # value defaults to '127.0.0.1' for -local and -scgi.
  904. #
  905. # -nowait Do not wait in the event loop. Return immediately
  906. # after all event handlers are established.
  907. #
  908. # -trace "puts" each request URL as it is handled, for
  909. # debugging
  910. #
  911. # -lint Run wapp-safety-check on the application instead
  912. # of running the application itself
  913. #
  914. # -Dvar=value Set TCL global variable "var" to "value"
  915. #
  916. #
  917. proc wapp-start {arglist} {
  918. global env
  919. set mode auto
  920. set port 0
  921. set nowait 0
  922. set fromip {}
  923. set n [llength $arglist]
  924. for {set i 0} {$i<$n} {incr i} {
  925. set term [lindex $arglist $i]
  926. if {[string match --* $term]} {set term [string range $term 1 end]}
  927. switch -glob -- $term {
  928. -server {
  929. incr i;
  930. set mode "server"
  931. set port [lindex $arglist $i]
  932. }
  933. -local {
  934. incr i;
  935. set mode "local"
  936. set fromip 127.0.0.1
  937. set port [lindex $arglist $i]
  938. }
  939. -scgi {
  940. incr i;
  941. set mode "scgi"
  942. set fromip 127.0.0.1
  943. set port [lindex $arglist $i]
  944. }
  945. -remote-scgi {
  946. incr i;
  947. set mode "remote-scgi"
  948. set port [lindex $arglist $i]
  949. }
  950. -cgi {
  951. set mode "cgi"
  952. }
  953. -fromip {
  954. incr i
  955. set fromip [lindex $arglist $i]
  956. }
  957. -nowait {
  958. set nowait 1
  959. }
  960. -trace {
  961. proc wappInt-trace {} {
  962. set q [wapp-param QUERY_STRING]
  963. set uri [wapp-param BASE_URL][wapp-param PATH_INFO]
  964. if {$q!=""} {append uri ?$q}
  965. puts $uri
  966. }
  967. }
  968. -lint {
  969. set res [wapp-safety-check]
  970. if {$res!=""} {
  971. puts "Potential problems in this code:"
  972. puts $res
  973. exit 1
  974. } else {
  975. exit
  976. }
  977. }
  978. -D*=* {
  979. if {[regexp {^.D([^=]+)=(.*)$} $term all var val]} {
  980. set ::$var $val
  981. }
  982. }
  983. default {
  984. error "unknown option: $term"
  985. }
  986. }
  987. }
  988. if {$mode=="auto"} {
  989. if {[info exists env(GATEWAY_INTERFACE)]
  990. && [string match CGI/1.* $env(GATEWAY_INTERFACE)]} {
  991. set mode cgi
  992. } else {
  993. set mode local
  994. }
  995. }
  996. if {$mode=="cgi"} {
  997. wappInt-handle-cgi-request
  998. } else {
  999. wappInt-start-listener $port $mode $fromip
  1000. if {!$nowait} {
  1001. vwait ::forever
  1002. }
  1003. }
  1004. }
  1005.  
  1006. # Call this version 1.0
  1007. package provide wapp 1.0