├── .github └── workflows │ └── ci.yml ├── .gitignore ├── LICENSE ├── README.md ├── arguments.tcl ├── entities.tcl ├── example.tcl ├── html.tcl ├── http.tcl ├── json.tcl ├── mime.tcl ├── rejim.tcl ├── static.jpg ├── storage.tcl ├── template.tcl ├── testing.tcl ├── tests.tcl └── update-readme.tcl /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: [push, pull_request] 3 | 4 | jobs: 5 | test: 6 | runs-on: ubuntu-latest 7 | strategy: 8 | matrix: 9 | redis-version: [5, 6, 7] 10 | 11 | steps: 12 | - uses: actions/checkout@v4 13 | 14 | - name: Install Tcl 15 | run: sudo apt-get install -y tcl 16 | 17 | - name: Start Redis server 18 | uses: supercharge/redis-github-action@1.8.0 19 | with: 20 | redis-version: ${{ matrix.redis-version }} 21 | 22 | - name: Download Jim Tcl versions 23 | run: | 24 | wget -O jimsh-0.76 https://github.com/dbohdan/jimsh-static/releases/download/v1/jimsh-0.76-51f65c6d38-i386 25 | wget -O jimsh-0.77 https://github.com/dbohdan/jimsh-static/releases/download/v1/jimsh-0.77-a9bf5975fd-i386 26 | wget -O jimsh-0.78 https://github.com/dbohdan/jimsh-static/releases/download/v1/jimsh-0.78-022f902632-i386 27 | wget -O jimsh-0.79 https://github.com/dbohdan/jimsh-static/releases/download/v2/jimsh-0.79-0aa0fb4e3a-amd64 28 | wget -O jimsh-0.80 https://github.com/dbohdan/jimsh-static/releases/download/v4-0.80-e4416cf86f/jimsh-0.80-e4416cf86f-amd64 29 | wget -O jimsh-0.82 https://github.com/dbohdan/jimsh-static/releases/download/v5-0.82-fcbb4499a6/jimsh-0.82-fcbb4499a6-amd64 30 | 31 | chmod +x jimsh* 32 | 33 | - name: 'Set `PATH`' 34 | run: echo "PATH=$PATH:$PWD/jimtcl" >> $GITHUB_ENV 35 | 36 | - name: Run tests 37 | run: | 38 | ./jimsh-0.76 tests.tcl 39 | ./jimsh-0.77 tests.tcl 40 | ./jimsh-0.78 tests.tcl 41 | ./jimsh-0.79 tests.tcl 42 | ./jimsh-0.80 tests.tcl 43 | ./jimsh-0.82 tests.tcl 44 | tclsh tests.tcl 45 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /vagrant/.vagrant/* 2 | /storage.sqlite3 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2024 D. Bohdan 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # jimhttp 2 | 3 | A collection of standalone libraries and a web microframework prototype for [Jim Tcl](http://jim.tcl-lang.org/). 4 | Most of the libraries also work in Tcl 8.5–9. 5 | The libraries implement command-line and proc argument parsing, an HTML DSL, parsing and generating JSON, templates, and persistent storage 6 | powered by SQLite 3. 7 | The web microframework provides a rough implementation of the HTTP/1.1 protocol and a routing DSL. 8 | 9 | ## Components 10 | 11 | The components listed below work in Tcl 8.5, 8.6, 9.0b2rc2, and Jim Tcl 0.76 and later unless indicated otherwise. 12 | Each component is versioned separately. 13 | Component version numbers follow [semantic versioning](http://semver.org/spec/v2.0.0.html). 14 | A major version number of zero indicates an unstable API. 15 | 16 | | Filename | Function | Version | 17 | |----------|----------|---------| 18 | | [arguments.tcl](arguments.tcl) | Command line argument parsing. | 1.0.0 | 19 | | [example.tcl](example.tcl) 1 | A sample web server that demonstrates the use of the other components. | — | 20 | | [entities.tcl](entities.tcl) | A dictionary mapping characters to HTML entities. | 1.0.0 | 21 | | [html.tcl](html.tcl) | A DSL for generating HTML. Requires entities.tcl. | 0.2.1 | 22 | | [http.tcl](http.tcl) 1 | The titular web microframework. Requires mime.tcl. | 0.15.2 | 23 | | [json.tcl](json.tcl) | JSON generation with schema support. 3 JSON parsing. 4 | 3.0.0 | 24 | | [mime.tcl](mime.tcl) | Rudimentary MIME type detection based on the file extension. | 1.2.0 | 25 | | [rejim.tcl](rejim.tcl) 2 | A basic RESP2 Redis/Valkey/KeyDB/etc. client. | 0.2.0 | 26 | | [storage.tcl](storage.tcl) 1 | SQLite persistence of static variables. | 0.2.0 | 27 | | [template.tcl](template.tcl) | [tmpl_parser](https://wiki.tcl-lang.org/20363) templating. | 1.0.0 | 28 | | [testing.tcl](testing.tcl) | A test framework with support for tcltest-style constraints. | 0.5.0 | 29 | | [tests.tcl](tests.tcl) | Tests for the other components. 5 | — | 30 | 31 | 1\. Jim Tcl-only. 32 | 33 | 2\. Does not support Tcl 8.5. 34 | 35 | 3\. Schemas define data shapes. See the example below. 36 | 37 | 4\. **Warning:** parsing is fairly slow in general and extremely slow in UTF-8 builds of Jim Tcl. 38 | ([Obsolete benchmark](https://wiki.tcl-lang.org/48500).) 39 | This can matter to you if you need to decode more than a few dozen kilobytes of JSON at a time. 40 | Since version 0.79, Jim Tcl can be built with a fast binary extension for parsing and encoding JSON. 41 | The [jq module](https://wiki.tcl-lang.org/11630) is an option for faster JSON parsing in earlier versions. 42 | It requires an external binary. 43 | 44 | 5\. Only compatible components are tested in Tcl 8 and 9. 45 | 46 | ## Use examples 47 | 48 | ### http.tcl 49 | 50 | ```Tcl 51 | source http.tcl 52 | 53 | ::http::add-handler GET /hello/:name/:town { 54 | ::http::respond [::http::make-response \ 55 | "Hello, $routeVars(name) from $routeVars(town)!"] 56 | } 57 | 58 | ::http::start-server 127.0.0.1 8080 59 | ``` 60 | 61 | ### http.tcl and storage.tcl 62 | 63 | ```Tcl 64 | source http.tcl 65 | source storage.tcl 66 | 67 | ::http::add-handler GET /counter-persistent {{counter 0}} { 68 | ::storage::restore-statics 69 | 70 | incr counter 71 | 72 | ::storage::persist-statics 73 | ::http::respond [::http::make-response $counter] 74 | } 75 | 76 | ::storage::init 77 | ::http::start-server 127.0.0.1 8080 78 | ``` 79 | 80 | ### json.tcl 81 | 82 | ```Tcl 83 | # This produces the output 84 | # {"a": "123", "b": 123, "c": [123, 456], "d": "true", "e": true} 85 | 86 | source json.tcl 87 | 88 | puts [::json::stringify { 89 | a 123 90 | b 123 91 | c {123 456} 92 | d true 93 | e true 94 | } 0 { 95 | a string 96 | c {*element* number} 97 | d string 98 | }] 99 | ``` 100 | 101 | ## Requirements 102 | 103 | Compile Jim Tcl 0.76 or later from its Git repository. 104 | Stable releases prior to that (0.75 and earlier) will not work. 105 | You will need an SQLite 3 development package 106 | (`libsqlite3-dev` on Debian and Ubuntu, `libsqlite3x-devel` on Fedora, `sqlite3-devel` on openSUSE Tumbleweed) 107 | to do this 108 | and optionally AsciiDoc 109 | (`asciidoc` on Debian and Ubuntu, Fedora, and openSUSE) 110 | to generate the documentation (don't use the option `--disable-docs` if you want it). 111 | 112 | ```sh 113 | git clone https://github.com/msteveb/jimtcl.git 114 | 115 | cd jimtcl 116 | ./configure --with-ext="oo tree binary sqlite3" --enable-utf8 --ipv6 --disable-docs 117 | make 118 | sudo make install 119 | ``` 120 | 121 | Once you have installed Jim Tcl, you can clone this repository and try out the example by running 122 | 123 | ```sh 124 | git clone https://github.com/dbohdan/jimhttp.git 125 | cd jimhttp 126 | jimsh example.tcl 127 | ``` 128 | 129 | and then pointing your web browser to . 130 | 131 | ## License 132 | 133 | MIT. 134 | 135 | [entities.tcl](entities.tcl) 136 | is copyright 1998–2000 Ajuba Solutions and copyright 2006 Michael Schlenker. 137 | It is distributed under the Tcl license. 138 | See the top comment in the file. 139 | 140 | `static.jpg` photo by [Steven Lewis](http://notsteve.com/). 141 | License: [CC0](https://creativecommons.org/publicdomain/zero/1.0/). 142 | -------------------------------------------------------------------------------- /arguments.tcl: -------------------------------------------------------------------------------- 1 | # Process command-line arguments. 2 | # Copyright (c) 2014-2016 D. Bohdan. 3 | # License: MIT. 4 | 5 | namespace eval ::arguments { 6 | variable version 1.0.0 7 | } 8 | 9 | # Return a dict mapping varNames to command-line-argument values. 10 | # mandatoryArguments: a list {-arg varName ...} 11 | # optionalArguments: a dict {-optArg varName defaultValue ...} 12 | proc ::arguments::parse {mandatoryArguments optionalArguments argv} { 13 | set result {} 14 | set error [catch { 15 | foreach {argument key defaultValue} $optionalArguments { 16 | if {[dict exists $argv $argument]} { 17 | lappend result $key [dict get $argv $argument] 18 | } else { 19 | lappend result $key $defaultValue 20 | } 21 | dict unset argv $argument 22 | } 23 | foreach {argument key} $mandatoryArguments { 24 | if {[dict exists $argv $argument]} { 25 | lappend result $key [dict get $argv $argument] 26 | } else { 27 | error "missing argument: $argument" 28 | } 29 | dict unset argv $argument 30 | } 31 | } errorMessage] 32 | if {$error} { 33 | error "cannot parse arguments ($errorMessage)" 34 | } 35 | if {$argv ne ""} { 36 | error "unknown argument(s): $argv" 37 | } 38 | return [dict create {*}$result] 39 | } 40 | 41 | # Return a usage message. 42 | proc ::arguments::usage {mandatoryArguments optionalArguments argv0} { 43 | set result {} 44 | append result "usage: $argv0" 45 | foreach {argument key} $mandatoryArguments { 46 | append result " $argument $key" 47 | } 48 | foreach {argument key defaultValue} $optionalArguments { 49 | append result " \[$argument $key\]" 50 | } 51 | return $result 52 | } 53 | -------------------------------------------------------------------------------- /entities.tcl: -------------------------------------------------------------------------------- 1 | # HTML entity list. 2 | 3 | # The contents of the dictionary html::entities is taken verbatim from 4 | # Tcllib's html package, which bears the following copyright notice: 5 | 6 | # Copyright (c) 1998-2000 by Ajuba Solutions. 7 | # Copyright (c) 2006 Michael Schlenker 8 | # 9 | # See the file "license.terms" for information on usage and redistribution 10 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 | # 12 | # Originally by Brent Welch, with help from Dan Kuchler and Melissa Chawla 13 | 14 | # The text of "license.terms" is as follows: 15 | 16 | # This software is copyrighted by Ajuba Solutions and other parties. 17 | # The following terms apply to all files associated with the software unless 18 | # explicitly disclaimed in individual files. 19 | # 20 | # The authors hereby grant permission to use, copy, modify, distribute, 21 | # and license this software and its documentation for any purpose, provided 22 | # that existing copyright notices are retained in all copies and that this 23 | # notice is included verbatim in any distributions. No written agreement, 24 | # license, or royalty fee is required for any of the authorized uses. 25 | # Modifications to this software may be copyrighted by their authors 26 | # and need not follow the licensing terms described here, provided that 27 | # the new terms are clearly indicated on the first page of each file where 28 | # they apply. 29 | # 30 | # IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY 31 | # FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES 32 | # ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY 33 | # DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE 34 | # POSSIBILITY OF SUCH DAMAGE. 35 | # 36 | # THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, 37 | # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, 38 | # FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE 39 | # IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE 40 | # NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR 41 | # MODIFICATIONS. 42 | # 43 | # GOVERNMENT USE: If you are acquiring this software on behalf of the 44 | # U.S. government, the Government shall have only "Restricted Rights" 45 | # in the software and related documentation as defined in the Federal 46 | # Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you 47 | # are acquiring the software on behalf of the Department of Defense, the 48 | # software shall be classified as "Commercial Computer Software" and the 49 | # Government shall have only "Restricted Rights" as defined in Clause 50 | # 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the 51 | # authors grant the U.S. Government and others acting in its behalf 52 | # permission to use and distribute the software in accordance with the 53 | # terms specified in this license. 54 | 55 | namespace eval ::html { 56 | variable version 1.0.0 57 | } 58 | 59 | set ::html::entities [dict create {*}{ 60 | \xa0   \xa1 ¡ \xa2 ¢ \xa3 £ \xa4 ¤ 61 | \xa5 ¥ \xa6 ¦ \xa7 § \xa8 ¨ \xa9 © 62 | \xaa ª \xab « \xac ¬ \xad ­ \xae ® 63 | \xaf ¯ \xb0 ° \xb1 ± \xb2 ² \xb3 ³ 64 | \xb4 ´ \xb5 µ \xb6 ¶ \xb7 · \xb8 ¸ 65 | \xb9 ¹ \xba º \xbb » \xbc ¼ \xbd ½ 66 | \xbe ¾ \xbf ¿ \xc0 À \xc1 Á \xc2  67 | \xc3 à \xc4 Ä \xc5 Å \xc6 Æ \xc7 Ç 68 | \xc8 È \xc9 É \xca Ê \xcb Ë \xcc Ì 69 | \xcd Í \xce Î \xcf Ï \xd0 Ð \xd1 Ñ 70 | \xd2 Ò \xd3 Ó \xd4 Ô \xd5 Õ \xd6 Ö 71 | \xd7 × \xd8 Ø \xd9 Ù \xda Ú \xdb Û 72 | \xdc Ü \xdd Ý \xde Þ \xdf ß \xe0 à 73 | \xe1 á \xe2 â \xe3 ã \xe4 ä \xe5 å 74 | \xe6 æ \xe7 ç \xe8 è \xe9 é \xea ê 75 | \xeb ë \xec ì \xed í \xee î \xef ï 76 | \xf0 ð \xf1 ñ \xf2 ò \xf3 ó \xf4 ô 77 | \xf5 õ \xf6 ö \xf7 ÷ \xf8 ø \xf9 ù 78 | \xfa ú \xfb û \xfc ü \xfd ý \xfe þ 79 | \xff ÿ \u192 ƒ \u391 Α \u392 Β \u393 Γ 80 | \u394 Δ \u395 Ε \u396 Ζ \u397 Η \u398 Θ 81 | \u399 Ι \u39A Κ \u39B Λ \u39C Μ \u39D Ν 82 | \u39E Ξ \u39F Ο \u3A0 Π \u3A1 Ρ \u3A3 Σ 83 | \u3A4 Τ \u3A5 Υ \u3A6 Φ \u3A7 Χ \u3A8 Ψ 84 | \u3A9 Ω \u3B1 α \u3B2 β \u3B3 γ \u3B4 δ 85 | \u3B5 ε \u3B6 ζ \u3B7 η \u3B8 θ \u3B9 ι 86 | \u3BA κ \u3BB λ \u3BC μ \u3BD ν \u3BE ξ 87 | \u3BF ο \u3C0 π \u3C1 ρ \u3C2 ς \u3C3 σ 88 | \u3C4 τ \u3C5 υ \u3C6 φ \u3C7 χ \u3C8 ψ 89 | \u3C9 ω \u3D1 ϑ \u3D2 ϒ \u3D6 ϖ 90 | \u2022 • \u2026 … \u2032 ′ \u2033 ″ 91 | \u203E ‾ \u2044 ⁄ \u2118 ℘ \u2111 ℑ 92 | \u211C ℜ \u2122 ™ \u2135 ℵ \u2190 ← 93 | \u2191 ↑ \u2192 → \u2193 ↓ \u2194 ↔ \u21B5 ↵ 94 | \u21D0 ⇐ \u21D1 ⇑ \u21D2 ⇒ \u21D3 ⇓ \u21D4 ⇔ 95 | \u2200 ∀ \u2202 ∂ \u2203 ∃ \u2205 ∅ 96 | \u2207 ∇ \u2208 ∈ \u2209 ∉ \u220B ∋ \u220F ∏ 97 | \u2211 ∑ \u2212 − \u2217 ∗ \u221A √ 98 | \u221D ∝ \u221E ∞ \u2220 ∠ \u2227 ∧ \u2228 ∨ 99 | \u2229 ∩ \u222A ∪ \u222B ∫ \u2234 ∴ \u223C ∼ 100 | \u2245 ≅ \u2248 ≈ \u2260 ≠ \u2261 ≡ \u2264 ≤ 101 | \u2265 ≥ \u2282 ⊂ \u2283 ⊃ \u2284 ⊄ \u2286 ⊆ 102 | \u2287 ⊇ \u2295 ⊕ \u2297 ⊗ \u22A5 ⊥ 103 | \u22C5 ⋅ \u2308 ⌈ \u2309 ⌉ \u230A ⌊ 104 | \u230B ⌋ \u2329 ⟨ \u232A ⟩ \u25CA ◊ 105 | \u2660 ♠ \u2663 ♣ \u2665 ♥ \u2666 ♦ 106 | \x22 " \x26 & \x3C < \x3E > \u152 Œ 107 | \u153 œ \u160 Š \u161 š \u178 Ÿ 108 | \u2C6 ˆ \u2DC ˜ \u2002   \u2003   \u2009   109 | \u200C ‌ \u200D ‍ \u200E ‎ \u200F ‏ \u2013 – 110 | \u2014 — \u2018 ‘ \u2019 ’ \u201A ‚ 111 | \u201C “ \u201D ” \u201E „ \u2020 † 112 | \u2021 ‡ \u2030 ‰ \u2039 ‹ \u203A › 113 | \u20AC € 114 | }] 115 | -------------------------------------------------------------------------------- /example.tcl: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env jimsh 2 | # A jimhttp use example. 3 | # Copyright (c) 2014-2016 D. Bohdan. 4 | # License: MIT 5 | 6 | source arguments.tcl 7 | source html.tcl 8 | source http.tcl 9 | source json.tcl 10 | source storage.tcl 11 | source template.tcl 12 | 13 | # This file showcases the various features of the framework and the ways in 14 | # which it can be used (e.g., HTML DSL vs. templates). 15 | 16 | # An example of the HTML DSL from html.tcl. It also provides links to 17 | # other examples. 18 | ::http::add-handler GET / { 19 | ::http::respond [::http::make-response \ 20 | [html "" \n \ 21 | [form {action /form method POST} \n \ 22 | [h1 "Hello"] [br] \n \ 23 | [input {name name type text value Anonymous}] [br] \n \ 24 | [textarea {name message} "Your message here."] [br] \n \ 25 | [input {type submit}]] [br] \n \ 26 | [ul {} \ 27 | [li [a {href "/ajax"} /ajax]] \n \ 28 | [li [a {href "/cookie"} /cookie]] \n \ 29 | [li [a {href "/counter"} /counter]] \n \ 30 | [li [a {href "/counter-persistent"} \ 31 | /counter-persistent]] \n \ 32 | [li [a {href "/delay"} /delay]] \n \ 33 | [li [a {href "/file-echo"} \ 34 | /file-echo]] \n \ 35 | [li [a {href "/hello/John"} /hello/John]] \n \ 36 | [li [a {href "/hello/John/Smallville"} \ 37 | /hello/John/Smallville]] \n \ 38 | [li [a {href "/json"} /json]] \n \ 39 | [li [a {href "/static.jpg"} /static.jpg]] \n \ 40 | [li [a {href "/table"} /table]] \n \ 41 | [li [a {href "/template"} /template]] \n \ 42 | [li [a {href "/quit"} /quit]]]] {} $request] 43 | } 44 | 45 | # Process POST form data for the form at /. 46 | ::http::add-handler {GET POST} /form { 47 | if {[dict exists $request formPost name] && \ 48 | [dict exists $request formPost message]} { 49 | ::http::respond [::http::make-response [format {You (%s) said:
%s} \ 50 | [::html::escape [dict get $request formPost name]] \ 51 | [::html::escape [dict get $request formPost message]]] \ 52 | {} \ 53 | $request] 54 | } else { 55 | ::http::respond [::http::make-response \ 56 | "Please fill in the form at [a {href /} /]." {} $request] 57 | } 58 | } 59 | 60 | # Shut down the HTTP server. 61 | ::http::add-handler GET /quit { 62 | global ::http::done 63 | set ::http::done 1 64 | ::http::respond [::http::make-response "Bye!" {} $request] 65 | } 66 | 67 | # Process route variables. Their values are available to the handler script 68 | # through the dict routeVars. 69 | ::http::add-handler GET {/hello/:name /hello/:name/:town} { 70 | set response "Hello, $routeVars(name)" 71 | if {[dict exists $routeVars town]} { 72 | append response " from $routeVars(town)" 73 | } 74 | append response ! 75 | ::http::respond [::http::make-response $response {} $request] 76 | } 77 | 78 | # Table generation using html.tcl. 79 | ::http::add-handler GET /table { 80 | ::http::respond \ 81 | [::http::make-response [::html::make-table {{a b} {1 2} {3 4}} 1] \ 82 | {} $request] 83 | } 84 | 85 | # Static variables in a handler. 86 | ::http::add-handler GET /counter {{counter 0}} { 87 | incr counter 88 | 89 | ::http::respond [::http::make-response $counter {} $request] 90 | } 91 | 92 | # Persistent storage. 93 | ::http::add-handler GET /counter-persistent {{counter 0}} { 94 | ::storage::restore-statics 95 | 96 | incr counter 97 | 98 | ::storage::persist-statics 99 | ::http::respond [::http::make-response $counter {} $request] 100 | } 101 | 102 | # AJAX requests. 103 | ::http::add-handler GET /ajax { 104 | ::http::respond [::http::make-response { 105 | 106 | 107 | 108 | 117 |
118 | Click the button. 119 |
120 | 121 | 122 | 123 | } {} $request] 124 | } 125 | 126 | # HTML templates. 127 | ::http::add-handler GET /template { 128 | ::http::respond [::http::make-response [eval [::template::parse { 129 | 130 | 131 | 132 | The most populous metropolitan areas in the world are: 133 |
134 | <% foreach {city population} \ 135 | {Tokyo 37.8 Seoul 25.62 Shanghai 24.75} { %> 136 |
<%= $city %>
<%= $population %> million people
137 | <% } %> 138 |
139 | 140 | 141 | }]] {} $request] 142 | } 143 | 144 | # File uploading. Sends the uploaded file back to the client. 145 | ::http::add-handler {GET POST} /file-echo { 146 | if {($request(method) eq "POST") && 147 | [dict exists $request files testfile content]} { 148 | ::http::respond [::http::make-response \ 149 | [dict get $request files testfile content] \ 150 | [list contentType \ 151 | [mime::type \ 152 | [dict get $request \ 153 | files testfile filename]]]] 154 | } else { 155 | ::http::respond [::http::make-response \ 156 | [html "" \n \ 157 | [form {action /file-echo method POST 158 | enctype {multipart/form-data}} \n \ 159 | [input {type hidden name test value blah}] \ 160 | [input {type file name testfile}] " " \ 161 | [input {type submit}]]] 162 | {} \ 163 | $request] 164 | } 165 | } 166 | 167 | # JSON generation and parsing. 168 | ::http::add-handler {GET POST} /json { 169 | if {$request(method) eq "POST"} { 170 | set error [catch {set result [::json::parse $request(formPost) 1]}] 171 | if {!$error} { 172 | ::http::respond [::http::make-response \ 173 | "Decoded JSON:\n[list $result]\n" \ 174 | {contentType text/plain} \ 175 | $request] 176 | } else { 177 | ::http::respond [::http::error-response \ 178 | 400 \ 179 | "

