├── logo.png ├── install-macos.tcl ├── pkgIndex.tcl ├── install-freebsd.tcl ├── toolatra_mustache.tcl ├── LICENSE ├── toolatra_templates.tcl ├── toolatra_auth.tcl ├── README.asciidoc └── toolatra_http.tcl /logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/humansinput/toolatra/HEAD/logo.png -------------------------------------------------------------------------------- /install-macos.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | set directory "$::env(HOME)/Library/Tcl/toolatra-master" 3 | if {[file isdirectory $directory]} { 4 | file delete -force $directory 5 | } 6 | 7 | file mkdir $directory 8 | foreach fn {toolatra_http.tcl toolatra_templates.tcl toolatra_auth.tcl toolatra_mustache.tcl pkgIndex.tcl} { 9 | file copy $fn "$directory/$fn" 10 | } 11 | 12 | puts done 13 | exit 0 14 | 15 | -------------------------------------------------------------------------------- /pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | global toolatraIsPackaged 3 | set toolatraIsPackaged 1 4 | package ifneeded Toolatra 19.12 [list source "$dir/toolatra_http.tcl"] 5 | package ifneeded ToolatraTemplates 19.11 [list source "$dir/toolatra_templates.tcl"] 6 | package ifneeded ToolatraAuth 19.12 [list source "$dir/toolatra_auth.tcl"] 7 | package ifneeded ToolatraMustache 20.06 [list source "$dir/toolatra_mustache.tcl"] -------------------------------------------------------------------------------- /install-freebsd.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | if {$::env(USER) != {root}} { 3 | puts "Please run this script as root." 4 | exit 1 5 | } 6 | 7 | set dirv /usr/local/lib 8 | set dirb "$dirv/toolatra" 9 | if {! [file isdirectory $dirb]} { 10 | file mkdir -- $dirb 11 | } 12 | 13 | foreach fn {toolatra_http.tcl toolatra_auth.tcl toolatra_templates.tcl toolatra_mustache.tcl pkgIndex.tcl} { 14 | file copy $fn "$dirb/$fn" 15 | } 16 | 17 | puts done 18 | exit 0 19 | -------------------------------------------------------------------------------- /toolatra_mustache.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | # Toolatra - Sinatra-like web microframework for Tcl 8.5/8.6 3 | # Copyright (C) Tim K/RoverAMD 2018-2020 . 4 | # 5 | # File: toolatra_mustache.tcl 6 | # Description: Bare-bones support for Mustache templates for Toolatra web applications 7 | # License: MIT License 8 | 9 | proc mustache {fn items} { 10 | set fnReal "[pwd]/templates/$fn.mustache" 11 | if {! [file exists "$fnReal"]} { 12 | error "No Mustache template available with name '$fn' (looked for it at '$fnReal')" 13 | } 14 | set desc [open $fnReal r] 15 | set ctnt [read $desc] 16 | close $desc 17 | foreach key [info globals] { 18 | global $key 19 | dict set items $key [eval "\$$key"] 20 | } 21 | show [::mustache::mustache $ctnt $items] 22 | } 23 | 24 | package provide ToolatraMustache 20.06 25 | package require Tcl 8.5 26 | package require mustache 1.1.3 -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Tim K 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /toolatra_templates.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | # Toolatra - Sinatra-like web microframework for Tcl 8.5/8.6 3 | # Copyright (C) Tim K/RoverAMD 2018-2019 . 4 | # 5 | # File: toolatra_templates.tcl 6 | # Description: Addon for Toolatra that allows rendering templates 7 | # License: MIT License 8 | 9 | proc _toolatra_varpingpong {vr} { 10 | return $vr 11 | } 12 | 13 | proc _toolatra_template_load {relPath {context -1}} { 14 | if {$context != -1} { 15 | dict for {key val} $context { 16 | set $key $val 17 | } 18 | } 19 | foreach key [info globals] { 20 | global $key 21 | } 22 | set desc [open $relPath r] 23 | set contents [read $desc] 24 | close $desc 25 | set result "" 26 | set tmpEval "" 27 | set insideEval 0 28 | for {set index 0} {$index < [string length $contents]} {incr index} { 29 | set cchar [string index $contents $index] 30 | if {$cchar == "@"} { 31 | set cchar2 [string index $contents [expr $index+1]] 32 | if {$cchar2=="@"} { 33 | incr index ; 34 | set result "$result@" ; 35 | continue ; 36 | } 37 | if {$insideEval} { 38 | set insideEval 0 39 | if {[info exists $tmpEval]} { 40 | set result "$result[eval "_toolatra_varpingpong \$$tmpEval"]" 41 | } elseif {[string index $tmpEval 0] == {!}} { 42 | set substrTmpEval [string trim [string range $tmpEval 1 end]] 43 | set result "$result[layout $substrTmpEval $context]" 44 | } else { 45 | set result "$result[eval $tmpEval]" 46 | } 47 | set tmpEval "" 48 | } else { 49 | set insideEval 1 50 | set tmpEval "" 51 | } 52 | } elseif {$insideEval} { 53 | set tmpEval "$tmpEval$cchar" 54 | } else { 55 | set result "$result$cchar" 56 | } 57 | } 58 | return $result 59 | } 60 | 61 | proc layout {name {cntx -1}} { 62 | set layoutsDir "[pwd]/layouts" 63 | set lt "$layoutsDir/$name" 64 | if {! [file exists $lt]} { 65 | return "No such file or directory - \"$lt\" (layout: $name)." 66 | } else { 67 | return [_toolatra_template_load $lt $cntx] 68 | } 69 | } 70 | 71 | proc etcl {name {cntx -1}} { 72 | set relPath [pwd]/templates/$name 73 | if {! [file exists $relPath]} { 74 | error "No such file or directory - \"$relPath\"." 75 | } 76 | show [_toolatra_template_load $relPath $cntx] 77 | } 78 | 79 | package provide ToolatraTemplates 19.11 80 | package require Toolatra 19.10 81 | package require Tcl 8.5 82 | -------------------------------------------------------------------------------- /toolatra_auth.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | # Toolatra - Sinatra-like web microframework for Tcl 8.5/8.6 3 | # Copyright (C) Tim K/RoverAMD 2018-2019 . 4 | # 5 | # File: toolatra_auth.tcl 6 | # Description: Authorization module for Toolatra framework 7 | # License: MIT License 8 | 9 | proc _toolatra_auth_isValid {vt} { 10 | if {[string length $vt] != 4} { 11 | return 0 12 | } 13 | set charactersMet {} 14 | for {set index 0} {$index < 4} {incr index} { 15 | set chr [string index $vt $index] 16 | if {[lsearch -exact $charactersMet $chr] >= 0} { 17 | return 0 18 | } else { 19 | lappend charactersMet $chr 20 | } 21 | } 22 | return 1 23 | } 24 | 25 | if {! [info exists toolatra_auth] || ! [_toolatra_auth_isValid $toolatra_auth]} { 26 | error "Please set the value of the global variable \"toolatra_auth\" to a 4-character string, where each character must be unique. Notice that the variable must exist before including the ToolatraAuth module." 27 | } 28 | 29 | proc _toolatra_auth_mkMap {vt} { 30 | set map [dict create + [string index $vt 0] / [string index $vt 1] x [string index $vt 2] M [string index $vt 3]] 31 | return $map 32 | } 33 | 34 | proc _toolatra_auth_reverseMap {mp} { 35 | set result [dict create] 36 | dict for {keyVar valueVar} $mp { 37 | dict set result $valueVar $keyVar 38 | } 39 | return $result 40 | } 41 | 42 | proc _toolatra_auth_pretifyBase {bs} { 43 | global toolatra_auth 44 | set map [_toolatra_auth_mkMap $toolatra_auth] 45 | return [string map $map $bs] 46 | } 47 | 48 | proc _toolatra_auth_decodeToken {tkn} { 49 | global toolatra_auth 50 | set splitTkn [split $tkn +] 51 | if {[llength $splitTkn] < 2} { 52 | return {} 53 | } 54 | set tknV [join [lreplace $splitTkn 0 0] +] 55 | #puts "tknV is $tknV" 56 | set map [_toolatra_auth_reverseMap [_toolatra_auth_mkMap $toolatra_auth]] 57 | set tknDec [string map $map $tknV] 58 | return [base64::decode $tknDec] 59 | } 60 | 61 | proc token {ctnt {expires -1}} { 62 | set finalDate [expr {[clock seconds] + $expires}] 63 | if {$expires < 0} { 64 | set finalDate [expr {[clock seconds] + (int(rand() * 1000) * 60 * 60 * 24)}] 65 | } 66 | set formatted "$finalDate+$ctnt" 67 | return "$finalDate+[_toolatra_auth_pretifyBase [base64::encode $formatted]]" 68 | } 69 | 70 | proc tokenValid {tkn} { 71 | global toolatra_auth 72 | set date1 [lindex [split $tkn +] 0] 73 | if {! [string is integer $date1]} { 74 | return 0 75 | } 76 | set decTkn [_toolatra_auth_decodeToken $tkn] 77 | set date2 [lindex [split $decTkn +] 0] 78 | if {! [string is integer $date2]} { 79 | return 0 80 | } 81 | if {$date2 == $date1 && [clock seconds] <= $date2} { 82 | return 1 83 | } 84 | return 0 85 | } 86 | 87 | proc tokenValue {tkn} { 88 | global toolatra_auth 89 | if {! [tokenValid $tkn]} { 90 | return {} 91 | } 92 | set decTkn [_toolatra_auth_decodeToken $tkn] 93 | set decTknSplit [split $decTkn +] 94 | return [join [lreplace $decTknSplit 0 0] +] 95 | } 96 | 97 | package provide ToolatraAuth 19.12 98 | package require Toolatra 19.12 99 | package require base64 100 | package require Tcl 8.5 101 | -------------------------------------------------------------------------------- /README.asciidoc: -------------------------------------------------------------------------------- 1 | image::logo.png[] 2 | 3 | = Toolatra 4 | 5 | https://wiki.tcl-lang.org/page/Toolatra 6 | 7 | The simplicity of Sinatra brought to Tcl. 8 | 9 | [source,tcl] 10 | ---- 11 | package require Toolatra 12 | 13 | get / { 14 | show "Good morning!" 15 | } 16 | 17 | run 18 | ---- 19 | 20 | 21 | *Toolatra* is a micro web framework that is very similar to Sinatra, but is ported to Tcl. 22 | 23 | == What does it have? 24 | [squares] 25 | - Sinatra-like syntax 26 | - A module that provides a fully-featured template engine 27 | - Built-in web server that integrates easily with Nginx or Apache 28 | - A module for generating and validating authorization tokens 29 | 30 | == Installation 31 | === On macOS 32 | 33 | [source,bash] 34 | ---- 35 | $ tclsh8.5 install-macos.tcl 36 | ---- 37 | 38 | === On Ubuntu Linux 39 | 40 | [source,bash] 41 | ---- 42 | $ sudo sh 43 | $ mkdir -v /usr/share/tcltk/toolatra 44 | $ cp -r -v *.tcl /usr/share/tcltk/toolatra/ 45 | $ exit 46 | ---- 47 | 48 | == Usage 49 | Handling a GET request to a specific path: 50 | 51 | [source,tcl] 52 | ---- 53 | package require Toolatra 54 | 55 | get / { 56 | show {Hello there, stranger!} 57 | } 58 | 59 | run 60 | ---- 61 | 62 | If you save and run this file with tclsh and then go to http://127.0.0.1:5050, you should see ``Hello there, stranger!``. 63 | 64 | _SPOILER!_ Specifying the port number on which the server should be ran to the ``run`` command will start Toolatra's server on that port. 65 | 66 | Throwing HTTP errors: 67 | 68 | [source,tcl] 69 | ---- 70 | package require Toolatra 71 | 72 | get /this-will-cause-an-error { 73 | error 404 74 | } 75 | 76 | run 77 | ---- 78 | 79 | 80 | By default, Toolatra's ugly error handler will be used. To replace it with a custom one, just define a GET request handler with the path set to ``/``. Example: 81 | 82 | [source,tcl] 83 | ---- 84 | package require Toolatra 85 | 86 | get /404 { 87 | show "Whoops, an error has occured." 88 | } 89 | 90 | get /this-will-cause-an-error { 91 | error 404 92 | } 93 | 94 | run 95 | ---- 96 | 97 | Serving additional headers: 98 | 99 | [source,tcl] 100 | ---- 101 | package require Toolatra 102 | 103 | get / { 104 | header Content-type text/plain 105 | show {Look, I'm plain text!} 106 | } 107 | 108 | run 109 | ---- 110 | 111 | Using templates: 112 | 113 | [source,tcl] 114 | ---- 115 | package require Toolatra 116 | package require ToolatraTemplates 117 | 118 | get / { 119 | etcl index.html [dict create name Tim] 120 | } 121 | 122 | run 123 | ---- 124 | 125 | Example contents of ``index.html`` (it must be located in ``templates`` folder): 126 | 127 | [source,html] 128 | ---- 129 |

