test/wapp.tcl

   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} $s]
 159 }
 160
 161 # This is a helper routine for wappInt-enc-url and wappInt-enc-qp.  It returns
 162 # an appropriate %HH encoding for the single character c.  If c is a unicode
 163 # character, then this routine might return multiple bytes:  %HH%HH%HH
 164 #
 165 proc wappInt-%HHchar {c} {
 166   if {$c==" "} {return +}
 167   return [regsub -all .. [binary encode hex [encoding convertto utf-8 $c]] {%&}]
 168 }
 169
 170
 171 # Undo the www-url-encoded format.
 172 #
 173 # HT: This code stolen from ncgi.tcl
 174 #
 175 proc wappInt-decode-url {str} {
 176   set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str]
 177   regsub -all -- \
 178       {%([Ee][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \
 179       $str {[encoding convertfrom utf-8 [binary decode hex \1\2\3]]} str
 180   regsub -all -- \
 181       {%([CDcd][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])}                     \
 182       $str {[encoding convertfrom utf-8 [binary decode hex \1\2]]} str
 183   regsub -all -- {%([0-7][A-Fa-f0-9])} $str {\\u00\1} str
 184   return [subst -novar $str]
 185 }
 186
 187 # Reset the document back to an empty string.
 188 #
 189 proc wapp-reset {} {
 190   global wapp
 191   dict set wapp .reply {}
 192 }
 193
 194 # Change the mime-type of the result document.
 195 #
 196 proc wapp-mimetype {x} {
 197   global wapp
 198   dict set wapp .mimetype $x
 199 }
 200
 201 # Change the reply code.
 202 #
 203 proc wapp-reply-code {x} {
 204   global wapp
 205   dict set wapp .reply-code $x
 206 }
 207
 208 # Set a cookie
 209 #
 210 proc wapp-set-cookie {name value} {
 211   global wapp
 212   dict lappend wapp .new-cookies $name $value
 213 }
 214
 215 # Unset a cookie
 216 #
 217 proc wapp-clear-cookie {name} {
 218   wapp-set-cookie $name {}
 219 }
 220
 221 # Add extra entries to the reply header
 222 #
 223 proc wapp-reply-extra {name value} {
 224   global wapp
 225   dict lappend wapp .reply-extra $name $value
 226 }
 227
 228 # Specifies how the web-page under construction should be cached.
 229 # The argument should be one of:
 230 #
 231 #    no-cache
 232 #    max-age=N             (for some integer number of seconds, N)
 233 #    private,max-age=N
 234 #
 235 proc wapp-cache-control {x} {
 236   wapp-reply-extra Cache-Control $x
 237 }
 238
 239 # Redirect to a different web page
 240 #
 241 proc wapp-redirect {uri} {
 242   wapp-reply-code {307 Redirect}
 243   wapp-reply-extra Location $uri
 244 }
 245
 246 # Return the value of a wapp parameter
 247 #
 248 proc wapp-param {name {dflt {}}} {
 249   global wapp
 250   if {![dict exists $wapp $name]} {return $dflt}
 251   return [dict get $wapp $name]
 252 }
 253
 254 # Return true if a and only if the wapp parameter $name exists
 255 #
 256 proc wapp-param-exists {name} {
 257   global wapp
 258   return [dict exists $wapp $name]
 259 }
 260
 261 # Set the value of a wapp parameter
 262 #
 263 proc wapp-set-param {name value} {
 264   global wapp
 265   dict set wapp $name $value
 266 }
 267
 268 # Return all parameter names that match the GLOB pattern, or all
 269 # names if the GLOB pattern is omitted.
 270 #
 271 proc wapp-param-list {{glob {*}}} {
 272   global wapp
 273   return [dict keys $wapp $glob]
 274 }
 275
 276 # By default, Wapp does not decode query parameters and POST parameters
 277 # for cross-origin requests.  This is a security restriction, designed to
 278 # help prevent cross-site request forgery (CSRF) attacks.
 279 #
 280 # As a consequence of this restriction, URLs for sites generated by Wapp
 281 # that contain query parameters will not work as URLs found in other
 282 # websites.  You cannot create a link from a second website into a Wapp
 283 # website if the link contains query planner, by default.
 284 #
 285 # Of course, it is sometimes desirable to allow query parameters on external
 286 # links.  For URLs for which this is safe, the application should invoke
 287 # wapp-allow-xorigin-params.  This procedure tells Wapp that it is safe to
 288 # go ahead and decode the query parameters even for cross-site requests.
 289 #
 290 # In other words, for Wapp security is the default setting.  Individual pages
 291 # need to actively disable the cross-site request security if those pages
 292 # are safe for cross-site access.
 293 #
 294 proc wapp-allow-xorigin-params {} {
 295   global wapp
 296   if {![dict exists $wapp .qp] && ![dict get $wapp SAME_ORIGIN]} {
 297     wappInt-decode-query-params
 298   }
 299 }
 300
 301 # Set the content-security-policy.
 302 #
 303 # The default content-security-policy is very strict:  "default-src 'self'"
 304 # The default policy prohibits the use of in-line javascript or CSS.
 305 #
 306 # Provide an alternative CSP as the argument.  Or use "off" to disable
 307 # the CSP completely.
 308 #
 309 proc wapp-content-security-policy {val} {
 310   global wapp
 311   if {$val=="off"} {
 312     dict unset wapp .csp
 313   } else {
 314     dict set wapp .csp $val
 315   }
 316 }
 317
 318 # Examine the bodys of all procedures in this program looking for
 319 # unsafe calls to various Wapp interfaces.  Return a text string
 320 # containing warnings. Return an empty string if all is ok.
 321 #
 322 # This routine is advisory only.  It misses some constructs that are
 323 # dangerous and flags others that are safe.
 324 #
 325 proc wapp-safety-check {} {
 326   set res {}
 327   foreach p [info procs] {
 328     set ln 0
 329     foreach x [split [info body $p] \n] {
 330       incr ln
 331       if {[regexp {^[ \t]*wapp[ \t]+([^\n]+)} $x all tail]
 332        && [string index $tail 0]!="\173"
 333        && [regexp {[[$]} $tail]
 334       } {
 335         append res "$p:$ln: unsafe \"wapp\" call: \"[string trim $x]\"\n"
 336       }
 337       if {[regexp {^[ \t]*wapp-(subst|trim)[ \t]+[^\173]} $x all cx]} {
 338         append res "$p:$ln: unsafe \"wapp-$cx\" call: \"[string trim $x]\"\n"
 339       }
 340     }
 341   }
 342   return $res
 343 }
 344
 345 # Return a string that descripts the current environment.  Applications
 346 # might find this useful for debugging.
 347 #
 348 proc wapp-debug-env {} {
 349   global wapp
 350   set out {}
 351   foreach var [lsort [dict keys $wapp]] {
 352     if {[string index $var 0]=="."} continue
 353     append out "$var = [list [dict get $wapp $var]]\n"
 354   }
 355   append out "\[pwd\] = [list [pwd]]\n"
 356   return $out
 357 }
 358
 359 # Tracing function for each HTTP request.  This is overridden by wapp-start
 360 # if tracing is enabled.
 361 #
 362 proc wappInt-trace {} {}
 363
 364 # Start up a listening socket.  Arrange to invoke wappInt-new-connection
 365 # for each inbound HTTP connection.
 366 #
 367 #    port            Listen on this TCP port.  0 means to select a port
 368 #                    that is not currently in use
 369 #
 370 #    wappmode        One of "scgi", "remote-scgi", "server", or "local".
 371 #
 372 #    fromip          If not {}, then reject all requests from IP addresses
 373 #                    other than $fromip
 374 #
 375 proc wappInt-start-listener {port wappmode fromip} {
 376   if {[string match *scgi $wappmode]} {
 377     set type SCGI
 378     set server [list wappInt-new-connection \
 379                 wappInt-scgi-readable $wappmode $fromip]
 380   } else {
 381     set type HTTP
 382     set server [list wappInt-new-connection \
 383                 wappInt-http-readable $wappmode $fromip]
 384   }
 385   if {$wappmode=="local" || $wappmode=="scgi"} {
 386     set x [socket -server $server -myaddr 127.0.0.1 $port]
 387   } else {
 388     set x [socket -server $server $port]
 389   }
 390   set coninfo [chan configure $x -sockname]
 391   set port [lindex $coninfo 2]
 392   if {$wappmode=="local"} {
 393     wappInt-start-browser http://127.0.0.1:$port/
 394   } elseif {$fromip!=""} {
 395     puts "Listening for $type requests on TCP port $port from IP $fromip"
 396   } else {
 397     puts "Listening for $type requests on TCP port $port"
 398   }
 399 }
 400
 401 # Start a web-browser and point it at $URL
 402 #
 403 proc wappInt-start-browser {url} {
 404   global tcl_platform
 405   if {$tcl_platform(platform)=="windows"} {
 406     exec cmd /c start $url &
 407   } elseif {$tcl_platform(os)=="Darwin"} {
 408     exec open $url &
 409   } elseif {[catch {exec xdg-open $url}]} {
 410     exec firefox $url &
 411   }
 412 }
 413
 414 # This routine is a "socket -server" callback.  The $chan, $ip, and $port
 415 # arguments are added by the socket command.
 416 #
 417 # Arrange to invoke $callback when content is available on the new socket.
 418 # The $callback will process inbound HTTP or SCGI content.  Reject the
 419 # request if $fromip is not an empty string and does not match $ip.
 420 #
 421 proc wappInt-new-connection {callback wappmode fromip chan ip port} {
 422   upvar #0 wappInt-$chan W
 423   if {$fromip!="" && ![string match $fromip $ip]} {
 424     close $chan
 425     return
 426   }
 427   set W [dict create REMOTE_ADDR $ip REMOTE_PORT $port WAPP_MODE $wappmode \
 428          .header {}]
 429   fconfigure $chan -blocking 0 -translation binary
 430   fileevent $chan readable [list $callback $chan]
 431 }
 432
 433 # Close an input channel
 434 #
 435 proc wappInt-close-channel {chan} {
 436   if {$chan=="stdout"} {
 437     # This happens after completing a CGI request
 438     exit 0
 439   } else {
 440     unset ::wappInt-$chan
 441     close $chan
 442   }
 443 }
 444
 445 # Process new text received on an inbound HTTP request
 446 #
 447 proc wappInt-http-readable {chan} {
 448   if {[catch [list wappInt-http-readable-unsafe $chan] msg]} {
 449     puts stderr "$msg\n$::errorInfo"
 450     wappInt-close-channel $chan
 451   }
 452 }
 453 proc wappInt-http-readable-unsafe {chan} {
 454   upvar #0 wappInt-$chan W wapp wapp
 455   if {![dict exists $W .toread]} {
 456     # If the .toread key is not set, that means we are still reading
 457     # the header
 458     set line [string trimright [gets $chan]]
 459     set n [string length $line]
 460     if {$n>0} {
 461       if {[dict get $W .header]=="" || [regexp {^\s+} $line]} {
 462         dict append W .header $line
 463       } else {
 464         dict append W .header \n$line
 465       }
 466       if {[string length [dict get $W .header]]>100000} {
 467         error "HTTP request header too big - possible DOS attack"
 468       }
 469     } elseif {$n==0} {
 470       # We have reached the blank line that terminates the header.
 471       global argv0
 472       set a0 [file normalize $argv0]
 473       dict set W SCRIPT_FILENAME $a0
 474       dict set W DOCUMENT_ROOT [file dir $a0]
 475       if {[wappInt-parse-header $chan]} {
 476         catch {close $chan}
 477         return
 478       }
 479       set len 0
 480       if {[dict exists $W CONTENT_LENGTH]} {
 481         set len [dict get $W CONTENT_LENGTH]
 482       }
 483       if {$len>0} {
 484         # Still need to read the query content
 485         dict set W .toread $len
 486       } else {
 487         # There is no query content, so handle the request immediately
 488         set wapp $W
 489         wappInt-handle-request $chan 0
 490       }
 491     }
 492   } else {
 493     # If .toread is set, that means we are reading the query content.
 494     # Continue reading until .toread reaches zero.
 495     set got [read $chan [dict get $W .toread]]
 496     dict append W CONTENT $got
 497     dict set W .toread [expr {[dict get $W .toread]-[string length $got]}]
 498     if {[dict get $W .toread]<=0} {
 499       # Handle the request as soon as all the query content is received
 500       set wapp $W
 501       wappInt-handle-request $chan 0
 502     }
 503   }
 504 }
 505
 506 # Decode the HTTP request header.
 507 #
 508 # This routine is always running inside of a [catch], so if
 509 # any problems arise, simply raise an error.
 510 #
 511 proc wappInt-parse-header {chan} {
 512   upvar #0 wappInt-$chan W
 513   set hdr [split [dict get $W .header] \n]
 514   if {$hdr==""} {return 1}
 515   set req [lindex $hdr 0]
 516   dict set W REQUEST_METHOD [set method [lindex $req 0]]
 517   if {[lsearch {GET HEAD POST} $method]<0} {
 518     error "unsupported request method: \"[dict get $W REQUEST_METHOD]\""
 519   }
 520   set uri [lindex $req 1]
 521   set split_uri [split $uri ?]
 522   set uri0 [lindex $split_uri 0]
 523   if {![regexp {^/[-.a-z0-9_/]*$} $uri0]} {
 524     error "invalid request uri: \"$uri0\""
 525   }
 526   dict set W REQUEST_URI $uri0
 527   dict set W PATH_INFO $uri0
 528   set uri1 [lindex $split_uri 1]
 529   dict set W QUERY_STRING $uri1
 530   set n [llength $hdr]
 531   for {set i 1} {$i<$n} {incr i} {
 532     set x [lindex $hdr $i]
 533     if {![regexp {^(.+): +(.*)$} $x all name value]} {
 534       error "invalid header line: \"$x\""
 535     }
 536     set name [string toupper $name]
 537     switch -- $name {
 538       REFERER {set name HTTP_REFERER}
 539       USER-AGENT {set name HTTP_USER_AGENT}
 540       CONTENT-LENGTH {set name CONTENT_LENGTH}
 541       CONTENT-TYPE {set name CONTENT_TYPE}
 542       HOST {set name HTTP_HOST}
 543       COOKIE {set name HTTP_COOKIE}
 544       ACCEPT-ENCODING {set name HTTP_ACCEPT_ENCODING}
 545       default {set name .hdr:$name}
 546     }
 547     dict set W $name $value
 548   }
 549   return 0
 550 }
 551
 552 # Decode the QUERY_STRING parameters from a GET request or the
 553 # application/x-www-form-urlencoded CONTENT from a POST request.
 554 #
 555 # This routine sets the ".qp" element of the ::wapp dict as a signal
 556 # that query parameters have already been decoded.
 557 #
 558 proc wappInt-decode-query-params {} {
 559   global wapp
 560   dict set wapp .qp 1
 561   if {[dict exists $wapp QUERY_STRING]} {
 562     foreach qterm [split [dict get $wapp QUERY_STRING] &] {
 563       set qsplit [split $qterm =]
 564       set nm [lindex $qsplit 0]
 565       if {[regexp {^[a-z][a-z0-9]*$} $nm]} {
 566         dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]]
 567       }
 568     }
 569   }
 570   if {[dict exists $wapp CONTENT_TYPE] && [dict exists $wapp CONTENT]} {
 571     set ctype [dict get $wapp CONTENT_TYPE]
 572     if {$ctype=="application/x-www-form-urlencoded"} {
 573       foreach qterm [split [string trim [dict get $wapp CONTENT]] &] {
 574         set qsplit [split $qterm =]
 575         set nm [lindex $qsplit 0]
 576         if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} {
 577           dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]]
 578         }
 579       }
 580     } elseif {[string match multipart/form-data* $ctype]} {
 581       regexp {^(.*?)\r\n(.*)$} [dict get $wapp CONTENT] all divider body
 582       set ndiv [string length $divider]
 583       while {[string length $body]} {
 584         set idx [string first $divider $body]
 585         set unit [string range $body 0 [expr {$idx-3}]]
 586         set body [string range $body [expr {$idx+$ndiv+2}] end]
 587         if {[regexp {^Content-Disposition: form-data; (.*?)\r\n\r\n(.*)$} \
 588              $unit unit hdr content]} {
 589           if {[regexp {name="(.*)"; filename="(.*)"\r\nContent-Type: (.*?)$}\
 590                 $hdr hr name filename mimetype]} {
 591             dict set wapp $name.filename \
 592               [string map [list \\\" \" \\\\ \\] $filename]
 593             dict set wapp $name.mimetype $mimetype
 594             dict set wapp $name.content $content
 595           } elseif {[regexp {name="(.*)"} $hdr hr name]} {
 596             dict set wapp $name $content
 597           }
 598         }
 599       }
 600     }
 601   }
 602 }
 603
 604 # Invoke application-supplied methods to generate a reply to
 605 # a single HTTP request.
 606 #
 607 # This routine always runs within [catch], so handle exceptions by
 608 # invoking [error].
 609 #
 610 proc wappInt-handle-request {chan useCgi} {
 611   global wapp
 612   dict set wapp .reply {}
 613   dict set wapp .mimetype {text/html; charset=utf-8}
 614   dict set wapp .reply-code {200 Ok}
 615   dict set wapp .csp {default-src 'self'}
 616
 617   # Set up additional CGI environment values
 618   #
 619   if {![dict exists $wapp HTTP_HOST]} {
 620     dict set wapp BASE_URL {}
 621   } elseif {[dict exists $wapp HTTPS]} {
 622     dict set wapp BASE_URL https://[dict get $wapp HTTP_HOST]
 623   } else {
 624     dict set wapp BASE_URL http://[dict get $wapp HTTP_HOST]
 625   }
 626   if {![dict exists $wapp REQUEST_URI]} {
 627     dict set wapp REQUEST_URI /
 628   } elseif {[regsub {\?.*} [dict get $wapp REQUEST_URI] {} newR]} {
 629     # Some servers (ex: nginx) append the query parameters to REQUEST_URI.
 630     # These need to be stripped off
 631     dict set wapp REQUEST_URI $newR
 632   }
 633   if {[dict exists $wapp SCRIPT_NAME]} {
 634     dict append wapp BASE_URL [dict get $wapp SCRIPT_NAME]
 635   } else {
 636     dict set wapp SCRIPT_NAME {}
 637   }
 638   if {![dict exists $wapp PATH_INFO]} {
 639     # If PATH_INFO is missing (ex: nginx) then construct it
 640     set URI [dict get $wapp REQUEST_URI]
 641     set skip [string length [dict get $wapp SCRIPT_NAME]]
 642     dict set wapp PATH_INFO [string range $URI $skip end]
 643   }
 644   if {[regexp {^/([^/]+)(.*)$} [dict get $wapp PATH_INFO] all head tail]} {
 645     dict set wapp PATH_HEAD $head
 646     dict set wapp PATH_TAIL [string trimleft $tail /]
 647   } else {
 648     dict set wapp PATH_INFO {}
 649     dict set wapp PATH_HEAD {}
 650     dict set wapp PATH_TAIL {}
 651   }
 652   dict set wapp SELF_URL [dict get $wapp BASE_URL]/[dict get $wapp PATH_HEAD]
 653
 654   # Parse query parameters from the query string, the cookies, and
 655   # POST data
 656   #
 657   if {[dict exists $wapp HTTP_COOKIE]} {
 658     foreach qterm [split [dict get $wapp HTTP_COOKIE] {;}] {
 659       set qsplit [split [string trim $qterm] =]
 660       set nm [lindex $qsplit 0]
 661       if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} {
 662         dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]]
 663       }
 664     }
 665   }
 666   set same_origin 0
 667   if {[dict exists $wapp HTTP_REFERER]} {
 668     set referer [dict get $wapp HTTP_REFERER]
 669     set base [dict get $wapp BASE_URL]
 670     if {$referer==$base || [string match $base/* $referer]} {
 671       set same_origin 1
 672     }
 673   }
 674   dict set wapp SAME_ORIGIN $same_origin
 675   if {$same_origin} {
 676     wappInt-decode-query-params
 677   }
 678
 679   # Invoke the application-defined handler procedure for this page
 680   # request.  If an error occurs while running that procedure, generate
 681   # an HTTP reply that contains the error message.
 682   #
 683   wapp-before-dispatch-hook
 684   wappInt-trace
 685   set mname [dict get $wapp PATH_HEAD]
 686   if {[catch {
 687     if {$mname!="" && [llength [info proc wapp-page-$mname]]>0} {
 688       wapp-page-$mname
 689     } else {
 690       wapp-default
 691     }
 692   } msg]} {
 693     if {[wapp-param WAPP_MODE]=="local" || [wapp-param WAPP_MODE]=="server"} {
 694       puts "ERROR: $::errorInfo"
 695     }
 696     wapp-reset
 697     wapp-reply-code "500 Internal Server Error"
 698     wapp-mimetype text/html
 699     wapp-trim {
 700       <h1>Wapp Application Error</h1>
 701       <pre>%html($::errorInfo)</pre>
 702     }
 703     dict unset wapp .new-cookies
 704   }
 705
 706   # Transmit the HTTP reply
 707   #
 708   if {$chan=="stdout"} {
 709     puts $chan "Status: [dict get $wapp .reply-code]\r"
 710   } else {
 711     puts $chan "HTTP/1.1 [dict get $wapp .reply-code]\r"
 712     puts $chan "Server: wapp\r"
 713     puts $chan "Connection: close\r"
 714   }
 715   if {[dict exists $wapp .reply-extra]} {
 716     foreach {name value} [dict get $wapp .reply-extra] {
 717       puts $chan "$name: $value\r"
 718     }
 719   }
 720   if {[dict exists $wapp .csp]} {
 721     puts $chan "Content-Security-Policy: [dict get $wapp .csp]\r"
 722   }
 723   set mimetype [dict get $wapp .mimetype]
 724   puts $chan "Content-Type: $mimetype\r"
 725   if {[dict exists $wapp .new-cookies]} {
 726     foreach {nm val} [dict get $wapp .new-cookies] {
 727       if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} {
 728         if {$val==""} {
 729           puts $chan "Set-Cookie: $nm=; HttpOnly; Path=/; Max-Age=1\r"
 730         } else {
 731           set val [wappInt-enc-url $val]
 732           puts $chan "Set-Cookie: $nm=$val; HttpOnly; Path=/\r"
 733         }
 734       }
 735     }
 736   }
 737   if {[string match text/* $mimetype]} {
 738     set reply [encoding convertto utf-8 [dict get $wapp .reply]]
 739     if {[regexp {\ygzip\y} [wapp-param HTTP_ACCEPT_ENCODING]]} {
 740       catch {
 741         set x [zlib gzip $reply]
 742         set reply $x
 743         puts $chan "Content-Encoding: gzip\r"
 744       }
 745     }
 746   } else {
 747     set reply [dict get $wapp .reply]
 748   }
 749   puts $chan "Content-Length: [string length $reply]\r"
 750   puts $chan \r
 751   puts -nonewline $chan $reply
 752   flush $chan
 753   wappInt-close-channel $chan
 754 }
 755
 756 # This routine runs just prior to request-handler dispatch.  The
 757 # default implementation is a no-op, but applications can override
 758 # to do additional transformations or checks.
 759 #
 760 proc wapp-before-dispatch-hook {} {return}
 761
 762 # Process a single CGI request
 763 #
 764 proc wappInt-handle-cgi-request {} {
 765   global wapp env
 766   foreach key {
 767     CONTENT_LENGTH
 768     CONTENT_TYPE
 769     DOCUMENT_ROOT
 770     HTTP_ACCEPT_ENCODING
 771     HTTP_COOKIE
 772     HTTP_HOST
 773     HTTP_REFERER
 774     HTTP_USER_AGENT
 775     HTTPS
 776     PATH_INFO
 777     QUERY_STRING
 778     REMOTE_ADDR
 779     REQUEST_METHOD
 780     REQUEST_URI
 781     REMOTE_USER
 782     SCRIPT_FILENAME
 783     SCRIPT_NAME
 784     SERVER_NAME
 785     SERVER_PORT
 786     SERVER_PROTOCOL
 787   } {
 788     if {[info exists env($key)]} {
 789       dict set wapp $key $env($key)
 790     }
 791   }
 792   set len 0
 793   if {[dict exists $wapp CONTENT_LENGTH]} {
 794     set len [dict get $wapp CONTENT_LENGTH]
 795   }
 796   if {$len>0} {
 797     fconfigure stdin -translation binary
 798     dict set wapp CONTENT [read stdin $len]
 799   }
 800   dict set wapp WAPP_MODE cgi
 801   fconfigure stdout -translation binary
 802   wappInt-handle-request stdout 1
 803 }
 804
 805 # Process new text received on an inbound SCGI request
 806 #
 807 proc wappInt-scgi-readable {chan} {
 808   if {[catch [list wappInt-scgi-readable-unsafe $chan] msg]} {
 809     puts stderr "$msg\n$::errorInfo"
 810     wappInt-close-channel $chan
 811   }
 812 }
 813 proc wappInt-scgi-readable-unsafe {chan} {
 814   upvar #0 wappInt-$chan W wapp wapp
 815   if {![dict exists $W .toread]} {
 816     # If the .toread key is not set, that means we are still reading
 817     # the header.
 818     #
 819     # An SGI header is short.  This implementation assumes the entire
 820     # header is available all at once.
 821     #
 822     dict set W .remove_addr [dict get $W REMOTE_ADDR]
 823     set req [read $chan 15]
 824     set n [string length $req]
 825     scan $req %d:%s len hdr
 826     incr len [string length "$len:,"]
 827     append hdr [read $chan [expr {$len-15}]]
 828     foreach {nm val} [split $hdr \000] {
 829       if {$nm==","} break
 830       dict set W $nm $val
 831     }
 832     set len 0
 833     if {[dict exists $W CONTENT_LENGTH]} {
 834       set len [dict get $W CONTENT_LENGTH]
 835     }
 836     if {$len>0} {
 837       # Still need to read the query content
 838       dict set W .toread $len
 839     } else {
 840       # There is no query content, so handle the request immediately
 841       dict set W SERVER_ADDR [dict get $W .remove_addr]
 842       set wapp $W
 843       wappInt-handle-request $chan 0
 844     }
 845   } else {
 846     # If .toread is set, that means we are reading the query content.
 847     # Continue reading until .toread reaches zero.
 848     set got [read $chan [dict get $W .toread]]
 849     dict append W CONTENT $got
 850     dict set W .toread [expr {[dict get $W .toread]-[string length $got]}]
 851     if {[dict get $W .toread]<=0} {
 852       # Handle the request as soon as all the query content is received
 853       dict set W SERVER_ADDR [dict get $W .remove_addr]
 854       set wapp $W
 855       wappInt-handle-request $chan 0
 856     }
 857   }
 858 }
 859
 860 # Start up the wapp framework.  Parameters are a list passed as the
 861 # single argument.
 862 #
 863 #    -server $PORT         Listen for HTTP requests on this TCP port $PORT
 864 #
 865 #    -local $PORT          Listen for HTTP requests on 127.0.0.1:$PORT
 866 #
 867 #    -scgi $PORT           Listen for SCGI requests on 127.0.0.1:$PORT
 868 #
 869 #    -remote-scgi $PORT    Listen for SCGI requests on TCP port $PORT
 870 #
 871 #    -cgi                  Handle a single CGI request
 872 #
 873 # With no arguments, the behavior is called "auto".  In "auto" mode,
 874 # if the GATEWAY_INTERFACE environment variable indicates CGI, then run
 875 # as CGI.  Otherwise, start an HTTP server bound to the loopback address
 876 # only, on an arbitrary TCP port, and automatically launch a web browser
 877 # on that TCP port.
 878 #
 879 # Additional options:
 880 #
 881 #    -fromip GLOB         Reject any incoming request where the remote
 882 #                         IP address does not match the GLOB pattern.  This
 883 #                         value defaults to '127.0.0.1' for -local and -scgi.
 884 #
 885 #    -nowait              Do not wait in the event loop.  Return immediately
 886 #                         after all event handlers are established.
 887 #
 888 #    -trace               "puts" each request URL as it is handled, for
 889 #                         debugging
 890 #
 891 #    -lint                Run wapp-safety-check on the application instead
 892 #                         of running the application itself
 893 #
 894 #    -Dvar=value          Set TCL global variable "var" to "value"
 895 #
 896 #
 897 proc wapp-start {arglist} {
 898   global env
 899   set mode auto
 900   set port 0
 901   set nowait 0
 902   set fromip {}
 903   set n [llength $arglist]
 904   for {set i 0} {$i<$n} {incr i} {
 905     set term [lindex $arglist $i]
 906     if {[string match --* $term]} {set term [string range $term 1 end]}
 907     switch -glob -- $term {
 908       -server {
 909         incr i;
 910         set mode "server"
 911         set port [lindex $arglist $i]
 912       }
 913       -local {
 914         incr i;
 915         set mode "local"
 916         set fromip 127.0.0.1
 917         set port [lindex $arglist $i]
 918       }
 919       -scgi {
 920         incr i;
 921         set mode "scgi"
 922         set fromip 127.0.0.1
 923         set port [lindex $arglist $i]
 924       }
 925       -remote-scgi {
 926         incr i;
 927         set mode "remote-scgi"
 928         set port [lindex $arglist $i]
 929       }
 930       -cgi {
 931         set mode "cgi"
 932       }
 933       -fromip {
 934         incr i
 935         set fromip [lindex $arglist $i]
 936       }
 937       -nowait {
 938         set nowait 1
 939       }
 940       -trace {
 941         proc wappInt-trace {} {
 942           set q [wapp-param QUERY_STRING]
 943           set uri [wapp-param BASE_URL][wapp-param PATH_INFO]
 944           if {$q!=""} {append uri ?$q}
 945           puts $uri
 946         }
 947       }
 948       -lint {
 949         set res [wapp-safety-check]
 950         if {$res!=""} {
 951           puts "Potential problems in this code:"
 952           puts $res
 953           exit 1
 954         } else {
 955           exit
 956         }
 957       }
 958       -D*=* {
 959         if {[regexp {^.D([^=]+)=(.*)$} $term all var val]} {
 960           set ::$var $val
 961         }
 962       }
 963       default {
 964         error "unknown option: $term"
 965       }
 966     }
 967   }
 968   if {$mode=="auto"} {
 969     if {[info exists env(GATEWAY_INTERFACE)]
 970         && [string match CGI/1.* $env(GATEWAY_INTERFACE)]} {
 971       set mode cgi
 972     } else {
 973       set mode local
 974     }
 975   }
 976   if {$mode=="cgi"} {
 977     wappInt-handle-cgi-request
 978   } else {
 979     wappInt-start-listener $port $mode $fromip
 980     if {!$nowait} {
 981       vwait ::forever
 982     }
 983   }
 984 }
 985
 986 # Call this version 1.0
 987 package provide wapp 1.0