├── .github
    └── workflows
    │   └── ci.yml
├── .gitignore
├── AUTHORS
├── GNUmakefile
├── README.md
├── example.jsonl
├── screenshot.png
├── tests
    ├── dir1
    │   ├── bar.html
    │   ├── foo.txt
    │   ├── nulls
    │   ├── tiny.gif
    │   └── tiny.png
    ├── dir2
    │   └── bad.html
    └── tests.tcl
├── tinyfts-dev.tcl
├── tools
    ├── dir2jsonl
    ├── import
    ├── titlecat
    └── wrap
└── vendor
    ├── tacit
        └── tacit.css
    └── wapp
        └── wapp.tcl


/.github/workflows/ci.yml:
--------------------------------------------------------------------------------
 1 | name: CI
 2 | on: [push]
 3 | jobs:
 4 |   test:
 5 |     runs-on: ubuntu-latest
 6 |     steps:
 7 |     - name: Install dependencies
 8 |       run: sudo apt-get install -y libsqlite3-tcl sqlite3 tcl tcllib tdom
 9 |     - name: Checkout
10 |       uses: actions/checkout@v4
11 |     - name: Build
12 |       run: make tinyfts
13 |     - name: Run tests
14 |       run: make test
15 |     
16 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | /tinyfts
2 | /vendor/tacit/tacit.css.tcl
3 | 


--------------------------------------------------------------------------------
/AUTHORS:
--------------------------------------------------------------------------------
 1 | # The AUTHORS Certificate
 2 | # First edition, Fourteenth draft
 3 | #
 4 | # By proposing a change to this project that adds a line like
 5 | #
 6 | #     Name <E-Mail> (URL) [Working For]
 7 | #
 8 | # below, you certify:
 9 | #
10 | # 1. All of your contributions to this project are and will be your own,
11 | #    original work, licensed on the same terms as this project.
12 | #
13 | # 2. If someone else might own intellectual property in your
14 | #    contributions, like an employer or client, you've added their legal
15 | #    name in square brackets and got their written permission to submit
16 | #    your contribution.
17 | #
18 | # 3. If you haven't added a name in square brackets, you are sure that
19 | #    you have the legal right to license all your contributions so far
20 | #    by yourself.
21 | #
22 | # 4. If you make any future contribution under different intellectual
23 | #    property circumstances, you'll propose a change to add another line
24 | #    to this file for that contribution.
25 | #
26 | # 5. The name, e-mail, and URL you've added to this file are yours. You
27 | #    understand the project will make this file public.
28 | D. Bohdan <see commit history> http://dbohdan.com/
29 | 


--------------------------------------------------------------------------------
/GNUmakefile:
--------------------------------------------------------------------------------
 1 | test: tinyfts
 2 | 	./tests/tests.tcl
 3 | 
 4 | tinyfts: GNUmakefile tools/titlecat tools/wrap tinyfts-dev.tcl vendor/tacit/tacit.css.tcl vendor/wapp/wapp.tcl
 5 | 	printf '#! /usr/bin/env tclsh\n# tinyfts single-file bundle.\n' > $@
 6 | 	./tools/titlecat vendor/tacit/tacit.css.tcl vendor/wapp/wapp.tcl tinyfts-dev.tcl >> $@
 7 | 	chmod +x $@
 8 | 
 9 | vendor/tacit/tacit.css.tcl: vendor/tacit/tacit.css GNUmakefile tools/wrap