Couldn't parse JSON.

" \ 180 | $request] 181 | } 182 | } else { 183 | set json [dict create {*}{ 184 | objectSample {Tokyo 37.8 Seoul 25.62 Shanghai 24.75} 185 | arraySample {0 Tokyo 1 Seoul 2 Shanghai} 186 | }] 187 | ::http::respond [::http::make-response \ 188 | [::json::stringify $json 1] {} $request] 189 | } 190 | } 191 | 192 | # Cookies. 193 | ::http::add-handler GET /cookie { 194 | set cookies {} 195 | catch {set cookies [dict get $request cookies]} 196 | 197 | set cookieTable [tr "" [th name] [th value]] 198 | foreach {name value} $cookies { 199 | append cookieTable [tr "" [td $name] [td $value]] 200 | } 201 | 202 | ::http::respond [::http::make-response \ 203 | [html [body [table $cookieTable]]] \ 204 | { 205 | cookies { 206 | {name alpha value {cookie 1} maxAge 360} 207 | {name beta value {cookie 2} expires 1727946435 httpOnly 1} 208 | } 209 | } \ 210 | $request] 211 | } 212 | 213 | # Keeping the channel open. We get a connection and respond later in an [after] 214 | # script. 215 | ::http::add-handler GET /delay { 216 | after 25 [list apply {{channel t1 request} { 217 | set message "You waited $([clock milliseconds] - $t1) milliseconds\ 218 | for your response." 219 | ::http::respond [::http::make-response \ 220 | [html [body {} [p $message]]] \ 221 | {} \ 222 | $request] 223 | close $channel 224 | }} $channel [clock milliseconds] $request] 225 | } 226 | dict set ::http::routes /delay GET close 0 227 | 228 | # Activate or deactivate GZip compression of responses. 229 | ::http::add-handler {GET POST} /compression { 230 | set gzipFilter [dict get $::http::sampleFilters gzipExternal] 231 | 232 | if {($request(method) eq {POST}) && 233 | [dict exists $request formPost enable]} { 234 | if {[dict get $request formPost enable]} { 235 | set ::http::responseFilters [list $gzipFilter] 236 | } else { 237 | set ::http::responseFilters {} 238 | } 239 | } 240 | 241 | set enabled [expr { 242 | $gzipFilter in $::http::responseFilters ? "on" : "off" 243 | }] 244 | ::http::respond [::http::make-response \ 245 | [html [body [h1 "Compression is $enabled"]]] \ 246 | {} \ 247 | $request] 248 | } 249 | 250 | # Static file. 251 | ::http::add-static-file /static.jpg 252 | 253 | proc main {} { 254 | global argv 255 | global argv0 256 | global ::http::crashOnError 257 | global ::http::verbosity 258 | 259 | stdout buffering line 260 | 261 | set ::http::crashOnError 1 ;# exit if an error occurs. 262 | 263 | set optionalArgs [list -p port 8080 -i ip 127.0.0.1 -v verbosity 3] 264 | set error [catch { 265 | set args [::arguments::parse {} $optionalArgs $argv] 266 | } errorMessage] 267 | if {$error} { 268 | puts "Error: $errorMessage" 269 | puts [::arguments::usage {} $optionalArgs $argv0] 270 | exit 1 271 | } 272 | set ::http::verbosity $args(verbosity) 273 | 274 | ::storage::init 275 | ::http::start-server $args(ip) $args(port) 276 | } 277 | 278 | main 279 | -------------------------------------------------------------------------------- /html.tcl: -------------------------------------------------------------------------------- 1 | # An HTML DSL for Jim Tcl. 2 | # Copyright (c) 2014-2016 D. Bohdan. 3 | # License: MIT. 4 | 5 | namespace eval ::html { 6 | variable version 0.2.1 7 | } 8 | 9 | # HTML entities processing code based on http://wiki.tcl-lang.org/26403. 10 | source entities.tcl 11 | 12 | set ::html::entitiesInverse [lreverse $::html::entities] 13 | 14 | # Escape HTML entities in $text. 15 | proc ::html::escape text { 16 | global ::html::entities 17 | string map $::html::entities $text 18 | } 19 | 20 | proc ::html::unescape text { 21 | global ::html::entitiesInverse 22 | string map $::html::entitiesInverse $text 23 | } 24 | 25 | # [::html::tag tag {attr1 val1} content] returns content 26 | # [::html::tag tag content] returns content 27 | proc ::html::tag {tag args} { 28 | # If there's only argument given treat it as tag content. If there is more 29 | # than one argument treat the first one as a tag attribute dict and the 30 | # rest as content. 31 | set attribs {} 32 | if {[llength $args] > 1} { 33 | set attribs [lindex $args 0] 34 | set args [lrange $args 1 end] 35 | } 36 | 37 | set attribText {} 38 | foreach {name value} $attribs { 39 | append attribText " $name=\"$value\"" 40 | } 41 | return "<$tag$attribText>[join $args ""]" 42 | } 43 | 44 | # [::html::tag tag {attr1 val1}] returns 45 | proc ::html::tag-no-content {tag {attribs {}}} { 46 | set attribText {} 47 | foreach {name value} $attribs { 48 | append attribText " $name=\"$value\"" 49 | } 50 | return "<$tag$attribText>" 51 | } 52 | 53 | proc ::html::make-tags {tagList {withContent 1}} { 54 | if {$withContent} { 55 | set procName ::html::tag 56 | } else { 57 | set procName ::html::tag-no-content 58 | } 59 | foreach tag $tagList { 60 | # Proc static variables are not use for the sake of Tcl compatibility. 61 | proc [namespace parent]::$tag args [ 62 | format {%s %s {*}$args} $procName $tag 63 | ] 64 | } 65 | } 66 | 67 | # Here we actually create the tag procs. 68 | ::html::make-tags {head title body table td tr th ul li a div pre p form \ 69 | textarea h1 h2 h3 h4 h5 b i u s tt} 1 70 | ::html::make-tags {input submit br hr} 0 71 | # Create the html tag proc as a special case. 72 | proc html args { 73 | set result "" 74 | append result [::html::tag html {*}$args] 75 | return $result 76 | } 77 | 78 | proc ::html::make-table-row {items {header 0}} { 79 | if {$header} { 80 | set command th 81 | } else { 82 | set command td 83 | } 84 | set cells {} 85 | foreach item $items { 86 | lappend cells [$command $item] 87 | } 88 | tr "" {*}$cells 89 | } 90 | 91 | # Return an HTML table. Each argument is converted to a table row. 92 | proc ::html::make-table {rows {makeHeader 0}} { 93 | set rowsProcessed {} 94 | set header $makeHeader 95 | foreach row $rows { 96 | lappend rowsProcessed [::html::make-table-row $row $header] 97 | set header 0 98 | } 99 | table {} {*}$rowsProcessed 100 | } 101 | -------------------------------------------------------------------------------- /http.tcl: -------------------------------------------------------------------------------- 1 | # An HTTP server and web framework for Jim Tcl. 2 | # Copyright (c) 2014-2016, 2019 D. Bohdan. 3 | # License: MIT. 4 | 5 | namespace eval ::http { 6 | source mime.tcl 7 | 8 | variable version 0.15.2 9 | 10 | variable verbosity 0 11 | variable crashOnError 0 12 | variable maxRequestLength [expr 16*1024*1024] 13 | variable routes {} 14 | # A lambda run by ::http::serve before any communication with the client 15 | # happens over a newly established connection's channel. Use 16 | # [upvar 1 channel channel] to access the channel from the lambda. 17 | variable newConnectionLambda {{} {}} 18 | 19 | variable statusCodePhrases [dict create {*}{ 20 | 100 Continue 21 | 200 OK 22 | 201 {Created} 23 | 301 {Moved Permanently} 24 | 400 {Bad Request} 25 | 401 {Unauthorized} 26 | 403 {Forbidden} 27 | 404 {Not Found} 28 | 405 {Method Not Allowed} 29 | 413 {Request Entity Too Large} 30 | 500 {Internal Server Error} 31 | }] 32 | 33 | variable requestFormat [dict create {*}{ 34 | Accept: accept 35 | Accept-Charset: acceptCharset 36 | Accept-Encoding: acceptEncoding 37 | Accept-Language: acceptLanguage 38 | Connection: connection 39 | Content-Disposition: contentDisposition 40 | Content-Length: contentLength 41 | Content-Type: contentType 42 | Cookie: cookie 43 | Expect: expect 44 | Host: host 45 | Referer: referer 46 | User-Agent: userAgent 47 | }] 48 | 49 | variable cookieFields [dict create {*}{ 50 | Domain domain 51 | Path path 52 | Expires expires 53 | Max-Age maxAge 54 | Secure secure 55 | HttpOnly httpOnly 56 | }] 57 | variable cookieFieldsInv [lreverse $::http::cookieFields] 58 | variable cookieDateFormat {%a, %d-%b-%Y %H:%M:%S GMT} 59 | 60 | variable requestFormatLowerCase {} 61 | foreach {key value} $requestFormat { 62 | dict set requestFormatLowerCase [string tolower $key] $value 63 | } 64 | 65 | variable methods [list {*}{ 66 | OPTIONS GET HEAD POST PUT DELETE TRACE CONNECT 67 | }] 68 | 69 | # A list of lambdas. Each lambda takes a response body, a list of response 70 | # headers and a list of request headers and return a list consisting of an 71 | # updated response body and a list of updated response headers. Can be used 72 | # to implement, e.g., compression. Applied in order. 73 | variable responseFilters {} 74 | 75 | # Sample filters. To active a filter add it to responseFilters. 76 | variable sampleFilters {} 77 | # Perform GZip compression of the content using an external gzip binary. 78 | dict set sampleFilters gzipExternal {{body responseHeaders request} { 79 | if {[dict exists $request acceptEncoding] && 80 | [string match *gzip* $request(acceptEncoding)]} { 81 | dict set responseHeaders contentEncoding gzip 82 | set body [exec gzip << $body] 83 | } 84 | return [list $body $responseHeaders] 85 | }} 86 | # Perform GZip compression of the content using the zlib module. 87 | dict set sampleFilters gzipInternal {{body responseHeaders request} { 88 | if {[dict exists $request acceptEncoding] && 89 | [string match *gzip* $request(acceptEncoding)]} { 90 | dict set responseHeaders contentEncoding gzip 91 | set body [zlib gzip $body] 92 | } 93 | return [list $body $responseHeaders] 94 | }} 95 | # Perform Deflate compression of the content using the zlib module. 96 | dict set sampleFilters deflateInternal {{body responseHeaders request} { 97 | if {[dict exists $request acceptEncoding] && 98 | [string match *deflate* $request(acceptEncoding)]} { 99 | dict set responseHeaders contentEncoding deflate 100 | set body [zlib deflate $body] 101 | } 102 | return [list $body $responseHeaders] 103 | }} 104 | } 105 | 106 | # Return the text of an HTTP response with the body $body. 107 | proc ::http::make-response {body {headers {}} {request {}}} { 108 | set ::http::responseTemplate \ 109 | {HTTP/1.1 $headers(code) $::http::statusCodePhrases($headers(code)) 110 | Content-Type: $headers(contentType) 111 | Content-Length: $length} 112 | 113 | set ::http::headerDefaults [dict create {*}{ 114 | code 200 115 | contentType text/html 116 | }] 117 | 118 | set headers [dict merge $::http::headerDefaults $headers] 119 | 120 | # Handle response processing, e.g., compression. 121 | foreach lambda $::http::responseFilters { 122 | lassign [apply $lambda $body $headers $request] body headers 123 | } 124 | 125 | set length [string bytelength $body] 126 | 127 | set response [subst $::http::responseTemplate] 128 | 129 | # TODO: Generalize for other possible fields in the headers. 130 | if {[dict exists $headers cookies]} { 131 | foreach cookie $headers(cookies) { 132 | append response "\nSet-Cookie: [::http::make-cookie $cookie]" 133 | } 134 | } 135 | if {[dict exists $headers contentEncoding]} { 136 | append response \ 137 | "\nContent-Encoding: [dict get $headers contentEncoding]" 138 | } 139 | 140 | append response "\n\n$body" 141 | return $response 142 | } 143 | 144 | # Write $message to stdout if $level <= $::http::verbosity. Levels 0 and lower 145 | # are for errors that are always reported. 146 | proc ::http::log {level message} \ 147 | [list [list levelNumber [dict create {*}{ 148 | debug 3 info 2 warning 1 error 0 critical -1 149 | }]]] { 150 | set levelNumber 151 | 152 | if {$levelNumber($level) <= $::http::verbosity} { 153 | puts [format "%-9s %s" "[string toupper $level]:" $message] 154 | } 155 | } 156 | 157 | # From http://wiki.tcl-lang.org/14144. 158 | proc ::http::uri-decode str { 159 | # rewrite "+" back to space 160 | # protect \ from quoting another '\' 161 | set str [string map [list + { } "\\" "\\\\"] $str] 162 | 163 | # prepare to process all %-escapes 164 | regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str 165 | 166 | # process \u unicode mapped chars 167 | return [subst -novar -nocommand $str] 168 | } 169 | 170 | # Decode a POST/GET form. 171 | # string -> dict 172 | proc ::http::form-decode {formData} { 173 | set result {} 174 | foreach x [split $formData &] { 175 | lassign [lmap y [split $x =] { uri-decode $y }] key value 176 | dict set result $key $value 177 | } 178 | return $result 179 | } 180 | 181 | # A slow Unicode-agnostic [string first]. 182 | proc ::http::string-bytefirst {needle haystack} { 183 | set bytesNeedle [string bytelength $needle] 184 | set bytesHaystack [string bytelength $haystack] 185 | 186 | set n $($bytesHaystack - $bytesNeedle) 187 | for {set i 0} {$i <= $n} {incr i} { 188 | set range [string byterange $haystack $i $($i + $bytesNeedle - 1)] 189 | if {$range eq $needle} { 190 | return $i 191 | } 192 | } 193 | 194 | return -1 195 | } 196 | 197 | # Return the bytes up to but not including $separator in variable 198 | # $stringVarName. Remove them and the separator following them from 199 | # $stringVarName. If $separator isn't in $stringVarName's value, return 200 | # the whole string. Ignores Unicode. 201 | proc ::http::string-pop {stringVarName separator} { 202 | upvar 1 $stringVarName str 203 | 204 | set bytes [string-bytefirst $separator $str] 205 | 206 | if {$bytes > -1} { 207 | set substr [string byterange $str 0 $bytes-1] 208 | set str [string byterange $str \ 209 | $bytes+[string bytelength $separator] \ 210 | end] 211 | } else { 212 | set substr $str 213 | set str {} 214 | } 215 | 216 | 217 | return $substr 218 | } 219 | 220 | # Parse a cookie dict in the format of 221 | # {{name somecookie value "some value" expires 1727946435 domain foo path / 222 | # secure 0 httpOnly 1} ...} into an HTTP header Set-Cookie value. 223 | proc ::http::make-cookie cookieDict { 224 | set result {} 225 | append result "$cookieDict(name)=$cookieDict(value)" 226 | dict unset cookieDict name 227 | dict unset cookieDict value 228 | foreach {field value} $cookieDict { 229 | if {($field eq "secure") || ($field eq "httpOnly")} { 230 | if {$value} { 231 | append result "; $::http::cookieFieldsInv($field)" 232 | } 233 | } else { 234 | append result "; $::http::cookieFieldsInv($field)" 235 | if {$field eq "expires"} { 236 | # TODO: adjust for the local timezone. clock format does not yet 237 | # support the -gmt switch in Jim Tcl. 238 | append result "=[clock format $value \ 239 | -format $::http::cookieDateFormat]" 240 | } else { 241 | append result "=$value" 242 | } 243 | } 244 | } 245 | return $result 246 | } 247 | 248 | # Parse HTTP request headers presented as a list of lines into a dict. 249 | proc ::http::parse-headers {headerLines} { 250 | set headers {} 251 | set field {} 252 | set value {} 253 | 254 | foreach line $headerLines { 255 | # Split $line on its first space. 256 | regexp {^(.*?) (.*)$} $line _ field value 257 | ::http::log debug [list $line] 258 | 259 | if {[lsearch -exact $::http::methods $field] > -1} { 260 | dict set headers method $field 261 | lassign [split [lindex [split $value] 0] ?] headers(url) formData 262 | dict set headers form [form-decode $formData] 263 | } else { 264 | # Translate "Content-Type:" to "contentType", etc. 265 | set field [string tolower $field] 266 | if {$field eq "cookie:"} { 267 | if {![dict exists $headers cookies]} { 268 | dict set headers cookies {} 269 | } 270 | dict set headers cookies [dict merge $headers(cookies) \ 271 | [::http::parse-value $value]] 272 | } elseif {[dict exists $::http::requestFormatLowerCase $field]} { 273 | dict set headers $::http::requestFormatLowerCase($field) $value 274 | } 275 | } 276 | } 277 | return $headers 278 | } 279 | 280 | # Convert an HTTP request value of type {string;key1=value1; key2="value2"} to 281 | # dict. 282 | proc ::http::parse-value {str} { 283 | set result {} 284 | foreach x [split $str ";"] { 285 | set x [string trimleft $x " "] ;# For "; ". 286 | if {[regexp {(.*?)="?([^"]*)"?} $x _ name value]} { 287 | dict set result $name $value 288 | } else { 289 | dict set result $x 1 290 | } 291 | } 292 | return $result 293 | } 294 | 295 | # Return the files and formPost fields in encoded in a multipart/form-data form. 296 | # Very hacky. 297 | proc ::http::parse-multipart-data {postString contentType newline} { 298 | set result {} 299 | 300 | try { 301 | set boundary \ 302 | [dict get [::http::parse-value $contentType] boundary] 303 | } on error _ { 304 | error {no boundary specified in Content-Type} 305 | } 306 | 307 | while {$postString ne {}} { 308 | set part [string-pop postString $newline--$boundary] 309 | 310 | set lines [split [string-pop part $newline$newline] \ 311 | $newline] 312 | set partHeader [::http::parse-headers $lines] 313 | 314 | if {$part in {{} --}} continue 315 | 316 | set m [::http::parse-value $partHeader(contentDisposition)] 317 | 318 | if {[dict exists $m form-data] && [dict exists $m name]} { 319 | # Store files and form fields separately. 320 | if {[dict exists $m filename]} { 321 | dict set result \ 322 | files $m(name) filename $m(filename) 323 | dict set result \ 324 | files $m(name) content $part 325 | } else { 326 | dict set result formPost $m(name) $part 327 | } 328 | } 329 | } 330 | 331 | return $result 332 | } 333 | 334 | # Return error responses. 335 | proc ::http::error-response {code {customMessage ""} {request {}}} { 336 | return [::http::make-response \ 337 | "

