├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── rl_http.tcl └── tests ├── all.tcl ├── common.tcl ├── keepalive_limits.test ├── rl_http.test └── tapchan.test /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | tm 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This software is copyrighted by Ruby Lane. The following terms apply to all 2 | files associated with the software unless explicitly disclaimed in individual 3 | files. 4 | 5 | The authors hereby grant permission to use, copy, modify, distribute, 6 | and license this software and its documentation for any purpose, provided 7 | that existing copyright notices are retained in all copies and that this 8 | notice is included verbatim in any distributions. No written agreement, 9 | license, or royalty fee is required for any of the authorized uses. 10 | Modifications to this software may be copyrighted by their authors 11 | and need not follow the licensing terms described here, provided that 12 | the new terms are clearly indicated on the first page of each file where 13 | they apply. 14 | 15 | IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY 16 | FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES 17 | ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY 18 | DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE 19 | POSSIBILITY OF SUCH DAMAGE. 20 | 21 | THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, 22 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, 23 | FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE 24 | IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE 25 | NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR 26 | MODIFICATIONS. 27 | 28 | GOVERNMENT USE: If you are acquiring this software on behalf of the 29 | U.S. government, the Government shall have only "Restricted Rights" 30 | in the software and related documentation as defined in the Federal 31 | Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you 32 | are acquiring the software on behalf of the Department of Defense, the 33 | software shall be classified as "Commercial Computer Software" and the 34 | Government shall have only "Restricted Rights" as defined in Clause 35 | 252.227-7014 (b) (3) of DFARs. Notwithstanding the foregoing, the 36 | authors grant the U.S. Government and others acting in its behalf 37 | permission to use and distribute the software in accordance with the 38 | terms specified in this license. 39 | 40 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | DESTDIR= 2 | PREFIX=/usr/local 3 | PACKAGE_NAME=rl_http 4 | VER=1.20 5 | TCLSH=tclsh 6 | 7 | all: tm/$(PACKAGE_NAME)-$(VER).tm 8 | 9 | tm/$(PACKAGE_NAME)-$(VER).tm: rl_http.tcl 10 | mkdir -p tm 11 | cp rl_http.tcl tm/$(PACKAGE_NAME)-$(VER).tm 12 | 13 | install-tm: tm/$(PACKAGE_NAME)-$(VER).tm 14 | mkdir -p $(DESTDIR)$(PREFIX)/lib/tcl8/site-tcl 15 | cp $< $(DESTDIR)$(PREFIX)/lib/tcl8/site-tcl/ 16 | 17 | install: install-tm 18 | 19 | clean: 20 | rm -r tm 21 | 22 | test: tm/$(PACKAGE_NAME)-$(VER).tm 23 | $(TCLSH) tests/all.tcl $(TESTFLAGS) -load "source [file join $$::tcltest::testsDirectory .. tm $(PACKAGE_NAME)-$(VER).tm]; package provide $(PACKAGE_NAME) $(VER)" 24 | 25 | vim-gdb: tm/$(PACKAGE_NAME)-$(VER).tm 26 | vim -c "set number" -c "set mouse=a" -c "set foldlevel=100" -c "Termdebug -ex set\ print\ pretty\ on --args $(TCLSH) tests/all.tcl -singleproc 1 -load source\ [file\ join\ $$::tcltest::testsDirectory\ ..\ tm\ $(PACKAGE_NAME)-$(VER).tm];\ package\ provide\ $(PACKAGE_NAME)\ $(VER) $(TESTFLAGS)" -c "2windo set nonumber" -c "1windo set nonumber" 27 | 28 | .PHONY: all clean install install-tm test 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | RL\_HTTP 2 | ======= 3 | 4 | This package provides a REST-capable, entirely non-blocking HTTP client library. 5 | 6 | Features 7 | -------- 8 | 9 | * Supported HTTP verbs: GET, POST, PUT, DELETE, HEAD, PATCH, OPTIONS 10 | * HTTPS (using the tls package) 11 | * Never blocks, and uses async socket establishment to support reliable timeouts 12 | * gzip, deflate, compress supported 13 | * utf-8, iso-8859-1 and windows-1252 charset encodings 14 | * Chunked-transfer encoding 15 | * Automatic multi-thread keepalive support 16 | * Inspection of the read and write events and bytes on the wire for debugging 17 | * Works in NaviServer / AOLServer / plain Tcl 18 | * Supports HTTP over unix domain sockets (with the unix\_sockets package) 19 | * Fully async single threaded mode if called from coroutines, partial support with vwait if not 20 | 21 | Quick Reference 22 | --------------- 23 | rl\_http instvar *varname* *METHOD* *url* ?*-option* *value* ...? 24 | 25 | ### Options 26 | | Option | Default | Description | 27 | |--------|---------|-------------| 28 | | -timeout | 15.0 | Time in seconds after which to consider the request a timeout. The timeout applies from the start of the connection attempt until the response is fully received. Use a value of "" to disable | 29 | | -ver | 1.1 | The HTTP version to declare in the request | 30 | | -accept | \*/\* | The Accept header to send with the request | 31 | | -headers | | The request headers to send, as a list similar to a dictionary but allowing duplicate keys: HTTP headers can be multivalued | 32 | | -sizelimit | | If set, and the returned Content-Length is larger than this value, and exception will be raised: {RL HTTP READ\_BODY TOO\_BIG $content\_length} | 33 | | -data | | The body of the request. Must already be encoded to bytes | 34 | | -data\_cb | | If set, the value is used as a command prefix to invoke to write the request body to the socket. The socket channel is appended as the first argument. The channel is in binary mode for writing | 35 | | -data\_len | | If -data\_cb is used, the -data\_len option can be used to supply a Content-Length header in the request | 36 | | -override\_host | | If set, use the supplied value as the request Host header, otherwise default to the authority section of the supplied url | 37 | | -tapchan | | If set, a stacked channel will be layered on top of the socket, with the -tapchan value used as the command prefix for the reflected channel handler. An example handler is provided as ::rl\_http::tapchan, which logs the read and write events and the base64 encoded bytes on the wire, for debugging. Redefine ::rl\_http::log to suit your environment (default writes to stderr) | 38 | | -useragent | Ruby Lane HTTP client | The value to send as the User-Agent header in the request | 39 | | -max\_keepalive\_age | -1 | If >= 0, the maximum age of a keepalive connection | 40 | | -max\_keepalive\_count | -1 | If >=0, the maximum number of requests on a keepalive connection | 41 | | -keepalive\_check | h {return true} | A lambda that can opt to close a connection rather than parking it for potential future reuse. The *h* argument is the rl\_http instance, so things like the HTTP status or response headers can be interrogated | 42 | 43 | ### Instance Methods 44 | | Method | Arguments | Description | 45 | |--------|-----------|-------------| 46 | | code | | The HTTP status code of the response | 47 | | headers | | The response headers, as a dictionary with the headers as keys, normalized to lower case, and the values as a list (HTTP headers are multi-valued) | 48 | | body | | The response body, decoded and interpreted in the charset according to the response headers | 49 | 50 | Usage 51 | ----- 52 | 53 | rl\_http uses gc\_class, so instance management is best left to bound instance variables: 54 | 55 | ~~~tcl 56 | rl_http instvar h GET https://raw.githubusercontent.com/RubyLane/rl_http/master/README.md 57 | switch -glob -- [$h code] { 58 | 2* { 59 | puts "Got result:\n[$h body]" 60 | puts "Headers: [$h headers]" 61 | } 62 | 63 | default { 64 | puts "Something went wrong: [$h code]\n[$h body]" 65 | } 66 | } 67 | ~~~ 68 | 69 | When $h is unset (usually because it went out of scope), or its value is 70 | changed, the instance of rl_http will be destroyed. 71 | 72 | ### Headers 73 | 74 | Response headers (returned by the *headers* method) are represented as a dictionary with the header names as the keys, normalized to lowercase. The values are a list (HTTP headers can be multi-valued) 75 | 76 | ### Upload body data and encoding 77 | 78 | Request body data supplied in the *-data* option must be fully encoded, matching the Content-Type request header. For text types this usually means utf-8, for images it should be the raw bytes of the image. 79 | ~~~tcl 80 | set json_body { 81 | { 82 | "hello": "server", 83 | "foo": 1234 84 | } 85 | } 86 | # utf-8 is the default for application/json, could also be explicit: "application/json; charset=utf-8" 87 | rl_http instvar h PUT $url -headers {Content-Type application/json} -data [encoding convertto utf-8 $json_body] 88 | ~~~ 89 | 90 | ~~~tcl 91 | set h [open avatar.jpg rb] 92 | try {set image_bytes [read $h]} finally {close $h} 93 | rl_http instvar h PUT $url -headers {Content-Type image/jpeg} -data $image_bytes 94 | ~~~ 95 | 96 | ### Exceptions 97 | * RL URI ERROR - the supplied url cannot be parsed. 98 | * RL HTTP CONNECT UNSUPPORTED\_SCHEME $scheme - the scheme specified in the url is not supported. 99 | * RL HTTP CONNECT timeout - attempting to connect to the server timed out. 100 | * RL HTTP READ\_HEADERS timeout - timeout while reading the response headers from the server. 101 | * RL HTTP READ\_HEADERS dropped - the TCP connection was closed while reading the response headers. 102 | * RL HTTP PARSE\_HEADERS $line - error parsing the response status line or headers. 103 | * RL HTTP READ\_BODY timeout - timeout while reading the response body. 104 | * RL HTTP READ\_BODY dropped - the TCP connection was closed while reading the body. 105 | * RL HTTP READ\_BODY truncated - the server returned fewer bytes in the body than it promised in the Content-Length response header. 106 | * RL HTTP READ\_BODY CORRUPT\_CHUNKED - the server returned malformed Transfer-Encoding: Chunked data. 107 | * RL HTTP READ\_BODY TOO\_BIG $content\_length - the returned Content-Length exceeded the limit set by the *-sizelimit* option. 108 | * RL HTTP READ\_BODY unhandled\_encoding $enc - the server used an encoding we don't support (and didn't advertise in the request Accept-\* headers) 109 | * RL HTTP READ\_BODY UNHANDLED\_CHARSET $charset - the server used a charset we don't support (and didn't advertise in the request Accept-\* headers) 110 | 111 | Required Packages 112 | ----------------- 113 | * gc\_class - https://github.com/RubyLane/gc_class 114 | * reuri - https://github.com/cyanogilvie/reuri, or uri from Tcllib (required if reuri is not available) 115 | * s2n, tls or twapi - for HTTPS support (optional). https://github.com/cyanogilvie/tcl-s2n 116 | * sockopt - https://github.com/cyanogilvie/sockopt - sets TCP\_NODELAY (optional) 117 | * unix\_sockets - https://github.com/cyanogilvie/unix_sockets - adds support for HTTP-over-UDS (optional) 118 | * resolve - https://github.com/cyanogilvie/resolve - adds support for async name resolution and caching (optional) 119 | 120 | License 121 | ------- 122 | 123 | This package is licensed under the same terms as the Tcl core. 124 | 125 | -------------------------------------------------------------------------------- /rl_http.tcl: -------------------------------------------------------------------------------- 1 | package require Tcl 8.6 2 | package require gc_class 3 | package require Thread 4 | package require parse_args 5 | 6 | namespace eval ::rl_http { 7 | namespace export * 8 | 9 | variable tls_driver 10 | if {![info exists tls_driver]} { 11 | set tls_driver [expr { 12 | [catch {package require s2n}] ? "tls" : "s2n" 13 | }] 14 | } 15 | 16 | # If the resolve package is available, use it for async name resolution 17 | variable have_resolve [expr { 18 | [catch {package require resolve}] == 0 19 | }] 20 | 21 | variable have_reuri [expr { 22 | [catch {package require reuri 0.13}] == 0 23 | }] 24 | if {!$have_reuri} { 25 | package require uri ;# from tcllib 26 | } 27 | 28 | if {[llength [info commands ::log]]} { 29 | interp alias {} ::rl_http::log {} ::log 30 | } else { 31 | proc log {lvl msg} { #<<< 32 | puts $msg 33 | #return 34 | ## This is slow for some reason ±50 usec 35 | #set s [expr {[clock microseconds] / 1e6}] 36 | #set frac [string range [format %.6f [expr {fmod($s, 1.0)}]] 1 end] 37 | #puts stdout "[clock format [expr {int($s)}] -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]$frac $msg" 38 | } 39 | 40 | #>>> 41 | } 42 | if {[llength [info commands utf8buffer]]} { 43 | utf8buffer destroy 44 | } 45 | ::gc_class create utf8buffer { #<<< 46 | variable {*}{ 47 | utf8chunks 48 | bytelength 49 | } 50 | 51 | constructor {} { #<<< 52 | if {[self next] ne ""} next 53 | 54 | set utf8chunks {} 55 | set bytelength 0 56 | } 57 | 58 | #>>> 59 | 60 | method append chunk { #<<< 61 | set utf8chunk [encoding convertto utf-8 $chunk] 62 | lappend utf8chunks $utf8chunk 63 | incr bytelength [string length $utf8chunk] 64 | } 65 | 66 | #>>> 67 | method bytelength {} {set bytelength} 68 | method write chan { #<<< 69 | foreach utf8chunk $utf8chunks { 70 | puts -nonewline $chan $utf8chunk 71 | } 72 | set utf8chunks {} 73 | set bytelength 0 74 | } 75 | 76 | #>>> 77 | } 78 | 79 | #>>> 80 | namespace eval tapchan { 81 | namespace export * 82 | namespace ensemble create -prefixes no 83 | 84 | proc initialize {chan mode} { #<<< 85 | ::rl_http::log debug "rl_http tapchan $chan initialize $mode" 86 | #return {initialize finalize read write flush drain clear} 87 | return {initialize finalize read write} 88 | } 89 | 90 | #>>> 91 | proc finalize chan { ::rl_http::log debug "tapchan $chan finalize" } 92 | proc read {chan bytes} { #<<< 93 | ::rl_http::log debug "rl_http tapchan $chan read [binary encode base64 $bytes]" 94 | set bytes 95 | } 96 | 97 | #>>> 98 | proc flush chan { #<<< 99 | ::rl_http::log debug "rl_http tapchan $chan flush" 100 | return {} 101 | } 102 | 103 | #>>> 104 | proc clear chan { #<<< 105 | ::rl_http::log debug "rl_http tapchan $chan clear" 106 | return {} 107 | } 108 | 109 | #>>> 110 | proc drain chan { #<<< 111 | ::rl_http::log debug "rl_http tapchan $chan drain" 112 | return {} 113 | } 114 | 115 | #>>> 116 | proc write {chan bytes} { #<<< 117 | ::rl_http::log debug "rl_http tapchan $chan write [binary encode base64 $bytes]" 118 | set bytes 119 | } 120 | 121 | #>>> 122 | } 123 | 124 | variable _force_vwait 0 125 | proc force_vwait_io script { #<<< 126 | variable _force_vwait 127 | incr _force_vwait 128 | try { 129 | uplevel 1 $script 130 | } on break {r o} - on continue {r o} { 131 | dict incr o -level 1 132 | return -options $o $r 133 | } on return {r o} { 134 | dict incr o -level 1 135 | dict set o -code return 136 | return -options $o $r 137 | } finally { 138 | incr _force_vwait -1 139 | } 140 | } 141 | 142 | #>>> 143 | } 144 | 145 | # Start the keepalive timeout handler thread <<< 146 | tsv::lock rl_http_threads { 147 | if {![tsv::exists rl_http_threads keepalive_handler]} { 148 | 149 | if {[llength [info commands ns_thread]] > 0 && [catch {package present ns_shim}]} { 150 | # using thread::create in Naviserver seems to cause a deadlock (at least when called during server startup) 151 | set start_thread {ns_thread begindetached} 152 | } else { 153 | set start_thread thread::create 154 | } 155 | 156 | {*}$start_thread { 157 | if {[info commands ns_log] ne ""} { 158 | interp alias {} log {} ns_log 159 | } else { 160 | proc log {lvl msg} { 161 | set s [expr {[clock microseconds] / 1e6}] 162 | set frac [string range [format %.6f [expr {fmod($s, 1.0)}]] 1 end] 163 | puts stderr "[clock format [expr {int($s)}] -format "%Y-%m-%d %H:%M:%S" -timezone :UTC]$frac $msg" 164 | } 165 | } 166 | 167 | while 1 { 168 | after 5000 169 | 170 | set now [expr {[clock microseconds]/1e6}] 171 | set to_close {} 172 | tsv::lock rl_http_keepalive_chans { 173 | foreach {key parked_chans} [tsv::array get rl_http_keepalive_chans] { 174 | set pruned [lmap chaninfo $parked_chans { 175 | lassign $chaninfo chan expires prev_uses first_use 176 | if {$now > $expires} { 177 | lappend to_close $key $chan 178 | continue 179 | } 180 | set chaninfo 181 | }] 182 | 183 | if {[llength $pruned] == 0} { 184 | tsv::unset rl_http_keepalive_chans $key 185 | } else { 186 | tsv::set rl_http_keepalive_chans $key $pruned 187 | } 188 | } 189 | } 190 | 191 | foreach {key chan} $to_close { 192 | try { 193 | #log debug "Closing expired channel $chan to $key" 194 | thread::attach $chan 195 | close $chan 196 | } on error {errmsg options} { 197 | # TODO: what? 198 | log debug "Error retiring expired parked channel $chan to $key: [dict get $options -errorinfo]" 199 | } 200 | } 201 | } 202 | } 203 | 204 | tsv::set rl_http_threads keepalive_handler started 205 | unset start_thread 206 | } 207 | } 208 | #>>> 209 | 210 | if {[llength [info commands rl_http::async_io]]} { 211 | rl_http::async_io destroy 212 | } 213 | oo::class create rl_http::async_io { #<<< 214 | variable {*}{ 215 | timeout_afterid 216 | } 217 | 218 | method _timeout {type message} { #<<< 219 | my destroy 220 | throw [list RL HTTP TIMEOUT $type] $message 221 | } 222 | 223 | #>>> 224 | method _connect_async {chanscript seconds} { # Connect to $ip:$port, with timeout support (-async + wait for writable event) <<< 225 | variable ::rl_http::_force_vwait 226 | my variable _timeout_connect_seq 227 | my variable _timeout_connect_res 228 | 229 | set my_seq [incr _timeout_connect_seq] 230 | 231 | set timeout_afterid "" 232 | try { 233 | if {[info coroutine] ne "" && $_force_vwait == 0} { 234 | set ev_prefix [list [info coroutine]] 235 | set wait_cmd {set _timeout_connect_res($my_seq) [yield]} 236 | } else { 237 | set ev_prefix [list set [namespace current]::_timeout_connect_res($my_seq)] 238 | set wait_cmd [list vwait [namespace current]::_timeout_connect_res($my_seq)] 239 | } 240 | 241 | set timeout_afterid [after [expr {int(round($seconds * 1000))}] [list {*}$ev_prefix timeout]] 242 | set before [clock microseconds] 243 | set chan [uplevel 1 $chanscript] 244 | #puts stderr "chan script $chanscript blocked for [format %.3f [expr {([clock microseconds]-$before)/1e3}]] ms" 245 | chan event $chan writable [list {*}$ev_prefix connected] 246 | 247 | #puts stderr "Waiting for writable on new chan $chan: $wait_cmd" 248 | try $wait_cmd 249 | #puts stderr "Got writable on $chan [format %.3f [expr {([clock microseconds]-$before)/1e3}]] ms from start of chan script" 250 | 251 | switch -- $_timeout_connect_res($my_seq) { 252 | connected {} 253 | timeout { my _timeout CONNECTION "Timeout connecting to server" } 254 | default { throw {RL HTTP PANIC} "Unexpected status connecting to server: ($_timeout_connect_res($my_seq))" } 255 | } 256 | } on error {errmsg options} { 257 | catch { 258 | close $chan 259 | unset chan 260 | } 261 | return -options $options $errmsg 262 | } finally { 263 | after cancel $timeout_afterid; set timeout_afterid "" 264 | if {[info exists chan] && $chan in [chan names]} { 265 | chan event $chan writable {} 266 | } 267 | unset -nocomplain _timeout_connect_res($my_seq) 268 | } 269 | 270 | set chan 271 | } 272 | 273 | #>>> 274 | method _wait_for_readable {chan seconds} { #<<< 275 | variable ::rl_http::_force_vwait 276 | my variable _wait_for_readable_seq 277 | my variable _wait_for_readable_res 278 | 279 | set my_seq [incr _wait_for_readable_seq] 280 | 281 | set timeout_afterid "" 282 | try { 283 | if {[info coroutine] ne "" && $_force_vwait == 0} { 284 | set ev_prefix [list [info coroutine]] 285 | set wait_cmd {set _wait_for_readable_res($my_seq) [yield]} 286 | } else { 287 | set ev_prefix [list set [namespace current]::_wait_for_readable_res($my_seq)] 288 | set wait_cmd [list vwait [namespace current]::_wait_for_readable_res($my_seq)] 289 | } 290 | 291 | if {$seconds ne ""} { 292 | set timeout_afterid [after [expr {int(round($seconds * 1000))}] [list {*}$ev_prefix timeout]] 293 | } 294 | chan event $chan readable [list {*}$ev_prefix readable] 295 | 296 | #puts stderr "Waiting for readable on $chan: $wait_cmd <[info frame -1]>" 297 | try $wait_cmd 298 | #puts stderr "Got readable on $chan" 299 | 300 | switch -- $_wait_for_readable_res($my_seq) { 301 | readable {} 302 | timeout { 303 | my _timeout READ "Timeout waiting for read" 304 | } 305 | default { 306 | throw {RL HTTP PANIC} "Unexpected status waiting for data: ($_wait_for_readable_res($my_seq))" 307 | } 308 | } 309 | } finally { 310 | after cancel $timeout_afterid; set timeout_afterid "" 311 | if {$chan in [chan names]} { 312 | chan event $chan readable {} 313 | } 314 | unset -nocomplain _wait_for_readable_res($my_seq) 315 | } 316 | } 317 | 318 | #>>> 319 | method _log {lvl msg} { #<<< 320 | # Override this to log messages 321 | } 322 | 323 | #>>> 324 | } 325 | 326 | #>>> 327 | 328 | ::gc_class create ::rl_http { 329 | superclass ::rl_http::async_io 330 | 331 | variable {*}{ 332 | method 333 | url 334 | wait 335 | timeout_afterid 336 | u 337 | response 338 | settings 339 | sock 340 | resp_headers_buf 341 | resp_body_buf 342 | chunk_buf 343 | starttime 344 | keepalive 345 | collected 346 | async_gap_start 347 | prev_uses 348 | first_use 349 | } 350 | 351 | constructor {a_method a_url args} { #<<< 352 | namespace path {::oo::Helpers ::parse_args} 353 | 354 | set method $a_method 355 | set url $a_url 356 | 357 | if {[self next] ne ""} next 358 | 359 | parse_args $args { 360 | -timeout {-default 15} 361 | -ver {-default 1.1} 362 | -accept {-default */*} 363 | -headers {-default {}} 364 | -sizelimit {-default ""} 365 | -data {-default ""} 366 | -data_cb {-default {}} 367 | -data_len {-default ""} 368 | -override_host {-default ""} 369 | -tapchan {-default ""} 370 | -useragent {-default "Ruby Lane HTTP client"} 371 | -stats_cx {-default ""} 372 | -async {-boolean -# {If set, don't wait for the response (get it with [$obj collect] later)}} 373 | -keepalive {-default 1 -# {Not used}} 374 | -max_keepalive_age {-default -1 -# {keep a connection for at most this many seconds. <0 = no limit}} 375 | -max_keepalive_count {-default -1 -# {keep a connection for at most this many requests. <0 = no limit}} 376 | -keepalive_check {-default {h {return true}} -# {lambda - return true if the connection should be reused for future requests}} 377 | } settings 378 | if {[dict get $settings override_host] eq ""} {dict unset settings override_host} 379 | 380 | set resp_headers_buf "" 381 | set resp_body_buf "" 382 | set chunk_buf "" 383 | set keepalive yes 384 | set collected false 385 | 386 | set response { 387 | headers {} 388 | data {} 389 | } 390 | 391 | set method [string toupper $method] 392 | if {$method ni {GET PUT POST DELETE HEAD PATCH OPTIONS}} { 393 | error "HTTP method \"$method\" not supported" 394 | } 395 | 396 | try { 397 | if {$::rl_http::have_reuri} { 398 | set u(scheme) [reuri get $url scheme] 399 | set u(host) [reuri get $url host] 400 | if {[reuri get $url hosttype] eq "local"} { 401 | set u(port) "" 402 | set u(host) [file join {*}$u(host)] 403 | } else { 404 | set u(port) [reuri get $url port [expr { 405 | $u(scheme) eq "http" ? 80 : 443 406 | }]] 407 | } 408 | set u(path) [reuri extract $url path ""] 409 | set u(query) [reuri extract $url query ""] 410 | } else { 411 | array set u [uri::split $url] 412 | if {[regexp {^\[(?:v0.local:)?(/.*)\]$} $u(host) - u(host)]} { 413 | set u(port) "" 414 | } elseif {$u(port) eq ""} { 415 | set u(port) [dict get { 416 | http 80 417 | https 443 418 | } $u(scheme)] 419 | } 420 | } 421 | } trap {RL HTTP} {errmsg options} { 422 | return -options $options $errmsg 423 | } on error {errmsg options} { 424 | ::rl_http::log error "Error parsing URI [dict get $options -errorcode]: [dict get $options -errorinfo]" 425 | throw [list RL URI ERROR] $errmsg 426 | } 427 | 428 | if {[string index $u(path) 0] ne "/"} { 429 | set u(path) /$u(path) 430 | } 431 | 432 | set starttime [clock microseconds] 433 | my _connect 434 | my _send_request 435 | set async_gap_start [clock microseconds] 436 | if {![dict get $settings async]} { 437 | my collect 438 | } 439 | } 440 | 441 | #>>> 442 | destructor { #<<< 443 | if {[info exists sock] && $sock in [chan names]} {close $sock} 444 | my _cancel_timeout 445 | if {[self next] ne ""} next 446 | } 447 | 448 | #>>> 449 | 450 | method collect {} { #<<< 451 | if {$collected} return 452 | if {[dict get $settings async]} { 453 | set async_gap [expr {[clock microseconds] - $async_gap_start}] 454 | } else { 455 | set async_gap 0 456 | } 457 | 458 | my _read_headers 459 | my _parse_statusline 460 | my _parse_headers $resp_headers_buf 461 | my _read_body 462 | set elapsed [expr {[clock microseconds] - $starttime - $async_gap}] 463 | my _stats [expr {$elapsed / 1e3}] 464 | 465 | my _cancel_timeout 466 | 467 | set collected true 468 | 469 | if {$sock in [chan names]} { 470 | if {[dict exists $response headers connection] && "close" in [dict get $response headers connection]} { 471 | close $sock 472 | unset sock 473 | } else { 474 | #::rl_http::log debug "Parking keepalive connection: $sock $u(scheme) $u(host) $u(port)" 475 | my _keepalive_park $sock $u(scheme) $u(host) $u(port) 15 476 | unset sock 477 | } 478 | } else { 479 | unset sock 480 | } 481 | 482 | return 483 | } 484 | 485 | #>>> 486 | method _timeout {type message} { #<<< 487 | # TODO: keep context info to provide a more granular error: timeout during headers read, etc. 488 | throw [list RL HTTP TIMEOUT $type] $message 489 | } 490 | 491 | #>>> 492 | method _cancel_timeout {} { #<<< 493 | if {![info exists timeout_afterid]} return 494 | after cancel $timeout_afterid; set timeout_afterid "" 495 | } 496 | 497 | #>>> 498 | method _keepalive_connect {scheme host port} { #<<< 499 | #::rl_http::log debug "[self] _keepalive_connect $scheme $host $port" 500 | set key $scheme://$host:$port 501 | set popchan {key { # Retrieve the next idle keepalive channel for $key <<< 502 | tsv::lock rl_http_keepalive_chans { 503 | if {![tsv::exists rl_http_keepalive_chans $key]} { 504 | return {} 505 | } 506 | set chaninfo [tsv::lpop rl_http_keepalive_chans $key] 507 | if {$chaninfo eq ""} { 508 | tsv::unset rl_http_keepalive_chans $key 509 | } 510 | set chaninfo 511 | } 512 | }} 513 | #>>> 514 | #::rl_http::log debug "Looking for parked connection $key: [tsv::array get rl_http_keepalive_chans]" 515 | while {[set chaninfo [apply $popchan $key]] ne ""} { 516 | lassign $chaninfo chan expiry prev_uses first_use 517 | #::rl_http::log debug "[self] reusing $chan for $scheme://$host:$port" 518 | try { 519 | thread::attach $chan 520 | set age [expr {[clock microseconds]/1e6 - $first_use}] 521 | if { 522 | [set max_age [dict get $settings max_keepalive_age]] >= 0 && 523 | $age > $max_age 524 | } { 525 | #::rl_http::log notice "parked chan too old: $chan for $key (remain: [tsv::get rl_http_keepalive_chans $key])" 526 | ::rl_http::log notice "parked chan too old: $chan for $key" 527 | chan close $chan 528 | continue 529 | } else { 530 | # Check if the remote closed on us or is too old <<< 531 | chan configure $chan -blocking 0 532 | chan read $chan 533 | if {[chan eof $chan]} { 534 | #::rl_http::log notice "parked chan collapsed: $chan for $key (remain: [tsv::get rl_http_keepalive_chans $key])" 535 | ::rl_http::log notice "parked chan collapsed: $chan for $key" 536 | chan close $chan 537 | continue 538 | } 539 | # Check if the remote closed on us >>> 540 | } 541 | #puts stderr "Reusing keepalive chan $chan, age: $age, first_use: $first_use" 542 | } on ok {} { 543 | if {[dict get $settings tapchan] ne ""} { 544 | chan push $chan [dict get $settings tapchan] 545 | } 546 | #::rl_http::log debug "returning parked chan $chan" 547 | return $chan 548 | } on error {errmsg options} { 549 | ::rl_http::log notice "Error attaching to parked chan \"$chan\": [dict get $options -errorinfo]" 550 | } 551 | } 552 | #::rl_http::log debug "Falling back on opening new connection $scheme://$host:$port" 553 | if {$port eq ""} { 554 | # HTTP-over-unix-domain-sockets 555 | package require unix_sockets 556 | switch -- $scheme { 557 | http {set chan [my _connect_async {unix_sockets::connect $host} [my _remaining_timeout]]} 558 | https { 559 | set chan [my _connect_async {unix_sockets::connect $host} [my _remaining_timeout]] 560 | my push_tls $chan [dict getdef $settings override_host {}] 561 | } 562 | default {throw [list RL HTTP CONNECT UNSUPPORTED_SCHEME $scheme] "Scheme $scheme is not supported"} 563 | } 564 | } else { 565 | if {$::rl_http::have_resolve} { 566 | # $port resolution: RFC 3986 doesn't support non-decimal ports in URIs, so we don't 567 | # resolve them here 568 | if { 569 | ![tsv::exists _rl_http_resolve_cache $host] || 570 | [clock seconds] - [dict get [tsv::get _rl_http_resolve_cache $host] ts] > 60 571 | } { 572 | resolve::resolver instvar resolve 573 | #::rl_http::log notice "[self] resolving $host" 574 | #set now [clock microseconds] 575 | $resolve add $host 576 | set addrs [$resolve get $host -timeout [my _remaining_timeout]] 577 | #::rl_http::log notice "[self] Got result for $host in [format %.3f [expr {([clock microseconds]-$now)/1e3}]] ms" 578 | tsv::set _rl_http_resolve_cache $host [list addrs $addrs ts [clock seconds]] 579 | # TODO: maybe have a background grooming thread go through this cache periodically and 580 | # remove expired entries? 581 | } else { 582 | set addrs [dict get [tsv::get _rl_http_resolve_cache $host] addrs] 583 | #::rl_http::log debug "Reused cached addrs for $host:$port: $addrs" 584 | } 585 | } else { 586 | set addrs [list $host] 587 | #::rl_http::log debug "No resolve package available, created addr list as $addrs" 588 | } 589 | 590 | # Try each of the resolved addresses in order, fail if all fail to connect 591 | set i 0 592 | foreach addr $addrs { 593 | incr i 594 | set chost $addr 595 | set cport $port 596 | 597 | try { 598 | #::rl_http::log debug "attempting to connect to $chost $port for $scheme://$host:$port" 599 | switch -- $scheme { 600 | http {set chan [my _connect_async {socket -async $chost $cport} [my _remaining_timeout]]} 601 | https { 602 | set chan [my _connect_async {socket -async $chost $cport} [my _remaining_timeout]] 603 | #set before [clock microseconds] 604 | my push_tls $chan [dict getdef $settings override_host $host] 605 | #set chan [s2n::socket -prefer throughput -servername $host $chost $cport] 606 | #::rl_http::log debug "push_tls on connected socket: [format %.3f [expr {([clock microseconds] - $before)/1e3}]] ms" 607 | } 608 | default {throw [list RL HTTP CONNECT UNSUPPORTED_SCHEME $scheme] "Scheme $scheme is not supported"} 609 | } 610 | break 611 | } on error {errmsg options} { 612 | if {$i < [llength $addrs]} { 613 | # More remain to try 614 | ::rl_http::log notice "Error connecting to $chost:$cport for $host:$port, trying next address" 615 | continue 616 | } 617 | return -options $options $errmsg 618 | } 619 | } 620 | if {![info exists chan]} { 621 | # Shouldn't be reachable, the last failed addr attempt above should have thrown an error 622 | throw [list RL HTTP CONNECT FAILED $scheme://$host:$port] "Couldn't connect to $scheme://$host:$port" 623 | } 624 | 625 | try { 626 | package require sockopt 627 | sockopt::setsockopt $chan SOL_TCP TCP_NODELAY 1 628 | } on error {} { 629 | } on ok {} { 630 | #puts stderr "Set TCP_NODELAY" 631 | } 632 | } 633 | if {[dict get $settings tapchan] ne ""} { 634 | chan push $chan [dict get $settings tapchan] 635 | } 636 | set prev_uses 0 637 | set first_use [expr {[clock microseconds] / 1e6}] 638 | set chan 639 | } 640 | 641 | #>>> 642 | method push_tls {chan servername} { #<<< 643 | variable ::rl_http::tls_driver 644 | if {$::rl_http::tls_driver eq "s2n"} { 645 | package require s2n 646 | if {$servername eq ""} { 647 | s2n::push $chan -prefer throughput 648 | } else { 649 | s2n::push $chan -servername $servername -prefer throughput 650 | } 651 | } else { 652 | package require tls 653 | if {$servername eq ""} { 654 | tls::import $chan -require true -cadir /etc/ssl/certs 655 | } else { 656 | tls::import $chan -servername $servername -require true -cadir /etc/ssl/certs 657 | } 658 | } 659 | } 660 | 661 | #>>> 662 | method _keepalive_park {chan scheme host port timeout} { #<<< 663 | #::rl_http::log notice "Parking $scheme://$host:$port" 664 | if {$chan in [chan names]} { 665 | if {[dict get $settings tapchan] ne ""} { 666 | chan pop $chan 667 | } 668 | 669 | # Apply -max_keepalive_* limits if set 670 | set now [expr {[clock microseconds] / 1e6}] 671 | set age [expr {$now - $first_use}] 672 | set uses [expr {$prev_uses + 1}] 673 | if { 674 | ( 675 | [set max_age [dict get $settings max_keepalive_age]] >= 0 && 676 | $age >= $max_age 677 | ) || ( 678 | [set max_uses [dict get $settings max_keepalive_count]] >= 0 && 679 | $uses >= $max_uses 680 | ) || 681 | ![apply [dict get $settings keepalive_check] [self]] 682 | } { 683 | close $chan 684 | return 685 | } 686 | 687 | set expires [expr { 688 | $max_age >= 0 689 | ? $first_use + $max_age 690 | : $now + $timeout 691 | }] 692 | 693 | thread::detach $chan 694 | tsv::lpush rl_http_keepalive_chans $scheme://$host:$port [list \ 695 | $chan \ 696 | $expires \ 697 | $uses \ 698 | $first_use \ 699 | ] 700 | } 701 | } 702 | 703 | #>>> 704 | method _connect {} { #<<< 705 | set sock [my _keepalive_connect $u(scheme) $u(host) $u(port)] 706 | chan configure $sock \ 707 | -translation {auto crlf} \ 708 | -blocking 0 \ 709 | -buffering full \ 710 | -buffersize 65536 \ 711 | -encoding ascii 712 | } 713 | 714 | #>>> 715 | method _send_request {} { #<<< 716 | puts $sock "$method $u(path)[if {$u(query) ne ""} {set _ ?$u(query)}] HTTP/[dict get $settings ver]" 717 | set have_headers [lsort -unique [lmap {k v} [dict get $settings headers] {string tolower $k}]] 718 | 719 | if {$::rl_http::have_reuri} { 720 | set encode_host {str {reuri encode host $str}} 721 | } else { 722 | set encode_host {str {set str}} ;# Wrong, but matches what was happening before, so not a regression 723 | } 724 | 725 | if {"host" ni $have_headers} { 726 | if {[dict exists $settings override_host]} { 727 | puts $sock "Host: [apply $encode_host [dict get $settings override_host]]" 728 | } else { 729 | if {$u(port) eq ""} { 730 | # Unix domain socket 731 | puts $sock "Host: localhost" 732 | } else { 733 | puts $sock "Host: [apply $encode_host $u(host)][if {$u(port) != 80} {set _ :$u(port)}]" 734 | } 735 | } 736 | } 737 | puts $sock "Accept: [dict get $settings accept]" 738 | puts $sock "Accept-Encoding: gzip, deflate, compress" 739 | puts $sock "Accept-Charset: utf-8, iso-8859-1;q=0.5, windows-1252;q=0.5" 740 | puts $sock "User-Agent: [dict get $settings useragent]" 741 | foreach {k v} [dict get $settings headers] { 742 | puts $sock [format {%s: %s} [string trim $k] [string map {"\r" "" "\n" ""} $v]] 743 | } 744 | if {[dict get $settings data] ne ""} { 745 | # Assumes the declared charset is utf-8. It's important to add this to the mimetype like so: 746 | # Content-Type: text/xml; charset=utf-8 747 | puts $sock "Content-Length: [string length [dict get $settings data]]" 748 | } elseif {[string is integer -strict [dict get $settings data_len]] && [dict get $settings data_cb] ne ""} { 749 | puts $sock "Content-Length: [dict get $settings data_len]" 750 | } 751 | puts $sock "Connection: keep-alive" 752 | puts $sock "" 753 | if {[dict get $settings data] ne ""} { 754 | chan configure $sock -buffersize 1000000 755 | chan configure $sock -translation {auto binary} 756 | puts -nonewline $sock [dict get $settings data] 757 | chan configure $sock -translation {auto crlf} -encoding ascii 758 | } elseif {[dict get $settings data_cb] ne ""} { 759 | chan configure $sock -buffersize 1000000 760 | chan configure $sock -translation {auto binary} 761 | uplevel #0 [list {*}[dict get $settings data_cb] $sock] 762 | chan configure $sock -translation {auto crlf} -encoding ascii 763 | } 764 | flush $sock 765 | } 766 | 767 | #>>> 768 | method _remaining_timeout {} { #<<< 769 | if {[dict get $settings timeout] eq ""} return 770 | set remain [expr { 771 | [dict get $settings timeout] - ([clock microseconds] - $starttime) / 1e6 772 | }] 773 | if {$remain < 0} {return 0.0} 774 | set remain 775 | } 776 | 777 | #>>> 778 | method _read_headers {} { #<<< 779 | chan configure $sock -buffering line -translation {auto crlf} -encoding ascii 780 | while 1 { 781 | #set before [clock microseconds] 782 | set line [gets $sock] 783 | #set elapsed_usec [expr {[clock microseconds] - $before}] 784 | if {[eof $sock]} { 785 | set headers_status dropped 786 | break 787 | } 788 | 789 | if {![chan blocked $sock]} { 790 | if {![dict exists $response statusline]} { 791 | if {$line eq ""} { 792 | # RFC 7230 Section 3.5 793 | continue 794 | } 795 | dict set response statusline $line 796 | my _response_start $line 797 | continue 798 | } 799 | 800 | if {$line eq ""} { 801 | set headers_status ok 802 | break 803 | } 804 | 805 | append resp_headers_buf $line \n 806 | } else { 807 | my _wait_for_readable $sock [my _remaining_timeout] 808 | } 809 | } 810 | 811 | if {$headers_status ne "ok"} { 812 | throw [list RL HTTP READ_HEADERS $headers_status] "Error reading HTTP headers: $headers_status" 813 | } 814 | } 815 | 816 | #>>> 817 | method _response_start line {} ;# Hook this to get called when the status line is received 818 | method _parse_statusline {} { #<<< 819 | if {![regexp {^HTTP/([0-9]+\.[0-9]+) ([0-9][0-9][0-9]) (.*)$} [dict get $response statusline] - resp_http_ver http_code]} { 820 | throw [list RL HTTP PARSE_HEADERS [dict get $response statusline]] "Invalid HTTP status line: \"[dict get $response statusline]\"" 821 | } 822 | dict set response ver $resp_http_ver 823 | dict set response code $http_code 824 | } 825 | 826 | #>>> 827 | method _parse_headers header_txt { #<<< 828 | # Unfold headers 829 | regsub -all {\n\s+} $header_txt { } header_txt 830 | 831 | foreach line [split [string trim $header_txt] \n] { 832 | if {![regexp {^([^:]+):\s*(.*)$} $line - k v]} { 833 | throw [list RL HTTP PARSE_HEADERS $line] "Unable to parse HTTP response header line: \"$line\"" 834 | } 835 | set kl [string tolower $k] 836 | 837 | set vl [if {$kl in { 838 | age 839 | authorization 840 | content-length 841 | content-location 842 | content-md5 843 | content-range 844 | content-type 845 | date 846 | etag 847 | expires 848 | from 849 | host 850 | if-modified-since 851 | if-range 852 | if-unmodified-since 853 | last-modified 854 | location 855 | max-forwards 856 | proxy-authentication 857 | range 858 | referer 859 | retry-after 860 | server 861 | user-agent 862 | set-cookie 863 | cookie 864 | }} { 865 | list [string trim $v] 866 | } else { 867 | lmap e [split $v ,] {string trim $e} 868 | }] 869 | 870 | my _append_headers $kl [lmap e $vl {string trim $e}] 871 | } 872 | } 873 | 874 | #>>> 875 | method _append_headers {k vlist} { #<<< 876 | if {![dict exists $response headers $k]} { 877 | dict set response headers $k {} 878 | } 879 | dict with response { 880 | dict lappend headers [string tolower $k] {*}$vlist 881 | } 882 | } 883 | 884 | #>>> 885 | method _read_chunk_control {} { #<<< 886 | chan configure $sock -translation {auto crlf} -encoding ascii -buffering line 887 | 888 | while 1 { 889 | set chunk_buf [gets $sock] 890 | 891 | if {[eof $sock]} { 892 | set body_status dropped 893 | break 894 | } 895 | 896 | if {![chan blocked $sock]} { 897 | set body_status ok 898 | break 899 | } 900 | 901 | my _wait_for_readable $sock [my _remaining_timeout] 902 | } 903 | 904 | if {$body_status ne "ok"} { 905 | throw [list RL HTTP READ_BODY $body_status] "Error reading HTTP chunk control line: $body_status" 906 | } 907 | 908 | if {![regexp {^([0-9a-fA-F]+)(?:;(.+))?$} $chunk_buf - octets chunk_extensions_enc]} { 909 | throw [list RL HTTP READ_BODY CORRUPT_CHUNKED] "Corrupt HTTP Transfer-Encoding: chunked body" 910 | } 911 | 912 | # Convert chunk_extensions to a dict 913 | set chunk_extensions [concat {*}[lmap e [split $chunk_extensions_enc ";"] { 914 | regexp {^([^=]+)(?:=(.*))?$} $e - name value 915 | list $name $value 916 | }]] 917 | 918 | set octets 0x$octets 919 | 920 | list $octets $chunk_extensions 921 | } 922 | 923 | #>>> 924 | method _read_chunk_data length { #<<< 925 | set expecting [expr {$length + 2}] ;# +2: trailing \r\n 926 | chan configure $sock -buffersize [expr {min(1000000, $expecting)}] -buffering full -translation binary 927 | 928 | while 1 { 929 | unset -nocomplain wait 930 | my _readable_body $expecting 931 | if {[info exists wait]} break 932 | my _wait_for_readable $sock [my _remaining_timeout] 933 | } 934 | set body_status $wait 935 | 936 | if {$body_status ne "ok"} { 937 | throw [list RL HTTP READ_BODY $body_status] "Error reading HTTP response chunk: $body_status" 938 | } 939 | 940 | if {[string range $resp_body_buf end-1 end] ne "\r\n"} { 941 | throw [list RL HTTP READ_BODY CORRUPT_CHUNKED] "Corrupt HTTP Transfer-Encoding: chunked body" 942 | } 943 | set resp_body_buf [string range [try {set resp_body_buf} finally {unset resp_body_buf}] 0 end-2] 944 | } 945 | 946 | #>>> 947 | method _read_body {} { #<<< 948 | if {[dict get $response code] == 204 || $method eq "HEAD"} { 949 | # 204 means No Content - there is nothing to read in this case 950 | dict set response body "" 951 | return 952 | } 953 | 954 | if {[dict exists $response headers content-length]} { 955 | set content_length [lindex [dict get $response headers content-length] 0] 956 | if {[dict get $settings sizelimit] ne ""} { 957 | if {$content_length > [dict get $settings sizelimit]} { 958 | throw [list RL HTTP READ_BODY TOO_BIG $content_length] "Content-Length exceeds maximum: $content_length > [dict get $settings sizelimit]" 959 | } 960 | } 961 | chan configure $sock -buffersize [expr {min(1000000, $content_length)}] 962 | } 963 | 964 | if {[dict exists $response headers transfer-encoding]} { 965 | set total_expecting 0 966 | while 1 { 967 | lassign [my _read_chunk_control] length chunk_extensions 968 | if {$length == 0} break 969 | incr total_expecting $length 970 | my _read_chunk_data $total_expecting 971 | } 972 | my _read_headers 973 | } else { 974 | chan configure $sock -buffering full -translation binary 975 | if {[dict exists $response headers content-length]} { 976 | set expecting [lindex [dict get $response headers content-length] 0] 977 | } else { 978 | set expecting "" 979 | } 980 | 981 | while 1 { 982 | my _readable_body $expecting 983 | if {[info exists wait]} break 984 | my _wait_for_readable $sock [my _remaining_timeout] 985 | } 986 | set body_status $wait 987 | 988 | if {$body_status ne "ok"} { 989 | throw [list RL HTTP READ_BODY $body_status] "Error reading HTTP response body: $body_status" 990 | } 991 | } 992 | 993 | # Check content-length (if provided) to ensure we got the whole response body 994 | if {[dict exists $response headers content-length]} { 995 | set content_length [lindex [dict get $response headers content-length] end] 996 | if {[string length $resp_body_buf] != $content_length} { 997 | throw [list RL HTTP READ_BODY truncated] "Expecting $content_length bytes in HTTP response body, got [string length $resp_body_buf]" 998 | } 999 | } elseif {[dict get $settings sizelimit] ne ""} { 1000 | # Need to check the sizelimit here again in-case the server didn't 1001 | # supply a Content-Length header, although it will be less useful 1002 | # since we already have the response body in memory, but at least 1003 | # we can honour the contract with our caller that we won't return a 1004 | # response bigger than -sizelimit 1005 | if {[string length $resp_body_buf] > [dict get $settings sizelimit]} { 1006 | throw [list RL HTTP READ_BODY TOO_BIG [string length $resp_body_buf]] "Content-Length exceeds maximum: [string length $resp_body_buf] > [dict get $settings sizelimit]" 1007 | } 1008 | } 1009 | 1010 | # Decode transfer-encoding and content-encoding 1011 | foreach header {transfer-encoding content-encoding} { 1012 | if {[dict exists $response headers $header]} { 1013 | foreach enc [lreverse [dict get $response headers $header]] { 1014 | switch -nocase -- $enc { 1015 | chunked { 1016 | # Handled during read 1017 | } 1018 | base64 { set resp_body_buf [binary decode base64 $resp_body_buf] } 1019 | gzip - x-gzip { set resp_body_buf [zlib gunzip $resp_body_buf] } 1020 | deflate { set resp_body_buf [zlib inflate $resp_body_buf] } 1021 | compress - x-compress { set resp_body_buf [zlib decompress $resp_body_buf] } 1022 | identity - 8bit - 7bit - binary {} 1023 | default { 1024 | throw [list RL HTTP READ_BODY unhandled_encoding $enc] "Unhandled HTTP response body $header: \"$enc\"" 1025 | } 1026 | } 1027 | } 1028 | } 1029 | } 1030 | 1031 | # Convert from the specified charset encoding (if supplied) 1032 | if {[dict exists $response headers content-type]} { 1033 | set content_type [lindex [dict get $response headers content-type] end] 1034 | if {[regexp -nocase {^((?:text|application)/[^ ]+)(?:\scharset=\"?([^\"]+)\"?)?$} $content_type - mimetype charset]} { 1035 | if {$charset eq ""} { 1036 | # Some mimetypes have default charsets 1037 | switch -- $mimetype { 1038 | application/json - 1039 | text/json { 1040 | set charset utf-8 1041 | } 1042 | 1043 | application/xml - 1044 | text/xml { 1045 | # According to the RFC, text/xml should default to 1046 | # US-ASCII, but this is widely regarded as stupid, 1047 | # and US-ASCII is a subset of UTF-8 anyway. Any 1048 | # documents that fail because of an invalid UTF-8 1049 | # encoding were broken anyway (they contained bytes 1050 | # not legal for US-ASCII either) 1051 | set charset utf-8 1052 | } 1053 | 1054 | default { 1055 | set charset identity 1056 | } 1057 | } 1058 | } 1059 | 1060 | switch -nocase -- $charset { 1061 | utf-8 { set resp_body_buf [encoding convertfrom utf-8 $resp_body_buf] } 1062 | iso-8859-1 { set resp_body_buf [encoding convertfrom iso8859-1 $resp_body_buf] } 1063 | windows-1252 { set resp_body_buf [encoding convertfrom cp1252 $resp_body_buf] } 1064 | identity {} 1065 | default { 1066 | # Only broken servers will land here - we specified the set of encodings we support in the 1067 | # request Accept-Encoding header 1068 | throw [list RL HTTP READ_BODY UNHANDLED_CHARSET $charset] "Unhandled HTTP response body charset: \"$charset\"" 1069 | } 1070 | } 1071 | } 1072 | } 1073 | 1074 | dict set response body $resp_body_buf 1075 | } 1076 | 1077 | #>>> 1078 | method _readable_body {{expecting ""}} { #<<< 1079 | if {$expecting ne ""} { 1080 | set chunk [read $sock [expr {$expecting - [string length $resp_body_buf]}]] 1081 | } else { 1082 | set chunk [read $sock] 1083 | } 1084 | append resp_body_buf $chunk 1085 | 1086 | if {[eof $sock]} { 1087 | close $sock 1088 | set wait ok 1089 | return 1090 | } 1091 | if {$expecting ne ""} { 1092 | set remain [expr {$expecting - [string length $resp_body_buf]}] 1093 | if {$remain <= 0} { 1094 | set wait ok 1095 | return 1096 | } 1097 | chan configure $sock -buffersize [expr {min(1000000, $remain)}] 1098 | } 1099 | } 1100 | 1101 | #>>> 1102 | method _stats ms { #<<< 1103 | # intended to be replaced if stats need to be logged 1104 | } 1105 | 1106 | #>>> 1107 | 1108 | foreach accessor {code body headers} { 1109 | method $accessor {} "my collect; dict get \$response [list $accessor]" 1110 | } 1111 | 1112 | # Utility HTTP-related class methods 1113 | if {$::rl_http::have_reuri} { 1114 | self method encode_query_params args {reuri::query new $args} 1115 | } elseif {[info commands ns_urlencode] eq ""} { 1116 | package require http 1117 | self method encode_query_params args { #<<< 1118 | http::formatQuery {*}$args 1119 | } 1120 | 1121 | #>>> 1122 | } else { 1123 | self method encode_query_params args { #<<< 1124 | join [lmap {k v} $args { 1125 | format %s=%s [ns_urlencode -charset utf-8 -- $k] [ns_urlencode -charset utf-8 -- $v] 1126 | }] & 1127 | } 1128 | 1129 | #>>> 1130 | } 1131 | 1132 | self method utf8buffer args {tailcall ::rl_http::utf8buffer {*}$args} 1133 | } 1134 | 1135 | 1136 | # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 1137 | -------------------------------------------------------------------------------- /tests/all.tcl: -------------------------------------------------------------------------------- 1 | # all.tcl -- 2 | # 3 | # This file contains a top-level script to run all of the Tcl 4 | # tests. Execute it by invoking "source all.test" when running tcltest 5 | # in this directory. 6 | # 7 | # Copyright (c) 1998-2000 by Scriptics Corporation. 8 | # All rights reserved. 9 | # 10 | # RCS: @(#) $Id: all.tcl,v 1.4 2004/07/04 22:04:20 patthoyts Exp $ 11 | 12 | if {[lsearch [namespace children] ::tcltest] == -1} { 13 | package require tcltest 14 | namespace import ::tcltest::* 15 | } 16 | 17 | set ::tcltest::testSingleFile false 18 | set ::tcltest::testsDirectory [file dir [info script]] 19 | 20 | # We need to ensure that the testsDirectory is absolute 21 | if {[catch {::tcltest::normalizePath ::tcltest::testsDirectory}]} { 22 | # The version of tcltest we have here does not support 23 | # 'normalizePath', so we have to do this on our own. 24 | 25 | set oldpwd [pwd] 26 | catch {cd $::tcltest::testsDirectory} 27 | set ::tcltest::testsDirectory [pwd] 28 | cd $oldpwd 29 | } 30 | 31 | set chan $::tcltest::outputChannel 32 | 33 | puts $chan "Tests running in interp: [info nameofexecutable]" 34 | puts $chan "Tests running with pwd: [pwd]" 35 | puts $chan "Tests running in working dir: $::tcltest::testsDirectory" 36 | if {[llength $::tcltest::skip] > 0} { 37 | puts $chan "Skipping tests that match: $::tcltest::skip" 38 | } 39 | if {[llength $::tcltest::match] > 0} { 40 | puts $chan "Only running tests that match: $::tcltest::match" 41 | } 42 | 43 | if {[llength $::tcltest::skipFiles] > 0} { 44 | puts $chan "Skipping test files that match: $::tcltest::skipFiles" 45 | } 46 | if {[llength $::tcltest::matchFiles] > 0} { 47 | puts $chan "Only sourcing test files that match: $::tcltest::matchFiles" 48 | } 49 | 50 | set timeCmd {clock format [clock seconds]} 51 | puts $chan "Tests began at [eval $timeCmd]" 52 | 53 | # source each of the specified tests 54 | foreach file [lsort [::tcltest::getMatchingFiles]] { 55 | set tail [file tail $file] 56 | puts $chan $tail 57 | if {[catch {source $file} msg]} { 58 | puts $chan $msg 59 | } 60 | } 61 | 62 | # cleanup 63 | puts $chan "\nTests ended at [eval $timeCmd]" 64 | ::tcltest::cleanupTests 1 65 | return 66 | 67 | -------------------------------------------------------------------------------- /tests/common.tcl: -------------------------------------------------------------------------------- 1 | if {[llength [info commands replay_server]] > 0} return 2 | try { 3 | 4 | tcltest::loadTestedCommands 5 | package require rl_http 6 | package require md5 7 | package require chantricks 8 | package require uri 9 | 10 | proc ::rl_http::log {lvl msg} { 11 | puts stderr $msg 12 | } 13 | 14 | proc parse_reqs bytes { #<<< 15 | set rl_httpreqs {} 16 | while {[string length $bytes]} { 17 | if {![regexp {^(.*?)\r\n(.*?)\r\n\r\n(.*)$} $bytes - reqline headers tail]} { 18 | error "Can't extract reqline and headers from [binary encode base64 $bytes]" 19 | } 20 | if {![regexp {^([-!#$%&'*+.^_`|~a-zA-Z0-0]+) ([^ ]+) HTTP/([0-9]\.[0-9])$} $reqline - method request_target ver]} { 21 | error "Can't parse reqline: ($reqline)" 22 | } 23 | # Unfold headers 24 | regsub -all {\r\n(?: |\t)+} $headers { } headers 25 | set hdrs {} 26 | foreach {- headerline} [regexp -all -inline {^(.*?)(?:\r\n|$)} $headers] { 27 | foreach {- header_name header_value} [regexp -all -inline {^([-!#$%&'*+.^_`|~a-zA-Z0-9]+):[ \t]*(.*?)[ \t]*$} $headerline] { 28 | foreach v [split $header_value ,] { 29 | set v [string trim $v " \t"] 30 | dict lappend hdrs [string tolower $header_name] $v 31 | } 32 | } 33 | } 34 | 35 | # Reconstruct rl_http constructor arguments from the req and headers 36 | set rl_httpargs [list $method $request_target -ver $ver] 37 | set req_headers {} 38 | 39 | set got_content_len 0 40 | foreach {h vals} $hdrs { 41 | switch $h { 42 | accept {lappend rl_httpargs -accept [lindex $vals end]} 43 | host {lappend rl_httpargs -override_host [lindex $vals end]} 44 | user-agent {lappend rl_httpargs -useragent [lindex $vals end]} 45 | content-length { 46 | set len [lindex $vals end] 47 | if {$len > [string length $tail]} { 48 | error "Content-Length from header doesn't match write tail: [string length $tail]" 49 | } 50 | set data [string range $tail 0 $len-1] 51 | set bytes [string range $tail $len end] 52 | lappend rl_httpargs -data $data 53 | set got_content_len 1 54 | } 55 | connection - accept-encoding - accept-charset {} 56 | default { 57 | foreach v $vals { 58 | lappend req_headers $h $v 59 | } 60 | } 61 | } 62 | } 63 | if {!$got_content_len} { 64 | if {[string length $tail]} { 65 | lappend rl_httpargs -data $tail 66 | } 67 | set bytes {} 68 | } 69 | if {$req_headers ne {}} { 70 | lappend rl_httpargs -headers $req_headers 71 | } 72 | 73 | lappend rl_httpreqs $rl_httpargs 74 | } 75 | set rl_httpreqs 76 | } 77 | 78 | #>>> 79 | gc_class create replay_server { #<<< 80 | variable {*}{ 81 | dump 82 | port 83 | afterid 84 | datum 85 | write_chunks 86 | clients 87 | } 88 | 89 | constructor a_dump { #<<< 90 | if {[self next] ne ""} next 91 | set dump $a_dump 92 | set listen [socket -server [namespace code {my _accept}] 0] 93 | set port [lindex [chan configure $listen -sockname] 2] 94 | set afterid "" 95 | set clients {} 96 | foreach {reltime dir b64} $dump { 97 | if {$dir ne "read"} continue 98 | lappend write_chunks [expr {int($reltime)}] [binary decode base64 $b64] 99 | } 100 | } 101 | 102 | #>>> 103 | destructor { #<<< 104 | after cancel $afterid; set afterid "" 105 | if {[info exists listen]} { 106 | close $listen 107 | unset listen 108 | } 109 | foreach chan [dict keys $clients] { 110 | close $chan 111 | } 112 | set clients {} 113 | if {[self next] ne ""} next 114 | } 115 | 116 | #>>> 117 | method port {} {set port} 118 | method _accept {chan cl_ip cl_port} { #<<< 119 | chan configure $chan -translation binary -blocking 0 -buffering none 120 | chan event $chan readable [namespace code [list my _readable $chan]] 121 | dict set clients $chan {} 122 | my _post_next_write [clock microseconds] $chan $write_chunks 123 | } 124 | 125 | #>>> 126 | method _readable chan { #<<< 127 | set chunk [read $chan] 128 | if {$chunk ne {}} { 129 | #puts stderr "tap_server read:\n$chunk" 130 | } 131 | if {[eof $chan]} { 132 | close $chan 133 | dict unset clients $chan 134 | return 135 | } 136 | # TODO: check $chunk against what we're expecting to receive 137 | } 138 | 139 | #>>> 140 | method _post_next_write {datum chan remaining} { #<<< 141 | try { 142 | while {[llength $remaining]} { 143 | set rel_elapsed [expr {[clock microseconds] - $datum}] 144 | #puts stderr "_post_next_write rel_elapsed: $rel_elapsed, next: ([lindex $remaining 0])" 145 | if {$rel_elapsed < [lindex $remaining 0]} { 146 | break 147 | } 148 | set remaining [lassign $remaining[unset remaining] - bytes] 149 | #puts stderr "tap_server writing next chunk: [string length $bytes] bytes" 150 | puts -nonewline $chan $bytes 151 | flush $chan 152 | } 153 | if {[llength $remaining]} { 154 | set delay_ms [expr {max(1,([lindex $remaining 0] - ([clock microseconds]-$datum))/1000)}] 155 | #puts stderr "waiting $delay_ms ms to write the next chunk" 156 | set afterid [after $delay_ms [namespace code [list my _post_next_write $datum $chan $remaining]]] 157 | } 158 | } on error {errmsg options} { 159 | puts stderr "Unhandled error in _post_next_write: [dict get $options -errorinfo]" 160 | return -options $options $errmsg 161 | } 162 | } 163 | 164 | #>>> 165 | } 166 | 167 | #>>> 168 | proc replay_tap tap_dump { #<<< 169 | set requests {} 170 | set writebytes {} 171 | foreach {rel dir b64} $tap_dump { 172 | if {$dir ne "write"} continue 173 | append writebytes [binary decode base64 $b64] 174 | } 175 | replay_server instvar s $tap_dump 176 | set base http://localhost:[$s port] 177 | 178 | lmap req [parse_reqs $writebytes] { 179 | set args [lassign $req method target] 180 | rl_http instvar h $method $base$target {*}$args 181 | list [$h code] [$h headers] [$h body] 182 | } 183 | } 184 | 185 | #>>> 186 | 187 | trace add execution test enter {apply {{cmd args} {set ::testname [lindex $cmd 1]}}} 188 | trace add execution test leave {apply {{cmd args} {unset -nocomplain ::testname}}} 189 | 190 | } on error {errmsg options} { 191 | puts stderr "Error loading common.tcl: [dict get $options -errorinfo]" 192 | } 193 | 194 | # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 195 | -------------------------------------------------------------------------------- /tests/keepalive_limits.test: -------------------------------------------------------------------------------- 1 | package require Tcl 8.6 2 | 3 | if {"::tcltest" ni [namespace children]} { 4 | package require tcltest 5 | namespace import ::tcltest::* 6 | } 7 | 8 | set here [file dirname [file normalize [info script]]] 9 | source [file join $here common.tcl] 10 | package require gc_class 11 | 12 | if 0 { 13 | gc_class create uds_ka_server { 14 | variable {*}{ 15 | tid 16 | } 17 | 18 | constructor testname { #<<< 19 | package require thread 20 | if {[self next] ne ""} next 21 | 22 | set tid [thread::create -preserved] 23 | thread::send $tid [string map [list \ 24 | %testname% [list $testname] \ 25 | ] { 26 | package require unix_sockets 27 | set sockname /tmp/rl_http_%testname%-[pid].sock 28 | 29 | set conuse {} 30 | set sockseq 0 31 | set sockidx {} 32 | set socks {} 33 | proc readable sock { 34 | global socks sockidx conuse 35 | while 1 { 36 | set line [read $sock] 37 | if {[eof $sock]} { 38 | dict unset $socks $sock 39 | close $sock 40 | return 41 | } 42 | if {$line eq ""} break 43 | } 44 | 45 | puts -nonewline $sock "HTTP/1.1 200 Ok\nContent-Length: 2\nContent-Type: text/plain\nServer: Test\nDate: [clock format [clock seconds] -format "%a, %d %b %Y %T GMT" -timezone :UTC]\n\nok" 46 | flush $sock 47 | dict incr conuse [dict get $sockidx $sock] 1 48 | } 49 | 50 | set listen [unix_sockets::listen $sockname [list apply {{sock args} { 51 | global socks sockseq sockidx 52 | dict set socks $sock 1 53 | dict set sockidx $sock [incr sockseq] 54 | chan configure $sock -blocking 0 -translation binary -buffering line 55 | chan event $sock readable [list readable $sock] 56 | }}]] 57 | 58 | proc cleanup {} { 59 | global sockname listen socks 60 | if {[info exists listen] && $listen in [chan names]} { 61 | close $listen 62 | } 63 | file delete $sockname 64 | foreach sock [dict keys $socks] { 65 | close $sock 66 | } 67 | } 68 | }] 69 | } 70 | 71 | #>>> 72 | destructor { #<<< 73 | if {[info exists tid]} { 74 | thread::send $tid cleanup 75 | thread::release $tid 76 | unset tid 77 | } 78 | if {[self next] ne ""} next 79 | } 80 | 81 | #>>> 82 | method sockname {} { thread::send $tid {set sockname} } 83 | method conuse {} { thread::send $tid {set conuse} } 84 | } 85 | } 86 | 87 | gc_class create lo_ka_server { 88 | variable {*}{ 89 | tid 90 | } 91 | 92 | constructor args { #<<< 93 | package require parse_args 94 | parse_args::parse_args $args { 95 | -response_code_i {-default {i {return 200}}} 96 | } 97 | 98 | package require thread 99 | if {[self next] ne ""} next 100 | 101 | set tid [thread::create -preserved] 102 | thread::send $tid [list set ::response_code_i $response_code_i] 103 | thread::send $tid { 104 | set conuse {} 105 | set sockseq 0 106 | set sockidx {} 107 | set socks {} 108 | proc readable sock { 109 | global socks sockidx conuse 110 | while 1 { 111 | set line [read $sock] 112 | if {[eof $sock]} { 113 | dict unset $socks $sock 114 | close $sock 115 | return 116 | } 117 | if {$line eq ""} break 118 | } 119 | 120 | set code [apply $::response_code_i [expr {1+[dict getdef $conuse [dict get $sockidx $sock] 0]}]] 121 | puts -nonewline $sock "HTTP/1.1 $code Ok\nContent-Length: 2\nContent-Type: text/plain\nServer: Test\nDate: [clock format [clock seconds] -format "%a, %d %b %Y %T GMT" -timezone :UTC]\n\nok" 122 | flush $sock 123 | dict incr conuse [dict get $sockidx $sock] 1 124 | } 125 | 126 | set listen [socket -myaddr 127.0.0.1 -server [list apply {{sock args} { 127 | global socks sockseq sockidx 128 | dict set socks $sock 1 129 | dict set sockidx $sock [incr sockseq] 130 | chan configure $sock -blocking 0 -translation binary -buffering line 131 | chan event $sock readable [list readable $sock] 132 | }}] 0] 133 | set port [lindex [chan configure $listen -sockname] 2] 134 | 135 | proc cleanup {} { 136 | global listen socks 137 | if {[info exists listen] && $listen in [chan names]} { 138 | close $listen 139 | } 140 | foreach sock [dict keys $socks] { 141 | close $sock 142 | } 143 | } 144 | } 145 | } 146 | 147 | #>>> 148 | destructor { #<<< 149 | if {[info exists tid]} { 150 | thread::send $tid cleanup 151 | thread::release $tid 152 | unset tid 153 | } 154 | if {[self next] ne ""} next 155 | } 156 | 157 | #>>> 158 | method port {} { thread::send $tid {set port} } 159 | method conuse {} { thread::send $tid {set conuse} } 160 | } 161 | 162 | test keepalive_limits_count-1.1 {Default, no limit} -setup { #<<< 163 | lo_ka_server instvar s 164 | set url http://127.0.0.1:[$s port] 165 | } -body { 166 | for {set i 0} {$i < 100} {incr i} { 167 | rl_http instvar h GET $url 168 | $h code 169 | } 170 | $s conuse 171 | } -cleanup { 172 | unset -nocomplain i h s url 173 | } -result {1 100} 174 | #>>> 175 | test keepalive_limits_count-2.1 {Default, count limit} -setup { #<<< 176 | lo_ka_server instvar s 177 | set url http://127.0.0.1:[$s port] 178 | } -body { 179 | for {set i 0} {$i < 125} {incr i} { 180 | rl_http instvar h GET $url -max_keepalive_count 50 181 | $h code 182 | } 183 | $s conuse 184 | } -cleanup { 185 | unset -nocomplain i h s url 186 | } -result {1 50 2 50 3 25} 187 | #>>> 188 | test keepalive_limits_count-3.1 {Default, explicit negative count limit} -setup { #<<< 189 | lo_ka_server instvar s 190 | set url http://127.0.0.1:[$s port] 191 | } -body { 192 | for {set i 0} {$i < 125} {incr i} { 193 | rl_http instvar h GET $url -max_keepalive_count -42 194 | $h code 195 | } 196 | $s conuse 197 | } -cleanup { 198 | unset -nocomplain i h s url 199 | } -result {1 125} 200 | #>>> 201 | 202 | test keepalive_limits_age-1.2 {Default, age limit} -setup { #<<< 203 | lo_ka_server instvar s 204 | set url http://127.0.0.1:[$s port] 205 | } -body { 206 | set start [expr {[clock microseconds]/1e6}] 207 | for {set i 0} {$i < 10} {incr i} { 208 | rl_http instvar h GET $url -max_keepalive_age 0.1 209 | $h code 210 | } 211 | while {[clock microseconds]/1e6 - $start < 0.11} {after 1} 212 | for {set i 0} {$i < 10} {incr i} { 213 | rl_http instvar h GET $url -max_keepalive_age 0.1 214 | $h code 215 | } 216 | $s conuse 217 | } -cleanup { 218 | unset -nocomplain i h s url start 219 | } -result {1 10 2 10} 220 | #>>> 221 | 222 | test keepalive_check-1.1 {Don't reuse connections after 500 response} -setup { #<<< 223 | lo_ka_server instvar s -response_code_i {i {expr {$i == 50 ? 500 : 200}}} 224 | set url http://127.0.0.1:[$s port] 225 | } -body { 226 | for {set i 0} {$i < 125} {incr i} { 227 | rl_http instvar h GET $url -keepalive_check {h { 228 | expr {[$h code] != 500} 229 | }} 230 | $h code 231 | } 232 | $s conuse 233 | } -cleanup { 234 | unset -nocomplain i h s url 235 | } -result {1 50 2 50 3 25} 236 | #>>> 237 | 238 | ::tcltest::cleanupTests 239 | return 240 | 241 | # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 242 | -------------------------------------------------------------------------------- /tests/rl_http.test: -------------------------------------------------------------------------------- 1 | package require Tcl 8.6 2 | 3 | if {"::tcltest" ni [namespace children]} { 4 | package require tcltest 5 | namespace import ::tcltest::* 6 | } 7 | 8 | set here [file dirname [file normalize [info script]]] 9 | source [file join $here common.tcl] 10 | package require gc_class 11 | 12 | gc_class create uds_server { 13 | variable {*}{ 14 | tid 15 | } 16 | 17 | constructor testname { #<<< 18 | package require thread 19 | if {[self next] ne ""} next 20 | 21 | set tid [thread::create -preserved] 22 | thread::send $tid [string map [list \ 23 | %testname% [list $testname] \ 24 | ] { 25 | package require unix_sockets 26 | set sockname /tmp/rl_http_%testname%-[pid].sock 27 | set listen [unix_sockets::listen $sockname [list apply {{sock args} { 28 | chan configure $sock -blocking 0 -translation {auto lf} -encoding binary 29 | read $sock 30 | puts -nonewline $sock "HTTP/1.1 200 Ok\nContent-Length: 2\nContent-Type: text/plain\nServer: Test\nDate: [clock format [clock seconds] -format "%a, %d %b %Y %T GMT" -timezone :UTC]\n\nok" 31 | close $sock 32 | }}]] 33 | 34 | proc cleanup {} { 35 | global sockname listen 36 | if {[info exists listen] && $listen in [chan names]} { 37 | close $listen 38 | } 39 | file delete $sockname 40 | } 41 | }] 42 | } 43 | 44 | #>>> 45 | destructor { #<<< 46 | if {[info exists tid]} { 47 | thread::send $tid cleanup 48 | thread::release $tid 49 | unset tid 50 | } 51 | if {[self next] ne ""} next 52 | } 53 | 54 | #>>> 55 | method sockname {} { thread::send $tid {set sockname} } 56 | } 57 | 58 | test rl_http-1.1 {Basic usage, GET, http://} -body { #<<< 59 | rl_http create h GET http://image0-rubylane.s3.amazonaws.com/0/cart/introbg.gif -timeout 5 60 | list [h code] [md5::md5 -hex [h body]] 61 | } -cleanup { 62 | if {[info object isa object h]} {h destroy} 63 | } -result {200 BD076D578BFE58AD406803AAAAD7AD9B} 64 | #>>> 65 | test rl_http-1.2 {Basic usage, GET, https://} -body { #<<< 66 | rl_http create h GET https://image0-rubylane.s3.amazonaws.com/0/cart/introbg.gif -timeout 5 67 | list [h code] [md5::md5 -hex [h body]] 68 | } -cleanup { 69 | if {[info object isa object h]} {h destroy} 70 | } -result {200 BD076D578BFE58AD406803AAAAD7AD9B} 71 | #>>> 72 | test rl_http-2.1 {local sockets, reuri} -setup { #<<< 73 | if {[info exists ::rl_http::have_reuri]} {set old_have_reuri $::rl_http::have_reuri} else {unset -nocomplain old_have_reuri} 74 | package require reuri 0.2.5 75 | set ::rl_http::have_reuri 1 76 | uds_server instvar s rl_http-2.1 77 | } -body { 78 | rl_http instvar h GET "http://\[[$s sockname]\]/foo" 79 | list [$h code] [$h body] 80 | } -cleanup { 81 | if {[info exists old_have_reuri]} {set ::rl_http::have_reuri $old_have_reuri} else {unset -nocomplain ::rl_http:have_reuri} 82 | unset -nocomplain h old_have_reuri s 83 | } -result {200 ok} 84 | #>>> 85 | test rl_http-2.2 {local sockets, ip_future version scope, reuri} -setup { #<<< 86 | if {[info exists ::rl_http::have_reuri]} {set old_have_reuri $::rl_http::have_reuri} else {unset -nocomplain old_have_reuri} 87 | package require reuri 0.2.5 88 | uds_server instvar s rl_http-2.2 89 | } -body { 90 | rl_http instvar h GET "http://\[v0.local:[$s sockname]\]/foo" 91 | list [$h code] [$h body] 92 | } -cleanup { 93 | if {[info exists old_have_reuri]} {set ::rl_http::have_reuri $old_have_reuri} else {unset -nocomplain ::rl_http:have_reuri} 94 | unset -nocomplain h old_have_reuri s 95 | } -result {200 ok} 96 | #>>> 97 | test rl_http-3.1 {local sockets, no reuri} -setup { #<<< 98 | if {[info exists ::rl_http::have_reuri]} {set old_have_reuri $::rl_http::have_reuri} else {unset -nocomplain old_have_reuri} 99 | set ::rl_http::have_reuri 0 100 | uds_server instvar s rl_http-3.1 101 | } -body { 102 | rl_http instvar h GET "http://\[[$s sockname]\]/foo" 103 | list [$h code] [$h body] 104 | } -cleanup { 105 | if {[info exists old_have_reuri]} {set ::rl_http::have_reuri $old_have_reuri} else {unset -nocomplain ::rl_http:have_reuri} 106 | unset -nocomplain h old_have_reuri s 107 | } -result {200 ok} 108 | #>>> 109 | test rl_http-3.2 {local sockets, ip_future version scope, reuri} -setup { #<<< 110 | if {[info exists ::rl_http::have_reuri]} {set old_have_reuri $::rl_http::have_reuri} else {unset -nocomplain old_have_reuri} 111 | uds_server instvar s rl_http-3.2 112 | } -body { 113 | rl_http instvar h GET "http://\[v0.local:[$s sockname]\]/foo" 114 | list [$h code] [$h body] 115 | } -cleanup { 116 | if {[info exists old_have_reuri]} {set ::rl_http::have_reuri $old_have_reuri} else {unset -nocomplain ::rl_http:have_reuri} 117 | unset -nocomplain h old_have_reuri s 118 | } -result {200 ok} 119 | #>>> 120 | 121 | ::tcltest::cleanupTests 122 | return 123 | 124 | # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 125 | -------------------------------------------------------------------------------- /tests/tapchan.test: -------------------------------------------------------------------------------- 1 | package require Tcl 8.6 2 | 3 | if {"::tcltest" ni [namespace children]} { 4 | package require tcltest 5 | namespace import ::tcltest::* 6 | } 7 | 8 | source tests/common.tcl 9 | 10 | test tapchan-1.1 {Inspect bytes on the wire with -tapchan} -setup { #<<< 11 | package require aio 12 | set fakeserver [socket -server [list coroutine coro_tapchan-1.1 apply {{chan peer_ip peer_port} { 13 | global socks 14 | lappend socks $chan 15 | chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 65536 -encoding ascii 16 | while {[aio gets $chan 1] ne ""} {} 17 | set line [gets $chan] 18 | if {![chan blocked $chan]} { 19 | set body [encoding convertto utf-8 "Extra garbage after HTTP request: $line"] 20 | puts $chan "HTTP/1.1 400 Bad" 21 | } else { 22 | set body [encoding convertto utf-8 "hello, tapchan"] 23 | puts $chan "HTTP/1.1 200 OK" 24 | } 25 | puts $chan "Content-Type: text/plain; charset=utf-8" 26 | puts $chan "Content-Length: [string length $body]" 27 | puts $chan "Server: fake test server" 28 | puts $chan "Date: Tue, 16 Aug 2022 08:11:55 GMT" 29 | puts $chan "Connection: close" 30 | puts $chan "" 31 | chan configure $chan -translation binary 32 | puts -nonewline $chan $body 33 | flush $chan 34 | close $chan 35 | }}] 0] 36 | lappend socks $fakeserver 37 | set port [lindex [chan configure $fakeserver -sockname] 2] 38 | } -body { 39 | rl_http instvar h GET http://localhost:$port/foo -timeout 5 -tapchan rl_http::tapchan 40 | list [$h code] [$h body] 41 | } -cleanup { 42 | if {[info exists socks]} { 43 | foreach sock $socks { 44 | if {$sock ni [chan names]} continue 45 | try {close $sock} on error {errmsg options} { 46 | puts stderr "Error closing sock $sock ([dict get $options -errorcode]): $errmsg" 47 | } 48 | } 49 | } 50 | unset -nocomplain fakeserver port socks sock h 51 | catch {rename coro_tapchan-1.1 {}} 52 | } -result {200 {hello, tapchan}} -match regexp -errorOutput {rl_http tapchan [^ ]+ initialize read write 53 | rl_http tapchan [^ ]+ write (?:[A-Za-z0-9+/-]+={0,2}) 54 | rl_http tapchan [^ ]+ read SFRUUC8xLjEgMjAwIE9LDQpDb250ZW50LVR5cGU6IHRleHQvcGxhaW47IGNoYXJzZXQ9dXRmLTgNCkNvbnRlbnQtTGVuZ3RoOiAxNA0KU2VydmVyOiBmYWtlIHRlc3Qgc2VydmVyDQpEYXRlOiBUdWUsIDE2IEF1ZyAyMDIyIDA4OjExOjU1IEdNVA0KQ29ubmVjdGlvbjogY2xvc2UNCg0KaGVsbG8sIHRhcGNoYW4= 55 | tapchan [^ ]+ finalize 56 | $} 57 | #>>> 58 | 59 | ::tcltest::cleanupTests 60 | return 61 | 62 | # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 63 | --------------------------------------------------------------------------------