10 | 	./tools/wrap $< :: 'dict set state css' > $@
11 | 
12 | clean:
13 | 	-rm tinyfts vendor/tacit/tacit.css.tcl
14 | 
15 | .PHONY: clean test
16 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # tinyfts
  2 | 
  3 | ![CI badge](https://github.com/dbohdan/tinyfts/workflows/CI/badge.svg)
  4 | 
  5 | A very small standalone full-text search HTTP/SCGI server.
  6 | 
  7 | ![A screenshot of what the unofficial tinyfts search service for the Tcler's Wiki looked like](screenshot.png)
  8 | 
  9 | 
 10 | ## Contents
 11 | 
 12 | - [Dependencies](#dependencies)
 13 | - [Usage](#usage)
 14 | - [Query syntax](#query-syntax)
 15 | - [Setup](#setup)
 16 | - [Operating notes](#operating-notes)
 17 | - [License](#license)
 18 | 
 19 | 
 20 | ## Dependencies
 21 | 
 22 | ### Server
 23 | 
 24 | - Tcl 8.6
 25 | - tclsqlite3 with [FTS5](https://sqlite.org/fts5.html)
 26 | 
 27 | ### Building, tools, and tests
 28 | 
 29 | The above and
 30 | - Tcllib
 31 | - kill(1), make(1), sqlite3(1)
 32 | - tDOM and file(1) to run `tools/dir2jsonl`
 33 | 
 34 | On recent Debian and Ubuntu install the dependencies with
 35 | 
 36 | ```sh
 37 | sudo apt install libsqlite3-tcl make sqlite3 tcl tcllib tdom
 38 | ```
 39 | 
 40 | On FreeBSD with sudo install the dependencies with
 41 | 
 42 | ```sh
 43 | sudo pkg install sqlite3 tcl-sqlite3 tcl86 tcllib tdom
 44 | cd /usr/local/bin
 45 | sudo ln -s tclsh8.6 tclsh
 46 | ```
 47 | 
 48 | 
 49 | ## Usage
 50 | 
 51 | ```none
 52 | Usage:
 53 |     tinyfts --db-file path [option ...] [wapp-arg ...]
 54 | Options:
 55 |     --css-file ''
 56 |     --credits <HTML>
 57 |     --header <HTML>
 58 |     --footer <HTML>
 59 |     --title tinyfts
 60 |     --subtitle <HTML>
 61 |     --table tinyfts
 62 |     --rate-limit 60
 63 |     --result-limit 100
 64 |     --log 'access bad-request error rate'
 65 |     --behind-reverse-proxy false
 66 |     --snippet-size 20
 67 |     --title-weight 1000.0
 68 |     --query-min-length 2
 69 |     --query-syntax web
 70 | ```
 71 | 
 72 | The basic usage is
 73 | 
 74 | ```sh
 75 | tools/import jsonl example.jsonl example.sqlite3
 76 | # Local server
 77 | ./tinyfts --db-file example.sqlite3 --local 8080
 78 | # Server available over the network
 79 | ./tinyfts --db-file example.sqlite3 --server 8080
 80 | ```
 81 | 
 82 | ## Query syntax
 83 | 
 84 | ### Default or "web"
 85 | 
 86 | The default full-text search query syntax in tinyfts resembles that of a Web search engine.
 87 | It can handle the following types of expressions.
 88 | 
 89 | - `foo` — search for the word `foo`.
 90 | - `"foo bar"` — search for the phrase `foo bar`.
 91 | - `foo AND bar`, `foo OR bar`, `NOT foo` — search for both `foo` and `bar`,
 92 |   at least one of `foo` and `bar`,
 93 |   and documents without `foo` respectively.
 94 |   `foo AND bar` is identical to `foo bar`.
 95 |   The operators `AND`, `OR`, and `NOT` must be in all caps.
 96 | - `-foo`, `-"foo bar"` — the same as `NOT foo`, `NOT "foo bar"`.
 97 | 
 98 | ### FTS5
 99 | 
100 | You can allow your users to write full
101 | [FTS5 queries](https://www.sqlite.org/fts5.html#full_text_query_syntax)
102 | with the command line option `--query-syntax fts5`.
103 | FTS5 queries are more powerful but expose the technical details of the underlying database.
104 | (For example, the column names.)
105 | Users who are unfamiliar with the FTS5 syntax will find it surprising and run into errors because they did not quote a word that has a special meaning.
106 | 
107 | 
108 | ## Setup
109 | 
110 | Tinyfts searches the contents of an SQLite database table with a particular schema.
111 | The bundled import tool `tools/import` can import serialized data
112 | (text files with one [JSON object](https://jsonlines.org/) or Tcl dictionary per line)
113 | and wiki pages from a [Wikit](https://wiki.tcl-lang.org/page/Wikit)/Nikit database to a tinyfts database.
114 | 
115 | ### Example
116 | 
117 | This example shows how to set up search for a backup copy of the
118 | [Tcler's Wiki](https://wiki.tcl-lang.org/page/About+the+WIki).
119 | The instructions should work on most Linux distributions and FreeBSD with the dependencies and Git installed.
120 | 
121 | 1\. Go to <https://sourceforge.net/project/showfiles.php?group_id=211498>.
122 |     Download and extract the last Wikit  database snapshot of the Tcler's Wiki.
123 | Currently that is `wikit-20141112.zip`.
124 |     Let's assume you have extracted the database file to `~/Downloads/wikit.tkd`.
125 | 
126 | 2\. Download, build, and test tinyfts.
127 |     In this example we use Git to get the latest development version.
128 | 
129 | ```sh
130 | git clone https://github.com/dbohdan/tinyfts
131 | cd tinyfts
132 | make
133 | ```
134 | 
135 | 3\. Create a tinyfts search database from the Tcler's Wiki database.
136 |     The repository includes an import tool that supports Wikit databases.
137 |     Depending on your hardware, this may take up to several minutes with an input database size in the hundreds of megabytes.
138 | 
139 | ```sh
140 | ./tools/import wikit ~/Downloads/wikit.tkd /tmp/fts.sqlite3
141 | ```
142 | 
143 | 4\. Start tinyfts on <http://localhost:8080>.
144 |     The server URL should open automatically in your browser.
145 |     Try searching.
146 | 
147 | ```sh
148 | ./tinyfts --db-file /tmp/fts.sqlite3 --title 'tinyfts demo' --local 8080
149 | ```
150 | 
151 | 
152 | ## Operating notes
153 | 
154 | - If you put tinyfts behind a reverse proxy, remember to start it with the command line option `--behind-reverse-proxy true`.
155 |   It is necessary for
156 | correct client IP address detection, which rate limiting depends on.
157 |   Do **not** enable `--behind-reverse-proxy` if tinyfts is not behind a reverse proxy.
158 |   It will let clients spoof their IP with the header `X-Real-IP` or `X-Forwarded-For` and evade rate limiting themselves and rate limit others.
159 | 
160 | 
161 | ## License
162 | 
163 | MIT.
164 | [Wapp](https://wapp.tcl.tk/) is copyright (c) 2017-2022 D. Richard Hipp and is distributed under the Simplified BSD License.
165 | [Tacit](https://github.com/yegor256/tacit) is copyright (c) 2015-2020 Yegor Bugayenko and is distributed under the MIT license.
166 | 


--------------------------------------------------------------------------------
/example.jsonl:
--------------------------------------------------------------------------------
1 | {"url":"https://fts.example.com/foo","title":"Foo","timestamp":652968000,"content":"Now this is a story"}
2 | {"url":"https://fts.example.com/bar","title":"Bar","timestamp":652968000,"content":"All about how"}
3 | {"url":"https://fts.example.com/baz","title":"Baz","timestamp":652968000,"content":"My life got flipped turned upside down..."}
4 | {"url":"https://fts.example.com/qux","title":"Qux","timestamp":-5667192000,"content":"Don't quote too much!"}
5 | {"url":"https://fts.example.com/lipsum1","title":"Lorem Ipsum 1","timestamp":-1767182400,"content":"Lorem ipsum dolor sit amet, consectetur adipiscing elit. Praesent elementum ut elit ut rutrum. Morbi a tincidunt urna, ac laoreet nisl. Suspendisse at neque metus. Curabitur a ipsum a dui vulputate semper. Mauris feugiat lectus ex. Maecenas scelerisque sapien non lorem commodo, eu tempus lorem tincidunt."}
6 | {"url":"https://fts.example.com/lipsum2","title":"Lorem Ipsum 2","timestamp":-1767182400,"content":"Lorem ipsum dolor sit amet, consectetur adipiscing elit. Praesent elementum ut elit ut rutrum. Morbi a tincidunt urna, ac laoreet nisl. Suspendisse at neque metus. Curabitur a ipsum a dui vulputate semper. Mauris feugiat lectus ex. Maecenas scelerisque sapien non lorem commodo, eu tempus lorem tincidunt."}
7 | {"url":"https://fts.example.com/lipsum3","title":"Lorem Ipsum 3","timestamp":-1767182400,"content":"Lorem ipsum dolor sit amet, consectetur adipiscing elit. Praesent elementum ut elit ut rutrum. Morbi a tincidunt urna, ac laoreet nisl. Suspendisse at neque metus. Curabitur a ipsum a dui vulputate semper. Mauris feugiat lectus ex. Maecenas scelerisque sapien non lorem commodo, eu tempus lorem tincidunt."}
8 | {"url":"https://fts.example.com/hello","title":"Greeting","timestamp":0,"content":"Hello, world!"}
9 | 


--------------------------------------------------------------------------------
/screenshot.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/dbohdan/tinyfts/4c2c8bb5418dcce96d5e60e684915ef9fb9ecf44/screenshot.png


--------------------------------------------------------------------------------
/tests/dir1/bar.html:
--------------------------------------------------------------------------------
 1 | <!doctype html>
 2 | <html lang="en">
 3 | <head>
 4 | <meta charset="utf-8">
 5 | <meta name="viewport" content="width=device-width, initial-scale=1">
 6 | </head>
 7 | <body>
 8 | <p>Bar.</p>
 9 | </body>
10 | </html>


--------------------------------------------------------------------------------
/tests/dir1/foo.txt:
--------------------------------------------------------------------------------
1 | Foo.


--------------------------------------------------------------------------------
/tests/dir1/nulls:
--------------------------------------------------------------------------------
1 | 


--------------------------------------------------------------------------------
/tests/dir1/tiny.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/dbohdan/tinyfts/4c2c8bb5418dcce96d5e60e684915ef9fb9ecf44/tests/dir1/tiny.gif


--------------------------------------------------------------------------------
/tests/dir1/tiny.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/dbohdan/tinyfts/4c2c8bb5418dcce96d5e60e684915ef9fb9ecf44/tests/dir1/tiny.png


--------------------------------------------------------------------------------
/tests/dir2/bad.html:
--------------------------------------------------------------------------------
1 | <HTML><HEA


--------------------------------------------------------------------------------
/tests/tests.tcl:
--------------------------------------------------------------------------------
  1 | #! /usr/bin/env tclsh
  2 | # ==============================================================================
  3 | # Copyright (c) 2019-2022, 2024-2025 D. Bohdan
  4 | # and contributors listed in AUTHORS
  5 | #
  6 | # Permission is hereby granted, free of charge, to any person obtaining a copy
  7 | # of this software and associated documentation files (the "Software"), to deal
  8 | # in the Software without restriction, including without limitation the rights
  9 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 10 | # copies of the Software, and to permit persons to whom the Software is
 11 | # furnished to do so, subject to the following conditions:
 12 | #
 13 | # The above copyright notice and this permission notice shall be included in
 14 | # all copies or substantial portions of the Software.
 15 | #
 16 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 17 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 18 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
 19 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
 20 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 21 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
 22 | # THE SOFTWARE.
 23 | # ==============================================================================
 24 | 
 25 | package require fileutil 1
 26 | package require http 2
 27 | package require json 1
 28 | package require tcltest 2
 29 | package require textutil
 30 | 
 31 | cd [file dirname [info script]]/..
 32 | 
 33 | set td(json-lines-sample) [string map [list \n\n \n \n {}] {
 34 |     {
 35 |         "url": "https://fts.example.com/foo",
 36 |         "title": "Foo",
 37 |         "timestamp": 1,
 38 |         "content": "Now this is a story UNO"
 39 |     }
 40 | 
 41 |     {
 42 |         "url": "https://fts.example.com/bar",
 43 |         "title": "Bar",
 44 |         "timestamp": 2,
 45 |         "content": "all about how UNO"
 46 |     }
 47 | 
 48 |     {
 49 |         "url": "https://fts.example.com/baz",
 50 |         "title": "Baz",
 51 |         "timestamp": 3,
 52 |         "content": "My life got flipped turned upside down UNO"
 53 |     }
 54 | 
 55 |     {
 56 |         "url": "https://fts.example.com/qux",
 57 |         "title": "Qux",
 58 |         "timestamp": 4,
 59 |         "content": "Don't quote UNO"
 60 |     }
 61 | 
 62 |     {
 63 |         "url": "https://fts.example.com/quux",
 64 |         "title": "Quux",
 65 |         "timestamp": 5,
 66 |         "content": "too much ウノ УНО UNO"
 67 |     }
 68 | }]
 69 | 
 70 | set td(tcl-sample) [join [lmap line [split $td(json-lines-sample) \n] {
 71 |     json::json2dict $line
 72 | }] \n]
 73 | 
 74 | 
 75 | proc fetch args {
 76 |     try {
 77 |         set token [http::geturl {*}$args]
 78 |         http::data $token
 79 |     } finally {
 80 |         catch { http::cleanup $token }
 81 |     }
 82 | }
 83 | 
 84 | 
 85 | proc kill pid {
 86 |     exec kill $pid
 87 | }
 88 | 
 89 | 
 90 | proc tclsh args {
 91 |     exec [info nameofexecutable] {*}$args
 92 | }
 93 | 
 94 | 
 95 | close [file tempfile td(dbFile) .sqlite3]
 96 | tcltest::makeFile {} $td(dbFile)
 97 | 
 98 | 
 99 | set td(cleanup) {
100 |     file delete $td(dbFile)
101 | }
102 | 
103 | 
104 | ### Unit: tinyfts.
105 | 
106 | source tinyfts
107 | 
108 | tcltest::test translate-query-1.1 {} -body {
109 |     translate-query::web {hello "very strange" world -foo -"foo bar"}
110 | } -result {"hello" "very strange" "world" NOT "foo" NOT "foo bar"}
111 | 
112 | tcltest::test translate-query-1.2 {} -body {
113 |     translate-query::web {foo bar OR baz}
114 | } -result {"foo" "bar" OR "baz"}
115 | 
116 | tcltest::test translate-query-1.3 {} -body {
117 |     translate-query::web foo\\\"bar
118 | } -result \"foo\\\"bar\"
119 | 
120 | tcltest::test translate-query-1.4 {} -body {
121 |     translate-query::web {foo bar's baz}
122 | } -result {"foo" "bar's" "baz"}
123 | 
124 | tcltest::test translate-query-1.5 {} -body {
125 |     translate-query::web {foo "bar's baz"}
126 | } -result {"foo" "bar's baz"}
127 | 
128 | 
129 | ### End-to-end: tools.
130 | 
131 | tcltest::test tools-import-1.1.1 {Tcl import} -body {
132 |     tclsh tools/import tcl - $td(dbFile) << $td(tcl-sample)
133 | } -cleanup $td(cleanup) -result {}
134 | 
135 | tcltest::test tools-import-1.1.2 {Tcl import} -cleanup $td(cleanup) -body {
136 |     tclsh tools/import tcl - $td(dbFile) --table blah \
137 |           << $td(tcl-sample)
138 | 
139 |     exec sqlite3 $td(dbFile) .schema
140 | } -match glob -result {*CREATE VIRTUAL TABLE "blah"*USING fts5*}
141 | 
142 | tcltest::test tools-import-1.1.3 {Tcl import} -cleanup $td(cleanup) -body {
143 |     tclsh tools/import tcl - $td(dbFile) --url-prefix http://example.com/ \
144 |           << $td(tcl-sample)
145 | 
146 |     exec sqlite3 $td(dbFile) {SELECT url FROM tinyfts LIMIT 2}
147 | } -match glob -result https://fts.example.com/foo\nhttps://fts.example.com/bar
148 | 
149 | 
150 | tcltest::test tools-import-1.2.1 {JSON Lines import} -body {
151 |     tclsh tools/import jsonl - $td(dbFile) << $td(json-lines-sample)
152 | } -cleanup $td(cleanup) -result {}
153 | 
154 | tcltest::test tools-import-1.2.2 {JSON Lines import} -cleanup $td(cleanup) -body {
155 |     tclsh tools/import jsonl - $td(dbFile) --table blah \
156 |           << $td(json-lines-sample)
157 | 
158 |     exec sqlite3 $td(dbFile) .schema
159 | } -match glob -result {*CREATE VIRTUAL TABLE "blah"*USING fts5*}
160 | 
161 | tcltest::test tools-import-1.2.3 {JSON Lines import} -cleanup $td(cleanup) -body {
162 |     tclsh tools/import jsonl - $td(dbFile) --url-prefix http://example.com/ \
163 |           << $td(json-lines-sample)
164 | 
165 |     exec sqlite3 $td(dbFile) {SELECT url FROM tinyfts LIMIT 2}
166 | } -match glob -result https://fts.example.com/foo\nhttps://fts.example.com/bar
167 | 
168 | 
169 | tcltest::test tools-import-2.1 {} -cleanup $td(cleanup) -body {
170 |     tclsh tools/import tcl /tmp/this/file/does/not/exit $td(dbFile)
171 | } -returnCodes 1 -match glob -result {*no such file*}
172 | 
173 | tcltest::test tools-import-2.2 {} -cleanup $td(cleanup) -body {
174 |     tclsh tools/import nikit $td(dbFile) $td(dbFile)
175 | } -returnCodes 1 -match glob -result {*unable to open database file*}
176 | 
177 | tcltest::test tools-import-2.3 {} -cleanup $td(cleanup) -body {
178 |     tclsh tools/import tcl - $td(dbFile) << \x00\x01\x02\x03\x04\x05\x06\x07
179 | } -returnCodes 1 -match glob -result *
180 | 
181 | 
182 | tcltest::test tools-dir2jsonl-1.1 {Normal dir} -body {
183 |     tclsh tools/dir2jsonl x/ tests/dir1/
184 | } -match regexp -result \
185 | {{"url":"x/bar.html","timestamp":\d+,"title":"bar.html","content":"Bar."}
186 | {"url":"x/foo.txt","timestamp":\d+,"title":"foo.txt","content":"Foo."}}
187 | 
188 | tcltest::test tools-dir2jsonl-2.1 {Bad HTML} -body {
189 |     tclsh tools/dir2jsonl x/ tests/dir2/ 2>@1
190 | } -match glob -result \
191 | {*can't parse HTML*Missing ">"*"content":"<HTML><HEA"\}}
192 | 
193 | 
194 | ### End-to-end: tinyfts.
195 | 
196 | set td(port) [expr 8000+int(rand()*1000)]
197 | tclsh tools/import tcl - $td(dbFile) << $td(tcl-sample)
198 | set td(pid) [tclsh tinyfts --db-file $td(dbFile) \
199 |                            --server $td(port) \
200 |                            --title Hello \
201 |                            --subtitle World \
202 |                            --rate-limit 20 \
203 |                            --result-limit 3 \
204 |                            --query-min-length 2 \
205 |                            --log {} \
206 |                            & \
207 | ]
208 | for {set i 0} {$i < 10} {incr i} {
209 |     try {
210 |         fetch http://127.0.0.1:$td(port)
211 |     } on ok _ break on error _ {}
212 |     after [expr {$i * 10}]
213 | }
214 | unset i
215 | 
216 | 
217 | tcltest::test default-1.1 {} -body {
218 |     fetch http://127.0.0.1:$td(port)/
219 | } -match glob -result {*<form action="/search">*}
220 | 
221 | 
222 | set td(query) http://127.0.0.1:$td(port)/search/?query
223 | 
224 | 
225 | tcltest::test search-1.1 {HTML result} -body {
226 |     fetch $td(query)=foo
227 | } -match glob -result {*Foo*(1970-01-01)*Now this is a story*}
228 | 
229 | tcltest::test search-1.2 {JSON result} -body {
230 |     json::json2dict [fetch $td(query)=foo&format=json]
231 | } -result {results {{url https://fts.example.com/foo\
232 |                      title Foo\
233 |                      timestamp 1\
234 |                      snippet {{Now this is a story UNO} {}}}}}
235 | 
236 | tcltest::test search-1.3 {Tcl result} -cleanup {unset raw} -body {
237 |     set raw [fetch $td(query)=foo&format=tcl]
238 |     dict create {*}[lindex [dict get $raw results] 0]
239 | } -result {url https://fts.example.com/foo\
240 |            title Foo\
241 |            timestamp 1\
242 |            snippet {{Now this is a story UNO} {}}}
243 | 
244 | tcltest::test search-1.4 {3 results} -cleanup {unset raw} -body {
245 |     set raw [fetch $td(query)=fts+NOT+Qu*&format=tcl]
246 |     lsort [lmap x [dict get $raw results] {
247 |         dict get $x title
248 |     }]
249 | } -result {Bar Baz Foo}
250 | 
251 | tcltest::test search-1.5 {Pagination} -cleanup {
252 |     unset next raw1 raw2
253 | } -body {
254 |     set raw1 [fetch $td(query)=uno&format=tcl]
255 |     set next [dict get $raw1 next]
256 |     set raw2 [fetch $td(query)=uno&format=tcl&start=$next]
257 | 
258 |     lsort [lmap x [concat [dict get $raw1 results] [dict get $raw2 results]] {
259 |         dict get $x title
260 |     }]
261 | } -result {Bar Baz Foo Quux Qux}
262 | 
263 | tcltest::test search-1.6 {Document title} -body {
264 |     fetch $td(query)=foo&format=html
265 | } -match glob -result {*<title>foo | Hello</title>*}
266 | 
267 | 
268 | tcltest::test search-1.7.1 {Unicode HTML} -body {
269 |     fetch $td(query)=quux&format=html
270 | } -match glob -result {*ウノ УНО UNO*}
271 | 
272 | tcltest::test search-1.7.2 {Unicode JSON} -body {
273 |     encoding convertfrom utf-8 [fetch $td(query)=quux&format=json]
274 | } -match glob -result {*ウノ УНО UNO*}
275 | 
276 | tcltest::test search-1.8.1 {Unicode HTML: "ウノ"} -body {
277 |     fetch $td(query)=%E3%82%A6%E3%83%8E&format=html
278 | } -match glob -result {*<strong>ウノ</strong>*}
279 | 
280 | tcltest::test search-1.8.2 {Unicode JSON: "ウノ"} -body {
281 |     encoding convertfrom utf-8 [fetch \
282 |         $td(query)=%E3%82%A6%E3%83%8E&format=json \
283 |     ]
284 | } -match glob -result {*,"ウノ",*}
285 | 
286 | tcltest::test search-1.9.1 {Unicode HTML: "УНО"} -body {
287 |     fetch $td(query)=%D0%A3%D0%9D%D0%9E&format=html
288 | } -match glob -result {*<strong>УНО</strong>*}
289 | 
290 | tcltest::test search-1.9.2 {Unicode JSON: "УНО"} -body {
291 |     encoding convertfrom utf-8 [fetch \
292 |          $td(query)=%D0%A3%D0%9D%D0%9E&format=json \
293 |     ]
294 | } -match glob -result {*,"УНО",*}
295 | 
296 | tcltest::test search-1.10.1 {Unicode HTML: "уно"} -body {
297 |     fetch $td(query)=%D1%83%D0%BD%D0%BE&format=html
298 | } -match glob -result {*<strong>УНО</strong>*}
299 | 
300 | tcltest::test search-1.10.2 {Unicode JSON: "уно"} -body {
301 |     encoding convertfrom utf-8 [fetch \
302 |          $td(query)=%D1%83%D0%BD%D0%BE&format=json \
303 |     ]
304 | } -match glob -result {*,"УНО",*}
305 | 
306 | 
307 | tcltest::test search-2.1 {No results} -body {
308 |     fetch $td(query)=111
309 | } -match glob -result {*No results.*}
310 | 
311 | tcltest::test search-2.2 {Unknown format} -body {
312 |     fetch $td(query)=foo&format=bar
313 | } -match glob -result {*Unknown format.*}
314 | 
315 | tcltest::test search-2.3 {Short query} -body {
316 |     fetch $td(query)=x
317 | } -match glob -result {*Query must be at least 2 characters long.*}
318 | 
319 | tcltest::test search-2.4 {Hit rate limit} -cleanup {unset i result} -body {
320 |     for {set i 0} {$i < 20} {incr i} {
321 |         set result [fetch $td(query)=nope]
322 |     }
323 |     set result
324 | } -result {Access denied.}
325 | 
326 | 
327 | kill $td(pid)
328 | file delete $td(dbFile)
329 | 
330 | 
331 | # Exit with a nonzero status if there are failed tests.
332 | set failed [expr {$tcltest::numTests(Failed) > 0}]
333 | 
334 | tcltest::cleanupTests
335 | if {$failed} {
336 |     exit 1
337 | }
338 | 


--------------------------------------------------------------------------------
/tinyfts-dev.tcl:
--------------------------------------------------------------------------------
  1 | #! /usr/bin/env tclsh
  2 | # tinyfts: a very small standalone full-text search HTTP server.
  3 | # ==============================================================================
  4 | # Copyright (c) 2019-2022, 2024 D. Bohdan
  5 | # and contributors listed in AUTHORS
  6 | #
  7 | # Permission is hereby granted, free of charge, to any person obtaining a copy
  8 | # of this software and associated documentation files (the "Software"), to deal
  9 | # in the Software without restriction, including without limitation the rights
 10 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 11 | # copies of the Software, and to permit persons to whom the Software is
 12 | # furnished to do so, subject to the following conditions:
 13 | #
 14 | # The above copyright notice and this permission notice shall be included in
 15 | # all copies or substantial portions of the Software.
 16 | #
 17 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 18 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 19 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
 20 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
 21 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 22 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
 23 | # THE SOFTWARE.
 24 | # ==============================================================================
 25 | 
 26 | package require Tcl 8.6 9
 27 | package require sqlite3 3.9
 28 | 
 29 | 
 30 | ### Configuration and globals
 31 | 
 32 | if {![info exists state]} {
 33 |     set state {}
 34 | }
 35 | set state [dict merge {
 36 |     css {}
 37 | 
 38 |     flags {
 39 |         hide db-file
 40 | 
 41 |         html-value {credits header footer subtitle}
 42 | 
 43 |         validator {
 44 |             query-syntax {
 45 |                 set validSyntaxes [lmap x [info commands translate-query::*] {
 46 |                     namespace tail $x
 47 |                 }]
 48 | 
 49 |                 if {$value ni $validSyntaxes} {
 50 |                     error [list invalid query syntax: $value]
 51 |                 }
 52 |             }
 53 |         }
 54 |     }
 55 | 
 56 |     rate {}
 57 |     version 0.8.0
 58 | } $state]
 59 | 
 60 | set config {
 61 |     db-file {}
 62 | 
 63 |     css-file {}
 64 | 
 65 |     credits {Powered by <a\
 66 |         href="https://github.com/dbohdan/tinyfts">tinyfts</a>}
 67 | 
 68 |     header {<!DOCTYPE html>
 69 | <html>
 70 | <head>
 71 |     <meta charset="utf-8">
 72 |     <meta name="viewport" content="width=device-width, initial-scale=1.0"/>
 73 |     <title>$documentTitle</title>
 74 |     <link rel="stylesheet" type="text/css" href="/css">
 75 | </head>
 76 | <body>
 77 | }
 78 | 
 79 |     footer {</body>
 80 | </html>
 81 | }
 82 | 
 83 |     title tinyfts
 84 | 
 85 |     subtitle {Full-text search.}
 86 | 
 87 |     table tinyfts
 88 | 
 89 |     rate-limit 60
 90 | 
 91 |     result-limit 100
 92 | 
 93 |     log {
 94 |         access
 95 |         bad-request
 96 |         error
 97 |         rate
 98 |     }
 99 | 
100 |     behind-reverse-proxy false
101 | 
102 |     snippet-size 20
103 | 
104 |     title-weight 1000.0
105 | 
106 |     query-min-length 2
107 | 
108 |     query-syntax web
109 | }
110 | 
111 | 
112 | proc accessor {name varName} {
113 |     namespace eval $name [format {
114 |         proc exists args {
115 |             return [dict exists $%1$s {*}$args]
116 |         }
117 | 
118 | 
119 |         proc for {varNames body} {
120 |             uplevel 1 [list dict for $varNames $%1$s $body]
121 |         }
122 | 
123 | 
124 |         proc get args {
125 |             return [dict get $%1$s {*}$args]
126 |         }
127 | 
128 | 
129 |         proc get-default {default args} {
130 |             if {[dict exists $%1$s {*}$args]} {
131 |                 return [dict get $%1$s {*}$args]
132 |             } else {
133 |                 return $default
134 |             }
135 |         }
136 | 
137 | 
138 |         proc set args {
139 |             dict set %1$s {*}$args
140 |         }
141 | 
142 | 
143 |         proc update args {
144 |             ::set updateScript [lindex $args end]
145 |             ::set args [lrange $args 0 end-1]
146 |             ::set updated [uplevel 1 [list {*}$updateScript \
147 |                                            [dict get $%1$s {*}$args]]]
148 |             dict set %1$s {*}$args $updated
149 |         }
150 |     } [list $varName]]
151 | }
152 | 
153 | 
154 | accessor config ::config
155 | accessor state ::state
156 | 
157 | 
158 | proc log {type {message {}}} {
159 |     if {$type ni [config::get log]} return
160 | 
161 |     set timestamp [clock format [clock seconds] \
162 |                                 -format %Y-%m-%dT%H:%M:%SZ \
163 |                                 -timezone :Etc/UTC \
164 |     ]
165 | 
166 |     puts \{[list \
167 |         timestamp $timestamp \
168 |         type $type \
169 |         caller [dict get [info frame -1] proc] \
170 |         message $message \
171 |         remote [real-remote] \
172 |         url [join [list [wapp-param SELF_URL] [wapp-param PATH_TAIL]] /] \
173 |         query-string [wapp-param QUERY_STRING] \
174 |         user-agent [wapp-param HTTP_USER_AGENT] \
175 |     ]\}
176 | }
177 | 
178 | 
179 | proc real-remote {} {
180 |     if {[config::get behind-reverse-proxy]} {
181 |         return [wapp-param .hdr:X-REAL-IP [wapp-param .hdr:X-FORWARDED-FOR {}]]
182 |     } else {
183 |         return [wapp-param REMOTE_ADDR]
184 |     }
185 | }
186 | 
187 | 
188 | proc gensym {} {
189 |     return [format sym-%u-%08x \
190 |                    [clock seconds] \
191 |                    [expr {int(4294967296*rand())}]]
192 | }
193 | 
194 | 
195 | ### Views
196 | 
197 | namespace eval view {}
198 | foreach ns {html json tcl} {
199 |     namespace eval view::$ns {
200 |         namespace path [namespace parent]
201 |     }
202 | }
203 | unset ns
204 | 
205 | 
206 | proc view::extract-marked {startMarker endMarker text} {
207 |     set re (.*?)${startMarker}(.*?)${endMarker}
208 | 
209 |     set all {}
210 | 
211 |     set start 0
212 |     while {[regexp -start $start -indices $re $text _ before marked]} {
213 |         lappend all [string range $text {*}$before] \
214 |                     [string range $text {*}$marked]
215 | 
216 |         set start [expr {[lindex $marked 1] + [string length $endMarker] + 1}]
217 |     }
218 | 
219 |     set remainder [string range $text $start end]
220 |     if {$remainder ne {}} {
221 |         lappend all $remainder {}
222 |     }
223 | 
224 |     return $all
225 | }
226 | 
227 | 
228 | proc view::html::header pageTitle {
229 |     set documentTitle [config::get title]
230 |     if {$pageTitle ne {}} {
231 |         set documentTitle "$pageTitle | $documentTitle"
232 |     }
233 | 
234 |     set map [list \$documentTitle [wappInt-enc-html $documentTitle]]
235 |     wapp-unsafe [string map $map [config::get header]]
236 | }
237 | 
238 | 
239 | proc view::html::footer {} {
240 |     wapp-unsafe [config::get footer]
241 | }
242 | 
243 | 
244 | proc view::html::credits {} {
245 |     set credits [config::get credits]
246 |     if {$credits ne {}} {
247 |         wapp-unsafe <footer><p>$credits</p></footer>
248 |     }
249 | }
250 | 
251 | 
252 | proc view::html::form query {
253 |     wapp-trim {
254 |         <form action="/search">
255 |             <input type="search" name="query" value="%html($query)">
256 |             <input type="submit" value="Search">
257 |         </form>
258 |     }
259 | }
260 | 
261 | 
262 | proc view::html::default {} {
263 |     header {}
264 |     wapp-trim {
265 |         <header>
266 |             <h1>%html([config::get title])</h1>
267 |             <p>%unsafe([config::get subtitle])</p>
268 |         </header>
269 |     }
270 |     wapp \n<main>\n
271 |     form {}
272 |     wapp \n</main>\n
273 |     credits
274 |     footer
275 | }
276 | 
277 | 
278 | proc view::html::error {code message} {
279 |     wapp-reply-code $code
280 | 
281 |     header {}
282 |     wapp-subst {<header><h1>Error</h1><p>%html($message)</p></header>\n}
283 |     credits
284 |     footer
285 | }
286 | 
287 | 
288 | proc view::html::results {query startMatch endMatch results counter} {
289 |     header $query
290 |     wapp <main>\n
291 |     form $query
292 |     wapp-subst {\n<ol start="%html($counter)">\n}
293 | 
294 |     foreach result $results {
295 |         set date [clock format [dict get $result timestamp] \
296 |                                 -format {%Y-%m-%d} \
297 |                                 -timezone :Etc/UTC]
298 |         wapp-trim {
299 |             <li>
300 |                 <dl>
301 |                     <dt>
302 |                         <a href="%html([dict get $result url])">
303 |                             %html([dict get $result title])
304 |                         </a>
305 |                         (%html($date))
306 |                     </dt>
307 |                     <dd>
308 |         }
309 |         wapp \n
310 | 
311 |         set marked [extract-marked $startMatch \
312 |                                    $endMatch \
313 |                                    [dict get $result snippet]]
314 |         foreach {before marked} $marked {
315 |             wapp-subst {%html($before)<strong>%html($marked)</strong>}
316 |         }
317 | 
318 |         wapp \n</dd>\n</dl>\n</li>\n
319 |     }
320 | 
321 |     wapp </ol>\n
322 |     if {[llength $results] == 0} {
323 |         wapp "No results.\n"
324 |     }
325 | 
326 |     if {[llength $results] == [config::get result-limit]} {
327 |         set next [dict get [lindex $results end] rank]
328 |         set nextCounter [expr {$counter + [llength $results]}]
329 |         wapp-subst {<p><a class="next-page" href="/search?query=%html($query)}
330 |         wapp-subst {&amp;start=%html($next)}
331 |         wapp-subst {&amp;counter=%html($nextCounter)">Next page</a></p>\n}
332 |     }
333 | 
334 |     wapp </main>\n
335 |     credits
336 |     footer
337 | }
338 | 
339 | proc view::json::error {code message} {
340 |     wapp-mimetype application/json
341 |     wapp-reply-code $code
342 | 
343 |     wapp-subst {{"error": "%string($message)"}}
344 | }
345 | 
346 | 
347 | proc view::json::results {query startMatch endMatch results} {
348 |     wapp-mimetype application/json
349 | 
350 |     wapp \{\n
351 | 
352 |     if {[llength $results] == [config::get result-limit]} {
353 |         set next [dict get [lindex $results end] rank]
354 |         wapp-subst {"next": "%unsafe([string-to-json $next])",\n}
355 |     }
356 | 
357 |     wapp {"results": [}
358 |     set first true
359 |     foreach result $results {
360 |         if {!$first} {
361 |             wapp ,
362 |         }
363 |         wapp \{\n
364 | 
365 |         foreach key {url title timestamp} {
366 |             set jsonValue [string-to-json [dict get $result $key]]
367 |             wapp-subst {    "%unsafe($key)": "%unsafe($jsonValue)",\n}
368 |         }
369 | 
370 |         set marked [extract-marked $startMatch \
371 |                                    $endMatch \
372 |                                    [dict get $result snippet]]
373 |         wapp {    "snippet": [}
374 |         set firstMarked true
375 |         foreach x $marked {
376 |             if {!$firstMarked} {
377 |                 wapp ,
378 |             }
379 |             wapp-subst {"%unsafe([string-to-json $x])"}
380 | 
381 |             set firstMarked false
382 |         }
383 |         wapp \]\n\}
384 | 
385 |         set first false
386 |     }
387 | 
388 |     wapp \]\}\n
389 | }
390 | 
391 | 
392 | proc view::json::string-to-json s {
393 |     return [string map {
394 |         \x00 \\u0000
395 |         \x01 \\u0001
396 |         \x02 \\u0002
397 |         \x03 \\u0003
398 |         \x04 \\u0004
399 |         \x05 \\u0005
400 |         \x06 \\u0006
401 |         \x07 \\u0007
402 |         \x08 \\b
403 |         \x09 \\t
404 |         \x0a \\n
405 |         \x0b \\u000b
406 |         \x0c \\f
407 |         \x0d \\r
408 |         \x0e \\u000e
409 |         \x0f \\u000f
410 |         \x10 \\u0010
411 |         \x11 \\u0011
412 |         \x12 \\u0012
413 |         \x13 \\u0013
414 |         \x14 \\u0014
415 |         \x15 \\u0015
416 |         \x16 \\u0016
417 |         \x17 \\u0017
418 |         \x18 \\u0018
419 |         \x19 \\u0019
420 |         \x1a \\u001a
421 |         \x1b \\u001b
422 |         \x1c \\u001c
423 |         \x1d \\u001d
424 |         \x1e \\u001e
425 |         \x1f \\u001f
426 |         \" \\\"
427 |         \\ \\\\
428 |         </  <\\/
429 |     } [encoding convertto utf-8 $s]]
430 | }
431 | 
432 | 
433 | proc view::tcl::error {code message} {
434 |     wapp-mimetype text/plain
435 |     wapp-reply-code $code
436 | 
437 |     wapp-trim [list error $message]
438 | }
439 | 
440 | 
441 | proc view::tcl::results {query startMatch endMatch results} {
442 |     wapp-mimetype text/plain
443 | 
444 |     if {[llength $results] == [config::get result-limit]} {
445 |         set next [dict get [lindex $results end] rank]
446 |         wapp-unsafe [list next $next]\n
447 |     }
448 | 
449 |     wapp "results \{"
450 | 
451 |     set first true
452 |     foreach result $results {
453 |         if {!$first} {
454 |             wapp { }
455 |         }
456 |         wapp \{\n
457 | 
458 |         foreach key {url title timestamp} {
459 |             wapp-unsafe "    $key [list [dict get $result $key]]\n"
460 |         }
461 | 
462 |         set marked [extract-marked $startMatch \
463 |                                    $endMatch \
464 |                                    [dict get $result snippet]]
465 |         wapp-unsafe "    [list snippet $marked]"
466 | 
467 |         wapp \n\}
468 | 
469 |         set first false
470 |     }
471 | 
472 |     wapp \}\n
473 | }
474 | 
475 | 
476 | ### Controllers
477 | 
478 | 
479 | namespace eval rate-limit {}
480 | 
481 | 
482 | proc rate-limit::allow? client {
483 |     set m [expr {[clock seconds] / 60}]
484 | 
485 |     if {[state::get-default -1 rate $client last] != $m} {
486 |         state::set rate $client last $m
487 |         state::set rate $client count 0
488 | 
489 |         return 1
490 |     }
491 | 
492 |     state::update rate $client count {apply {x {
493 |         incr x
494 |     }}}
495 | 
496 |     set diff [expr {
497 |         [state::get rate $client count] - [config::get rate-limit]
498 |     }]
499 |     if {$diff == 1} {
500 |         log rate {temporarily blocked remote address}
501 |     }
502 |     if {$diff > 0} {
503 |         return 0
504 |     }
505 | 
506 |     return 1
507 | }
508 | 
509 | 
510 | namespace eval translate-query {}
511 | 
512 | 
513 | proc translate-query::fts5 query {
514 |     return $query
515 | }
516 | 
517 | 
518 | proc translate-query::web query {
519 |     set not {}
520 |     set translated {}
521 | 
522 |     # A crude query tokenizer. Doesn't understand escaped double quotes.
523 |     set start 0
524 |     while {[regexp -indices \
525 |                    -start $start \
526 |                    {(?:^|\s)((?:[^\s]+|-?"[^"]*"))} \
527 |                    $query \
528 |                    _ tokenIdx]} {
529 |         set token [string range $query {*}$tokenIdx]
530 |         set start [lindex $tokenIdx 1]+1
531 | 
532 |         regexp {^(-)?"?(.*?)"?$} $token _ not token
533 |         regsub -all {(\"|\\)} $token {\\\1}
534 | 
535 |         if {$not ne {}} {
536 |             lappend translated NOT
537 |         }
538 | 
539 |         if {$token ni {AND NOT OR}} {
540 |             set token \"$token\"
541 |         }
542 | 
543 |         lappend translated $token
544 |     }
545 | 
546 |     return [join $translated { }]
547 | }
548 | 
549 | 
550 | proc wapp-default {} {
551 |     log access
552 | 
553 |     view::html::default
554 | }
555 | 
556 | 
557 | proc wapp-page-css {} {
558 |     wapp-mimetype text/css
559 |     wapp-unsafe [state::get css]
560 | }
561 | 
562 | 
563 | proc wapp-page-search {} {
564 |     wapp-allow-xorigin-params
565 | 
566 |     if {![rate-limit::allow? [real-remote]]} {
567 |         wapp-mimetype text/plain
568 |         wapp-reply-code 403
569 | 
570 |         wapp {Access denied.}
571 | 
572 |         return
573 |     }
574 | 
575 |     log access
576 | 
577 |     set startMatch [gensym]
578 |     set endMatch [gensym]
579 | 
580 |     set format [wapp-param format html]
581 |     set query [wapp-param query {}]
582 |     set start [wapp-param start -1000000]
583 |     set counter [wapp-param counter 1]
584 | 
585 |     set translated [translate-query::[config::get query-syntax] $query]
586 | 
587 |     foreach {badParamCheck msgTemplate} {
588 |         {$format ni {html json tcl}}
589 |         {Unknown format.}
590 | 
591 |         {[string length [string trim $query]] < [config::get query-min-length]}
592 |         {Query must be at least [config::get query-min-length] characters long.}
593 | 
594 |         {![string is integer -strict $counter] || $counter <= 0}
595 |         {"counter" must be a positive integer.}
596 |     } {
597 |         if $badParamCheck {
598 |             set msg [subst $msgTemplate]
599 |             view::html::error 400 $msg
600 |             log bad-request $msg
601 | 
602 |             return
603 |         }
604 |     }
605 | 
606 |     set results {}
607 |     try {
608 |         set selectStatement [format {
609 |             SELECT
610 |                 url,
611 |                 title,
612 |                 timestamp,
613 |                 snippet(
614 |                     "%1$s",
615 |                     3,
616 |                     :startMatch,
617 |                     :endMatch,
618 |                     '...',
619 |                     %3$u
620 |                 ) AS snippet,
621 |                 rank
622 |             FROM "%1$s"
623 |             WHERE
624 |                 "%1$s" MATCH :translated AND
625 |                 -- Column weight: url, title, timestamp, content.
626 |                 rank MATCH 'bm25(0.0, %3$f, 0.0, 1.0)' AND
627 |                 rank > CAST(:start AS REAL)
628 |             ORDER BY rank ASC
629 |             LIMIT %2$u
630 |         } [config::get table] \
631 |           [config::get result-limit] \
632 |           [config::get snippet-size] \
633 |           [config::get title-weight]]
634 | 
635 |         db eval $selectStatement values {
636 |             lappend results [array get values]
637 |         }
638 |     } on error {msg _} {
639 |         regsub ^fts5: $msg {Invalid query:} msg
640 | 
641 |         view::${format}::error 400 $msg
642 |         log error $msg
643 | 
644 |         return
645 |     }
646 | 
647 |     set viewArgs [list $query $startMatch $endMatch $results]
648 |     if {$format eq {html}} {
649 |         lappend viewArgs $counter
650 |     }
651 |     view::${format}::results {*}$viewArgs
652 | }
653 | 
654 | 
655 | ### CLI
656 | 
657 | 
658 | namespace eval cli {
659 |     namespace import ::config
660 | }
661 | 
662 | 
663 | proc cli::read-file args {
664 |     if {[llength $args] == 0} {
665 |         error "wrong # args: should be \"read-file ?options? path"
666 |     }
667 | 
668 |     set path [lindex $args end]
669 |     set options [lrange $args 0 end-1]
670 | 
671 |     set ch [open $path r]
672 |     fconfigure $ch {*}$options
673 |     set data [read $ch]
674 |     close $ch
675 | 
676 |     return $data
677 | }
678 | 
679 | 
680 | proc cli::usage me {
681 |     set padding {   }
682 |     puts stderr "Usage:\n$padding $me --db-file path\
683 |                  \[option ...\] \[wapp-arg ...\]"
684 |     puts stderr Options:
685 | 
686 |     config::for {k v} {
687 |         if {$k in [state::get flags hide]} continue
688 | 
689 |         if {$k in [state::get flags html-value]} {
690 |             set default <HTML>
691 |         } else {
692 |             set default [list {*}$v]
693 |             if {$default eq {} || [regexp {\s} $default]} {
694 |                 set default '$default'
695 |             }
696 |         }
697 | 
698 |         puts stderr "$padding --$k $default"
699 |     }
700 | }
701 | 
702 | 
703 | proc cli::start {argv0 argv} {
704 |     if {$argv in {-v -version --version}} {
705 |         puts stderr [state::get version]
706 |         exit 0
707 |     }
708 | 
709 |     if {$argv in {/? -? -h -help --help}} {
710 |         usage $argv0
711 |         exit 0
712 |     }
713 | 
714 |     try {
715 |         set wappArgs {}
716 |         foreach {flag v} $argv {
717 |             regsub ^--? $flag {} k
718 | 
719 |             if {[config::exists $k]} {
720 |                 set validator [state::get-default {} flags validator $k]
721 |                 apply [list value $validator] $v
722 | 
723 |                 config::set $k $v
724 |             } else {
725 |                 lappend wappArgs $flag $v
726 |             }
727 |         }
728 | 
729 |         if {[config::get db-file] eq {}} {
730 |             error {no --db-file given}
731 |         }
732 | 
733 |         sqlite3 db [config::get db-file] -create false -readonly true
734 |         cd [file dirname [info script]]
735 | 
736 |         if {[config::get css-file] eq {}} {
737 |             # Only read the default CSS file if no CSS is not already loaded
738 |             # (like it is in a bundle).
739 |             if {[state::get-default {} css] eq {}} {
740 |                 state::set css [read-file vendor/tacit/tacit.css]
741 |             }
742 |         } else {
743 |             state::set css [read-file [config::get css-file]]
744 |         }
745 | 
746 |         try {
747 |             package present wapp
748 |         } trap {TCL LOOKUP PACKAGE wapp} _ {
749 |             uplevel 1 {source vendor/wapp/wapp.tcl}
750 |         }
751 | 
752 |         wapp-start $wappArgs
753 |     } on error {msg opts} {
754 |         puts stderr "startup error: [dict get $opts -errorinfo]"
755 |         exit 1
756 |     }
757 | }
758 | 
759 | 
760 | # If this is the main script...
761 | if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
762 |     cli::start $argv0 $argv
763 | }
764 | 


--------------------------------------------------------------------------------
/tools/dir2jsonl:
--------------------------------------------------------------------------------
  1 | #! /usr/bin/env tclsh
  2 | # Print text files in a directory as tinyfts JSON Lines. This program uses
  3 | # file(1) to determine what is a text file. It attempts to extract text from
  4 | # HTML using tDOM.
  5 | # ==============================================================================
  6 | # Copyright (c) 2022, 2024 D. Bohdan
  7 | # and contributors listed in AUTHORS
  8 | #
  9 | # Permission is hereby granted, free of charge, to any person obtaining a copy
 10 | # of this software and associated documentation files (the "Software"), to deal
 11 | # in the Software without restriction, including without limitation the rights
 12 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 13 | # copies of the Software, and to permit persons to whom the Software is
 14 | # furnished to do so, subject to the following conditions:
 15 | #
 16 | # The above copyright notice and this permission notice shall be included in
 17 | # all copies or substantial portions of the Software.
 18 | #
 19 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 20 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 21 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
 22 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
 23 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 24 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
 25 | # THE SOFTWARE.
 26 | # ==============================================================================
 27 | 
 28 | package require Tcl 8.6 9
 29 | package require fileutil 1
 30 | package require json::write 1
 31 | package require tdom
 32 | 
 33 | set batchSize 1000
 34 | 
 35 | 
 36 | proc main {url-prefix dir args} {
 37 |     if {[llength $args] == 0} {
 38 |         set args *
 39 |     }
 40 | 
 41 |     set status 0
 42 |     json::write indented false
 43 | 
 44 |     cd $dir
 45 |     set files [lsort [fileutil::findByPattern . -glob -- {*}$args]]
 46 |     set len [llength $files]
 47 | 
 48 |     for {set i 0} {$i < $len} {incr i $::batchSize} {
 49 |         # Do not use "--files-from -", since it doesn't seem able to handle
 50 |         # filenames with newlines. Run file(1) with batches of files to avoid
 51 |         # exceeding the maximum argument length. A possible multiuser privacy
 52 |         # concern: the filenames are visible in the process list.
 53 |         set output [exec file \
 54 |             --mime-type \
 55 |             --print0 \
 56 |             --print0 \
 57 |             {*}[lrange $files $i [expr {$i + $::batchSize - 1}]] \
 58 |         ]
 59 |         set types [split [string trimright $output \0] \0]
 60 | 
 61 |         dict for {file type} $types {
 62 |             try {
 63 |                 print-file-as-json-lines ${url-prefix} $file $type
 64 |             } on error e {
 65 |                 puts stderr [list $file $e]
 66 |                 set status 1
 67 |             }
 68 |         }
 69 |     }
 70 | 
 71 |     exit $status
 72 | }
 73 | 
 74 | 
 75 | proc print-file-as-json-lines {url-prefix file type} {
 76 |     if {![string match text/* $type]} return
 77 | 
 78 |     set path [string range $file 2 end]
 79 |     set text [fileutil::cat $file]
 80 | 
 81 |     if {$type eq {text/html}} {
 82 |         try {
 83 |             # tDOM 0.9.2 can modify text passed to [dom parse -html]. This is
 84 |             # a violation of Tcl semantics. For example, "<HTML><HEA"
 85 |             # becomes "<html><hea" after a failed attempt to parse it.
 86 |             set copy [string range $text 0 end]
 87 |             set doc [dom parse -html $copy]
 88 |             set text [$doc asText]
 89 |             $doc delete
 90 |         } on error e {
 91 |             puts stderr [list $file {can't parse HTML; treating as text} $e]
 92 |         }
 93 |     }
 94 | 
 95 |     puts [json::write object \
 96 |         url [json::write string ${url-prefix}$path] \
 97 |         timestamp [file mtime $file] \
 98 |         title [json::write string $path] \
 99 |         content [json::write string $text] \
100 |     ]
101 | }
102 | 
103 | 
104 | proc usage {} {
105 |     puts stderr {usage: dir2jsonl url-prefix dir [glob-pattern ...]}
106 |     puts stderr "\nConvert text files in dir to tinyfts JSON Lines and print\
107 |         them to stdout. What is a text file is determined using file(1). The\
108 |         names of the files must match at least one glob pattern if any glob\
109 |         patterns are given."
110 | }
111 | 
112 | 
113 | # If this is the main script...
114 | if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
115 |     if {$argv in {{} -h -help --help -? /?}} {
116 |         usage
117 |         exit 0
118 |     }
119 |     main {*}$argv
120 | }
121 | 


--------------------------------------------------------------------------------
/tools/import:
--------------------------------------------------------------------------------
  1 | #! /usr/bin/env tclsh
  2 | # A tool to import data into a tinyfts database.
  3 | # ==============================================================================
  4 | # Copyright (c) 2019, 2021-2024 D. Bohdan
  5 | # and contributors listed in AUTHORS
  6 | #
  7 | # Permission is hereby granted, free of charge, to any person obtaining a copy
  8 | # of this software and associated documentation files (the "Software"), to deal
  9 | # in the Software without restriction, including without limitation the rights
 10 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 11 | # copies of the Software, and to permit persons to whom the Software is
 12 | # furnished to do so, subject to the following conditions:
 13 | #
 14 | # The above copyright notice and this permission notice shall be included in
 15 | # all copies or substantial portions of the Software.
 16 | #
 17 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 18 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 19 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
 20 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
 21 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 22 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
 23 | # THE SOFTWARE.
 24 | # ==============================================================================
 25 | 
 26 | package require Tcl 8.6 9
 27 | package require fileutil 1
 28 | package require http 2
 29 | package require json 1
 30 | package require sqlite3 3.9
 31 | 
 32 | 
 33 | namespace eval import {
 34 |     variable defaults {
 35 |         url-prefix https://wiki.tcl-lang.org/page/
 36 |         table tinyfts
 37 |     }
 38 | }
 39 | 
 40 | 
 41 | proc import::create-db {dest config} {
 42 |     dest eval [format {
 43 |         PRAGMA page_size = 32768;
 44 |         CREATE VIRTUAL TABLE IF NOT EXISTS "%s"
 45 |         USING fts5(
 46 |             url,
 47 |             title,
 48 |             timestamp,
 49 |             content,
 50 |             tokenize = 'porter unicode61'
 51 |         );
 52 |     } [dict get $config table]]
 53 | 
 54 |     dest function url [list apply {{prefix name} {
 55 |         set encoded [string range [http::formatQuery {} $name] 1 end]
 56 |         return -level 0 $prefix$encoded
 57 |     }} [dict get $config url-prefix]]
 58 | }
 59 | 
 60 | 
 61 | proc import::serialized {srcPath destPath config} {
 62 |     set ch [expr {
 63 |         $srcPath eq {-}
 64 |         ? {stdin}
 65 |         : [open $srcPath]
 66 |     }]
 67 | 
 68 |     try {
 69 |         set jsonLinesMode [expr {
 70 |             [dict get $config command] eq {jsonl}
 71 |         }]
 72 | 
 73 |         sqlite3 dest $destPath
 74 | 
 75 |         create-db dest $config
 76 | 
 77 |         set insertStatement [format {
 78 |             INSERT INTO "%s"
 79 |             VALUES (
 80 |                 :values(url),
 81 |                 :values(title),
 82 |                 :values(timestamp),
 83 |                 :values(content)
 84 |             )
 85 |         } [dict get $config table]]
 86 | 
 87 |         dest transaction {
 88 |             while {[gets $ch line] >= 0} {
 89 |                 if {[string is space $line]} continue
 90 | 
 91 |                 set dict [expr {
 92 |                     $jsonLinesMode
 93 |                     ? [json::json2dict $line]
 94 |                     : $line
 95 |                 }]
 96 |                 array set values $dict
 97 | 
 98 |                 dest eval $insertStatement
 99 |             }
100 |         }
101 |     } finally {
102 |         close $ch
103 |     }
104 | }
105 | 
106 | 
107 | 
108 | proc import::wiki {srcPath destPath config} {
109 |     sqlite3 src $srcPath -create false -readonly true
110 |     sqlite3 dest $destPath
111 | 
112 |     create-db dest $config
113 | 
114 |     set query [format {
115 |         SELECT pages.name, pages.date, pages_content.content
116 |         FROM pages
117 |         JOIN pages_content
118 |         ON pages.%1$s = pages_content.%1$s
119 |         WHERE pages_content.content <> ''
120 |     } [expr {
121 |         [dict get $config command] eq {wikit} ? {id} : {name}
122 |     }]]
123 | 
124 |     set insertStatement [format {
125 |         INSERT INTO "%s"
126 |         VALUES (
127 |             url(:values(name)),
128 |             :values(name),
129 |             :values(date),
130 |             :values(content)
131 |         )
132 |     } [dict get $config table]]
133 | 
134 |     dest transaction {
135 |         src eval $query values {
136 |             dest eval $insertStatement
137 |         }
138 |     }
139 | }
140 | 
141 | 
142 | namespace eval import::cli {
143 |     namespace path [namespace parent]
144 | }
145 | 
146 | 
147 | proc import::parse-options {command options} {
148 |     variable defaults
149 |     set config $defaults
150 |     dict set config command $command
151 | 
152 |     dict for {flag v} $options {
153 |         regsub ^--? $flag {} k
154 |         if {$k ni $config} {
155 |             error [list unknown option: $flag]
156 |         }
157 | 
158 |         dict set config $k $v
159 |     }
160 | 
161 |     return $config
162 | }
163 | 
164 | 
165 | proc import::jsonl {src dest args} {
166 |     serialized $src $dest [parse-options jsonl $args]
167 | }
168 | 
169 | 
170 | proc import::nikit {src dest args} {
171 |     wiki $src $dest [parse-options nikit $args]
172 | }
173 | 
174 | 
175 | proc import::tcl {src dest args} {
176 |     serialized $src $dest [parse-options tcl $args]
177 | }
178 | 
179 | 
180 | proc import::wikit {src dest args} {
181 |     wiki $src $dest [parse-options wikit $args]
182 | }
183 | 
184 | 
185 | namespace eval import {
186 |     namespace export jsonl nikit tcl wikit
187 |     namespace ensemble create
188 | }
189 | 
190 | 
191 | proc import::usage {} {
192 |     variable defaults
193 | 
194 |     puts stderr "usage: import (jsonl|tcl|nikit|wikit) src dest\
195 |         \[--table [dict get $defaults table]\]\
196 |         \[--url-prefix [dict get $defaults url-prefix]\]"
197 |     puts stderr "\nImport src (a file path or \"-\" for stdin) of one of\
198 |         the supported formats into the tinyfts database dest."
199 | }
200 | 
201 | # If this is the main script...
202 | if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
203 |     if {$argv in {{} -h -help --help -? /?}} {
204 |         import::usage
205 |         exit 0
206 |     }
207 |     import {*}$argv
208 | }
209 | 


--------------------------------------------------------------------------------
/tools/titlecat:
--------------------------------------------------------------------------------
 1 | #! /usr/bin/env tclsh
 2 | # Concatenate files with a comment containing the filename before each.
 3 | # ==============================================================================
 4 | # Copyright (c) 2019, 2021-2022, 2024 D. Bohdan
 5 | # and contributors listed in AUTHORS
 6 | #
 7 | # Permission is hereby granted, free of charge, to any person obtaining a copy
 8 | # of this software and associated documentation files (the "Software"), to deal
 9 | # in the Software without restriction, including without limitation the rights
10 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
11 | # copies of the Software, and to permit persons to whom the Software is
12 | # furnished to do so, subject to the following conditions:
13 | #
14 | # The above copyright notice and this permission notice shall be included in
15 | # all copies or substantial portions of the Software.
16 | #
17 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
18 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
19 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
20 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
21 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
22 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
23 | # THE SOFTWARE.
24 | # ==============================================================================
25 | 
26 | package require Tcl 8.6 9
27 | package require fileutil 1
28 | 
29 | 
30 | proc padding {formatString value target char} {
31 |     set len [string length [format $formatString $value {} {}]]
32 | 
33 |     set paddingLeft [string repeat = [expr {
34 |         ($target - $len) / 2
35 |     }]]
36 |     set paddingRight [string repeat = [expr {
37 |         $target - $len - [string length $paddingLeft]
38 |     }]]
39 | 
40 |     return [list $paddingLeft $paddingRight]
41 | }
42 | 
43 | 
44 | proc titlecat args {
45 |     set format {#%2$s file: %1$s%3$s}
46 |     fconfigure stdout -translation binary
47 | 
48 |     foreach file $args {
49 |         lassign [padding $format [list $file] 80 =] paddingLeft paddingRight
50 |         foreach varName {paddingLeft paddingRight} {
51 |             regsub ^. [set $varName] { } $varName
52 |         }
53 |         puts [format $format [list $file] $paddingLeft $paddingRight]
54 | 
55 |         puts -nonewline [fileutil::cat -translation binary -- $file]
56 |     }
57 | }
58 | 
59 | 
60 | # If this is the main script...
61 | if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
62 |     titlecat {*}$argv
63 | }
64 | 


--------------------------------------------------------------------------------
/tools/wrap:
--------------------------------------------------------------------------------
 1 | #! /usr/bin/env tclsh
 2 | # Store any data in Tcl source code.
 3 | # ==============================================================================
 4 | # Copyright (c) 2019, 2021-2022, 2024 D. Bohdan
 5 | # and contributors listed in AUTHORS
 6 | #
 7 | # Permission is hereby granted, free of charge, to any person obtaining a copy
 8 | # of this software and associated documentation files (the "Software"), to deal
 9 | # in the Software without restriction, including without limitation the rights
10 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
11 | # copies of the Software, and to permit persons to whom the Software is
12 | # furnished to do so, subject to the following conditions:
13 | #
14 | # The above copyright notice and this permission notice shall be included in
15 | # all copies or substantial portions of the Software.
16 | #
17 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
18 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
19 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
20 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
21 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
22 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
23 | # THE SOFTWARE.
24 | # ==============================================================================
25 | 
26 | package require Tcl 8.6 9
27 | package require fileutil 1
28 | 
29 | namespace eval wrap {}
30 | 
31 | 
32 | proc wrap::escape-char c {
33 |     if {$c in {\n \t}} {
34 |         return $c
35 |     }
36 | 
37 |     if {$c in {\{ \} [ ] $ \\}} {
38 |         return \\$c
39 |     }
40 | 
41 |     if {[set code [scan $c %c]] < 32} {
42 |         return \\u[format %04x $code]
43 |     }
44 | 
45 |     return $c
46 | }
47 | 
48 | 
49 | proc wrap::escape data {
50 |     set charCodes [lmap c [split $data {}] {
51 |         escape-char $c
52 |     }]
53 | 
54 |     return "subst -nocommands -novariables\
55 |             \{[encoding convertto utf-8 [join $charCodes {}]]\}"
56 | }
57 | 
58 | 
59 | proc wrap::main {src {namespace ::} {prefix {variable data}}} {
60 |     set data [expr {
61 |         $src eq {-}
62 |         ? [fconfigure stdin -translation binary read stdin]
63 |         : [fileutil::cat -translation binary -- $src]
64 |     }]
65 | 
66 |     fconfigure stdout -translation binary
67 |     puts "namespace eval [list $namespace] \{"
68 |     puts "$prefix \[[escape $data]\]"
69 |     puts \}
70 | }
71 | 
72 | 
73 | proc wrap::usage {} {
74 |     puts stderr {usage: wrap src [namespace] [prefix]}
75 |     puts stderr "\nWrap data for inclusion in Tcl source code. Reads the file\
76 |         src and prints code that runs in the given namespace (:: by default)\
77 |         the prefix code fragment with the contents of src as the last\
78 |         argument."
79 | }
80 | 
81 | 
82 | # If this is the main script...
83 | if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
84 |     if {$argv in {{} -h -help --help -? /?}} {
85 |         wrap::usage
86 |         exit 0
87 |     }
88 |     wrap::main {*}$argv
89 | }
90 | 


--------------------------------------------------------------------------------
/vendor/tacit/tacit.css:
--------------------------------------------------------------------------------
  1 | /*
  2 | The MIT License (MIT)
  3 | 
  4 | Copyright (c) 2015-2020 Yegor Bugayenko
  5 | 
  6 | Permission is hereby granted, free of charge, to any person obtaining a copy
  7 | of this software and associated documentation files (the "Software"), to deal
  8 | in the Software without restriction, including without limitation the rights
  9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 10 | copies of the Software, and to permit persons to whom the Software is
 11 | furnished to do so, subject to the following conditions:
 12 | //
 13 | The above copyright notice and this permission notice shall be included
 14 | in all copies or substantial portions of the Software.
 15 | //
 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 18 | FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. IN NO EVENT SHALL THE
 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 22 | SOFTWARE.
 23 | */
 24 | 
 25 | input,
 26 | textarea,
 27 | select,
 28 | button, option, html,
 29 | body {
 30 |   font-family: system-ui, "Helvetica Neue", Helvetica, Arial, sans-serif;
 31 |   font-size: 18px;
 32 |   font-stretch: normal;
 33 |   font-style: normal;
 34 |   font-weight: 400;
 35 |   line-height: 29.7px;
 36 | }
 37 | 
 38 | th {
 39 |   font-weight: 600;
 40 | }
 41 | 
 42 | td,
 43 | th {
 44 |   border-bottom: 1.08px solid #595959;
 45 |   padding: 14.85px 18px;
 46 |   text-align: left;
 47 |   vertical-align: top;
 48 | }
 49 | 
 50 | thead th {
 51 |   border-bottom-width: 2.16px;
 52 |   padding-bottom: 6.3px;
 53 | }
 54 | 
 55 | table {
 56 |   display: table;
 57 |   width: 100%;
 58 | }
 59 | 
 60 | @media all and (max-width: 1024px) {
 61 |   table {
 62 |     display: none;
 63 |   }
 64 | }
 65 | 
 66 | @media all and (max-width: 1024px) {
 67 |   table thead {
 68 |     display: none;
 69 |   }
 70 | }
 71 | 
 72 | table tr {
 73 |   border-bottom-width: 2.16px;
 74 | }
 75 | 
 76 | table tr th {
 77 |   border-bottom-width: 2.16px;
 78 | }
 79 | 
 80 | table tr td,
 81 | table tr th {
 82 |   overflow: hidden;
 83 |   padding: 5.4px 3.6px;
 84 | }
 85 | 
 86 | @media all and (max-width: 1024px) {
 87 |   table tr td,
 88 |   table tr th {
 89 |     border: 0;
 90 |     display: inline-block;
 91 |   }
 92 | }
 93 | 
 94 | @media all and (max-width: 1024px) {
 95 |   table tr {
 96 |     display: inline-block;
 97 |     margin: 10.8px 0;
 98 |   }
 99 | }
100 | 
101 | @media all and (max-width: 1024px) {
102 |   table {
103 |     display: inline-block;
104 |   }
105 | }
106 | 
107 | fieldset {
108 |   display: flex;
109 |   flex-direction: row;
110 |   flex-wrap: wrap;
111 | }
112 | 
113 | fieldset label,
114 | fieldset legend {
115 |   display: block;
116 | }
117 | 
118 | fieldset legend {
119 |   margin: 18px 0;
120 | }
121 | 
122 | input,
123 | textarea,
124 | select,
125 | button {
126 |   border-radius: 3.6px;
127 |   display: inline-block;
128 |   padding: 9.9px;
129 | }
130 | 
131 | input + label,
132 | input + input[type="checkbox"],
133 | input + input[type="radio"],
134 | textarea + label,
135 | textarea + input[type="checkbox"],
136 | textarea + input[type="radio"],
137 | select + label,
138 | select + input[type="checkbox"],
139 | select + input[type="radio"],
140 | button + label,
141 | button + input[type="checkbox"],
142 | button + input[type="radio"] {
143 |   page-break-before: always;
144 | }
145 | 
146 | input,
147 | select,
148 | label {
149 |   margin-right: 3.6px;
150 | }
151 | 
152 | textarea {
153 |   min-height: 90px;
154 |   min-width: 360px;
155 | }
156 | 
157 | label {
158 |   display: inline-block;
159 |   margin-bottom: 12.6px;
160 | }
161 | 
162 | label + * {
163 |   page-break-before: always;
164 | }
165 | 
166 | label > input {
167 |   margin-bottom: 0;
168 | }
169 | 
170 | input[type="submit"],
171 | input[type="reset"],
172 | button {
173 |   background: #f2f2f2;
174 |   color: #191919;
175 |   cursor: pointer;
176 |   display: inline;
177 |   margin-bottom: 18px;
178 |   margin-right: 7.2px;
179 |   padding: 6.525px 23.4px;
180 |   text-align: center;
181 | }
182 | 
183 | input[type="submit"]:hover,
184 | input[type="reset"]:hover,
185 | button:hover {
186 |   background: #d9d9d9;
187 |   color: #000;
188 | }
189 | 
190 | input[type="submit"][disabled],
191 | input[type="reset"][disabled],
192 | button[disabled] {
193 |   background: #e6e5e5;
194 |   color: #403f3f;
195 |   cursor: not-allowed;
196 | }
197 | 
198 | input[type="submit"],
199 | button[type="submit"] {
200 |   background: #275a90;
201 |   color: #fff;
202 | }
203 | 
204 | input[type="submit"]:hover,
205 | button[type="submit"]:hover {
206 |   background: #173454;
207 |   color: #bfbfbf;
208 | }
209 | 
210 | input,
211 | select,
212 | textarea {
213 |   margin-bottom: 18px;
214 | }
215 | 
216 | input[type="text"],
217 | input[type="password"],
218 | input[type="email"],
219 | input[type="url"],
220 | input[type="phone"],
221 | input[type="tel"],
222 | input[type="number"],
223 | input[type="datetime"],
224 | input[type="date"],
225 | input[type="month"],
226 | input[type="week"],
227 | input[type="color"],
228 | input[type="time"],
229 | input[type="search"],
230 | input[type="range"],
231 | input[type="file"],
232 | input[type="datetime-local"],
233 | select,
234 | textarea {
235 |   border: 1px solid #595959;
236 |   padding: 5.4px 6.3px;
237 | }
238 | 
239 | input[type="checkbox"],
240 | input[type="radio"] {
241 |   flex-grow: 0;
242 |   height: 29.7px;
243 |   margin-left: 0;
244 |   margin-right: 9px;
245 |   vertical-align: middle;
246 | }
247 | 
248 | input[type="checkbox"] + label,
249 | input[type="radio"] + label {
250 |   page-break-before: avoid;
251 | }
252 | 
253 | select[multiple] {
254 |   min-width: 270px;
255 | }
256 | 
257 | pre,
258 | code,
259 | kbd,
260 | samp,
261 | var,
262 | output {
263 |   font-family: Menlo, Monaco, Consolas, "Courier New", monospace;
264 |   font-size: 14.4px;
265 | }
266 | 
267 | pre {
268 |   border-left: 1.8px solid #59c072;
269 |   line-height: 25.2px;
270 |   overflow: auto;
271 |   padding-left: 18px;
272 | }
273 | 
274 | pre code {
275 |   background: none;
276 |   border: 0;
277 |   line-height: 29.7px;
278 |   padding: 0;
279 | }
280 | 
281 | code,
282 | kbd {
283 |   background: #daf1e0;
284 |   border-radius: 3.6px;
285 |   color: #2a6f3b;
286 |   display: inline-block;
287 |   line-height: 18px;
288 |   padding: 3.6px 6.3px 2.7px;
289 | }
290 | 
291 | kbd {
292 |   background: #2a6f3b;
293 |   color: #fff;
294 | }
295 | 
296 | mark {
297 |   background: #ffc;
298 |   padding: 0 3.6px;
299 | }
300 | 
301 | h1,
302 | h2,
303 | h3,
304 | h4,
305 | h5,
306 | h6 {
307 |   color: #000;
308 |   margin-bottom: 18px;
309 | }
310 | 
311 | h1 {
312 |   font-size: 36px;
313 |   font-weight: 500;
314 |   line-height: 43.2px;
315 |   margin-top: 72px;
316 | }
317 | 
318 | h2 {
319 |   font-size: 25.2px;
320 |   font-weight: 400;
321 |   line-height: 34.2px;
322 |   margin-top: 54px;
323 | }
324 | 
325 | h3 {
326 |   font-size: 21.6px;
327 |   line-height: 27px;
328 |   margin-top: 36px;
329 | }
330 | 
331 | h4 {
332 |   font-size: 18px;
333 |   line-height: 23.4px;
334 |   margin-top: 18px;
335 | }
336 | 
337 | h5 {
338 |   font-size: 14.4px;
339 |   font-weight: bold;
340 |   line-height: 21.6px;
341 |   text-transform: uppercase;
342 | }
343 | 
344 | h6 {
345 |   color: #595959;
346 |   font-size: 14.4px;
347 |   font-weight: bold;
348 |   line-height: 18px;
349 |   text-transform: uppercase;
350 | }
351 | 
352 | a {
353 |   color: #275a90;
354 |   text-decoration: none;
355 | }
356 | 
357 | a:hover {
358 |   text-decoration: underline;
359 | }
360 | 
361 | hr {
362 |   border-bottom: 1px solid #595959;
363 | }
364 | 
365 | figcaption,
366 | small {
367 |   font-size: 15.3px;
368 | }
369 | 
370 | figcaption {
371 |   color: #595959;
372 | }
373 | 
374 | var,
375 | em,
376 | i {
377 |   font-style: italic;
378 | }
379 | 
380 | dt,
381 | strong,
382 | b {
383 |   font-weight: 600;
384 | }
385 | 
386 | del,
387 | s {
388 |   text-decoration: line-through;
389 | }
390 | 
391 | ins,
392 | u {
393 |   text-decoration: underline;
394 | }
395 | 
396 | sub,
397 | sup {
398 |   font-size: 75%;
399 |   line-height: 0;
400 |   position: relative;
401 |   vertical-align: baseline;
402 | }
403 | 
404 | sup {
405 |   top: -.5em;
406 | }
407 | 
408 | sub {
409 |   bottom: -.25em;
410 | }
411 | 
412 | * {
413 |   border: 0;
414 |   border-collapse: separate;
415 |   border-spacing: 0;
416 |   box-sizing: border-box;
417 |   margin: 0;
418 |   max-width: 100%;
419 |   padding: 0;
420 |   vertical-align: baseline;
421 | }
422 | 
423 | html,
424 | body {
425 |   width: 100%;
426 | }
427 | 
428 | html {
429 |   height: 100%;
430 | }
431 | 
432 | body {
433 |   background: #fff;
434 |   color: #1a1919;
435 |   padding: 36px;
436 | }
437 | 
438 | p,
439 | ul,
440 | ol,
441 | dl,
442 | blockquote,
443 | hr,
444 | pre,
445 | table,
446 | form,
447 | fieldset,
448 | figure,
449 | address {
450 |   margin-bottom: 29.7px;
451 | }
452 | 
453 | body {
454 |   margin-left: auto;
455 |   margin-right: auto;
456 |   width: 900px;
457 | }
458 | 
459 | aside {
460 |   float: right;
461 |   width: 285px;
462 | }
463 | 
464 | article,
465 | header,
466 | footer {
467 |   padding: 43.2px;
468 | }
469 | 
470 | article {
471 |   background: #fff;
472 |   border: 1px solid #d9d9d9;
473 | }
474 | 
475 | nav {
476 |   text-align: center;
477 | }
478 | 
479 | nav ul {
480 |   list-style: none;
481 |   margin-left: 0;
482 |   text-align: center;
483 | }
484 | 
485 | nav ul li {
486 |   display: inline-block;
487 |   margin-left: 9px;
488 |   margin-right: 9px;
489 |   vertical-align: middle;
490 | }
491 | 
492 | nav ul li:first-child {
493 |   margin-left: 0;
494 | }
495 | 
496 | nav ul li:last-child {
497 |   margin-right: 0;
498 | }
499 | 
500 | ol,
501 | ul {
502 |   margin-left: 31.5px;
503 | }
504 | 
505 | li dl,
506 | li ol,
507 | li ul {
508 |   margin-bottom: 0;
509 | }
510 | 
511 | dl {
512 |   display: inline-block;
513 | }
514 | 
515 | dt {
516 |   padding: 0 18px;
517 | }
518 | 
519 | dd {
520 |   padding: 0 18px 4.5px;
521 | }
522 | 
523 | dd:last-of-type {
524 |   border-bottom: 1.08px solid #595959;
525 | }
526 | 
527 | dd + dt {
528 |   border-top: 1.08px solid #595959;
529 |   padding-top: 9px;
530 | }
531 | 
532 | blockquote {
533 |   border-left: 2.16px solid #595959;
534 |   padding: 4.5px 18px 4.5px 15.84px;
535 | }
536 | 
537 | blockquote footer {
538 |   color: #595959;
539 |   font-size: 13.5px;
540 |   margin: 0;
541 | }
542 | 
543 | blockquote p {
544 |   margin-bottom: 0;
545 | }
546 | 
547 | img {
548 |   height: auto;
549 |   margin: 0 auto;
550 | }
551 | 
552 | figure img {
553 |   display: block;
554 | }
555 | 
556 | @media (max-width: 767px) {
557 |   body {
558 |     padding: 18px 0;
559 |   }
560 |   article {
561 |     border: 0;
562 |     padding: 18px;
563 |   }
564 |   header,
565 |   footer {
566 |     padding: 18px;
567 |   }
568 |   textarea,
569 |   input,
570 |   select {
571 |     min-width: 0;
572 |   }
573 |   fieldset {
574 |     min-width: 0;
575 |   }
576 |   fieldset * {
577 |     flex-grow: 1;
578 |     page-break-before: auto;
579 |   }
580 |   section {
581 |     width: auto;
582 |   }
583 |   x:-moz-any-link {
584 |     display: table-cell;
585 |   }
586 | }
587 | 
588 | header > h1 { text-align: center; }
589 | main { padding: 0 10px; }
590 | li > dl { vertical-align: top; }
591 | a.next-page { font-weight: bold; }
592 | footer { padding-bottom: 0; }
593 | footer > p { text-align: center; }
594 | 


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


--------------------------------------------------------------------------------