Error $code: $::http::statusCodePhrases($code)

\ 338 | $customMessage" \ 339 | [list code $code] \ 340 | $request] 341 | } 342 | 343 | # Call ::http::serve. Catch and report any unhandled errors. 344 | proc ::http::serve-and-trap-errors {channel clientAddr clientPort} { 345 | set error [catch { 346 | ::http::serve $channel $clientAddr $clientPort 347 | } errorMessage errorOptions] 348 | if {$error} { 349 | ::http::log critical \ 350 | "Unhandled ::http::serve error: $errorMessage." 351 | catch {close $channel} 352 | if {$::http::crashOnError} { 353 | ::http::log info "Exiting due to error." 354 | exit 1 355 | } 356 | } 357 | } 358 | 359 | # Handle HTTP requests over a channel and send responses. A hacky HTTP 360 | # implementation. 361 | proc ::http::serve {channel clientAddr clientPort} { 362 | # "Preprocess" the channel before anything else is done with it, e.g., to 363 | # initiate a TLS connection. 364 | apply $::http::newConnectionLambda 365 | 366 | ::http::log info "Client connected: $clientAddr" 367 | 368 | set newline \r\n 369 | 370 | set headerLines {} 371 | set firstLine 1 372 | while {[gets $channel buf]} { 373 | if {$firstLine} { 374 | # Change the newline variable when the incoming request has 375 | # nonstandard \n newlines. This happens, e.g., when you use netcat. 376 | if {[string index $buf end] ne "\r"} { 377 | set newline "\n" 378 | ::http::log debug \ 379 | {The client uses \n instead of \r\n for newline.} 380 | } 381 | set firstLine 0 382 | } 383 | if {$newline eq "\r\n"} { 384 | set buf [string trimright $buf \r] 385 | } 386 | if {$buf eq {}} { 387 | break 388 | } 389 | lappend headerLines $buf 390 | } 391 | 392 | set request [::http::parse-headers $headerLines] 393 | set error 0 394 | 395 | if {![dict exists $request method] || ![dict exists $request url]} { 396 | ::http::log error "Bad request." 397 | set error 400 398 | } 399 | 400 | # Process POST data. Refactor me into a proc with early returns. 401 | if {$error != 0 || $request(method) ne "POST"} { 402 | dict set request formPost {} 403 | } else { 404 | set request [dict merge { 405 | contentType application/x-www-form-urlencoded 406 | contentLength 0 407 | } $request] 408 | 409 | if {![string is integer $request(contentLength)] 410 | || $request(contentLength) <= 0} { 411 | ::http::log error "Bad request: Content-Length is invalid\ 412 | (\"$request(contentLength)\")." 413 | set error 400 414 | } else { 415 | if {$request(contentLength) > $::http::maxRequestLength} { 416 | ::http::log error \ 417 | "Request too large: $request(contentLength)." 418 | set error 413 419 | } else { 420 | if {[dict exists $request expect] && 421 | ($request(expect) eq "100-continue")} { 422 | puts $channel "HTTP/1.1 100 Continue\n" 423 | } 424 | 425 | set postString [read $channel $request(contentLength)] 426 | if {$request(contentType) eq 427 | "application/x-www-form-urlencoded"} { 428 | ::http::log debug "POST request: {$postString}\n" 429 | dict set request formPost [form-decode $postString] 430 | } elseif {[string match "multipart/form-data*" \ 431 | $request(contentType)]} { 432 | ::http::log debug \ 433 | "POST request: (multipart/form-data skipped)" 434 | # Call ::http::parse-multipart-data to parse the data. 435 | set multipartDataError [catch { 436 | set request [dict merge $request \ 437 | [::http::parse-multipart-data \ 438 | $postString \ 439 | $request(contentType) \ 440 | $newline]] 441 | } errorMessage] 442 | if {$multipartDataError} { 443 | ::http::log error \ 444 | "Bad request: multipart/form-data parse error:\ 445 | $errorMessage." 446 | set error 400 447 | } 448 | } else { 449 | # Put content of other types (e.g., application/json) into 450 | # request(formPost) as is. 451 | ::http::log debug \ 452 | "POST request: ($request(contentType) skipped)" 453 | dict set request formPost $postString 454 | } 455 | } 456 | } 457 | } 458 | 459 | if {[dict exists $request cookies]} { 460 | ::http::log debug "cookies: $request(cookies)" 461 | } 462 | 463 | 464 | if {!$error} { 465 | ::http::log info "Responding." 466 | set matchResult [::http::route $channel $request] 467 | lassign $matchResult route 468 | if {$matchResult eq {0} || 469 | [dict get $::http::routes $route $request(method) close]} { 470 | close $channel 471 | } 472 | } else { 473 | puts -nonewline $channel [::http::error-response $error] 474 | close $channel 475 | } 476 | } 477 | 478 | # Start the HTTP server binding it to $ipAddress and $port. 479 | proc ::http::start-server {ipAddress port} { 480 | set ::http::serverSocket [socket stream.server $ipAddress:$port] 481 | $::http::serverSocket readable { 482 | set client [$::http::serverSocket accept addr] 483 | ::http::serve-and-trap-errors $client {*}[split $addr :] 484 | } 485 | ::http::log info "Started server on $ipAddress:$port." 486 | vwait ::http::done 487 | ::http::log info "The server has shut down." 488 | } 489 | 490 | # Call route handler for the request url if available and pass $channel to it. 491 | # Otherwise write a 404 error message to the channel. 492 | proc ::http::route {channel request} { 493 | # Don't show the contents of large files in the debug message. 494 | if {[dict exists $request files] && 495 | [string length $request(files)] > 8*1024} { 496 | set requestPrime $request 497 | dict set requestPrime files "(not shown here)" 498 | ::http::log debug "request: $requestPrime" 499 | set requestPrime {} 500 | } else { 501 | ::http::log debug "request: $request" 502 | } 503 | 504 | set url [dict get $request url] 505 | if {$url eq {}} { 506 | set url / 507 | } 508 | 509 | set matchResult [::http::match-route \ 510 | [dict keys $::http::routes] $url] 511 | if {$matchResult != 0} { 512 | set procName [dict get $::http::routes \ 513 | [lindex $matchResult 0] $request(method) handler] 514 | $procName $channel $request [lindex $matchResult 1] 515 | } else { 516 | puts -nonewline $channel [::http::error-response 404] 517 | } 518 | 519 | return $matchResult 520 | } 521 | 522 | # Return route variables contained in the url if it can be parsed as route 523 | # $route. Return 0 otherwise. 524 | proc ::http::get-route-variables {route url} { 525 | set routeVars {} 526 | foreach routeSegment [split $route /] urlSegment [split $url /] { 527 | if {[string index $routeSegment 0] eq ":"} { 528 | dict set routeVars [string range $routeSegment 1 end] $urlSegment 529 | } else { 530 | # Static parts of the URL and the route should be equal. 531 | if {$urlSegment ne $routeSegment} { 532 | return 0 533 | } 534 | } 535 | } 536 | return $routeVars 537 | } 538 | 539 | # Return the first route out of the list $routeList that matches $url. 540 | proc ::http::match-route {routeList url} { 541 | foreach route $routeList { 542 | set routeVars [::http::get-route-variables $route $url] 543 | if {$routeVars != 0} { 544 | return [list $route $routeVars] 545 | } 546 | } 547 | return 0 548 | } 549 | 550 | # Create a proc to handle the route $route with body $script. 551 | proc ::http::add-handler {methods routes {statics {}} script} { 552 | set procName "handler::${methods}::${routes}" 553 | proc $procName {channel request routeVars} $statics $script 554 | foreach method $methods { 555 | foreach route $routes { 556 | dict set ::http::routes $route $method handler $procName 557 | dict set ::http::routes $route $method close 1 558 | } 559 | } 560 | } 561 | 562 | # Return the contents of $filename. 563 | proc ::http::read-file {filename} { 564 | set fpvar [open $filename r] 565 | fconfigure $fpvar -translation binary 566 | set content [read $fpvar] 567 | close $fpvar 568 | return $content 569 | } 570 | 571 | # Add handler to return the contents of a static file. The file is either 572 | # $filename or [file tail $route] if no filename is given. 573 | proc ::http::add-static-file {route {filename {}}} { 574 | if {$filename eq {}} { 575 | set filename [file tail $route] 576 | } 577 | ::http::add-handler GET $route [list apply {{filename mimeType} { 578 | upvar 1 channel channel 579 | upvar 1 request request 580 | puts -nonewline $channel \ 581 | [::http::make-response \ 582 | [::http::read-file $filename] \ 583 | [list contentType $mimeType] \ 584 | $request] 585 | }} $filename [::mime::type $filename]] 586 | } 587 | 588 | # A convenience procedure to use from route handlers. 589 | proc ::http::respond {response} { 590 | upvar 1 channel channel 591 | puts -nonewline $channel $response 592 | } 593 | -------------------------------------------------------------------------------- /json.tcl: -------------------------------------------------------------------------------- 1 | # JSON parser/serializer. 2 | # Copyright (c) 2014-2019, 2024 D. Bohdan. 3 | # License: MIT. 4 | # 5 | # This library is compatible with Tcl 8.5-9 and Jim Tcl 0.76 and later. 6 | # However, to work with unescaped UTF-8 JSON strings 7 | # in a UTF-8 build of Jim Tcl, 8 | # you will need version a more recent version: 0.79 or later. 9 | 10 | ### The public API: will remain backwards compatible 11 | ### for a major release version of this module. 12 | 13 | namespace eval ::json { 14 | variable version 3.0.0 15 | 16 | variable everyElement *element* 17 | variable everyValue *value* 18 | } 19 | 20 | # Parse the string $str containing JSON into nested Tcl dictionaries. 21 | # 22 | # numberDictArrays: decode arrays as dictionaries with sequential integers 23 | # starting at zero as keys; otherwise, decode them as lists. 24 | proc ::json::parse {str {numberDictArrays 1}} { 25 | set tokens [::json::tokenize $str] 26 | set result [::json::decode $tokens $numberDictArrays] 27 | if {[lindex $result 1] == [llength $tokens]} { 28 | return [lindex $result 0] 29 | } else { 30 | error "trailing garbage after JSON data in [list $str]" 31 | } 32 | } 33 | 34 | # Serialize nested Tcl dictionaries as JSON. 35 | # 36 | # numberDictArrays: encode dictionaries with keys {0 1 2 3 ...} as arrays, 37 | # e.g., {0 a 1 b} as ["a", "b"]. 38 | # If $numberDictArrays false, 39 | # stringify will try to produce objects from all Tcl lists and dictionaries 40 | # unless explicitly told not to in the schema. 41 | # 42 | # schema: data types for the values in $data. 43 | # $schema consists of nested lists 44 | # and/or dictionaries that mirror the structure of the data in $data. 45 | # Each value in $schema specifies the data type of the corresponding value 46 | # in $data. 47 | # The type can be one of 48 | # "array", "boolean, "null", "number", "object", or "string". 49 | # The special dictionary key "*value*" in any dictionary in $schema 50 | # sets the default data type for every value 51 | # in the corresponding dictionary in $data. 52 | # The key "*element*" does the same for the elements of an array. 53 | # When $numberDictArrays is true, 54 | # the key "*value*" forces a dictionary to be serialized as an object 55 | # when it would have been serialized as an array by default 56 | # (for example, the dictionary {0 foo 1 bar}). 57 | # When $numberDictArrays is false, 58 | # "*element*" forces a list to be serialized 59 | # as an array rather than an object. 60 | # A list that uses "*element*" must start with it: 61 | # {*element* defaultType type1 type2 ...}. 62 | # 63 | # strictSchema: generate an error if there is no schema for a value in $data. 64 | # 65 | # compact: no decorative whitespace. 66 | proc ::json::stringify { 67 | data 68 | {numberDictArrays 1} 69 | {schema {}} 70 | {strictSchema 0} 71 | {compact 0} 72 | } { 73 | if {$schema eq "string"} { 74 | return \"[::json::escape-string $data]\" 75 | } 76 | 77 | set validDict [expr { 78 | [llength $data] % 2 == 0 79 | }] 80 | set schemaValidDict [expr { 81 | [llength $schema] % 2 == 0 82 | }] 83 | 84 | set schemaForceArray [expr { 85 | ($schema eq "array") || 86 | ([lindex $schema 0] eq $::json::everyElement) || 87 | ($numberDictArrays && $schemaValidDict && 88 | [dict exists $schema $::json::everyElement]) || 89 | (!$numberDictArrays && $validDict && $schemaValidDict && 90 | ([llength $schema] > 0) && 91 | (![::json::subset [dict keys $schema] [dict keys $data]])) 92 | }] 93 | 94 | set schemaForceObject [expr { 95 | ($schema eq "object") || 96 | ($schemaValidDict && [dict exists $schema $::json::everyValue]) 97 | }] 98 | 99 | if {([llength $data] <= 1) && 100 | !$schemaForceArray && !$schemaForceObject} { 101 | if { 102 | ($schema in {{} "number"}) && 103 | ([string is integer -strict $data] || 104 | [string is double -strict $data]) 105 | } { 106 | return $data 107 | } elseif { 108 | ($schema in {{} "boolean"}) && 109 | ($data in {true false on off yes no 1 0}) 110 | } { 111 | return [string map { 112 | 0 false 113 | off false 114 | no false 115 | 116 | 1 true 117 | on true 118 | yes true 119 | } $data] 120 | } elseif { 121 | ($schema in {{} "null"}) && 122 | ($data eq "null") 123 | } { 124 | return $data 125 | } elseif {$schema eq {}} { 126 | return \"[escape-string $data]\" 127 | } else { 128 | error "invalid schema \"$schema\" for value \"$data\"" 129 | } 130 | } else { 131 | # Dictionary or list. 132 | set isArray [expr { 133 | !$schemaForceObject && 134 | (($numberDictArrays && $validDict && 135 | [::json::number-dict? $data]) || 136 | (!$numberDictArrays && !$validDict) || 137 | ($schemaForceArray && (!$numberDictArrays || $validDict))) 138 | }] 139 | 140 | if {$isArray} { 141 | return [::json::stringify-array $data \ 142 | $numberDictArrays $schema $strictSchema $compact] 143 | } elseif {$validDict} { 144 | return [::json::stringify-object $data \ 145 | $numberDictArrays $schema $strictSchema $compact] 146 | } else { 147 | error "invalid schema \"$schema\" for list \"$data\"" 148 | } 149 | } 150 | error {this should not be reached} 151 | } 152 | 153 | # A convenience wrapper for ::json::stringify with named parameters. 154 | proc ::json::stringify2 {data args} { 155 | set numberDictArrays [::json::get-option -numberDictArrays 1 ] 156 | set schema [::json::get-option -schema {} ] 157 | set strictSchema [::json::get-option -strictSchema 0 ] 158 | set compact [::json::get-option -compact 0 ] 159 | if {[llength [dict keys $args]] > 0} { 160 | error "unknown options: [dict keys $args]" 161 | } 162 | 163 | return [::json::stringify \ 164 | $data $numberDictArrays $schema $strictSchema $compact] 165 | } 166 | 167 | ### The private API: can change at any time. 168 | 169 | ## Utility procedures. 170 | 171 | # If $option is a key in $args of the caller, 172 | # unset it and return its value. 173 | # If not, return $default. 174 | proc ::json::get-option {option default} { 175 | upvar args dictionary 176 | if {[dict exists $dictionary $option]} { 177 | set result [dict get $dictionary $option] 178 | dict unset dictionary $option 179 | } else { 180 | set result $default 181 | } 182 | return $result 183 | } 184 | 185 | # Return 1 if the elements in $a are a subset of those in $b 186 | # and 0 otherwise. 187 | proc ::json::subset {a b} { 188 | set keySet {} 189 | foreach x $a { 190 | dict set keySet $x 1 191 | } 192 | foreach x $b { 193 | dict unset keySet $x 194 | } 195 | return [expr {[llength $keySet] == 0}] 196 | } 197 | 198 | ## Procedures used by ::json::stringify. 199 | 200 | # Return 1 if the keys in dictionary are numbers 0, 1, 2... and 0 otherwise. 201 | proc ::json::number-dict? {dictionary} { 202 | set i 0 203 | foreach {key _} $dictionary { 204 | if {$key != $i} { 205 | return 0 206 | } 207 | incr i 208 | } 209 | return 1 210 | } 211 | 212 | # Return the value for key $key from $schema if the key is present. 213 | # Otherwise, either return the default value {} or, if $strictSchema is true, 214 | # generate an error. 215 | proc ::json::get-schema-by-key {schema key {strictSchema 0}} { 216 | if {[dict exists $schema $key]} { 217 | set valueSchema [dict get $schema $key] 218 | } elseif {[dict exists $schema $::json::everyValue]} { 219 | set valueSchema [dict get $schema $::json::everyValue] 220 | } elseif {[dict exists $schema $::json::everyElement]} { 221 | set valueSchema [dict get $schema $::json::everyElement] 222 | } else { 223 | if {$strictSchema} { 224 | error "missing schema for key \"$key\"" 225 | } else { 226 | set valueSchema {} 227 | } 228 | } 229 | } 230 | 231 | proc ::json::stringify-array {array {numberDictArrays 1} {schema {}} 232 | {strictSchema 0} {compact 0}} { 233 | set arrayElements {} 234 | if {$numberDictArrays} { 235 | foreach {key value} $array { 236 | if {($schema eq {}) || ($schema eq "array")} { 237 | set valueSchema {} 238 | } else { 239 | set valueSchema [::json::get-schema-by-key \ 240 | $schema $key $strictSchema] 241 | } 242 | lappend arrayElements [::json::stringify $value 1 \ 243 | $valueSchema $strictSchema] 244 | } 245 | } else { ;# list arrays 246 | set defaultSchema {} 247 | if {[lindex $schema 0] eq $::json::everyElement} { 248 | set defaultSchema [lindex $schema 1] 249 | set schema [lrange $schema 2 end] 250 | } 251 | foreach value $array valueSchema $schema { 252 | if {($schema eq {}) || ($schema eq "array")} { 253 | set valueSchema $defaultSchema 254 | } 255 | lappend arrayElements [::json::stringify $value 0 \ 256 | $valueSchema $strictSchema $compact] 257 | } 258 | } 259 | 260 | if {$compact} { 261 | set elementSeparator , 262 | } else { 263 | set elementSeparator {, } 264 | } 265 | return "\[[join $arrayElements $elementSeparator]\]" 266 | } 267 | 268 | proc ::json::stringify-object {dictionary {numberDictArrays 1} {schema {}} 269 | {strictSchema 0} {compact 0}} { 270 | set objectDict {} 271 | if {$compact} { 272 | set elementSeparator , 273 | set keyValueSeparator : 274 | } else { 275 | set elementSeparator {, } 276 | set keyValueSeparator {: } 277 | } 278 | 279 | foreach {key value} $dictionary { 280 | if {($schema eq {}) || ($schema eq "object")} { 281 | set valueSchema {} 282 | } else { 283 | set valueSchema [::json::get-schema-by-key \ 284 | $schema $key $strictSchema] 285 | } 286 | lappend objectDict "\"[escape-string \ 287 | $key]\"$keyValueSeparator[::json::stringify \ 288 | $value $numberDictArrays $valueSchema $strictSchema $compact]" 289 | } 290 | 291 | return "{[join $objectDict $elementSeparator]}" 292 | } 293 | 294 | proc ::json::escape-string s { 295 | return [string map { 296 | \u0000 \\u0000 297 | \u0001 \\u0001 298 | \u0002 \\u0002 299 | \u0003 \\u0003 300 | \u0004 \\u0004 301 | \u0005 \\u0005 302 | \u0006 \\u0006 303 | \u0007 \\u0007 304 | \u0008 \\b 305 | \u0009 \\t 306 | \u000a \\n 307 | \u000b \\u000b 308 | \u000c \\f 309 | \u000d \\r 310 | \u000e \\u000e 311 | \u000f \\u000f 312 | \u0010 \\u0010 313 | \u0011 \\u0011 314 | \u0012 \\u0012 315 | \u0013 \\u0013 316 | \u0014 \\u0014 317 | \u0015 \\u0015 318 | \u0016 \\u0016 319 | \u0017 \\u0017 320 | \u0018 \\u0018 321 | \u0019 \\u0019 322 | \u001a \\u001a 323 | \u001b \\u001b 324 | \u001c \\u001c 325 | \u001d \\u001d 326 | \u001e \\u001e 327 | \u001f \\u001f 328 | \" \\\" 329 | \\ \\\\ 330 | 0} { 352 | set max 5 353 | set context [lrange $tokens $i [expr {$i + $max - 1}]] 354 | if {[llength $tokens] - $i >= $max} { 355 | lappend context ... 356 | } 357 | append message " before $context" 358 | } else { 359 | append message " at the end of the token list" 360 | } 361 | uplevel 1 [list error $message] 362 | }] 363 | 364 | apply $nextToken 365 | 366 | if {$type in {STRING NUMBER RAW}} { 367 | return [list $arg [expr {$i - $startingOffset}]] 368 | } elseif {$type eq "OPEN_CURLY"} { 369 | # Object. 370 | set object {} 371 | set first 1 372 | 373 | while 1 { 374 | apply $nextToken 375 | 376 | if {$type eq "CLOSE_CURLY"} { 377 | return [list $object [expr {$i - $startingOffset}]] 378 | } 379 | 380 | if {!$first} { 381 | if {$type eq "COMMA"} { 382 | apply $nextToken 383 | } else { 384 | apply $errorMessage "object expected a comma, got $token" 385 | } 386 | } 387 | 388 | if {$type eq "STRING"} { 389 | set key $arg 390 | } else { 391 | apply $errorMessage "wrong key for object: $token" 392 | } 393 | 394 | apply $nextToken 395 | 396 | if {$type ne "COLON"} { 397 | apply $errorMessage "object expected a colon, got $token" 398 | } 399 | 400 | lassign [::json::decode $tokens $numberDictArrays $i] \ 401 | value tokensInValue 402 | lappend object $key $value 403 | incr i $tokensInValue 404 | 405 | set first 0 406 | } 407 | } elseif {$type eq "OPEN_BRACKET"} { 408 | # Array. 409 | set array {} 410 | set j 0 411 | 412 | while 1 { 413 | apply $nextToken 414 | 415 | if {$type eq "CLOSE_BRACKET"} { 416 | return [list $array [expr {$i - $startingOffset}]] 417 | } 418 | 419 | if {$j > 0} { 420 | if {$type eq "COMMA"} { 421 | apply $nextToken 422 | } else { 423 | apply $errorMessage "array expected a comma, got $token" 424 | } 425 | } 426 | 427 | # Use the last token as part of the value for recursive decoding. 428 | incr i -1 429 | 430 | lassign [::json::decode $tokens $numberDictArrays $i] \ 431 | value tokensInValue 432 | if {$numberDictArrays} { 433 | lappend array $j $value 434 | } else { 435 | lappend array $value 436 | } 437 | incr i $tokensInValue 438 | 439 | incr j 440 | } 441 | } else { 442 | if {$token eq {}} { 443 | apply $errorMessage "missing token" 444 | } else { 445 | apply $errorMessage "can't parse $token" 446 | } 447 | } 448 | 449 | error {this should not be reached} 450 | } 451 | 452 | # Transform a JSON blob into a list of tokens. 453 | proc ::json::tokenize json { 454 | if {$json eq {}} { 455 | error {empty JSON input} 456 | } 457 | 458 | set tokens {} 459 | for {set i 0} {$i < [string length $json]} {incr i} { 460 | set char [string index $json $i] 461 | switch -exact -- $char { 462 | \" { 463 | set value [::json::analyze-string $json $i] 464 | lappend tokens \ 465 | [list STRING [subst -nocommand -novariables $value]] 466 | 467 | incr i [string length $value] 468 | incr i ;# For the closing quote. 469 | } 470 | \{ { 471 | lappend tokens OPEN_CURLY 472 | } 473 | \} { 474 | lappend tokens CLOSE_CURLY 475 | } 476 | \[ { 477 | lappend tokens OPEN_BRACKET 478 | } 479 | \] { 480 | lappend tokens CLOSE_BRACKET 481 | } 482 | , { 483 | lappend tokens COMMA 484 | } 485 | : { 486 | lappend tokens COLON 487 | } 488 | { } {} 489 | \t {} 490 | \n {} 491 | \r {} 492 | default { 493 | if {$char in {- 0 1 2 3 4 5 6 7 8 9}} { 494 | set value [::json::analyze-number $json $i] 495 | lappend tokens [list NUMBER $value] 496 | 497 | incr i [expr {[string length $value] - 1}] 498 | } elseif {$char in {t f n}} { 499 | set value [::json::analyze-boolean-or-null $json $i] 500 | lappend tokens [list RAW $value] 501 | 502 | incr i [expr {[string length $value] - 1}] 503 | } else { 504 | parse-error {can't tokenize value as JSON: %s} $json 505 | } 506 | } 507 | } 508 | } 509 | return $tokens 510 | } 511 | 512 | # Return the beginning of $str parsed as "true", "false" or "null". 513 | proc ::json::analyze-boolean-or-null {str start} { 514 | regexp -start $start {(true|false|null)} $str value 515 | if {![info exists value]} { 516 | parse-error {can't parse value as JSON true/false/null: %s} \ 517 | $str 518 | } 519 | return $value 520 | } 521 | 522 | # Return the beginning of $str parsed as a JSON string. 523 | proc ::json::analyze-string {str start} { 524 | if {[regexp -start $start {"((?:[^"\\]|\\.)*)"} $str _ result]} { 525 | return $result 526 | } else { 527 | parse-error {can't parse JSON string: %s} $str 528 | } 529 | } 530 | 531 | # Return $str parsed as a JSON number. 532 | proc ::json::analyze-number {str start} { 533 | if {[regexp -start $start -- \ 534 | {-?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(:?(?:e|E)[+-]?[0-9]*)?} \ 535 | $str result]} { 536 | # [][ integer part ][ optional ][ optional exponent ] 537 | # ^ sign [ frac. part] 538 | return $result 539 | } else { 540 | parse-error {can't parse JSON number: %s} $str 541 | } 542 | } 543 | 544 | # Return the error $formatString formatted with $str as its argument. 545 | # $str is quoted and, if long, truncated. 546 | proc ::json::parse-error {formatString json} { 547 | if {[string length $json] > 300} { 548 | set truncated "\"[string trimright [string range $json 0 149]] ... " 549 | append truncated [string trimleft [string range $json end-149 end]]\" 550 | } else { 551 | set truncated [list $json] 552 | } 553 | error [format $formatString $truncated] 554 | } 555 | -------------------------------------------------------------------------------- /mime.tcl: -------------------------------------------------------------------------------- 1 | # MIME type detection by filename extension. 2 | # Copyright (c) 2014-2016 D. Bohdan. 3 | # License: MIT. 4 | 5 | namespace eval ::mime { 6 | variable version 1.2.0 7 | 8 | variable mimeDataInverted { 9 | text/plain { 10 | makefile 11 | COPYING 12 | LICENSE 13 | README 14 | Makefile 15 | .c 16 | .conf 17 | .h 18 | .log 19 | .md 20 | .sh 21 | .tcl 22 | .terms 23 | .tm 24 | .txt 25 | .wiki 26 | .LICENSE 27 | .README 28 | } 29 | text/css .css 30 | text/csv .csv 31 | image/gif .gif 32 | application/gzip .gz 33 | text/html { 34 | .htm 35 | .html 36 | } 37 | image/jpeg { 38 | .jpg 39 | .jpeg 40 | } 41 | application/javascript .js 42 | application/json .json 43 | application/pdf .pdf 44 | image/png .png 45 | application/postscript .ps 46 | application/xhtml .xhtml 47 | application/xml .xml 48 | application/zip .zip 49 | } 50 | 51 | variable byFilename {} 52 | variable byExtension {} 53 | foreach {mimeType files} $mimeDataInverted { 54 | foreach file $files { 55 | if {[string index $file 0] eq "."} { 56 | lappend byExtension $file $mimeType 57 | } else { 58 | lappend byFilename $file $mimeType 59 | } 60 | } 61 | } 62 | unset mimeDataInverted 63 | } 64 | 65 | proc ::mime::type {filename} { 66 | variable byFilename 67 | variable byExtension 68 | set tail [file tail $filename] 69 | set ext [file extension $filename] 70 | if {[dict exists $byFilename $tail]} { 71 | return [dict get $byFilename $tail] 72 | } elseif {[dict exists $byExtension $ext]} { 73 | return [dict get $byExtension $ext] 74 | } else { 75 | return application/octet-stream 76 | } 77 | } 78 | -------------------------------------------------------------------------------- /rejim.tcl: -------------------------------------------------------------------------------- 1 | # A basic RESP2 Redis/Valkey/KeyDB/etc. client library. 2 | # Pronounced "regime" for some reason. 3 | # Copyright (c) 2019-2020, 2024 D. Bohdan. 4 | # License: MIT. 5 | 6 | namespace eval rejim { 7 | variable version 0.2.0 8 | 9 | variable jim [expr { ![catch { 10 | proc x y {} {} 11 | rename x {} 12 | }] }] 13 | 14 | if {$jim} { 15 | proc byte-range {string first last} { 16 | string byterange $string $first $last 17 | } 18 | proc byte-length string { 19 | string bytelength $string 20 | } 21 | } else { 22 | proc byte-range {string first last} { 23 | string range $string $first $last 24 | } 25 | proc byte-length string { 26 | string length $string 27 | } 28 | } 29 | } 30 | 31 | 32 | proc rejim::command {handle commandList} { 33 | fconfigure $handle -translation binary -buffering none 34 | 35 | puts -nonewline $handle [serialize $commandList] 36 | set result [parse $handle] 37 | return $result 38 | } 39 | 40 | 41 | proc rejim::parse handle { 42 | fconfigure $handle -translation binary -buffering none 43 | 44 | set typeByte [read $handle 1] 45 | set firstData [byte-range [read-until $handle \r] 0 end-1] 46 | read $handle 1 ;# Discard \n. 47 | 48 | switch -- $typeByte { 49 | + - 50 | - { 51 | set type [expr { $typeByte eq {+} ? {simple} : {error} }] 52 | return [list $type $firstData] 53 | } 54 | 55 | : { 56 | return [list integer $firstData] 57 | } 58 | 59 | $ { 60 | set len $firstData 61 | if {$len == -1} { 62 | return null 63 | } 64 | if {$len < -1} { 65 | error [list invalid bulk string length: $len] 66 | } 67 | 68 | set data [read $handle $len] 69 | read $handle 2 ;# Discard \r\n. 70 | 71 | return [list bulk $data] 72 | } 73 | 74 | * { 75 | set n $firstData 76 | if {$n < 0} { 77 | error [list invalid number of array elements: $n] 78 | } 79 | 80 | set list {} 81 | for {set i 0} {$i < $n} {incr i} { 82 | lappend list [parse $handle] 83 | } 84 | 85 | return [concat array $list] 86 | } 87 | 88 | default { 89 | error [list unknown message type: $typeByte] 90 | } 91 | } 92 | } 93 | 94 | 95 | proc rejim::read-until {handle needle} { 96 | fconfigure $handle -translation binary -buffering none 97 | 98 | # We only use this proc to find short strings. The performance of reading 99 | # one byte at a time shouldn't matter. 100 | if {[byte-length $needle] != 1} { 101 | error [list $needle isn't one byte] 102 | } 103 | 104 | set data {} 105 | 106 | while 1 { 107 | if {[eof $handle]} break 108 | set last [read $handle 1] 109 | append data $last 110 | if {$last eq $needle} break 111 | } 112 | 113 | if {[info exists last] && $last ne $needle} { 114 | error [list stream ended before $needle] 115 | } 116 | 117 | return $data 118 | } 119 | 120 | 121 | proc rejim::serialize list { 122 | set resp *[llength $list]\r\n 123 | foreach el $list { 124 | append resp $[byte-length $el]\r\n$el\r\n 125 | } 126 | 127 | return $resp 128 | } 129 | 130 | 131 | proc rejim::serialize-tagged tagged { 132 | set data [lassign $tagged tag] 133 | unset tagged 134 | 135 | switch -- $tag { 136 | array { 137 | return *[llength $data]\r\n[join [lmap x $data { 138 | serialize-tagged $x 139 | }] {}] 140 | } 141 | 142 | bulk { 143 | return \$[byte-length $data]\r\n$data\r\n 144 | } 145 | 146 | error - 147 | integer - 148 | simple { 149 | set c [dict get { 150 | error - 151 | integer : 152 | simple + 153 | } $tag] 154 | 155 | return $c$data\r\n 156 | } 157 | 158 | null { 159 | return \$-1\r\n 160 | } 161 | 162 | default { 163 | error [list unknown tag: $tag] 164 | } 165 | } 166 | } 167 | 168 | 169 | proc rejim::strip-tags {response {null %NULL%}} { 170 | set tag [lindex $response 0] 171 | 172 | switch -- $tag { 173 | bulk - 174 | error - 175 | integer - 176 | simple { 177 | return [lindex $response 1] 178 | } 179 | 180 | null { 181 | return $null 182 | } 183 | 184 | array { 185 | return [lmap x [lrange $response 1 end] { 186 | strip-tags $x $null 187 | }] 188 | } 189 | 190 | default { 191 | error [list unknown tag: $tag] 192 | } 193 | } 194 | } 195 | -------------------------------------------------------------------------------- /static.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbohdan/jimhttp/2cb1b6e69f98ee8b151eed296f00969cf80ea11a/static.jpg -------------------------------------------------------------------------------- /storage.tcl: -------------------------------------------------------------------------------- 1 | # Simple persistent key-value storage. 2 | # Copyright (c) 2014-2016 D. Bohdan. 3 | # License: MIT. 4 | namespace eval ::storage { 5 | variable version 0.2.0 6 | } 7 | 8 | set ::storage::db [proc ::storage::not-initialized args { 9 | error {::storage::db isn't initialized} 10 | }] 11 | 12 | # Open the SQLite3 database in the file $filename. Create the table if needed. 13 | proc ::storage::init {{filename ""}} { 14 | if {$filename eq ""} { 15 | set filename [file join [file dirname [info script]] storage.sqlite3] 16 | } 17 | 18 | set ::storage::db [sqlite3.open $filename] 19 | $::storage::db query { 20 | CREATE TABLE IF NOT EXISTS storage( 21 | key TEXT PRIMARY KEY, 22 | value TEXT 23 | ); 24 | } 25 | } 26 | 27 | # Store $value under $key. 28 | proc ::storage::put {key value} { 29 | $::storage::db query { 30 | INSERT OR REPLACE INTO storage(key, value) VALUES ('%s', '%s'); 31 | } $key $value 32 | } 33 | 34 | # Return the value under $key or "" if it doesn't exist. 35 | proc ::storage::get {key} { 36 | 37 | # The return format of query is {{key value ...} ...}. 38 | lindex [lindex [$::storage::db query { 39 | SELECT value FROM storage WHERE key = '%s' LIMIT 1; 40 | } $key] 0] 1 41 | } 42 | 43 | # Return 1 if a value exists under $key or 0 otherwise. 44 | proc ::storage::exists {key} { 45 | # The return format of query is {{key value ...} ...}. 46 | lindex [lindex [$::storage::db query { 47 | SELECT EXISTS(SELECT value FROM storage WHERE key = '%s' LIMIT 1); 48 | } $key] 0] 1 49 | } 50 | 51 | # Store the values of the variables listed in varNameList. 52 | proc ::storage::persist-var {varNameList} { 53 | foreach varName $varNameList { 54 | ::storage::put $varName [set $varName] 55 | } 56 | } 57 | 58 | # Set the variables listed in varNameList to their stored values. 59 | proc ::storage::restore-var {varNameList} { 60 | foreach varName $varNameList { 61 | set $varName [::storage::get $varName] 62 | } 63 | } 64 | 65 | proc ::storage::caller-full-name {{level 1}} { 66 | # Get the caller proc name without the namespace. 67 | set procName [lindex [split \ 68 | [lindex [info level -$level] 0] ::] end] 69 | # Get the caller proc namespace. This is needed to handle nested 70 | # namespaces since [info level] will only tell us the direct parent 71 | # namespace of the proc. 72 | set procNamespace [uplevel $level {namespace current}] 73 | return ${procNamespace}::${procName} 74 | } 75 | 76 | # Store the values of the static variables either of proc $procName or the 77 | # caller proc if $procName is "". 78 | proc ::storage::persist-statics {{procName ""}} { 79 | if {$procName eq ""} { 80 | set procName [::storage::caller-full-name 2] 81 | } 82 | foreach {key value} [info statics $procName] { 83 | ::storage::put ${procName}::${key} $value 84 | } 85 | } 86 | 87 | # Set the static variables of the caller proc to their stored values. 88 | proc ::storage::restore-statics {} { 89 | set procName [::storage::caller-full-name 2] 90 | foreach {varName _} [info statics $procName] { 91 | set key ${procName}::${varName} 92 | if {[::storage::exists $key]} { 93 | uplevel 1 [list set $varName [::storage::get $key]] 94 | } 95 | } 96 | } 97 | -------------------------------------------------------------------------------- /template.tcl: -------------------------------------------------------------------------------- 1 | # Templating engine. 2 | # Copyright (c) 2014-2016 D. Bohdan. 3 | # License: MIT. 4 | namespace eval ::template { 5 | variable version 1.0.0 6 | } 7 | 8 | # Convert a template into Tcl code. 9 | proc ::template::parse {template} { 10 | set result {} 11 | set regExpr {^(.*?)<%(.*?)%>(.*)$} 12 | set listing "set _output {}\n" 13 | while {[regexp $regExpr $template \ 14 | match preceding token template]} { 15 | append listing [list append _output $preceding]\n 16 | switch -exact -- [string index $token 0] { 17 | = { 18 | append listing \ 19 | [format {append _output [expr %s]} \ 20 | [list [string range $token 1 end]]] 21 | } 22 | ! { 23 | append listing \ 24 | [format {append _output [%s]} \ 25 | [string range $token 1 end]] 26 | } 27 | default { 28 | append listing $token 29 | } 30 | } 31 | append listing \n 32 | } 33 | append listing [list append _output $template]\n 34 | return $listing 35 | } 36 | -------------------------------------------------------------------------------- /testing.tcl: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env jimsh 2 | # A test framework with constraints. 3 | # Copyright (c) 2014-2016, 2019 D. Bohdan. 4 | # License: MIT. 5 | 6 | namespace eval ::testing { 7 | variable version 0.5.0 8 | 9 | namespace export * 10 | variable tests {} 11 | variable constraints {} 12 | } 13 | namespace eval ::testing::tests {} 14 | 15 | # Generate an error with $expression is not true. 16 | proc ::testing::assert {expression {message ""}} { 17 | if {![uplevel 1 [list expr $expression]]} { 18 | set errorMessage "Not true: $expression" 19 | if {$message ne ""} { 20 | append errorMessage " ($message)" 21 | } 22 | error $errorMessage 23 | } 24 | } 25 | 26 | # Compare all args for equality. 27 | proc ::testing::assert-equal args { 28 | set firstArg [lindex $args 0] 29 | foreach arg [lrange $args 1 end] { 30 | assert [list \"$arg\" eq \"$firstArg\"] 31 | } 32 | } 33 | 34 | # Tell if we are running Tcl 8.x or Jim Tcl. 35 | proc ::testing::engine {} { 36 | if {[catch {info tclversion}]} { 37 | return jim 38 | } else { 39 | return tcl 40 | } 41 | } 42 | 43 | # Return a value from dictionary like dict get would if it is there. 44 | # Otherwise return the default value. 45 | proc ::testing::dict-default-get {default dictionary args} { 46 | if {[dict exists $dictionary {*}$args]} { 47 | dict get $dictionary {*}$args 48 | } else { 49 | return $default 50 | } 51 | } 52 | 53 | # Create a new test $name with code $code. 54 | proc ::testing::test args { 55 | variable tests 56 | 57 | set name [lindex $args 0] 58 | set options [lrange $args 1 end] 59 | proc ::testing::tests::$name {} [dict get $options -body] 60 | dict set tests $name constraints [dict-default-get "" $options -constraints] 61 | } 62 | 63 | proc ::testing::unsat-constraints test { 64 | variable tests 65 | variable constraints 66 | 67 | set unsat {} 68 | 69 | foreach constraint [dict get $tests $test constraints] { 70 | if {$constraint ni $constraints} { 71 | lappend unsat $constraint 72 | } 73 | } 74 | 75 | return $unsat 76 | } 77 | 78 | 79 | # Run all or selected tests. 80 | proc ::testing::run-tests argv { 81 | variable constraints 82 | lappend constraints [::testing::engine] 83 | 84 | set testsToRun $argv 85 | set tests {} 86 | foreach testProc [lsort [info procs ::testing::tests::*]] { 87 | lappend tests [namespace tail $testProc] 88 | } 89 | if {$testsToRun in {"" "all"}} { 90 | set testsToRun $tests 91 | } 92 | 93 | set failed {} 94 | set skipped {} 95 | 96 | puts {running tests:} 97 | foreach test $tests { 98 | if {$test ni $testsToRun} { 99 | lappend skipped $test {user choice} 100 | continue 101 | } 102 | 103 | set unsat [::testing::unsat-constraints $test] 104 | if {$unsat eq {}} { 105 | puts "- $test" 106 | if {[catch { 107 | ::testing::tests::$test 108 | } msg opts]} { 109 | set stacktrace [expr { 110 | [::testing::engine] eq {jim} 111 | ? [errorInfo $msg [dict get $opts -errorinfo]] 112 | : [dict get $opts -errorinfo] 113 | }] 114 | puts "failed: $stacktrace" 115 | lappend failed $test $opts 116 | } 117 | } else { 118 | lappend skipped $test [concat constraints: $unsat] 119 | } 120 | } 121 | 122 | if {$skipped ne {}} { 123 | puts \nskipped: 124 | } 125 | foreach {test reason} $skipped { 126 | puts "- $test ($reason)" 127 | } 128 | 129 | set n(total) [llength $tests] 130 | set n(skipped) [expr {[llength $skipped] / 2}] 131 | set n(failed) [expr {[llength $failed] / 2}] 132 | set n(passed) [expr {$n(total) - $n(skipped) - $n(failed)}] 133 | puts \n[list total $n(total) \ 134 | passed $n(passed) \ 135 | skipped $n(skipped) \ 136 | failed $n(failed)] 137 | 138 | if {$failed ne {}} { 139 | exit 1 140 | } 141 | } 142 | -------------------------------------------------------------------------------- /tests.tcl: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env jimsh 2 | # Tests for the web framework and its modules. 3 | # Copyright (c) 2014-2016, 2018-2020, 2024 D. Bohdan. 4 | # License: MIT. 5 | 6 | source testing.tcl 7 | namespace import ::testing::* 8 | 9 | proc client-socket {server port} { 10 | # This code must run in Tcl 8.5-9. 11 | if {[catch { 12 | set ch [socket stream $server:$port] 13 | }]} { 14 | set ch [socket $server $port] 15 | } 16 | 17 | fconfigure $ch -translation binary 18 | return $ch 19 | } 20 | 21 | # A wrapper that hides some of the differences between an event-driven socket 22 | # server in Jim Tcl and Tcl 8. $script runs when a client connection becomes 23 | # readable with the client connection channel as its argument. 24 | proc server-socket {server port script} { 25 | # This code does not need to run in Tcl 8.5; we can use [try]. 26 | try { 27 | set ch [socket stream.server $server:$port] 28 | 29 | set lambda [list apply {{script ch} { 30 | set client [$ch accept] 31 | {*}$script $client 32 | }} $script $ch] 33 | 34 | fileevent $ch readable $lambda 35 | } on error _ { 36 | set lambda [list apply {{script ch args} { 37 | fconfigure $ch -blocking false 38 | fileevent $ch readable [list {*}$script $ch] 39 | }} $script] 40 | 41 | set ch [socket -server $lambda -myaddr $server $port] 42 | } 43 | 44 | return $ch 45 | } 46 | 47 | # Set the test constraints. 48 | set redisServer {127.0.0.1 6379} 49 | if { ![catch { close [client-socket {*}$redisServer] }] } { 50 | lappend ::testing::constraints redis 51 | } 52 | apply {{} { 53 | if { ![catch { exec redis-cli --version } version] 54 | && [regexp {(\d+)\.\d+\.\d+} $version _ major] 55 | && $major >= 4 } { 56 | lappend ::testing::constraints redis-cli 57 | } 58 | }} 59 | if {![string match 8.5.* [info patchlevel]]} { 60 | lappend ::testing::constraints not-8.5 61 | } 62 | 63 | # http.tcl tests 64 | test http \ 65 | -constraints jim \ 66 | -body { 67 | source http.tcl 68 | 69 | assert-equal \ 70 | [::http::get-route-variables \ 71 | {/hello/:name/:town} {/hello/john/smallville}] \ 72 | [::http::get-route-variables \ 73 | {/hello/:name/:town} {/hello/john/smallville/}] \ 74 | [::http::get-route-variables \ 75 | {/hello/there/:name/:town} {/hello/there/john/smallville/}]\ 76 | [::http::get-route-variables \ 77 | {/hello/:name/from/:town} {/hello/john/from/smallville/}] 78 | 79 | assert-equal \ 80 | [::http::get-route-variables \ 81 | {/bye/:name/:town} {/hello/john/smallville/}] \ 82 | 0 83 | 84 | assert-equal [::http::form-decode a=b&c=d] [dict create {*}{ 85 | a b c d 86 | }] 87 | 88 | assert-equal \ 89 | [::http::form-decode message=Hello%2C+world%21] \ 90 | [dict create {*}{ 91 | message {Hello, world!} 92 | }] 93 | 94 | 95 | assert-equal [::http::string-bytefirst c abcdef] 2 96 | assert-equal [::http::string-bytefirst f abcdef] 5 97 | assert-equal [::http::string-bytefirst е тест] 2 98 | assert-equal [::http::string-bytefirst world helloworld] 5 99 | assert-equal [::http::string-bytefirst тест мегатест] 8 100 | 101 | 102 | set seq ----sepfoo----сепbar----sepbaz\u0001----sep 103 | assert-equal [::http::string-pop seq ----sep] {} 104 | assert-equal [::http::string-pop seq ----сеп] foo 105 | assert-equal [::http::string-pop seq --sep] bar-- 106 | assert-equal [::http::string-pop seq ----sep] baz\u0001 107 | assert-equal [::http::string-pop seq ----sep] {} 108 | assert-equal $seq {} 109 | 110 | 111 | set postString " 112 | Content-Disposition: form-data; name=\"image file\" filename=\"bar.png\" 113 | Content-Type: application/octet-stream 114 | 115 | \u00ff\u00ff\u00ff\u0001\u0002\u0003\u0004\u0005 116 | ------------------------38d79e1985ee3bbf" 117 | assert-equal [::http::string-pop postString \ 118 | ------------------------38d79e1985ee3bbf] \ 119 | " 120 | Content-Disposition: form-data; name=\"image file\" filename=\"bar.png\" 121 | Content-Type: application/octet-stream 122 | 123 | \u00ff\u00ff\u00ff\u0001\u0002\u0003\u0004\u0005 124 | " 125 | assert-equal $postString {} 126 | 127 | set contentType {multipart/form-data; boundary=------------------------38d79e1985ee3bbf} 128 | set formData "--------------------------38d79e1985ee3bbf 129 | Content-Disposition: form-data; name=\"text\" 130 | 131 | This is text. 132 | --------------------------38d79e1985ee3bbf 133 | Content-Disposition: form-data; name=\"text file\" filename=\"foo.txt\" 134 | 135 | Hello. 136 | --------------------------38d79e1985ee3bbf 137 | Content-Disposition: form-data; name=\"image file\" filename=\"bar.png\" 138 | Content-Type: application/octet-stream 139 | 140 | \u00ff\u0001\u0002\u0003\u0004\u0005 141 | --------------------------38d79e1985ee3bbf" 142 | set parsed [::http::parse-multipart-data $formData $contentType \n] 143 | 144 | assert-equal [dict get $parsed formPost text] {This is text.} 145 | assert-equal [dict get $parsed formPost {text file}] Hello. 146 | assert-equal [dict get $parsed formPost {image file}] \ 147 | \u00ff\u0001\u0002\u0003\u0004\u0005 148 | 149 | assert-equal [dict keys $parsed] formPost 150 | assert-equal [lsort [dict keys $parsed(formPost)]] \ 151 | {{image file} text {text file}} 152 | } 153 | 154 | # html.tcl tests 155 | test html \ 156 | -body { 157 | source html.tcl 158 | 159 | foreach t {{!@#$%^&*()_+} {Hello!}} { 160 | assert-equal [::html::unescape [html::escape $t]] $t 161 | } 162 | 163 | assert-equal [b "Hello!"] [b "" "Hello!"] {Hello!} 164 | assert-equal [br] [br ""] {
} 165 | 166 | assert-equal [::html::make-table {{a b} {c d}}] \ 167 | {
ab
cd
} 168 | } 169 | 170 | # json.tcl tests 171 | test json \ 172 | -body { 173 | source json.tcl 174 | 175 | set d [dict create {*}{ 176 | array {0 Tokyo 1 Seoul 2 Shanghai} 177 | object {Tokyo 37.8 Seoul 25.62 Shanghai 24.75} 178 | }] 179 | 180 | assert-equal [::json::tokenize {"a"}] [list [list STRING a]] 181 | assert-equal [::json::tokenize {"ab\nc\"de"}] \ 182 | [list [list STRING ab\nc\"de]] 183 | 184 | assert-equal [::json::tokenize {0}] [list [list NUMBER 0]] 185 | assert-equal [::json::tokenize {0.}] [list [list NUMBER 0.]] 186 | assert-equal [::json::tokenize {-0.1234567890}] \ 187 | [list [list NUMBER -0.1234567890]] 188 | assert-equal [::json::tokenize {-525}] [list [list NUMBER -525]] 189 | assert-equal [::json::tokenize {1E100}] [list [list NUMBER 1E100]] 190 | assert-equal [::json::tokenize {1.23e-99}] [list [list NUMBER 1.23e-99]] 191 | assert-equal [::json::tokenize {1.23e-99, 0, 0}] [list \ 192 | [list NUMBER 1.23e-99] COMMA \ 193 | [list NUMBER 0] COMMA \ 194 | [list NUMBER 0]] 195 | 196 | assert-equal [::json::tokenize true] [list [list RAW true]] 197 | assert-equal [::json::tokenize false] [list [list RAW false]] 198 | assert-equal [::json::tokenize null] [list [list RAW null]] 199 | 200 | assert-equal [::json::parse {[1.23e-99, 0, 0]} 0] \ 201 | [list 1.23e-99 0 0] 202 | assert-equal [::json::parse {[ 1.23e-99, 0, 0 ]} 0] \ 203 | [list 1.23e-99 0 0] 204 | assert-equal [::json::parse {[1.23e-99, "a", [1,2,3]]} 0] \ 205 | [list 1.23e-99 a {1 2 3}] 206 | assert-equal [::json::parse {["alpha", "beta", "gamma"]} 0] \ 207 | [list alpha beta gamma] 208 | assert-equal [::json::parse {["alpha", "beta", "gamma"]} 1] \ 209 | [list 0 alpha 1 beta 2 gamma] 210 | assert-equal [::json::parse {[true, false,null ]} 1] \ 211 | [list 0 true 1 false 2 null] 212 | assert-equal [::json::parse {[]} 1] \ 213 | [list] 214 | 215 | 216 | assert-equal [::json::parse {{"key": "value"}} 0] \ 217 | [list key value] 218 | assert-equal \ 219 | [::json::parse {{ "key" : "value" }} 0] \ 220 | [list key value] 221 | assert-equal [::json::parse "\t{\t \"key\"\t: \n\"value\"\n\r}" 0] \ 222 | [list key value] 223 | assert-equal [::json::parse {{"key": [1, 2, 3]}} 0] \ 224 | [list key {1 2 3}] 225 | assert-equal \ 226 | [::json::parse {{"k1": true, "k2": false, "k3": null}} 0] \ 227 | [list k1 true k2 false k3 null] 228 | assert-equal [::json::parse {{}}] [list] 229 | assert-equal [::json::parse {[] }] [list] 230 | 231 | assert-equal [::json::parse [::json::stringify $d 1] 1] $d 232 | 233 | assert-equal [::json::stringify 0] 0 234 | assert-equal [::json::stringify 0.5] 0.5 235 | assert-equal [::json::stringify Hello] {"Hello"} 236 | assert-equal [::json::stringify {key value}] {{"key": "value"}} 237 | assert-equal \ 238 | [::json::stringify {0 a 1 b 2 c} 0] \ 239 | {{"0": "a", "1": "b", "2": "c"}} 240 | assert-equal \ 241 | [::json::stringify {0 a 1 b 2 c} 1] \ 242 | {["a", "b", "c"]} 243 | 244 | # Invalid JSON. 245 | assert {[catch {::json::parse x}]} 246 | # Trailing garbage. 247 | assert {[catch {::json::parse {"Hello" blah}}]} 248 | 249 | assert-equal [::json::subset {a b c} {a b c d e f}] 1 250 | assert-equal [::json::subset {a b c d e f} {a b c}] 0 251 | assert-equal [::json::subset {a b c d e f} {}] 0 252 | assert-equal [::json::subset {} {a b c}] 1 253 | assert-equal [::json::subset a a] 1 254 | 255 | # Schema tests. 256 | 257 | assert-equal [::json::stringify 0 1 number] 0 258 | assert-equal [::json::stringify 0 1 string] \"0\" 259 | assert-equal [::json::stringify 0 1 boolean] false 260 | assert-equal [::json::stringify false 1 boolean] false 261 | assert-equal [::json::stringify off 1 boolean] false 262 | assert-equal [::json::stringify no 1 boolean] false 263 | assert-equal [::json::stringify 1 1 boolean] true 264 | assert-equal [::json::stringify true 1 boolean] true 265 | assert-equal [::json::stringify on 1 boolean] true 266 | assert-equal [::json::stringify yes 1 boolean] true 267 | assert-equal [::json::stringify null 1 null] null 268 | 269 | assert {[catch {::json::stringify 0 1 object}]} 270 | assert {[catch {::json::stringify 0 1 noise}]} 271 | assert {[catch {::json::stringify 0 1 array}]} 272 | assert {[catch {::json::stringify x 1 boolean}]} 273 | assert {[catch {::json::stringify x 1 null}]} 274 | 275 | assert-equal \ 276 | [::json::stringify \ 277 | {key1 true key2 0.5 key3 1} 1 \ 278 | {key1 boolean key2 number key3 number}] \ 279 | {{"key1": true, "key2": 0.5, "key3": 1}} 280 | assert-equal \ 281 | [::json::stringify \ 282 | {key1 true key2 0.5 key3 1} 1 \ 283 | {key1 string key2 string key3 string}] \ 284 | {{"key1": "true", "key2": "0.5", "key3": "1"}} 285 | assert-equal \ 286 | [::json::stringify {key1 {0 a 1 b}} 1 ""] \ 287 | [::json::stringify {key1 {0 a 1 b}} 1 {key1 ""}] \ 288 | [::json::stringify {key1 {0 a 1 b}} 1 {key1 {0 string 1 string}}] \ 289 | {{"key1": ["a", "b"]}} 290 | assert {[catch { 291 | ::json::stringify {key1 {0 a 1 b}} 1 {key1 {0 string 2 string}} 1 292 | }]} 293 | assert {[catch { 294 | ::json::stringify {key1 {0 a 1 b}} 1 {key1 {0 boolean}} 295 | }]} 296 | 297 | assert-equal [::json::stringify {} 1 ""] {""} 298 | assert-equal [::json::stringify {} 1 string] {""} 299 | assert-equal [::json::stringify {key {}} 1 ""] {{"key": ""}} 300 | assert-equal [::json::stringify {0 {} 1 {}} 1 ""] {["", ""]} 301 | assert-equal [::json::stringify {} 1 array] {[]} 302 | assert-equal [::json::stringify {} 1 object] "{}" 303 | assert-equal \ 304 | [::json::stringify \ 305 | {0 1 1 {0 1} 2 {0 x 1 null}} 1 \ 306 | {0 boolean 1 {0 boolean} 2 array}] \ 307 | {[true, [true], ["x", null]]} 308 | assert-equal \ 309 | [::json::stringify \ 310 | {key1 1 key2 {0 1} key3 {0 x 1 null}} 1 \ 311 | {0 boolean 1 {0 boolean} 2 array}] \ 312 | {{"key1": 1, "key2": [1], "key3": ["x", null]}} 313 | 314 | assert-equal \ 315 | [::json::stringify {1 {key 1} 2 {x null} 3} 0 array] \ 316 | {[1, {"key": 1}, 2, {"x": null}, 3]} 317 | assert-equal \ 318 | [::json::stringify {1 {key 1} 2 {x null} 3} 0 string] \ 319 | {"1 {key 1} 2 {x null} 3"} 320 | assert-equal \ 321 | [::json::stringify {1 {key 1} 2 {x null} 3} 0 \ 322 | {string string string string string}] \ 323 | {["1", "key 1", "2", "x null", "3"]} 324 | assert-equal \ 325 | [::json::stringify {0 {key 1} 1 {x null}} 1 {*element* string}] \ 326 | {["key 1", "x null"]} 327 | assert-equal \ 328 | [::json::stringify {1 {key 1} 2 {x null}} 1 {*value* string}] \ 329 | {{"1": "key 1", "2": "x null"}} 330 | assert-equal \ 331 | [::json::stringify {key {true false null}} 0 \ 332 | {key {string string string}}]\ 333 | {{"key": ["true", "false", "null"]}} 334 | assert-equal \ 335 | [::json::stringify {0 {n 1 s 1}} 0 {0 {n number s string}}] \ 336 | {{"0": {"n": 1, "s": "1"}}} 337 | 338 | assert-equal \ 339 | [::json::stringify2 {1 {key 1} 2 {x null} 3} \ 340 | -numberDictArrays 0 \ 341 | -schema array \ 342 | -compact 1] \ 343 | {[1,{"key":1},2,{"x":null},3]} 344 | assert-equal \ 345 | [::json::stringify2 {1 {key 1} 2 {x null} 3} \ 346 | -numberDictArrays 0 \ 347 | -schema {string string string string string} \ 348 | -compact 1] \ 349 | {["1","key 1","2","x null","3"]} 350 | assert-equal \ 351 | [::json::stringify2 {1 {key 1} 2 {x null} 3 null} \ 352 | -numberDictArrays 0 \ 353 | -schema {string string string string string string} \ 354 | -compact 1] \ 355 | {["1","key 1","2","x null","3","null"]} 356 | assert-equal \ 357 | [::json::stringify2 {1 {key 1} 2 {x null}} \ 358 | -numberDictArrays 0 \ 359 | -schema {1 string 2 string} \ 360 | -compact 1] \ 361 | {{"1":"key 1","2":"x null"}} 362 | assert-equal \ 363 | [::json::stringify2 {0 {key 1} 1 {x null}} \ 364 | -numberDictArrays 1 \ 365 | -schema {*element* string} \ 366 | -compact 1] \ 367 | {["key 1","x null"]} 368 | assert-equal \ 369 | [::json::stringify2 {1 {key 1} 2 {x null}} \ 370 | -numberDictArrays 0 \ 371 | -schema {1 string 2 string} \ 372 | -compact 1] \ 373 | {{"1":"key 1","2":"x null"}} 374 | assert-equal \ 375 | [::json::stringify2 {1 {key 1} 2 {x null}} \ 376 | -numberDictArrays 0 \ 377 | -schema {*value* string} \ 378 | -compact 1] \ 379 | {{"1":"key 1","2":"x null"}} 380 | assert-equal \ 381 | [::json::stringify2 {key {true false null}} \ 382 | -numberDictArrays 0 \ 383 | -schema {key {string string string}} \ 384 | -compact 1] \ 385 | {{"key":["true","false","null"]}} 386 | assert-equal \ 387 | [::json::stringify2 {a 0 b 1 c 2} \ 388 | -numberDictArrays 1 \ 389 | -schema {*value* string c number} \ 390 | -compact 1] \ 391 | {{"a":"0","b":"1","c":2}} 392 | assert-equal \ 393 | [::json::stringify2 {a 123 b {456 789}} \ 394 | -numberDictArrays 0 \ 395 | -schema {a string b {*element* number}} \ 396 | -strictSchema 1] \ 397 | {{"a": "123", "b": [456, 789]}} 398 | assert-equal \ 399 | [::json::stringify2 {a b c d} \ 400 | -numberDictArrays 0 \ 401 | -schema {*element* {}} \ 402 | -strictSchema 1] \ 403 | {["a", "b", "c", "d"]} 404 | assert {[catch {::json::stringify2 {a 0 b 1} \ 405 | -numberDictArrays 0 \ 406 | -schema {a string} \ 407 | -strictSchema 1]}]} 408 | assert-equal \ 409 | [::json::stringify2 {a 0 b 1} \ 410 | -numberDictArrays 0 \ 411 | -schema {a string *value* string } \ 412 | -strictSchema 1] \ 413 | {{"a": "0", "b": "1"}} 414 | assert {[catch {::json::stringify2 {a 0 b 1} -foo bar]}]} 415 | 416 | # String escaping. 417 | 418 | assert-equal [::json::stringify {"Hello, world!"}] \ 419 | {"\"Hello, world!\""} 420 | assert-equal [::json::stringify2 "a\nb" \ 421 | -schema string] \ 422 | {"a\nb"} 423 | 424 | assert-equal [::json::stringify2 "a/b/c/ c:\\b\\a\\" \ 425 | -schema string] \ 426 | {"a/b/c/ c:\\b\\a\\"} 427 | 428 | assert-equal [::json::stringify2 "\b\f\n\r\t" \ 429 | -schema string] \ 430 | {"\b\f\n\r\t"} 431 | 432 | set s {} 433 | for {set i 0} {$i < 32} {incr i} { 434 | append s [format %c $i] 435 | } 436 | assert-equal [::json::stringify2 $s -schema string] \ 437 | \"[join [list \\u0000 \\u0001 \\u0002 \\u0003 \ 438 | \\u0004 \\u0005 \\u0006 \\u0007 \ 439 | \\b \\t \\n \\u000b \ 440 | \\f \\r \\u000e \\u000f \ 441 | \\u0010 \\u0011 \\u0012 \\u0013 \ 442 | \\u0014 \\u0015 \\u0016 \\u0017 \ 443 | \\u0018 \\u0019 \\u001a \\u001b \ 444 | \\u001c \\u001d \\u001e \\u001f] {}]\" 445 | assert-equal [::json::parse [::json::stringify2 $s -schema string]] \ 446 | $s 447 | unset s 448 | # Only perform the following test if [regexp] supports Unicode character 449 | # indices or this isn't a UTF-8 build. 450 | if {[regexp -inline -start 1 . こ] eq {}} { 451 | assert-equal [::json::parse {{"тест": "こんにちは世界"}}] \ 452 | {тест こんにちは世界} 453 | } 454 | 455 | assert-equal [::json::stringify2 {{"key space"} value}] \ 456 | {{"\"key space\"": "value"}} 457 | 458 | assert-equal [::json::stringify2 {} \ 459 | -schema string] \ 460 | {"