Hello there, @name@!

130 |

Did you know that I can run Tcl code from here? Just look: 2 + 2 = @expr {2+2}@

131 | ---- 132 | 133 | Speaking of templates, you don't have to use Toolatra's template engine - you can use Mustache templates if you want in a pretty similar manner (you'll need ianka's mustache.tcl library installed first, though); 134 | 135 | [source,tcl] 136 | ---- 137 | package require Toolatra 19.12 138 | package require ToolatraMustache 20.06 ;# needed for Mustache templates to work 139 | 140 | get / { 141 | mustache greeter.html [dict create name Tim] 142 | } 143 | 144 | ---- 145 | 146 | Example contents of ``greeter.html.mustache`` located inside the ``templates`` folder: 147 | 148 | [source,html] 149 | ---- 150 |

Hello again, {{name}}!

151 | ---- 152 | 153 | Serving dynamically-generated binary data: 154 | 155 | [source,tcl] 156 | ---- 157 | package require Toolatra 19.12 158 | 159 | get / { 160 | set binDtDesc [open a.out r] 161 | fconfigure $binDtDesc -translation binary -encoding binary 162 | set ctnt [read $binDtDesc] 163 | close $binDtDesc 164 | bshow $ctnt application/octet-stream ;# or brender 165 | } 166 | ---- 167 | 168 | Accessing query string parameters: 169 | 170 | [source,tcl] 171 | ----- 172 | package require Toolatra 173 | package require ToolatraTemplates 174 | 175 | get / { 176 | if {[dict exists $params name]} { 177 | show "Hello, [dict get $params name]!" 178 | } else { 179 | etcl form.html 180 | } 181 | } 182 | 183 | run 184 | ----- 185 | 186 | ``form.html`` template: 187 | 188 | [source,html] 189 | ---- 190 |
191 |

Your name:

192 |
193 | ---- 194 | 195 | This Tcl wiki page contains some useful examples on using templates and layouts: https://wiki.tcl-lang.org/page/Toolatra 196 | 197 | Accessing header values: 198 | 199 | [source,tcl] 200 | ---- 201 | package require Toolatra 202 | 203 | get / { 204 | if {[dict exists $params User-Agent]} { 205 | show [dict get $params User-Agent] 206 | } else { 207 | show None 208 | } 209 | } 210 | 211 | run 212 | ---- 213 | 214 | Redirecting to other pages: 215 | 216 | [source,tcl] 217 | ---- 218 | package require Toolatra 219 | 220 | get / { 221 | redirect http://example.com 222 | } 223 | 224 | 225 | run 226 | ---- 227 | 228 | Handling POST requests with data: 229 | 230 | [source,tcl] 231 | ---- 232 | package require Toolatra 233 | 234 | post / { 235 | render "Data sent: $rawData" 236 | } 237 | 238 | get / { 239 | render "Params/headers sent: $params" 240 | } 241 | 242 | run 243 | ---- 244 | 245 | Handling cookies: 246 | 247 | [source,tcl] 248 | ---- 249 | package require Toolatra 19.12 250 | 251 | get / { 252 | if {[cookie token] != {}} { 253 | show "Cookie 'token' is set to [cookie token]" 254 | } else { 255 | redirect /settoken 256 | } 257 | } 258 | 259 | get /settoken { 260 | cookie token [expr {int(rand() * 9999)}] 261 | } 262 | ---- 263 | 264 | Authorization example: 265 | 266 | [source,tcl] 267 | ---- 268 | set toolatra_auth ",(!%" ;# this is a 4-digit string that will be used to later encode the tokens that ToolatraAuth produces 269 | 270 | package require Toolatra 19.12 271 | package require ToolatraTemplates 19.11 272 | package require ToolatraAuth 19.12 273 | 274 | get / { 275 | set cv [cookie authToken] 276 | if {! [tokenValid $cv]} { 277 | redirect /login 278 | } else { 279 | redirect /greet 280 | } 281 | } 282 | 283 | get /login { 284 | if {! [dict exists $params nm]} { 285 | etcl form.html 286 | } else { 287 | set name [dict get $params nm] 288 | set tkn [token $name] ;# the generated token will expire in 1 day, to specify the expiration date, specify the number of seconds as the second argument 289 | cookie authToken $tkn 290 | redirect /greet 291 | } 292 | } 293 | 294 | get /greet { 295 | set tkn [cookie authToken] 296 | if {! [tokenValid $tkn]} { 297 | redirect /login 298 | } else { 299 | set name [tokenValue $tkn] 300 | show "Greetings, $name!" 301 | } 302 | } 303 | 304 | run 305 | ---- 306 | 307 | where ``form.html`` is: 308 | 309 | [source,html] 310 | ---- 311 |
312 |

To continue, please enter your name.

313 |

Name:

314 | 315 |
316 | ---- 317 | 318 | == License 319 | As always, MIT License. 320 | -------------------------------------------------------------------------------- /toolatra_http.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | # Toolatra - Sinatra-like web microframework for Tcl 8.5/8.6 3 | # Copyright (C) Tim K/RoverAMD 2018-2019 . 4 | # 5 | # File: toolatra_http.tcl 6 | # Description: Toolatra framework itself 7 | # License: MIT License 8 | 9 | if {[lsearch -exact [info globals] toolatraIsPackaged] < 0 || ! $toolatraIsPackaged} { 10 | puts "IMPORTANT WARNING! Please notice that as of version 19.10.2, support for Tcl package command was added and so it is now recommended to use \"package require Toolatra\" instead of \"source toolatra_http.tcl\"." 11 | } 12 | 13 | set _toolatra_http_requesthandlers {} 14 | set _toolatra_http_response [dict create] 15 | set _toolatra_version_major 19 16 | set _toolatra_version_minor 12 17 | set _toolatra_http_responsenohandle -1 18 | set _toolatra_http_mergeableUrlParams [dict create] 19 | 20 | proc _toolatra_tclext_urlmatch {url1 url2} { 21 | global _toolatra_http_mergeableUrlParams 22 | set _toolatra_http_mergeableUrlParams [dict create] 23 | set splitCompared [split $url2 /] 24 | set splitCurrent [split $url1 /] 25 | if {[llength $splitCurrent] != [llength $splitCompared]} { 26 | return 0 27 | } 28 | for {set index 0} {$index < [llength $splitCompared]} {incr index} { 29 | set itm [lindex $splitCurrent $index] 30 | set itmN [lindex $splitCompared $index] 31 | if {[string length $itmN] > 0 && [string index $itmN 0] == {+}} { 32 | dict set _toolatra_http_mergeableUrlParams [string range $itmN 1 end] $itm 33 | } elseif {$itmN != $itm} { 34 | return 0 35 | } 36 | } 37 | return 1 38 | } 39 | 40 | proc _toolatra_http_evalrequest {type url} { 41 | global _toolatra_http_requesthandlers 42 | foreach rq $_toolatra_http_requesthandlers { 43 | if {[lindex $rq 0] == $type && [_toolatra_tclext_urlmatch $url [lindex $rq 1]]} { 44 | return [lindex $rq 2] 45 | } 46 | } 47 | return ? 48 | } 49 | 50 | 51 | proc _toolatra_server_finderror {errc} { 52 | set errorCodes [dict create 200 OK \ 53 | 201 Created \ 54 | 202 Accepted \ 55 | 204 {No Content} \ 56 | 302 {Moved Temporarily} \ 57 | 301 {Moved Permenently} \ 58 | 500 {Internal Server Error} \ 59 | 400 {Bad Request} \ 60 | 404 {Not Found} \ 61 | 403 Forbidden] 62 | 63 | if {! [dict exists $errorCodes $errc]} { 64 | error "HTTP error code not supported by Toolatra: $errc" 65 | } 66 | return [dict get $errorCodes $errc] 67 | } 68 | 69 | proc _toolatra_server_genheaders {response} { 70 | global _toolatra_version_major 71 | global _toolatra_version_minor 72 | set listing [list "X-ToolatraFramework-TclVersion: [info patchlevel]" "X-ToolatraFramework-Version: $_toolatra_version_major.$_toolatra_version_minor"] 73 | set content "" 74 | dict for {key val} $response { 75 | if {$key != "toolatra_ctnt"} { 76 | if {$key != "sender" && $key != "when" && $key != "error"} { 77 | lappend listing "$key: $val" 78 | } else { 79 | lappend listing "X-ToolatraFramework-RequestRelatedVars-$key: $val" 80 | } 81 | } else { 82 | set content "$val" 83 | } 84 | } 85 | lappend listing "Connection: closed" 86 | lappend listing {} 87 | lappend listing $content 88 | return $listing 89 | } 90 | 91 | proc _toolatra_has_request {type url} { 92 | if {[_toolatra_http_evalrequest $type $url] != "?"} { 93 | return 1 94 | } 95 | return 0 96 | } 97 | 98 | 99 | proc _toolatra_server_error {url message} { 100 | global _toolatra_http_responsenohandle 101 | if {$_toolatra_http_responsenohandle == -1} { 102 | set result "Toolatra framework error" 103 | set result "$result

Toolatra Server Error

" 104 | set result "$result

URL: $url

" 105 | set result "$result

Error: $message

" 106 | set result "$result

An error that is specified above has occured while processing your request. You should contact the developers of this application if you know that this has worked previously.

" 107 | } else { 108 | set result [string map [list {@message@} $message {@url} $url] $_toolatra_http_responsenohandle] 109 | } 110 | return $result 111 | } 112 | 113 | proc _toolatra_has_qs {url} { 114 | for {set index 0 } { $index < [string length $url] } { incr index } { 115 | if {[string index $url $index] == "?"} { 116 | return 1 117 | } 118 | } 119 | return 0 120 | } 121 | 122 | proc _toolatra_server_mimetypefn {fn} { 123 | set extension [file extension $fn] 124 | set extension [string range $extension 1 end] 125 | if {$extension == "html" || $extension == "htm"} { 126 | return text/html 127 | } elseif {$extension == "css"} { 128 | return text/css 129 | } elseif {$extension == "js"} { 130 | return application/javascript 131 | } elseif {$extension == "jpeg" || $extension == "jpg" || $extension == "jpe"} { 132 | return image/jpeg 133 | } elseif {$extension == "gif"} { 134 | return image/gif 135 | } elseif {$extension == "png"} { 136 | return image/png 137 | } elseif {$extension == "txt"} { 138 | return text/plain 139 | } else { 140 | return application/octet-stream 141 | } 142 | } 143 | 144 | proc _toolatra_tclext_nolast {lst} { 145 | return [string range $lst 0 [expr {[string length $lst] - 2}]] 146 | } 147 | 148 | proc _toolatra_server_collectheaders {sockt} { 149 | set result [dict create] 150 | while {! [catch {gets $sockt rqctnt}]} { 151 | if {[string length $rqctnt] < 3} { 152 | break 153 | } 154 | set splitrq [split $rqctnt :] 155 | dict set result [_toolatra_tclext_nolast [lindex $rqctnt 0]] [string trim [lindex $rqctnt 1]] 156 | 157 | } 158 | return $result 159 | } 160 | 161 | proc _toolatra_tclext_rmempty {listing} { 162 | set result {} 163 | foreach itm $listing { 164 | if {[string length [string trim $itm]] >= 1} { 165 | lappend result $itm 166 | } 167 | } 168 | return $result 169 | } 170 | 171 | proc _toolatra_socket_secureputs {sock what} { 172 | if {[catch {puts $sock $what}]} { 173 | return 0 174 | } 175 | return 1 176 | } 177 | 178 | proc _toolatra_server_processrequest {sock addr time} { 179 | global _toolatra_http_response 180 | set _toolatra_http_response [dict create sender $addr when $time] 181 | puts ------------------------------------------------------ 182 | puts "Processing incoming connection by $addr on [clock format $time -format {%Y-%m-%d %H:%M:%S}]" 183 | set headersDict [dict create] 184 | chan configure $sock -encoding utf-8 185 | if {[eof $sock] || [catch {gets $sock rqctnt}]} { 186 | close $sock 187 | puts "Connection closed" 188 | } else { 189 | puts "Connection kept open" 190 | set headersDict [_toolatra_server_collectheaders $sock] 191 | puts $headersDict 192 | } 193 | set requestSplit [split $rqctnt { }] 194 | if {[llength $requestSplit] < 3} { 195 | close $sock 196 | puts "Invalid request sent by $addr's browser, not handling it in any way." 197 | puts ------------------------------------------------------ 198 | return 199 | } 200 | set requestType [string toupper [lindex $requestSplit 0]] 201 | set requestUrl [lindex $requestSplit 1] 202 | set requestHttp [lindex $requestSplit 2] 203 | set params $headersDict 204 | if {[_toolatra_has_qs $requestUrl]} { 205 | puts "(Query string CGI parameters specified)" 206 | set paramsStr [lindex [split $requestUrl ?] 1] 207 | set requestUrl [lindex [split $requestUrl ?] 0] 208 | set paramsStr [split $paramsStr &] 209 | foreach prm $paramsStr { 210 | set splitPrm [split $prm =] 211 | set key [lindex $splitPrm 0] 212 | set value [join [lreplace $splitPrm 0 0] =] 213 | dict set params $key $value 214 | } 215 | } 216 | puts "URL: $requestUrl" 217 | set cwdPublic "[pwd]/public/$requestUrl" 218 | if {[file exists $cwdPublic] && [file isdirectory $cwdPublic] != 1} { 219 | puts "Static resource found in $cwdPublic" 220 | set mimeType [_toolatra_server_mimetypefn $cwdPublic] 221 | puts "Mime-type: $mimeType" 222 | set ctntTmp [open $cwdPublic] 223 | fconfigure $ctntTmp -translation binary -encoding binary 224 | set everythingTmp [read $ctntTmp] 225 | close $ctntTmp 226 | _toolatra_socket_secureputs $sock "HTTP/1.1 200 OK" 227 | _toolatra_socket_secureputs $sock "Content-type: $mimeType" 228 | _toolatra_socket_secureputs $sock "Connection: closed" 229 | _toolatra_socket_secureputs $sock "X-ToolatraFramework-FoundResource: $cwdPublic" 230 | _toolatra_socket_secureputs $sock "" 231 | chan configure $sock -translation binary -encoding binary 232 | _toolatra_socket_secureputs $sock $everythingTmp 233 | puts ------------------------------------------------------ 234 | close $sock 235 | return 236 | } 237 | if {$requestHttp != "HTTP/1.1"} { 238 | puts "Invalid HTTP version ($requestHttp), not handling it in any way." 239 | } elseif {[_toolatra_has_request $requestType $requestUrl]} { 240 | set rawData {} 241 | global _toolatra_http_mergeableUrlParams 242 | set params [dict merge $params $_toolatra_http_mergeableUrlParams] 243 | set _toolatra_http_mergeableUrlParams [dict create] 244 | if {$requestType != {GET}} { 245 | set countOfChars 0 246 | if {! [dict exists $params Content-Length]} { 247 | puts "Invalid $requestType request without Content-Length, not reading any data." 248 | return 249 | } else { 250 | set countOfChars [dict get $params Content-Length] 251 | set rawData [read $sock $countOfChars] 252 | puts "Read $countOfChars bytes of data" 253 | } 254 | } 255 | #set rawData [_toolatra_tclext_rmempty $rawData] 256 | set me $requestUrl 257 | if {[catch {eval [_toolatra_http_evalrequest $requestType $requestUrl]} reason]} { 258 | puts "Exception thrown, displaying an error (reason = '$reason')" 259 | _toolatra_socket_secureputs $sock "HTTP/1.1 500 Internal Server Error" 260 | _toolatra_socket_secureputs $sock "Content-type: text/html" 261 | _toolatra_socket_secureputs $sock "" 262 | _toolatra_socket_secureputs $sock [_toolatra_server_error $requestUrl "Tcl exception was thrown:

[string map [list "\r\n" "
" "\n" "
"] $::errorInfo]"] 263 | close $sock 264 | puts ------------------------------------------------------ 265 | return 266 | } 267 | if {! [dict exists $_toolatra_http_response toolatra_ctnt]} { 268 | dict set _toolatra_http_response toolatra_ctnt "" 269 | } 270 | if {[dict exists $_toolatra_http_response error]} { 271 | set errcv [dict get $_toolatra_http_response error] 272 | if {[string length [string trim [dict get $_toolatra_http_response toolatra_ctnt]]] < 1} { 273 | if {[_toolatra_has_request GET /$errcv]} { 274 | eval [_toolatra_http_evalrequest GET /$errcv] 275 | } else { 276 | dict set _toolatra_http_response Content-type text/html 277 | dict set _toolatra_http_response toolatra_ctnt [_toolatra_server_error $requestUrl [_toolatra_server_finderror $errcv]] 278 | } 279 | dict set _toolatra_http_response error $errcv 280 | } 281 | _toolatra_socket_secureputs $sock "HTTP/1.1 $errcv [_toolatra_server_finderror $errcv]" 282 | } else { 283 | _toolatra_socket_secureputs $sock "HTTP/1.1 200 OK" 284 | } 285 | set hdrs [_toolatra_server_genheaders $_toolatra_http_response] 286 | if {[lsearch -exact [info globals] toolatra_noCORSAllow] < 0 && [dict exists $params Origin]} { 287 | dict set _toolatra_http_response Access-Control-Allow-Origin [dict get $params Origin] 288 | } 289 | if {[dict exists $_toolatra_http_response X-ToolatraFramework-IsBinary] && [dict get $_toolatra_http_response X-ToolatraFramework-IsBinary]} { 290 | _toolatra_socket_secureputs $sock [join [lreplace $hdrs end end] "\n"] 291 | chan configure $sock -encoding binary -translation binary -buffering none 292 | _toolatra_socket_secureputs $sock [lindex $hdrs [expr {[llength $hdrs] - 1}]] 293 | } else { 294 | foreach hdr $hdrs { 295 | _toolatra_socket_secureputs $sock $hdr 296 | } 297 | } 298 | } elseif {$requestUrl == "/" && $requestType == "GET"} { 299 | _toolatra_socket_secureputs $sock "HTTP/1.1 302 Moved Temporarily" 300 | _toolatra_socket_secureputs $sock "Content-type: text/plain" 301 | _toolatra_socket_secureputs $sock "X-ToolatraFramework-FirstRun: 1" 302 | _toolatra_socket_secureputs $sock "Location: http://timkoi.gitlab.io/toolatra/welcome" 303 | _toolatra_socket_secureputs $sock "URI: http://timkoi.gitlab.io/toolatra/welcome" 304 | _toolatra_socket_secureputs $sock "Connection: close" 305 | _toolatra_socket_secureputs $sock "" 306 | _toolatra_socket_secureputs $sock "If you are not being redirected, manually go to http://timkoi.gitlab.io/toolatra/welcome" 307 | } else { 308 | puts "No handler for request $requestUrl ($requestType), returning an error." 309 | _toolatra_socket_secureputs $sock "HTTP/1.1 404 Not Found" 310 | _toolatra_socket_secureputs $sock "Content-type: text/html" 311 | _toolatra_socket_secureputs $sock "" 312 | _toolatra_socket_secureputs $sock [_toolatra_server_error $requestUrl "There is no handler registered for this URL."] 313 | } 314 | close $sock 315 | puts ------------------------------------------------------ 316 | } 317 | 318 | proc _toolatra_server_queuerequest {sock addr port} { 319 | puts ------------------------------------------------------ 320 | puts "Incoming connection added to Toolatra's socket queue" 321 | puts "Sender: $addr:$port" 322 | puts "Time: [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}]" 323 | puts ------------------------------------------------------ 324 | fconfigure $sock -buffering line 325 | fileevent $sock readable [list _toolatra_server_processrequest $sock $addr [clock seconds]] 326 | } 327 | 328 | proc _toolatra_server_kickstart {port} { 329 | set skt [socket -server _toolatra_server_queuerequest $port] 330 | puts "Toolatra's built-in HTTPD is up and running and you can go to http://localhost:$port to enjoy your web app!" 331 | vwait forever 332 | } 333 | 334 | proc _toolatra_request {type url handler} { 335 | set inlineList [list $type $url $handler] 336 | if {[_toolatra_has_request $type $url]} { 337 | error "$type request handler for URL \"$url\" was already declared earlier." 338 | } 339 | global _toolatra_http_requesthandlers 340 | lappend _toolatra_http_requesthandlers $inlineList 341 | } 342 | 343 | proc get {url handler} { 344 | _toolatra_request GET $url $handler 345 | } 346 | 347 | proc show {content {mimetype {text/html; charset=utf-8}}} { 348 | global _toolatra_http_response 349 | if {! [dict exists $_toolatra_http_response toolatra_ctnt]} { 350 | dict set _toolatra_http_response toolatra_ctnt "" 351 | } 352 | dict set _toolatra_http_response toolatra_ctnt "[dict get $_toolatra_http_response toolatra_ctnt]$content" 353 | dict set _toolatra_http_response Content-type $mimetype 354 | } 355 | 356 | proc bshow {content {mimetype {application/octet-stream}}} { 357 | global _toolatra_http_response 358 | dict set _toolatra_http_response toolatra_ctnt $content 359 | dict set _toolatra_http_response X-ToolatraFramework-IsBinary 1 360 | dict set _toolatra_http_response Content-type $mimetype 361 | } 362 | 363 | proc brender {content {mimetype {application/octet-stream}}} { 364 | bshow $content $mimetype 365 | } 366 | 367 | proc status {errc} { 368 | global _toolatra_http_response 369 | dict set _toolatra_http_response error $errc 370 | } 371 | 372 | proc error {errc} { 373 | status $errc 374 | } 375 | 376 | proc render {content {mimetype {text/html; charset=utf-8}}} { 377 | show $content $mimetype 378 | } 379 | 380 | proc run {{port 5050}} { 381 | if {[info exists ::env(TOOLATRA_FORCEDPORT)]} { 382 | set port $::env(TOOLATRA_FORCEDPORT) 383 | } 384 | _toolatra_server_kickstart $port 385 | } 386 | 387 | proc post {url handler} { 388 | _toolatra_request POST $url $handler 389 | } 390 | 391 | proc put {url handler} { 392 | _toolatra_request PUT $url $handler 393 | } 394 | 395 | proc delete {url handler} { 396 | _toolatra_request DELETE $url $handler 397 | } 398 | 399 | proc header {name text} { 400 | global _toolatra_http_response 401 | dict set _toolatra_http_response $name $text 402 | } 403 | 404 | proc cookie {name {val {}}} { 405 | upvar params params 406 | if {$val != {}} { 407 | header Set-Cookie "$name=$val" 408 | return $val 409 | } else { 410 | if {! [dict exists $params Cookie]} { 411 | return {} 412 | } 413 | set cookiesStr [dict get $params Cookie] 414 | set cookiesSplit [split $cookiesStr ";"] 415 | foreach kvp $cookiesSplit { 416 | set kvp [string trimleft $kvp] 417 | set kvpSplit [split $kvp {=}] 418 | if {[lindex $kvpSplit 0] == $name} { 419 | return [join [lreplace $kvpSplit 0 0] {=}] 420 | } 421 | } 422 | return {} 423 | } 424 | } 425 | 426 | proc redirect {url} { 427 | global _toolatra_http_response 428 | dict set _toolatra_http_response Content-type text/html 429 | dict set _toolatra_http_response Location $url 430 | dict set _toolatra_http_response URI $url 431 | dict set _toolatra_http_response toolatra_ctnt "If you aren't getting redirected, click here." 432 | dict set _toolatra_http_response error 302 433 | } 434 | 435 | proc unhandled_show {what} { 436 | global _toolatra_http_responsenohandle 437 | set _toolatra_http_responsenohandle $what 438 | } 439 | 440 | 441 | package provide Toolatra $_toolatra_version_major.$_toolatra_version_minor 442 | package require Tcl 8.5 443 | 444 | if {[info exists argv0] && $argv0 == [info script]} { 445 | puts "Toolatra must be included from a Tcl script and cannot be run as a standalone script itself, because it is a framework, not a fully-featured program." 446 | exit 1 447 | } 448 | --------------------------------------------------------------------------------