| # Copyright (c) 2017 D. Richard Hipp |
| # |
| # This program is free software; you can redistribute it and/or |
| # modify it under the terms of the Simplified BSD License (also |
| # known as the "2-Clause License" or "FreeBSD License".) |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but without any warranty; without even the implied warranty of |
| # merchantability or fitness for a particular purpose. |
| # |
| #--------------------------------------------------------------------------- |
| # |
| # Design rules: |
| # |
| # (1) All identifiers in the global namespace begin with "wapp" |
| # |
| # (2) Indentifiers intended for internal use only begin with "wappInt" |
| # |
| package require Tcl 8.6 |
| |
| # Add text to the end of the HTTP reply. No interpretation or transformation |
| # of the text is performs. The argument should be enclosed within {...} |
| # |
| proc wapp {txt} { |
| global wapp |
| dict append wapp .reply $txt |
| } |
| |
| # Add text to the page under construction. Do no escaping on the text. |
| # |
| # Though "unsafe" in general, there are uses for this kind of thing. |
| # For example, if you want to return the complete, unmodified content of |
| # a file: |
| # |
| # set fd [open content.html rb] |
| # wapp-unsafe [read $fd] |
| # close $fd |
| # |
| # You could do the same thing using ordinary "wapp" instead of "wapp-unsafe". |
| # The difference is that wapp-safety-check will complain about the misuse |
| # of "wapp", but it assumes that the person who write "wapp-unsafe" understands |
| # the risks. |
| # |
| # Though occasionally necessary, the use of this interface should be minimized. |
| # |
| proc wapp-unsafe {txt} { |
| global wapp |
| dict append wapp .reply $txt |
| } |
| |
| # Add text to the end of the reply under construction. The following |
| # substitutions are made: |
| # |
| # %html(...) Escape text for inclusion in HTML |
| # %url(...) Escape text for use as a URL |
| # %qp(...) Escape text for use as a URI query parameter |
| # %string(...) Escape text for use within a JSON string |
| # %unsafe(...) No transformations of the text |
| # |
| # The substitutions above terminate at the first ")" character. If the |
| # text of the TCL string in ... contains ")" characters itself, use instead: |
| # |
| # %html%(...)% |
| # %url%(...)% |
| # %qp%(...)% |
| # %string%(...)% |
| # %unsafe%(...)% |
| # |
| # In other words, use "%(...)%" instead of "(...)" to include the TCL string |
| # to substitute. |
| # |
| # The %unsafe substitution should be avoided whenever possible, obviously. |
| # In addition to the substitutions above, the text also does backslash |
| # escapes. |
| # |
| # The wapp-trim proc works the same as wapp-subst except that it also removes |
| # whitespace from the left margin, so that the generated HTML/CSS/Javascript |
| # does not appear to be indented when delivered to the client web browser. |
| # |
| if {$tcl_version>=8.7} { |
| proc wapp-subst {txt} { |
| global wapp |
| regsub -all -command \ |
| {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt |
| dict append wapp .reply [subst -novariables -nocommand $txt] |
| } |
| proc wapp-trim {txt} { |
| global wapp |
| regsub -all {\n\s+} [string trim $txt] \n txt |
| regsub -all -command \ |
| {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt |
| dict append wapp .reply [subst -novariables -nocommand $txt] |
| } |
| proc wappInt-enc {all mode nu1 txt} { |
| return [uplevel 2 "wappInt-enc-$mode \"$txt\""] |
| } |
| } else { |
| proc wapp-subst {txt} { |
| global wapp |
| regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \ |
| {[wappInt-enc-\1 "\3"]} txt |
| dict append wapp .reply [uplevel 1 [list subst -novariables $txt]] |
| } |
| proc wapp-trim {txt} { |
| global wapp |
| regsub -all {\n\s+} [string trim $txt] \n txt |
| regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \ |
| {[wappInt-enc-\1 "\3"]} txt |
| dict append wapp .reply [uplevel 1 [list subst -novariables $txt]] |
| } |
| } |
| |
| # There must be a wappInt-enc-NAME routine for each possible substitution |
| # in wapp-subst. Thus there are routines for "html", "url", "qp", and "unsafe". |
| # |
| # wappInt-enc-html Escape text so that it is safe to use in the |
| # body of an HTML document. |
| # |
| # wappInt-enc-url Escape text so that it is safe to pass as an |
| # argument to href= and src= attributes in HTML. |
| # |
| # wappInt-enc-qp Escape text so that it is safe to use as the |
| # value of a query parameter in a URL or in |
| # post data or in a cookie. |
| # |
| # wappInt-enc-string Escape ", ', \, and < for using inside of a |
| # javascript string literal. The < character |
| # is escaped to prevent "</script>" from causing |
| # problems in embedded javascript. |
| # |
| # wappInt-enc-unsafe Perform no encoding at all. Unsafe. |
| # |
| proc wappInt-enc-html {txt} { |
| return [string map {& & < < > > \" " \\ \} $txt] |
| } |
| proc wappInt-enc-unsafe {txt} { |
| return $txt |
| } |
| proc wappInt-enc-url {s} { |
| if {[regsub -all {[^-{}@~?=#_.:/a-zA-Z0-9]} $s {[wappInt-%HHchar {&}]} s]} { |
| set s [subst -novar -noback $s] |
| } |
| if {[regsub -all {[{}]} $s {[wappInt-%HHchar \\&]} s]} { |
| set s [subst -novar -noback $s] |
| } |
| return $s |
| } |
| proc wappInt-enc-qp {s} { |
| if {[regsub -all {[^-{}_.a-zA-Z0-9]} $s {[wappInt-%HHchar {&}]} s]} { |
| set s [subst -novar -noback $s] |
| } |
| if {[regsub -all {[{}]} $s {[wappInt-%HHchar \\&]} s]} { |
| set s [subst -novar -noback $s] |
| } |
| return $s |
| } |
| proc wappInt-enc-string {s} { |
| return [string map {\\ \\\\ \" \\\" ' \\' < \\u003c} $s] |
| } |
| |
| # This is a helper routine for wappInt-enc-url and wappInt-enc-qp. It returns |
| # an appropriate %HH encoding for the single character c. If c is a unicode |
| # character, then this routine might return multiple bytes: %HH%HH%HH |
| # |
| proc wappInt-%HHchar {c} { |
| if {$c==" "} {return +} |
| return [regsub -all .. [binary encode hex [encoding convertto utf-8 $c]] {%&}] |
| } |
| |
| |
| # Undo the www-url-encoded format. |
| # |
| # HT: This code stolen from ncgi.tcl |
| # |
| proc wappInt-decode-url {str} { |
| set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str] |
| regsub -all -- \ |
| {%([Ee][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \ |
| $str {[encoding convertfrom utf-8 [binary decode hex \1\2\3]]} str |
| regsub -all -- \ |
| {%([CDcd][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \ |
| $str {[encoding convertfrom utf-8 [binary decode hex \1\2]]} str |
| regsub -all -- {%([0-7][A-Fa-f0-9])} $str {\\u00\1} str |
| return [subst -novar $str] |
| } |
| |
| # Reset the document back to an empty string. |
| # |
| proc wapp-reset {} { |
| global wapp |
| dict set wapp .reply {} |
| } |
| |
| # Change the mime-type of the result document. |
| # |
| proc wapp-mimetype {x} { |
| global wapp |
| dict set wapp .mimetype $x |
| } |
| |
| # Change the reply code. |
| # |
| proc wapp-reply-code {x} { |
| global wapp |
| dict set wapp .reply-code $x |
| } |
| |
| # Set a cookie |
| # |
| proc wapp-set-cookie {name value} { |
| global wapp |
| dict lappend wapp .new-cookies $name $value |
| } |
| |
| # Unset a cookie |
| # |
| proc wapp-clear-cookie {name} { |
| wapp-set-cookie $name {} |
| } |
| |
| # Add extra entries to the reply header |
| # |
| proc wapp-reply-extra {name value} { |
| global wapp |
| dict lappend wapp .reply-extra $name $value |
| } |
| |
| # Specifies how the web-page under construction should be cached. |
| # The argument should be one of: |
| # |
| # no-cache |
| # max-age=N (for some integer number of seconds, N) |
| # private,max-age=N |
| # |
| proc wapp-cache-control {x} { |
| wapp-reply-extra Cache-Control $x |
| } |
| |
| # Redirect to a different web page |
| # |
| proc wapp-redirect {uri} { |
| wapp-reply-code {307 Redirect} |
| wapp-reply-extra Location $uri |
| } |
| |
| # Return the value of a wapp parameter |
| # |
| proc wapp-param {name {dflt {}}} { |
| global wapp |
| if {![dict exists $wapp $name]} {return $dflt} |
| return [dict get $wapp $name] |
| } |
| |
| # Return true if a and only if the wapp parameter $name exists |
| # |
| proc wapp-param-exists {name} { |
| global wapp |
| return [dict exists $wapp $name] |
| } |
| |
| # Set the value of a wapp parameter |
| # |
| proc wapp-set-param {name value} { |
| global wapp |
| dict set wapp $name $value |
| } |
| |
| # Return all parameter names that match the GLOB pattern, or all |
| # names if the GLOB pattern is omitted. |
| # |
| proc wapp-param-list {{glob {*}}} { |
| global wapp |
| return [dict keys $wapp $glob] |
| } |
| |
| # By default, Wapp does not decode query parameters and POST parameters |
| # for cross-origin requests. This is a security restriction, designed to |
| # help prevent cross-site request forgery (CSRF) attacks. |
| # |
| # As a consequence of this restriction, URLs for sites generated by Wapp |
| # that contain query parameters will not work as URLs found in other |
| # websites. You cannot create a link from a second website into a Wapp |
| # website if the link contains query planner, by default. |
| # |
| # Of course, it is sometimes desirable to allow query parameters on external |
| # links. For URLs for which this is safe, the application should invoke |
| # wapp-allow-xorigin-params. This procedure tells Wapp that it is safe to |
| # go ahead and decode the query parameters even for cross-site requests. |
| # |
| # In other words, for Wapp security is the default setting. Individual pages |
| # need to actively disable the cross-site request security if those pages |
| # are safe for cross-site access. |
| # |
| proc wapp-allow-xorigin-params {} { |
| global wapp |
| if {![dict exists $wapp .qp] && ![dict get $wapp SAME_ORIGIN]} { |
| wappInt-decode-query-params |
| } |
| } |
| |
| # Set the content-security-policy. |
| # |
| # The default content-security-policy is very strict: "default-src 'self'" |
| # The default policy prohibits the use of in-line javascript or CSS. |
| # |
| # Provide an alternative CSP as the argument. Or use "off" to disable |
| # the CSP completely. |
| # |
| proc wapp-content-security-policy {val} { |
| global wapp |
| if {$val=="off"} { |
| dict unset wapp .csp |
| } else { |
| dict set wapp .csp $val |
| } |
| } |
| |
| # Examine the bodys of all procedures in this program looking for |
| # unsafe calls to various Wapp interfaces. Return a text string |
| # containing warnings. Return an empty string if all is ok. |
| # |
| # This routine is advisory only. It misses some constructs that are |
| # dangerous and flags others that are safe. |
| # |
| proc wapp-safety-check {} { |
| set res {} |
| foreach p [info procs] { |
| set ln 0 |
| foreach x [split [info body $p] \n] { |
| incr ln |
| if {[regexp {^[ \t]*wapp[ \t]+([^\n]+)} $x all tail] |
| && [string index $tail 0]!="\173" |
| && [regexp {[[$]} $tail] |
| } { |
| append res "$p:$ln: unsafe \"wapp\" call: \"[string trim $x]\"\n" |
| } |
| if {[regexp {^[ \t]*wapp-(subst|trim)[ \t]+[^\173]} $x all cx]} { |
| append res "$p:$ln: unsafe \"wapp-$cx\" call: \"[string trim $x]\"\n" |
| } |
| } |
| } |
| return $res |
| } |
| |
| # Return a string that descripts the current environment. Applications |
| # might find this useful for debugging. |
| # |
| proc wapp-debug-env {} { |
| global wapp |
| set out {} |
| foreach var [lsort [dict keys $wapp]] { |
| if {[string index $var 0]=="."} continue |
| append out "$var = [list [dict get $wapp $var]]\n" |
| } |
| append out "\[pwd\] = [list [pwd]]\n" |
| return $out |
| } |
| |
| # Tracing function for each HTTP request. This is overridden by wapp-start |
| # if tracing is enabled. |
| # |
| proc wappInt-trace {} {} |
| |
| # Start up a listening socket. Arrange to invoke wappInt-new-connection |
| # for each inbound HTTP connection. |
| # |
| # port Listen on this TCP port. 0 means to select a port |
| # that is not currently in use |
| # |
| # wappmode One of "scgi", "remote-scgi", "server", or "local". |
| # |
| # fromip If not {}, then reject all requests from IP addresses |
| # other than $fromip |
| # |
| proc wappInt-start-listener {port wappmode fromip} { |
| if {[string match *scgi $wappmode]} { |
| set type SCGI |
| set server [list wappInt-new-connection \ |
| wappInt-scgi-readable $wappmode $fromip] |
| } else { |
| set type HTTP |
| set server [list wappInt-new-connection \ |
| wappInt-http-readable $wappmode $fromip] |
| } |
| if {$wappmode=="local" || $wappmode=="scgi"} { |
| set x [socket -server $server -myaddr 127.0.0.1 $port] |
| } else { |
| set x [socket -server $server $port] |
| } |
| set coninfo [chan configure $x -sockname] |
| set port [lindex $coninfo 2] |
| if {$wappmode=="local"} { |
| wappInt-start-browser http://127.0.0.1:$port/ |
| } elseif {$fromip!=""} { |
| puts "Listening for $type requests on TCP port $port from IP $fromip" |
| } else { |
| puts "Listening for $type requests on TCP port $port" |
| } |
| } |
| |
| # Start a web-browser and point it at $URL |
| # |
| proc wappInt-start-browser {url} { |
| global tcl_platform |
| if {$tcl_platform(platform)=="windows"} { |
| exec cmd /c start $url & |
| } elseif {$tcl_platform(os)=="Darwin"} { |
| exec open $url & |
| } elseif {[catch {exec xdg-open $url}]} { |
| exec firefox $url & |
| } |
| } |
| |
| # This routine is a "socket -server" callback. The $chan, $ip, and $port |
| # arguments are added by the socket command. |
| # |
| # Arrange to invoke $callback when content is available on the new socket. |
| # The $callback will process inbound HTTP or SCGI content. Reject the |
| # request if $fromip is not an empty string and does not match $ip. |
| # |
| proc wappInt-new-connection {callback wappmode fromip chan ip port} { |
| upvar #0 wappInt-$chan W |
| if {$fromip!="" && ![string match $fromip $ip]} { |
| close $chan |
| return |
| } |
| set W [dict create REMOTE_ADDR $ip REMOTE_PORT $port WAPP_MODE $wappmode \ |
| .header {}] |
| fconfigure $chan -blocking 0 -translation binary |
| fileevent $chan readable [list $callback $chan] |
| } |
| |
| # Close an input channel |
| # |
| proc wappInt-close-channel {chan} { |
| if {$chan=="stdout"} { |
| # This happens after completing a CGI request |
| exit 0 |
| } else { |
| unset ::wappInt-$chan |
| close $chan |
| } |
| } |
| |
| # Process new text received on an inbound HTTP request |
| # |
| proc wappInt-http-readable {chan} { |
| if {[catch [list wappInt-http-readable-unsafe $chan] msg]} { |
| puts stderr "$msg\n$::errorInfo" |
| wappInt-close-channel $chan |
| } |
| } |
| proc wappInt-http-readable-unsafe {chan} { |
| upvar #0 wappInt-$chan W wapp wapp |
| if {![dict exists $W .toread]} { |
| # If the .toread key is not set, that means we are still reading |
| # the header |
| set line [string trimright [gets $chan]] |
| set n [string length $line] |
| if {$n>0} { |
| if {[dict get $W .header]=="" || [regexp {^\s+} $line]} { |
| dict append W .header $line |
| } else { |
| dict append W .header \n$line |
| } |
| if {[string length [dict get $W .header]]>100000} { |
| error "HTTP request header too big - possible DOS attack" |
| } |
| } elseif {$n==0} { |
| # We have reached the blank line that terminates the header. |
| global argv0 |
| set a0 [file normalize $argv0] |
| dict set W SCRIPT_FILENAME $a0 |
| dict set W DOCUMENT_ROOT [file dir $a0] |
| if {[wappInt-parse-header $chan]} { |
| catch {close $chan} |
| return |
| } |
| set len 0 |
| if {[dict exists $W CONTENT_LENGTH]} { |
| set len [dict get $W CONTENT_LENGTH] |
| } |
| if {$len>0} { |
| # Still need to read the query content |
| dict set W .toread $len |
| } else { |
| # There is no query content, so handle the request immediately |
| set wapp $W |
| wappInt-handle-request $chan 0 |
| } |
| } |
| } else { |
| # If .toread is set, that means we are reading the query content. |
| # Continue reading until .toread reaches zero. |
| set got [read $chan [dict get $W .toread]] |
| dict append W CONTENT $got |
| dict set W .toread [expr {[dict get $W .toread]-[string length $got]}] |
| if {[dict get $W .toread]<=0} { |
| # Handle the request as soon as all the query content is received |
| set wapp $W |
| wappInt-handle-request $chan 0 |
| } |
| } |
| } |
| |
| # Decode the HTTP request header. |
| # |
| # This routine is always running inside of a [catch], so if |
| # any problems arise, simply raise an error. |
| # |
| proc wappInt-parse-header {chan} { |
| upvar #0 wappInt-$chan W |
| set hdr [split [dict get $W .header] \n] |
| if {$hdr==""} {return 1} |
| set req [lindex $hdr 0] |
| dict set W REQUEST_METHOD [set method [lindex $req 0]] |
| if {[lsearch {GET HEAD POST} $method]<0} { |
| error "unsupported request method: \"[dict get $W REQUEST_METHOD]\"" |
| } |
| set uri [lindex $req 1] |
| set split_uri [split $uri ?] |
| set uri0 [lindex $split_uri 0] |
| if {![regexp {^/[-.a-z0-9_/]*$} $uri0]} { |
| error "invalid request uri: \"$uri0\"" |
| } |
| dict set W REQUEST_URI $uri0 |
| dict set W PATH_INFO $uri0 |
| set uri1 [lindex $split_uri 1] |
| dict set W QUERY_STRING $uri1 |
| set n [llength $hdr] |
| for {set i 1} {$i<$n} {incr i} { |
| set x [lindex $hdr $i] |
| if {![regexp {^(.+): +(.*)$} $x all name value]} { |
| error "invalid header line: \"$x\"" |
| } |
| set name [string toupper $name] |
| switch -- $name { |
| REFERER {set name HTTP_REFERER} |
| USER-AGENT {set name HTTP_USER_AGENT} |
| CONTENT-LENGTH {set name CONTENT_LENGTH} |
| CONTENT-TYPE {set name CONTENT_TYPE} |
| HOST {set name HTTP_HOST} |
| COOKIE {set name HTTP_COOKIE} |
| ACCEPT-ENCODING {set name HTTP_ACCEPT_ENCODING} |
| default {set name .hdr:$name} |
| } |
| dict set W $name $value |
| } |
| return 0 |
| } |
| |
| # Decode the QUERY_STRING parameters from a GET request or the |
| # application/x-www-form-urlencoded CONTENT from a POST request. |
| # |
| # This routine sets the ".qp" element of the ::wapp dict as a signal |
| # that query parameters have already been decoded. |
| # |
| proc wappInt-decode-query-params {} { |
| global wapp |
| dict set wapp .qp 1 |
| if {[dict exists $wapp QUERY_STRING]} { |
| foreach qterm [split [dict get $wapp QUERY_STRING] &] { |
| set qsplit [split $qterm =] |
| set nm [lindex $qsplit 0] |
| if {[regexp {^[a-z][a-z0-9]*$} $nm]} { |
| dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]] |
| } |
| } |
| } |
| if {[dict exists $wapp CONTENT_TYPE] && [dict exists $wapp CONTENT]} { |
| set ctype [dict get $wapp CONTENT_TYPE] |
| if {$ctype=="application/x-www-form-urlencoded"} { |
| foreach qterm [split [string trim [dict get $wapp CONTENT]] &] { |
| set qsplit [split $qterm =] |
| set nm [lindex $qsplit 0] |
| if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} { |
| dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]] |
| } |
| } |
| } elseif {[string match multipart/form-data* $ctype]} { |
| regexp {^(.*?)\r\n(.*)$} [dict get $wapp CONTENT] all divider body |
| set ndiv [string length $divider] |
| while {[string length $body]} { |
| set idx [string first $divider $body] |
| set unit [string range $body 0 [expr {$idx-3}]] |
| set body [string range $body [expr {$idx+$ndiv+2}] end] |
| if {[regexp {^Content-Disposition: form-data; (.*?)\r\n\r\n(.*)$} \ |
| $unit unit hdr content]} { |
| if {[regexp {name="(.*)"; filename="(.*)"\r\nContent-Type: (.*?)$}\ |
| $hdr hr name filename mimetype]} { |
| dict set wapp $name.filename \ |
| [string map [list \\\" \" \\\\ \\] $filename] |
| dict set wapp $name.mimetype $mimetype |
| dict set wapp $name.content $content |
| } elseif {[regexp {name="(.*)"} $hdr hr name]} { |
| dict set wapp $name $content |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| # Invoke application-supplied methods to generate a reply to |
| # a single HTTP request. |
| # |
| # This routine always runs within [catch], so handle exceptions by |
| # invoking [error]. |
| # |
| proc wappInt-handle-request {chan useCgi} { |
| global wapp |
| dict set wapp .reply {} |
| dict set wapp .mimetype {text/html; charset=utf-8} |
| dict set wapp .reply-code {200 Ok} |
| dict set wapp .csp {default-src 'self'} |
| |
| # Set up additional CGI environment values |
| # |
| if {![dict exists $wapp HTTP_HOST]} { |
| dict set wapp BASE_URL {} |
| } elseif {[dict exists $wapp HTTPS]} { |
| dict set wapp BASE_URL https://[dict get $wapp HTTP_HOST] |
| } else { |
| dict set wapp BASE_URL http://[dict get $wapp HTTP_HOST] |
| } |
| if {![dict exists $wapp REQUEST_URI]} { |
| dict set wapp REQUEST_URI / |
| } elseif {[regsub {\?.*} [dict get $wapp REQUEST_URI] {} newR]} { |
| # Some servers (ex: nginx) append the query parameters to REQUEST_URI. |
| # These need to be stripped off |
| dict set wapp REQUEST_URI $newR |
| } |
| if {[dict exists $wapp SCRIPT_NAME]} { |
| dict append wapp BASE_URL [dict get $wapp SCRIPT_NAME] |
| } else { |
| dict set wapp SCRIPT_NAME {} |
| } |
| if {![dict exists $wapp PATH_INFO]} { |
| # If PATH_INFO is missing (ex: nginx) then construct it |
| set URI [dict get $wapp REQUEST_URI] |
| set skip [string length [dict get $wapp SCRIPT_NAME]] |
| dict set wapp PATH_INFO [string range $URI $skip end] |
| } |
| if {[regexp {^/([^/]+)(.*)$} [dict get $wapp PATH_INFO] all head tail]} { |
| dict set wapp PATH_HEAD $head |
| dict set wapp PATH_TAIL [string trimleft $tail /] |
| } else { |
| dict set wapp PATH_INFO {} |
| dict set wapp PATH_HEAD {} |
| dict set wapp PATH_TAIL {} |
| } |
| dict set wapp SELF_URL [dict get $wapp BASE_URL]/[dict get $wapp PATH_HEAD] |
| |
| # Parse query parameters from the query string, the cookies, and |
| # POST data |
| # |
| if {[dict exists $wapp HTTP_COOKIE]} { |
| foreach qterm [split [dict get $wapp HTTP_COOKIE] {;}] { |
| set qsplit [split [string trim $qterm] =] |
| set nm [lindex $qsplit 0] |
| if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} { |
| dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]] |
| } |
| } |
| } |
| set same_origin 0 |
| if {[dict exists $wapp HTTP_REFERER]} { |
| set referer [dict get $wapp HTTP_REFERER] |
| set base [dict get $wapp BASE_URL] |
| if {$referer==$base || [string match $base/* $referer]} { |
| set same_origin 1 |
| } |
| } |
| dict set wapp SAME_ORIGIN $same_origin |
| if {$same_origin} { |
| wappInt-decode-query-params |
| } |
| |
| # Invoke the application-defined handler procedure for this page |
| # request. If an error occurs while running that procedure, generate |
| # an HTTP reply that contains the error message. |
| # |
| wapp-before-dispatch-hook |
| wappInt-trace |
| set mname [dict get $wapp PATH_HEAD] |
| if {[catch { |
| if {$mname!="" && [llength [info proc wapp-page-$mname]]>0} { |
| wapp-page-$mname |
| } else { |
| wapp-default |
| } |
| } msg]} { |
| if {[wapp-param WAPP_MODE]=="local" || [wapp-param WAPP_MODE]=="server"} { |
| puts "ERROR: $::errorInfo" |
| } |
| wapp-reset |
| wapp-reply-code "500 Internal Server Error" |
| wapp-mimetype text/html |
| wapp-trim { |
| <h1>Wapp Application Error</h1> |
| <pre>%html($::errorInfo)</pre> |
| } |
| dict unset wapp .new-cookies |
| } |
| |
| # Transmit the HTTP reply |
| # |
| if {$chan=="stdout"} { |
| puts $chan "Status: [dict get $wapp .reply-code]\r" |
| } else { |
| puts $chan "HTTP/1.1 [dict get $wapp .reply-code]\r" |
| puts $chan "Server: wapp\r" |
| puts $chan "Connection: close\r" |
| } |
| if {[dict exists $wapp .reply-extra]} { |
| foreach {name value} [dict get $wapp .reply-extra] { |
| puts $chan "$name: $value\r" |
| } |
| } |
| if {[dict exists $wapp .csp]} { |
| puts $chan "Content-Security-Policy: [dict get $wapp .csp]\r" |
| } |
| set mimetype [dict get $wapp .mimetype] |
| puts $chan "Content-Type: $mimetype\r" |
| if {[dict exists $wapp .new-cookies]} { |
| foreach {nm val} [dict get $wapp .new-cookies] { |
| if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} { |
| if {$val==""} { |
| puts $chan "Set-Cookie: $nm=; HttpOnly; Path=/; Max-Age=1\r" |
| } else { |
| set val [wappInt-enc-url $val] |
| puts $chan "Set-Cookie: $nm=$val; HttpOnly; Path=/\r" |
| } |
| } |
| } |
| } |
| if {[string match text/* $mimetype]} { |
| set reply [encoding convertto utf-8 [dict get $wapp .reply]] |
| if {[regexp {\ygzip\y} [wapp-param HTTP_ACCEPT_ENCODING]]} { |
| catch { |
| set x [zlib gzip $reply] |
| set reply $x |
| puts $chan "Content-Encoding: gzip\r" |
| } |
| } |
| } else { |
| set reply [dict get $wapp .reply] |
| } |
| puts $chan "Content-Length: [string length $reply]\r" |
| puts $chan \r |
| puts -nonewline $chan $reply |
| flush $chan |
| wappInt-close-channel $chan |
| } |
| |
| # This routine runs just prior to request-handler dispatch. The |
| # default implementation is a no-op, but applications can override |
| # to do additional transformations or checks. |
| # |
| proc wapp-before-dispatch-hook {} {return} |
| |
| # Process a single CGI request |
| # |
| proc wappInt-handle-cgi-request {} { |
| global wapp env |
| foreach key { |
| CONTENT_LENGTH |
| CONTENT_TYPE |
| DOCUMENT_ROOT |
| HTTP_ACCEPT_ENCODING |
| HTTP_COOKIE |
| HTTP_HOST |
| HTTP_REFERER |
| HTTP_USER_AGENT |
| HTTPS |
| PATH_INFO |
| QUERY_STRING |
| REMOTE_ADDR |
| REQUEST_METHOD |
| REQUEST_URI |
| REMOTE_USER |
| SCRIPT_FILENAME |
| SCRIPT_NAME |
| SERVER_NAME |
| SERVER_PORT |
| SERVER_PROTOCOL |
| } { |
| if {[info exists env($key)]} { |
| dict set wapp $key $env($key) |
| } |
| } |
| set len 0 |
| if {[dict exists $wapp CONTENT_LENGTH]} { |
| set len [dict get $wapp CONTENT_LENGTH] |
| } |
| if {$len>0} { |
| fconfigure stdin -translation binary |
| dict set wapp CONTENT [read stdin $len] |
| } |
| dict set wapp WAPP_MODE cgi |
| fconfigure stdout -translation binary |
| wappInt-handle-request stdout 1 |
| } |
| |
| # Process new text received on an inbound SCGI request |
| # |
| proc wappInt-scgi-readable {chan} { |
| if {[catch [list wappInt-scgi-readable-unsafe $chan] msg]} { |
| puts stderr "$msg\n$::errorInfo" |
| wappInt-close-channel $chan |
| } |
| } |
| proc wappInt-scgi-readable-unsafe {chan} { |
| upvar #0 wappInt-$chan W wapp wapp |
| if {![dict exists $W .toread]} { |
| # If the .toread key is not set, that means we are still reading |
| # the header. |
| # |
| # An SGI header is short. This implementation assumes the entire |
| # header is available all at once. |
| # |
| dict set W .remove_addr [dict get $W REMOTE_ADDR] |
| set req [read $chan 15] |
| set n [string length $req] |
| scan $req %d:%s len hdr |
| incr len [string length "$len:,"] |
| append hdr [read $chan [expr {$len-15}]] |
| foreach {nm val} [split $hdr \000] { |
| if {$nm==","} break |
| dict set W $nm $val |
| } |
| set len 0 |
| if {[dict exists $W CONTENT_LENGTH]} { |
| set len [dict get $W CONTENT_LENGTH] |
| } |
| if {$len>0} { |
| # Still need to read the query content |
| dict set W .toread $len |
| } else { |
| # There is no query content, so handle the request immediately |
| dict set W SERVER_ADDR [dict get $W .remove_addr] |
| set wapp $W |
| wappInt-handle-request $chan 0 |
| } |
| } else { |
| # If .toread is set, that means we are reading the query content. |
| # Continue reading until .toread reaches zero. |
| set got [read $chan [dict get $W .toread]] |
| dict append W CONTENT $got |
| dict set W .toread [expr {[dict get $W .toread]-[string length $got]}] |
| if {[dict get $W .toread]<=0} { |
| # Handle the request as soon as all the query content is received |
| dict set W SERVER_ADDR [dict get $W .remove_addr] |
| set wapp $W |
| wappInt-handle-request $chan 0 |
| } |
| } |
| } |
| |
| # Start up the wapp framework. Parameters are a list passed as the |
| # single argument. |
| # |
| # -server $PORT Listen for HTTP requests on this TCP port $PORT |
| # |
| # -local $PORT Listen for HTTP requests on 127.0.0.1:$PORT |
| # |
| # -scgi $PORT Listen for SCGI requests on 127.0.0.1:$PORT |
| # |
| # -remote-scgi $PORT Listen for SCGI requests on TCP port $PORT |
| # |
| # -cgi Handle a single CGI request |
| # |
| # With no arguments, the behavior is called "auto". In "auto" mode, |
| # if the GATEWAY_INTERFACE environment variable indicates CGI, then run |
| # as CGI. Otherwise, start an HTTP server bound to the loopback address |
| # only, on an arbitrary TCP port, and automatically launch a web browser |
| # on that TCP port. |
| # |
| # Additional options: |
| # |
| # -fromip GLOB Reject any incoming request where the remote |
| # IP address does not match the GLOB pattern. This |
| # value defaults to '127.0.0.1' for -local and -scgi. |
| # |
| # -nowait Do not wait in the event loop. Return immediately |
| # after all event handlers are established. |
| # |
| # -trace "puts" each request URL as it is handled, for |
| # debugging |
| # |
| # -lint Run wapp-safety-check on the application instead |
| # of running the application itself |
| # |
| # -Dvar=value Set TCL global variable "var" to "value" |
| # |
| # |
| proc wapp-start {arglist} { |
| global env |
| set mode auto |
| set port 0 |
| set nowait 0 |
| set fromip {} |
| set n [llength $arglist] |
| for {set i 0} {$i<$n} {incr i} { |
| set term [lindex $arglist $i] |
| if {[string match --* $term]} {set term [string range $term 1 end]} |
| switch -glob -- $term { |
| -server { |
| incr i; |
| set mode "server" |
| set port [lindex $arglist $i] |
| } |
| -local { |
| incr i; |
| set mode "local" |
| set fromip 127.0.0.1 |
| set port [lindex $arglist $i] |
| } |
| -scgi { |
| incr i; |
| set mode "scgi" |
| set fromip 127.0.0.1 |
| set port [lindex $arglist $i] |
| } |
| -remote-scgi { |
| incr i; |
| set mode "remote-scgi" |
| set port [lindex $arglist $i] |
| } |
| -cgi { |
| set mode "cgi" |
| } |
| -fromip { |
| incr i |
| set fromip [lindex $arglist $i] |
| } |
| -nowait { |
| set nowait 1 |
| } |
| -trace { |
| proc wappInt-trace {} { |
| set q [wapp-param QUERY_STRING] |
| set uri [wapp-param BASE_URL][wapp-param PATH_INFO] |
| if {$q!=""} {append uri ?$q} |
| puts $uri |
| } |
| } |
| -lint { |
| set res [wapp-safety-check] |
| if {$res!=""} { |
| puts "Potential problems in this code:" |
| puts $res |
| exit 1 |
| } else { |
| exit |
| } |
| } |
| -D*=* { |
| if {[regexp {^.D([^=]+)=(.*)$} $term all var val]} { |
| set ::$var $val |
| } |
| } |
| default { |
| error "unknown option: $term" |
| } |
| } |
| } |
| if {$mode=="auto"} { |
| if {[info exists env(GATEWAY_INTERFACE)] |
| && [string match CGI/1.* $env(GATEWAY_INTERFACE)]} { |
| set mode cgi |
| } else { |
| set mode local |
| } |
| } |
| if {$mode=="cgi"} { |
| wappInt-handle-cgi-request |
| } else { |
| wappInt-start-listener $port $mode $fromip |
| if {!$nowait} { |
| vwait ::forever |
| } |
| } |
| } |
| |
| # Call this version 1.0 |
| package provide wapp 1.0 |