diff options
Diffstat (limited to 'www/search')
| -rwxr-xr-x | www/search | 1440 |
1 files changed, 1440 insertions, 0 deletions
diff --git a/www/search b/www/search new file mode 100755 index 0000000..02edc49 --- /dev/null +++ b/www/search @@ -0,0 +1,1440 @@ +#!/usr/bin/tclsh.docsrc +#### Import of wapp.tcl +# 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 \n \\n \r \\r + \f \\f \t \\t \x01 \\u0001 \x02 \\u0002 \x03 \\u0003 + \x04 \\u0004 \x05 \\u0005 \x06 \\u0006 \x07 \\u0007 + \x0b \\u000b \x0e \\u000e \x0f \\u000f \x10 \\u0010 + \x11 \\u0011 \x12 \\u0012 \x13 \\u0013 \x14 \\u0014 + \x15 \\u0015 \x16 \\u0016 \x17 \\u0017 \x18 \\u0018 + \x19 \\u0019 \x1a \\u001a \x1b \\u001b \x1c \\u001c + \x1d \\u001d \x1e \\u001e \x1f \\u001f} $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 command] { + 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 + if {[info exists ::argv0]} { + set a0 [file normalize $argv0] + } else { + set a0 / + } + 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 + } + } + } 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 + } + } +} + +# 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 uses the global variable ::wapp and so must not be nested. +# It must run to completion before the next instance runs. If a recursive +# instances of this routine starts while another is running, the the +# recursive instance is added to a queue to be invoked after the current +# instance finishes. Yes, this means that WAPP IS SINGLE THREADED. Only +# a single page rendering instance my be running at a time. There can +# be multiple HTTP requests inbound at once, but only one my be processed +# at a time once the request is full read and parsed. +# +set wappIntPending {} +set wappIntLock 0 +proc wappInt-handle-request {chan} { + global wappIntPending wappIntLock + fileevent $chan readable {} + if {$wappIntLock} { + # Another instance of request is already running, so defer this one + lappend wappIntPending [list wappInt-handle-request $chan] + return + } + set wappIntLock 1 + catch [list wappInt-handle-request-unsafe $chan] + set wappIntLock 0 + if {[llength $wappIntPending]>0} { + # If there are deferred requests, then launch the oldest one + after idle [lindex $wappIntPending 0] + set wappIntPending [lrange $wappIntPending 1 end] + } +} +proc wappInt-handle-request-unsafe {chan} { + 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 command 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 + } + wapp-before-reply-hook + + # 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} + +# This routine runs after the request-handler dispatch and just +# before the reply is generated. The default implementation is +# a no-op, but applications can override to do validation and security +# checks on the reply, such as verifying that no sensitive information +# such as an API key or password is accidentally included in the +# reply text. +# +proc wapp-before-reply-hook {} {return} + +# Process a single CGI request +# +proc wappInt-handle-cgi-request {} { + global wapp env + foreach key [array names env {[A-Z]*}] {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-unsafe stdout +} + +# 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 + } + } 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 + } + } +} + +# 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 + +#### End of wapp.tcl + +# Generate all header content for the output document +# +proc search_header {} { + wapp { +<!DOCTYPE html> +<html><head> +<meta name="viewport" content="width=device-width, initial-scale=1.0"> +<meta http-equiv="content-type" content="text/html; charset=UTF-8"> +<link href="sqlite.css" rel="stylesheet"> +<title>Search SQLite Documentation</title> +<!-- path= --> +</head> +<body> +<div class=nosearch> +<a href="index.html"> +<img class="logo" src="images/sqlite370_banner.gif" alt="SQLite" border="0"> +</a> +<div><!-- IE hack to prevent disappearing logo --></div> +<div class="tagline desktoponly"> +Small. Fast. Reliable.<br>Choose any three. +</div> +<div class="menu mainmenu"> +<ul> +<li><a href="index.html">Home</a> +<li class='mobileonly'><a href="javascript:void(0)" onclick='toggle_div("submenu")'>Menu</a> +<li class='wideonly'><a href='about.html'>About</a> +<li class='desktoponly'><a href="docs.html">Documentation</a> +<li class='desktoponly'><a href="download.html">Download</a> +<li class='wideonly'><a href='copyright.html'>License</a> +<li class='desktoponly'><a href="support.html">Support</a> +<li class='desktoponly'><a href="prosupport.html">Purchase</a> +<li class='search' id='search_menubutton'> +<a href="javascript:void(0)" onclick='toggle_search()'>Search</a> +</ul> +</div> +<div class="menu submenu" id="submenu"> +<ul> +<li><a href='about.html'>About</a> +<li><a href='docs.html'>Documentation</a> +<li><a href='download.html'>Download</a> +<li><a href='support.html'>Support</a> +<li><a href='prosupport.html'>Purchase</a> +</ul> +</div> +<div class="searchmenu" id="searchmenu"> +<form method="GET" action="search"> +<select name="s" id="searchtype"> +<option value="d">Search Documentation</option> +<option value="c">Search Changelog</option> +</select> +<input type="text" name="q" id="searchbox" value=""> +<input type="submit" value="Go"> +</form> +</div> +</div> +<script> +function toggle_div(nm) { +var w = document.getElementById(nm); +if( w.style.display=="block" ){ +w.style.display = "none"; +}else{ +w.style.display = "block"; +} +} +function toggle_search() { +var w = document.getElementById("searchmenu"); +if( w.style.display=="block" ){ +w.style.display = "none"; +} else { +w.style.display = "block"; +setTimeout(function(){ +document.getElementById("searchbox").focus() +}, 30); +} +} +function div_off(nm){document.getElementById(nm).style.display="none";} +window.onbeforeunload = function(e){div_off("submenu");} +/* Disable the Search feature if we are not operating from CGI, since */ +/* Search is accomplished using CGI and will not work without it. */ +if( !location.origin || !location.origin.match || !location.origin.match(/http/) ){ +document.getElementById("search_menubutton").style.display = "none"; +} +/* Used by the Hide/Show button beside syntax diagrams, to toggle the */ +function hideorshow(btn,obj){ +var x = document.getElementById(obj); +var b = document.getElementById(btn); +if( x.style.display!='none' ){ +x.style.display = 'none'; +b.innerHTML='show'; +}else{ +x.style.display = ''; +b.innerHTML='hide'; +} +return false; +} +var antiRobot = 0; +function antiRobotGo(){ +if( antiRobot!=3 ) return; +antiRobot = 7; +var j = document.getElementById("mtimelink"); +if(j && j.hasAttribute("data-href")) j.href=j.getAttribute("data-href"); +} +function antiRobotDefense(){ +document.body.onmousedown=function(){ +antiRobot |= 2; +antiRobotGo(); +document.body.onmousedown=null; +} +document.body.onmousemove=function(){ +antiRobot |= 2; +antiRobotGo(); +document.body.onmousemove=null; +} +setTimeout(function(){ +antiRobot |= 1; +antiRobotGo(); +}, 100) +antiRobotGo(); +} +antiRobotDefense(); +</script> + } +} + +#------------------------------------------------------------------------- +# Add an entry to the log database for the current query. Which +# returns $nRes results. +# +proc search_add_log_entry {nRes} { + if {[wapp-param-exists donotlog]} return + sqlite3 db2 [file dir [wapp-param SCRIPT_FILENAME]]/search.d/searchlog.db + db2 timeout 10000 + set ip [wapp-param REMOTE_ADDR] + set query [wapp-param q] + db2 eval { + PRAGMA synchronous=OFF; + PRAGMA journal_mode=OFF; + BEGIN; + CREATE TABLE IF NOT EXISTS log( + ip, -- IP query was made from + query, -- Fts5 query string + nres, -- Number of results + timestamp DEFAULT CURRENT_TIMESTAMP + ); + INSERT INTO log(ip, query, nres) VALUES($ip, $query, $nRes); + COMMIT; + } + db2 close +} + +#------------------------------------------------------------------------- +# This command is similar to the builtin Tcl [time] command, except that +# it only ever runs the supplied script once. Also, instead of returning +# a string like "xxx microseconds per iteration", it returns "x.yy ms" or +# "x.yy s", depending on the magnitude of the time spent running the +# command. For example: +# +# % ttime {after 1500} +# 1.50 s +# % ttime {after 45} +# 45.02 ms +# +proc ttime {script} { + set t [lindex [time [list uplevel $script]] 0] + if {$t>1000000} { return [format "%.2f s" [expr {$t/1000000.0}]] } + return [format "%.2f ms" [expr {$t/1000.0}]] +} + +#----------------------------------------------------------------------- +# Do a search of the change log +# +proc searchchanges {} { + set q [wapp-param q] + if {$q==""} {return {}} + if {[regexp -all \x22 $q] % 2} { append q \x22 } + set x "" + foreach word [split $q " "] { + append x " \"[string map [list "\"" "\"\""] $word]\"" + } + set q [string trim $x] + regsub -all {[^a-zA-Z0-9_]} $q { } q + set open {<span style="background-color:#d9f2e6">} + set close {</span>} + set query { + SELECT url, version, idx, highlight(change, 3, $open, $close) AS text + FROM change($q) ORDER BY rowid ASC + } + wapp-trim { + <p>Change log entries mentioning: <b>%html($q)</b> + <table border=0> + } + set s2 "style=\"margin-top:0\"" + set s1 "style=\"font-size:larger; text-align:left\" class=nounderline" + set prev "" + db eval $query { + if {$prev!=$version} { + wapp-trim { + <tr> <td %unsafe($s1) valign=top> <a href='%url($url)'>%html($version)</a> + <td> <ul %unsafe($s2)> + } + set prev $version + } + wapp-subst {<li value=%html($idx)> (%html($idx)) %unsafe($text)\n} + } + wapp-trim { + </table> + <center><p>You can also see the <a href=changes.html>entire + changelog as a single page</a> if you wish.</center> + } +} + +#----------------------------------------------------------------------- +# Do a search over all documentation other than the change log +# +proc searchresults {} { + set q [wapp-param q] + if {$q==""} {return ""} + + # Count the '"' characters in $::A(q). If there is an odd number of + # occurences, add a " to the end of the query so that fts5 can parse + # it without error. + if {[regexp -all \x22 $q] % 2} { append q \x22 } + + # Set iStart to the index of the first result to display. Results are + # indexed starting at zero from most to least relevant. + # + set iStart 0 + catch {set iStart [expr {[wapp-param i 0]*10}]} + + # Grab a list of rowid results. + # + set sql { + SELECT rowid FROM page WHERE page MATCH $q + ORDER BY srank(page) DESC, + rank * COALESCE( + (SELECT percent FROM weight WHERE id=page.rowid), 100 + ); + } + if {[catch { set lRowid [db eval $sql] }]} { + set x "" + foreach word [split $q " "] { + append x " \"[string map [list "\"" "\"\""] $word]\"" + } + set q [string trim $x] + set lRowid [db eval $sql] + } + + set lRes [list] + foreach rowid $lRowid { + if {$rowid > 1000} { + set parent [expr $rowid / 1000] + lappend subsections($parent) $rowid + } else { + lappend lRes $rowid + } + } + + set nRes [llength $lRes] + set lRes [lrange $lRes $iStart [expr $iStart+9]] + + # Add an entry to the log database. + # + search_add_log_entry $nRes + + # If there are no results, return a message to that effect. + # + if {[llength $lRes] == 0} { + wapp-subst {<p>No Results for: <b>%html($q)</b>\n} + } + + # HTML markup used to highlight keywords within FTS5 generated snippets. + # + set open {<span style="background-color:#d9f2e6">} + set close {</span>} + set ellipsis {<b> ... </b>} + + # Grab the required data + # + db eval [string map [list %LIST% [join $lRowid ,]] { + SELECT + rowid AS parentid, + snippet(page, 0, $open, $close, $ellipsis, 6) AS s_apis, + snippet(page, 2, $open, $close, '', 40) AS s_title1, + snippet(page, 3, $open, $close, $ellipsis, 40) AS s_title2, + snippet(page, 4, $open, $close, $ellipsis, 40) AS s_content, + url, rank + FROM page($q) + WHERE rowid IN (%LIST%) + }] X { + foreach k [array names X] { set data($X(parentid),$k) [set X($k)] } + } + + set i1 [expr {$iStart+1}] + set i2 [expr {($nRes < $iStart+10) ? $nRes : $iStart+10}] + wapp-trim { + <table border=0> + <p>Search results %html($i1)..%html($i2) of %html($nRes) for: <b>%html($q)</b> + } + + foreach rowid $lRes { + + foreach a {parentid s_apis s_title1 s_content url rank} { + set $a $data($rowid,$a) + } + + if {[info exists subsections($parentid)]} { + set childid [lindex $subsections($parentid) 0] + set link $data($childid,url) + set hdr $data($childid,s_title2) + + if {$hdr==""} { + set s_content "" + } else { + set s_content [subst { + <b><a style=color:#044a64 href=$link>$hdr</a></b> + }] + } + + append s_content " $data($childid,s_content)" + } + + wapp-trim {<tr> + <td valign=top style="line-height:150%"> + <div style="white-space:wrap;font-size:larger" class=nounderline> + <a href="%url($url)">%unsafe($s_title1)</a> + <div style="float:right;font-size:smaller;color:#BBB">(%url($url))</div> + </div> + <div style="margin-left: 10ex; font:larger monospace">%unsafe($s_apis)</div> + <div style="margin-left: 4ex; margin-bottom:1.5em"> + %unsafe($s_content) + </div> + </td> + } + } + wapp-subst {</table>\n} + + + # If the query returned more than 10 results, add up to 10 links to + # each set of 10 results (first link to results 1-10, second to 11-20, + # third to 21-30, as required). + # + if {$nRes>10} { + set s(0) {border:solid #044a64 1px;padding:1ex;margin:1ex;line-height:300%;} + set s(1) "$s(0);background:#044a64;color:white" + wapp-subst {<center><p>\n} + for {set i 0} {$i < 10 && ($i*10)<$nRes} {incr i} { + set style $s([expr {($iStart/10)==$i}]) + wapp-trim { + <a style="%html($style)" + href="search?q=%qp($q)&i=%qp($i)">%html([expr $i+1])</a> + } + } + wapp-subst {</center>\n} + } +} + +# This is the main entry point into the search result page generator +# +proc wapp-default {} { + wapp-content-security-policy {default-src 'self' 'unsafe-inline'} + wapp-allow-xorigin-params + if {[wapp-param-exists env]} { + search_header + wapp-trim { + <h1>Environment Dump For Debugging</h1> + <pre>%html([wapp-debug-env])</pre> + } + return + } + + # When running using the built-in webserver in Wapp (in other words, + # when not running as CGI) any filename that contains a "." loads + # directly from the filesystem. + if {[wapp-param WAPP_MODE]!="cgi" + && [string match *.* [wapp-param PATH_INFO]] + } { + set altfile [file dir [wapp-param SCRIPT_FILENAME]][wapp-param PATH_INFO] + set fd [open $altfile rb] + fconfigure $fd -translation binary + wapp-unsafe [read $fd] + close $fd + switch -glob -- $altfile { + *.html { + wapp-mimetype text/html + } + *.css { + wapp-mimetype text/css + } + *.gif { + wapp-mimetype image/gif + } + } + return + } + + search_header + sqlite3 db [file dir [wapp-param SCRIPT_FILENAME]]/search.d/search.db + set searchType [wapp-param s d] + if {$searchType=="c"} { + set cmd searchchanges + } else { + set cmd searchresults + } + db transaction { + set t [ttime {$cmd}] + } + wapp-trim { + <center> + <p>Page generated by <a href='fts5.html'>FTS5</a> in about %html($t). + </center> + <script> + window.addEventListener('load', function() { + var w = document.getElementById("searchmenu"); + w.style.display = "block"; + w = document.getElementById("searchtype"); + w.value = "%string($searchType)" + setTimeout(function(){ + var s = document.getElementById("searchbox"); + s.value = "%string([wapp-param q])" + s.focus(); + s.select(); + }, 30); + }); + </script> + } +} +wapp-start $argv |