gitlab.com/CoiaPrant/sqlite3@v1.19.1/testdata/tcl/wapp.tcl (about) 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 {& & < < > > \" " \\ \} $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