[37] | 1 | # http.tcl -- |
---|
| 2 | # |
---|
| 3 | # Client-side HTTP for GET, POST, and HEAD commands. |
---|
| 4 | # These routines can be used in untrusted code that uses |
---|
| 5 | # the Safesock security policy. These procedures use a |
---|
| 6 | # callback interface to avoid using vwait, which is not |
---|
| 7 | # defined in the safe base. |
---|
| 8 | # |
---|
| 9 | # See the file "license.terms" for information on usage and |
---|
| 10 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 11 | # |
---|
| 12 | # RCS: @(#) $Id: http.tcl,v 1.43.2.4 2004/05/25 22:50:47 hobbs Exp $ |
---|
| 13 | |
---|
| 14 | # Rough version history: |
---|
| 15 | # 1.0 Old http_get interface |
---|
| 16 | # 2.0 http:: namespace and http::geturl |
---|
| 17 | # 2.1 Added callbacks to handle arriving data, and timeouts |
---|
| 18 | # 2.2 Added ability to fetch into a channel |
---|
| 19 | # 2.3 Added SSL support, and ability to post from a channel |
---|
| 20 | # This version also cleans up error cases and eliminates the |
---|
| 21 | # "ioerror" status in favor of raising an error |
---|
| 22 | # 2.4 Added -binary option to http::geturl and charset element |
---|
| 23 | # to the state array. |
---|
| 24 | |
---|
| 25 | package require Tcl 8.2 |
---|
| 26 | # keep this in sync with pkgIndex.tcl |
---|
| 27 | # and with the install directories in Makefiles |
---|
| 28 | package provide http 2.5.0 |
---|
| 29 | |
---|
| 30 | namespace eval http { |
---|
| 31 | variable http |
---|
| 32 | array set http { |
---|
| 33 | -accept */* |
---|
| 34 | -proxyhost {} |
---|
| 35 | -proxyport {} |
---|
| 36 | -proxyfilter http::ProxyRequired |
---|
| 37 | -urlencoding utf-8 |
---|
| 38 | } |
---|
| 39 | set http(-useragent) "Tcl http client package [package provide http]" |
---|
| 40 | |
---|
| 41 | proc init {} { |
---|
| 42 | variable formMap |
---|
| 43 | variable alphanumeric a-zA-Z0-9 |
---|
| 44 | for {set i 0} {$i <= 256} {incr i} { |
---|
| 45 | set c [format %c $i] |
---|
| 46 | if {![string match \[$alphanumeric\] $c]} { |
---|
| 47 | set formMap($c) %[format %.2x $i] |
---|
| 48 | } |
---|
| 49 | } |
---|
| 50 | # These are handled specially |
---|
| 51 | array set formMap { " " + \n %0d%0a } |
---|
| 52 | } |
---|
| 53 | init |
---|
| 54 | |
---|
| 55 | variable urlTypes |
---|
| 56 | array set urlTypes { |
---|
| 57 | http {80 ::socket} |
---|
| 58 | } |
---|
| 59 | |
---|
| 60 | variable encodings [string tolower [encoding names]] |
---|
| 61 | # This can be changed, but iso8859-1 is the RFC standard. |
---|
| 62 | variable defaultCharset "iso8859-1" |
---|
| 63 | |
---|
| 64 | namespace export geturl config reset wait formatQuery register unregister |
---|
| 65 | # Useful, but not exported: data size status code |
---|
| 66 | } |
---|
| 67 | |
---|
| 68 | # http::register -- |
---|
| 69 | # |
---|
| 70 | # See documentaion for details. |
---|
| 71 | # |
---|
| 72 | # Arguments: |
---|
| 73 | # proto URL protocol prefix, e.g. https |
---|
| 74 | # port Default port for protocol |
---|
| 75 | # command Command to use to create socket |
---|
| 76 | # Results: |
---|
| 77 | # list of port and command that was registered. |
---|
| 78 | |
---|
| 79 | proc http::register {proto port command} { |
---|
| 80 | variable urlTypes |
---|
| 81 | set urlTypes($proto) [list $port $command] |
---|
| 82 | } |
---|
| 83 | |
---|
| 84 | # http::unregister -- |
---|
| 85 | # |
---|
| 86 | # Unregisters URL protocol handler |
---|
| 87 | # |
---|
| 88 | # Arguments: |
---|
| 89 | # proto URL protocol prefix, e.g. https |
---|
| 90 | # Results: |
---|
| 91 | # list of port and command that was unregistered. |
---|
| 92 | |
---|
| 93 | proc http::unregister {proto} { |
---|
| 94 | variable urlTypes |
---|
| 95 | if {![info exists urlTypes($proto)]} { |
---|
| 96 | return -code error "unsupported url type \"$proto\"" |
---|
| 97 | } |
---|
| 98 | set old $urlTypes($proto) |
---|
| 99 | unset urlTypes($proto) |
---|
| 100 | return $old |
---|
| 101 | } |
---|
| 102 | |
---|
| 103 | # http::config -- |
---|
| 104 | # |
---|
| 105 | # See documentaion for details. |
---|
| 106 | # |
---|
| 107 | # Arguments: |
---|
| 108 | # args Options parsed by the procedure. |
---|
| 109 | # Results: |
---|
| 110 | # TODO |
---|
| 111 | |
---|
| 112 | proc http::config {args} { |
---|
| 113 | variable http |
---|
| 114 | set options [lsort [array names http -*]] |
---|
| 115 | set usage [join $options ", "] |
---|
| 116 | if {[llength $args] == 0} { |
---|
| 117 | set result {} |
---|
| 118 | foreach name $options { |
---|
| 119 | lappend result $name $http($name) |
---|
| 120 | } |
---|
| 121 | return $result |
---|
| 122 | } |
---|
| 123 | set options [string map {- ""} $options] |
---|
| 124 | set pat ^-([join $options |])$ |
---|
| 125 | if {[llength $args] == 1} { |
---|
| 126 | set flag [lindex $args 0] |
---|
| 127 | if {[regexp -- $pat $flag]} { |
---|
| 128 | return $http($flag) |
---|
| 129 | } else { |
---|
| 130 | return -code error "Unknown option $flag, must be: $usage" |
---|
| 131 | } |
---|
| 132 | } else { |
---|
| 133 | foreach {flag value} $args { |
---|
| 134 | if {[regexp -- $pat $flag]} { |
---|
| 135 | set http($flag) $value |
---|
| 136 | } else { |
---|
| 137 | return -code error "Unknown option $flag, must be: $usage" |
---|
| 138 | } |
---|
| 139 | } |
---|
| 140 | } |
---|
| 141 | } |
---|
| 142 | |
---|
| 143 | # http::Finish -- |
---|
| 144 | # |
---|
| 145 | # Clean up the socket and eval close time callbacks |
---|
| 146 | # |
---|
| 147 | # Arguments: |
---|
| 148 | # token Connection token. |
---|
| 149 | # errormsg (optional) If set, forces status to error. |
---|
| 150 | # skipCB (optional) If set, don't call the -command callback. This |
---|
| 151 | # is useful when geturl wants to throw an exception instead |
---|
| 152 | # of calling the callback. That way, the same error isn't |
---|
| 153 | # reported to two places. |
---|
| 154 | # |
---|
| 155 | # Side Effects: |
---|
| 156 | # Closes the socket |
---|
| 157 | |
---|
| 158 | proc http::Finish { token {errormsg ""} {skipCB 0}} { |
---|
| 159 | variable $token |
---|
| 160 | upvar 0 $token state |
---|
| 161 | global errorInfo errorCode |
---|
| 162 | if {[string length $errormsg] != 0} { |
---|
| 163 | set state(error) [list $errormsg $errorInfo $errorCode] |
---|
| 164 | set state(status) error |
---|
| 165 | } |
---|
| 166 | catch {close $state(sock)} |
---|
| 167 | catch {after cancel $state(after)} |
---|
| 168 | if {[info exists state(-command)] && !$skipCB} { |
---|
| 169 | if {[catch {eval $state(-command) {$token}} err]} { |
---|
| 170 | if {[string length $errormsg] == 0} { |
---|
| 171 | set state(error) [list $err $errorInfo $errorCode] |
---|
| 172 | set state(status) error |
---|
| 173 | } |
---|
| 174 | } |
---|
| 175 | if {[info exists state(-command)]} { |
---|
| 176 | # Command callback may already have unset our state |
---|
| 177 | unset state(-command) |
---|
| 178 | } |
---|
| 179 | } |
---|
| 180 | } |
---|
| 181 | |
---|
| 182 | # http::reset -- |
---|
| 183 | # |
---|
| 184 | # See documentaion for details. |
---|
| 185 | # |
---|
| 186 | # Arguments: |
---|
| 187 | # token Connection token. |
---|
| 188 | # why Status info. |
---|
| 189 | # |
---|
| 190 | # Side Effects: |
---|
| 191 | # See Finish |
---|
| 192 | |
---|
| 193 | proc http::reset { token {why reset} } { |
---|
| 194 | variable $token |
---|
| 195 | upvar 0 $token state |
---|
| 196 | set state(status) $why |
---|
| 197 | catch {fileevent $state(sock) readable {}} |
---|
| 198 | catch {fileevent $state(sock) writable {}} |
---|
| 199 | Finish $token |
---|
| 200 | if {[info exists state(error)]} { |
---|
| 201 | set errorlist $state(error) |
---|
| 202 | unset state |
---|
| 203 | eval ::error $errorlist |
---|
| 204 | } |
---|
| 205 | } |
---|
| 206 | |
---|
| 207 | # http::geturl -- |
---|
| 208 | # |
---|
| 209 | # Establishes a connection to a remote url via http. |
---|
| 210 | # |
---|
| 211 | # Arguments: |
---|
| 212 | # url The http URL to goget. |
---|
| 213 | # args Option value pairs. Valid options include: |
---|
| 214 | # -blocksize, -validate, -headers, -timeout |
---|
| 215 | # Results: |
---|
| 216 | # Returns a token for this connection. |
---|
| 217 | # This token is the name of an array that the caller should |
---|
| 218 | # unset to garbage collect the state. |
---|
| 219 | |
---|
| 220 | proc http::geturl { url args } { |
---|
| 221 | variable http |
---|
| 222 | variable urlTypes |
---|
| 223 | variable defaultCharset |
---|
| 224 | |
---|
| 225 | # Initialize the state variable, an array. We'll return the |
---|
| 226 | # name of this array as the token for the transaction. |
---|
| 227 | |
---|
| 228 | if {![info exists http(uid)]} { |
---|
| 229 | set http(uid) 0 |
---|
| 230 | } |
---|
| 231 | set token [namespace current]::[incr http(uid)] |
---|
| 232 | variable $token |
---|
| 233 | upvar 0 $token state |
---|
| 234 | reset $token |
---|
| 235 | |
---|
| 236 | # Process command options. |
---|
| 237 | |
---|
| 238 | array set state { |
---|
| 239 | -binary false |
---|
| 240 | -blocksize 8192 |
---|
| 241 | -queryblocksize 8192 |
---|
| 242 | -validate 0 |
---|
| 243 | -headers {} |
---|
| 244 | -timeout 0 |
---|
| 245 | -type application/x-www-form-urlencoded |
---|
| 246 | -queryprogress {} |
---|
| 247 | state header |
---|
| 248 | meta {} |
---|
| 249 | coding {} |
---|
| 250 | currentsize 0 |
---|
| 251 | totalsize 0 |
---|
| 252 | querylength 0 |
---|
| 253 | queryoffset 0 |
---|
| 254 | type text/html |
---|
| 255 | body {} |
---|
| 256 | status "" |
---|
| 257 | http "" |
---|
| 258 | } |
---|
| 259 | # These flags have their types verified [Bug 811170] |
---|
| 260 | array set type { |
---|
| 261 | -binary boolean |
---|
| 262 | -blocksize integer |
---|
| 263 | -queryblocksize integer |
---|
| 264 | -validate boolean |
---|
| 265 | -timeout integer |
---|
| 266 | } |
---|
| 267 | set state(charset) $defaultCharset |
---|
| 268 | set options {-binary -blocksize -channel -command -handler -headers \ |
---|
| 269 | -progress -query -queryblocksize -querychannel -queryprogress\ |
---|
| 270 | -validate -timeout -type} |
---|
| 271 | set usage [join $options ", "] |
---|
| 272 | set options [string map {- ""} $options] |
---|
| 273 | set pat ^-([join $options |])$ |
---|
| 274 | foreach {flag value} $args { |
---|
| 275 | if {[regexp $pat $flag]} { |
---|
| 276 | # Validate numbers |
---|
| 277 | if {[info exists type($flag)] && \ |
---|
| 278 | ![string is $type($flag) -strict $value]} { |
---|
| 279 | unset $token |
---|
| 280 | return -code error "Bad value for $flag ($value), must be $type($flag)" |
---|
| 281 | } |
---|
| 282 | set state($flag) $value |
---|
| 283 | } else { |
---|
| 284 | unset $token |
---|
| 285 | return -code error "Unknown option $flag, can be: $usage" |
---|
| 286 | } |
---|
| 287 | } |
---|
| 288 | |
---|
| 289 | # Make sure -query and -querychannel aren't both specified |
---|
| 290 | |
---|
| 291 | set isQueryChannel [info exists state(-querychannel)] |
---|
| 292 | set isQuery [info exists state(-query)] |
---|
| 293 | if {$isQuery && $isQueryChannel} { |
---|
| 294 | unset $token |
---|
| 295 | return -code error "Can't combine -query and -querychannel options!" |
---|
| 296 | } |
---|
| 297 | |
---|
| 298 | # Validate URL, determine the server host and port, and check proxy case |
---|
| 299 | # Recognize user:pass@host URLs also, although we do not do anything |
---|
| 300 | # with that info yet. |
---|
| 301 | |
---|
| 302 | set exp {^(([^:]*)://)?([^@]+@)?([^/:]+)(:([0-9]+))?(/.*)?$} |
---|
| 303 | if {![regexp -nocase $exp $url x prefix proto user host y port srvurl]} { |
---|
| 304 | unset $token |
---|
| 305 | return -code error "Unsupported URL: $url" |
---|
| 306 | } |
---|
| 307 | if {[string length $proto] == 0} { |
---|
| 308 | set proto http |
---|
| 309 | set url ${proto}://$url |
---|
| 310 | } |
---|
| 311 | if {![info exists urlTypes($proto)]} { |
---|
| 312 | unset $token |
---|
| 313 | return -code error "Unsupported URL type \"$proto\"" |
---|
| 314 | } |
---|
| 315 | set defport [lindex $urlTypes($proto) 0] |
---|
| 316 | set defcmd [lindex $urlTypes($proto) 1] |
---|
| 317 | |
---|
| 318 | if {[string length $port] == 0} { |
---|
| 319 | set port $defport |
---|
| 320 | } |
---|
| 321 | if {[string length $srvurl] == 0} { |
---|
| 322 | set srvurl / |
---|
| 323 | } |
---|
| 324 | if {[string length $proto] == 0} { |
---|
| 325 | set url http://$url |
---|
| 326 | } |
---|
| 327 | set state(url) $url |
---|
| 328 | if {![catch {$http(-proxyfilter) $host} proxy]} { |
---|
| 329 | set phost [lindex $proxy 0] |
---|
| 330 | set pport [lindex $proxy 1] |
---|
| 331 | } |
---|
| 332 | |
---|
| 333 | # If a timeout is specified we set up the after event |
---|
| 334 | # and arrange for an asynchronous socket connection. |
---|
| 335 | |
---|
| 336 | if {$state(-timeout) > 0} { |
---|
| 337 | set state(after) [after $state(-timeout) \ |
---|
| 338 | [list http::reset $token timeout]] |
---|
| 339 | set async -async |
---|
| 340 | } else { |
---|
| 341 | set async "" |
---|
| 342 | } |
---|
| 343 | |
---|
| 344 | # If we are using the proxy, we must pass in the full URL that |
---|
| 345 | # includes the server name. |
---|
| 346 | |
---|
| 347 | if {[info exists phost] && [string length $phost]} { |
---|
| 348 | set srvurl $url |
---|
| 349 | set conStat [catch {eval $defcmd $async {$phost $pport}} s] |
---|
| 350 | } else { |
---|
| 351 | set conStat [catch {eval $defcmd $async {$host $port}} s] |
---|
| 352 | } |
---|
| 353 | if {$conStat} { |
---|
| 354 | |
---|
| 355 | # something went wrong while trying to establish the connection |
---|
| 356 | # Clean up after events and such, but DON'T call the command callback |
---|
| 357 | # (if available) because we're going to throw an exception from here |
---|
| 358 | # instead. |
---|
| 359 | Finish $token "" 1 |
---|
| 360 | cleanup $token |
---|
| 361 | return -code error $s |
---|
| 362 | } |
---|
| 363 | set state(sock) $s |
---|
| 364 | |
---|
| 365 | # Wait for the connection to complete |
---|
| 366 | |
---|
| 367 | if {$state(-timeout) > 0} { |
---|
| 368 | fileevent $s writable [list http::Connect $token] |
---|
| 369 | http::wait $token |
---|
| 370 | |
---|
| 371 | if {[string equal $state(status) "error"]} { |
---|
| 372 | # something went wrong while trying to establish the connection |
---|
| 373 | # Clean up after events and such, but DON'T call the command |
---|
| 374 | # callback (if available) because we're going to throw an |
---|
| 375 | # exception from here instead. |
---|
| 376 | set err [lindex $state(error) 0] |
---|
| 377 | cleanup $token |
---|
| 378 | return -code error $err |
---|
| 379 | } elseif {![string equal $state(status) "connect"]} { |
---|
| 380 | # Likely to be connection timeout |
---|
| 381 | return $token |
---|
| 382 | } |
---|
| 383 | set state(status) "" |
---|
| 384 | } |
---|
| 385 | |
---|
| 386 | # Send data in cr-lf format, but accept any line terminators |
---|
| 387 | |
---|
| 388 | fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize) |
---|
| 389 | |
---|
| 390 | # The following is disallowed in safe interpreters, but the socket |
---|
| 391 | # is already in non-blocking mode in that case. |
---|
| 392 | |
---|
| 393 | catch {fconfigure $s -blocking off} |
---|
| 394 | set how GET |
---|
| 395 | if {$isQuery} { |
---|
| 396 | set state(querylength) [string length $state(-query)] |
---|
| 397 | if {$state(querylength) > 0} { |
---|
| 398 | set how POST |
---|
| 399 | set contDone 0 |
---|
| 400 | } else { |
---|
| 401 | # there's no query data |
---|
| 402 | unset state(-query) |
---|
| 403 | set isQuery 0 |
---|
| 404 | } |
---|
| 405 | } elseif {$state(-validate)} { |
---|
| 406 | set how HEAD |
---|
| 407 | } elseif {$isQueryChannel} { |
---|
| 408 | set how POST |
---|
| 409 | # The query channel must be blocking for the async Write to |
---|
| 410 | # work properly. |
---|
| 411 | fconfigure $state(-querychannel) -blocking 1 -translation binary |
---|
| 412 | set contDone 0 |
---|
| 413 | } |
---|
| 414 | |
---|
| 415 | if {[catch { |
---|
| 416 | puts $s "$how $srvurl HTTP/1.0" |
---|
| 417 | puts $s "Accept: $http(-accept)" |
---|
| 418 | if {$port == $defport} { |
---|
| 419 | # Don't add port in this case, to handle broken servers. |
---|
| 420 | # [Bug #504508] |
---|
| 421 | puts $s "Host: $host" |
---|
| 422 | } else { |
---|
| 423 | puts $s "Host: $host:$port" |
---|
| 424 | } |
---|
| 425 | puts $s "User-Agent: $http(-useragent)" |
---|
| 426 | foreach {key value} $state(-headers) { |
---|
| 427 | set value [string map [list \n "" \r ""] $value] |
---|
| 428 | set key [string trim $key] |
---|
| 429 | if {[string equal $key "Content-Length"]} { |
---|
| 430 | set contDone 1 |
---|
| 431 | set state(querylength) $value |
---|
| 432 | } |
---|
| 433 | if {[string length $key]} { |
---|
| 434 | puts $s "$key: $value" |
---|
| 435 | } |
---|
| 436 | } |
---|
| 437 | if {$isQueryChannel && $state(querylength) == 0} { |
---|
| 438 | # Try to determine size of data in channel |
---|
| 439 | # If we cannot seek, the surrounding catch will trap us |
---|
| 440 | |
---|
| 441 | set start [tell $state(-querychannel)] |
---|
| 442 | seek $state(-querychannel) 0 end |
---|
| 443 | set state(querylength) \ |
---|
| 444 | [expr {[tell $state(-querychannel)] - $start}] |
---|
| 445 | seek $state(-querychannel) $start |
---|
| 446 | } |
---|
| 447 | |
---|
| 448 | # Flush the request header and set up the fileevent that will |
---|
| 449 | # either push the POST data or read the response. |
---|
| 450 | # |
---|
| 451 | # fileevent note: |
---|
| 452 | # |
---|
| 453 | # It is possible to have both the read and write fileevents active |
---|
| 454 | # at this point. The only scenario it seems to affect is a server |
---|
| 455 | # that closes the connection without reading the POST data. |
---|
| 456 | # (e.g., early versions TclHttpd in various error cases). |
---|
| 457 | # Depending on the platform, the client may or may not be able to |
---|
| 458 | # get the response from the server because of the error it will |
---|
| 459 | # get trying to write the post data. Having both fileevents active |
---|
| 460 | # changes the timing and the behavior, but no two platforms |
---|
| 461 | # (among Solaris, Linux, and NT) behave the same, and none |
---|
| 462 | # behave all that well in any case. Servers should always read thier |
---|
| 463 | # POST data if they expect the client to read their response. |
---|
| 464 | |
---|
| 465 | if {$isQuery || $isQueryChannel} { |
---|
| 466 | puts $s "Content-Type: $state(-type)" |
---|
| 467 | if {!$contDone} { |
---|
| 468 | puts $s "Content-Length: $state(querylength)" |
---|
| 469 | } |
---|
| 470 | puts $s "" |
---|
| 471 | fconfigure $s -translation {auto binary} |
---|
| 472 | fileevent $s writable [list http::Write $token] |
---|
| 473 | } else { |
---|
| 474 | puts $s "" |
---|
| 475 | flush $s |
---|
| 476 | fileevent $s readable [list http::Event $token] |
---|
| 477 | } |
---|
| 478 | |
---|
| 479 | if {! [info exists state(-command)]} { |
---|
| 480 | |
---|
| 481 | # geturl does EVERYTHING asynchronously, so if the user |
---|
| 482 | # calls it synchronously, we just do a wait here. |
---|
| 483 | |
---|
| 484 | wait $token |
---|
| 485 | if {[string equal $state(status) "error"]} { |
---|
| 486 | # Something went wrong, so throw the exception, and the |
---|
| 487 | # enclosing catch will do cleanup. |
---|
| 488 | return -code error [lindex $state(error) 0] |
---|
| 489 | } |
---|
| 490 | } |
---|
| 491 | } err]} { |
---|
| 492 | # The socket probably was never connected, |
---|
| 493 | # or the connection dropped later. |
---|
| 494 | |
---|
| 495 | # Clean up after events and such, but DON'T call the command callback |
---|
| 496 | # (if available) because we're going to throw an exception from here |
---|
| 497 | # instead. |
---|
| 498 | |
---|
| 499 | # if state(status) is error, it means someone's already called Finish |
---|
| 500 | # to do the above-described clean up. |
---|
| 501 | if {[string equal $state(status) "error"]} { |
---|
| 502 | Finish $token $err 1 |
---|
| 503 | } |
---|
| 504 | cleanup $token |
---|
| 505 | return -code error $err |
---|
| 506 | } |
---|
| 507 | |
---|
| 508 | return $token |
---|
| 509 | } |
---|
| 510 | |
---|
| 511 | # Data access functions: |
---|
| 512 | # Data - the URL data |
---|
| 513 | # Status - the transaction status: ok, reset, eof, timeout |
---|
| 514 | # Code - the HTTP transaction code, e.g., 200 |
---|
| 515 | # Size - the size of the URL data |
---|
| 516 | |
---|
| 517 | proc http::data {token} { |
---|
| 518 | variable $token |
---|
| 519 | upvar 0 $token state |
---|
| 520 | return $state(body) |
---|
| 521 | } |
---|
| 522 | proc http::status {token} { |
---|
| 523 | variable $token |
---|
| 524 | upvar 0 $token state |
---|
| 525 | return $state(status) |
---|
| 526 | } |
---|
| 527 | proc http::code {token} { |
---|
| 528 | variable $token |
---|
| 529 | upvar 0 $token state |
---|
| 530 | return $state(http) |
---|
| 531 | } |
---|
| 532 | proc http::ncode {token} { |
---|
| 533 | variable $token |
---|
| 534 | upvar 0 $token state |
---|
| 535 | if {[regexp {[0-9]{3}} $state(http) numeric_code]} { |
---|
| 536 | return $numeric_code |
---|
| 537 | } else { |
---|
| 538 | return $state(http) |
---|
| 539 | } |
---|
| 540 | } |
---|
| 541 | proc http::size {token} { |
---|
| 542 | variable $token |
---|
| 543 | upvar 0 $token state |
---|
| 544 | return $state(currentsize) |
---|
| 545 | } |
---|
| 546 | |
---|
| 547 | proc http::error {token} { |
---|
| 548 | variable $token |
---|
| 549 | upvar 0 $token state |
---|
| 550 | if {[info exists state(error)]} { |
---|
| 551 | return $state(error) |
---|
| 552 | } |
---|
| 553 | return "" |
---|
| 554 | } |
---|
| 555 | |
---|
| 556 | # http::cleanup |
---|
| 557 | # |
---|
| 558 | # Garbage collect the state associated with a transaction |
---|
| 559 | # |
---|
| 560 | # Arguments |
---|
| 561 | # token The token returned from http::geturl |
---|
| 562 | # |
---|
| 563 | # Side Effects |
---|
| 564 | # unsets the state array |
---|
| 565 | |
---|
| 566 | proc http::cleanup {token} { |
---|
| 567 | variable $token |
---|
| 568 | upvar 0 $token state |
---|
| 569 | if {[info exists state]} { |
---|
| 570 | unset state |
---|
| 571 | } |
---|
| 572 | } |
---|
| 573 | |
---|
| 574 | # http::Connect |
---|
| 575 | # |
---|
| 576 | # This callback is made when an asyncronous connection completes. |
---|
| 577 | # |
---|
| 578 | # Arguments |
---|
| 579 | # token The token returned from http::geturl |
---|
| 580 | # |
---|
| 581 | # Side Effects |
---|
| 582 | # Sets the status of the connection, which unblocks |
---|
| 583 | # the waiting geturl call |
---|
| 584 | |
---|
| 585 | proc http::Connect {token} { |
---|
| 586 | variable $token |
---|
| 587 | upvar 0 $token state |
---|
| 588 | global errorInfo errorCode |
---|
| 589 | if {[eof $state(sock)] || |
---|
| 590 | [string length [fconfigure $state(sock) -error]]} { |
---|
| 591 | Finish $token "connect failed [fconfigure $state(sock) -error]" 1 |
---|
| 592 | } else { |
---|
| 593 | set state(status) connect |
---|
| 594 | fileevent $state(sock) writable {} |
---|
| 595 | } |
---|
| 596 | return |
---|
| 597 | } |
---|
| 598 | |
---|
| 599 | # http::Write |
---|
| 600 | # |
---|
| 601 | # Write POST query data to the socket |
---|
| 602 | # |
---|
| 603 | # Arguments |
---|
| 604 | # token The token for the connection |
---|
| 605 | # |
---|
| 606 | # Side Effects |
---|
| 607 | # Write the socket and handle callbacks. |
---|
| 608 | |
---|
| 609 | proc http::Write {token} { |
---|
| 610 | variable $token |
---|
| 611 | upvar 0 $token state |
---|
| 612 | set s $state(sock) |
---|
| 613 | |
---|
| 614 | # Output a block. Tcl will buffer this if the socket blocks |
---|
| 615 | set done 0 |
---|
| 616 | if {[catch { |
---|
| 617 | # Catch I/O errors on dead sockets |
---|
| 618 | |
---|
| 619 | if {[info exists state(-query)]} { |
---|
| 620 | # Chop up large query strings so queryprogress callback |
---|
| 621 | # can give smooth feedback |
---|
| 622 | |
---|
| 623 | puts -nonewline $s \ |
---|
| 624 | [string range $state(-query) $state(queryoffset) \ |
---|
| 625 | [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]] |
---|
| 626 | incr state(queryoffset) $state(-queryblocksize) |
---|
| 627 | if {$state(queryoffset) >= $state(querylength)} { |
---|
| 628 | set state(queryoffset) $state(querylength) |
---|
| 629 | set done 1 |
---|
| 630 | } |
---|
| 631 | } else { |
---|
| 632 | # Copy blocks from the query channel |
---|
| 633 | |
---|
| 634 | set outStr [read $state(-querychannel) $state(-queryblocksize)] |
---|
| 635 | puts -nonewline $s $outStr |
---|
| 636 | incr state(queryoffset) [string length $outStr] |
---|
| 637 | if {[eof $state(-querychannel)]} { |
---|
| 638 | set done 1 |
---|
| 639 | } |
---|
| 640 | } |
---|
| 641 | } err]} { |
---|
| 642 | # Do not call Finish here, but instead let the read half of |
---|
| 643 | # the socket process whatever server reply there is to get. |
---|
| 644 | |
---|
| 645 | set state(posterror) $err |
---|
| 646 | set done 1 |
---|
| 647 | } |
---|
| 648 | if {$done} { |
---|
| 649 | catch {flush $s} |
---|
| 650 | fileevent $s writable {} |
---|
| 651 | fileevent $s readable [list http::Event $token] |
---|
| 652 | } |
---|
| 653 | |
---|
| 654 | # Callback to the client after we've completely handled everything |
---|
| 655 | |
---|
| 656 | if {[string length $state(-queryprogress)]} { |
---|
| 657 | eval $state(-queryprogress) [list $token $state(querylength)\ |
---|
| 658 | $state(queryoffset)] |
---|
| 659 | } |
---|
| 660 | } |
---|
| 661 | |
---|
| 662 | # http::Event |
---|
| 663 | # |
---|
| 664 | # Handle input on the socket |
---|
| 665 | # |
---|
| 666 | # Arguments |
---|
| 667 | # token The token returned from http::geturl |
---|
| 668 | # |
---|
| 669 | # Side Effects |
---|
| 670 | # Read the socket and handle callbacks. |
---|
| 671 | |
---|
| 672 | proc http::Event {token} { |
---|
| 673 | variable $token |
---|
| 674 | upvar 0 $token state |
---|
| 675 | set s $state(sock) |
---|
| 676 | |
---|
| 677 | if {[eof $s]} { |
---|
| 678 | Eof $token |
---|
| 679 | return |
---|
| 680 | } |
---|
| 681 | if {[string equal $state(state) "header"]} { |
---|
| 682 | if {[catch {gets $s line} n]} { |
---|
| 683 | Finish $token $n |
---|
| 684 | } elseif {$n == 0} { |
---|
| 685 | variable encodings |
---|
| 686 | set state(state) body |
---|
| 687 | if {$state(-binary) || ![string match -nocase text* $state(type)] |
---|
| 688 | || [string match *gzip* $state(coding)] |
---|
| 689 | || [string match *compress* $state(coding)]} { |
---|
| 690 | # Turn off conversions for non-text data |
---|
| 691 | fconfigure $s -translation binary |
---|
| 692 | if {[info exists state(-channel)]} { |
---|
| 693 | fconfigure $state(-channel) -translation binary |
---|
| 694 | } |
---|
| 695 | } else { |
---|
| 696 | # If we are getting text, set the incoming channel's |
---|
| 697 | # encoding correctly. iso8859-1 is the RFC default, but |
---|
| 698 | # this could be any IANA charset. However, we only know |
---|
| 699 | # how to convert what we have encodings for. |
---|
| 700 | set idx [lsearch -exact $encodings \ |
---|
| 701 | [string tolower $state(charset)]] |
---|
| 702 | if {$idx >= 0} { |
---|
| 703 | fconfigure $s -encoding [lindex $encodings $idx] |
---|
| 704 | } |
---|
| 705 | } |
---|
| 706 | if {[info exists state(-channel)] && \ |
---|
| 707 | ![info exists state(-handler)]} { |
---|
| 708 | # Initiate a sequence of background fcopies |
---|
| 709 | fileevent $s readable {} |
---|
| 710 | CopyStart $s $token |
---|
| 711 | } |
---|
| 712 | } elseif {$n > 0} { |
---|
| 713 | if {[regexp -nocase {^content-type:(.+)$} $line x type]} { |
---|
| 714 | set state(type) [string trim $type] |
---|
| 715 | # grab the optional charset information |
---|
| 716 | regexp -nocase {charset\s*=\s*(\S+)} $type x state(charset) |
---|
| 717 | } |
---|
| 718 | if {[regexp -nocase {^content-length:(.+)$} $line x length]} { |
---|
| 719 | set state(totalsize) [string trim $length] |
---|
| 720 | } |
---|
| 721 | if {[regexp -nocase {^content-encoding:(.+)$} $line x coding]} { |
---|
| 722 | set state(coding) [string trim $coding] |
---|
| 723 | } |
---|
| 724 | if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { |
---|
| 725 | lappend state(meta) $key [string trim $value] |
---|
| 726 | } elseif {[string match HTTP* $line]} { |
---|
| 727 | set state(http) $line |
---|
| 728 | } |
---|
| 729 | } |
---|
| 730 | } else { |
---|
| 731 | if {[catch { |
---|
| 732 | if {[info exists state(-handler)]} { |
---|
| 733 | set n [eval $state(-handler) {$s $token}] |
---|
| 734 | } else { |
---|
| 735 | set block [read $s $state(-blocksize)] |
---|
| 736 | set n [string length $block] |
---|
| 737 | if {$n >= 0} { |
---|
| 738 | append state(body) $block |
---|
| 739 | } |
---|
| 740 | } |
---|
| 741 | if {$n >= 0} { |
---|
| 742 | incr state(currentsize) $n |
---|
| 743 | } |
---|
| 744 | } err]} { |
---|
| 745 | Finish $token $err |
---|
| 746 | } else { |
---|
| 747 | if {[info exists state(-progress)]} { |
---|
| 748 | eval $state(-progress) \ |
---|
| 749 | {$token $state(totalsize) $state(currentsize)} |
---|
| 750 | } |
---|
| 751 | } |
---|
| 752 | } |
---|
| 753 | } |
---|
| 754 | |
---|
| 755 | # http::CopyStart |
---|
| 756 | # |
---|
| 757 | # Error handling wrapper around fcopy |
---|
| 758 | # |
---|
| 759 | # Arguments |
---|
| 760 | # s The socket to copy from |
---|
| 761 | # token The token returned from http::geturl |
---|
| 762 | # |
---|
| 763 | # Side Effects |
---|
| 764 | # This closes the connection upon error |
---|
| 765 | |
---|
| 766 | proc http::CopyStart {s token} { |
---|
| 767 | variable $token |
---|
| 768 | upvar 0 $token state |
---|
| 769 | if {[catch { |
---|
| 770 | fcopy $s $state(-channel) -size $state(-blocksize) -command \ |
---|
| 771 | [list http::CopyDone $token] |
---|
| 772 | } err]} { |
---|
| 773 | Finish $token $err |
---|
| 774 | } |
---|
| 775 | } |
---|
| 776 | |
---|
| 777 | # http::CopyDone |
---|
| 778 | # |
---|
| 779 | # fcopy completion callback |
---|
| 780 | # |
---|
| 781 | # Arguments |
---|
| 782 | # token The token returned from http::geturl |
---|
| 783 | # count The amount transfered |
---|
| 784 | # |
---|
| 785 | # Side Effects |
---|
| 786 | # Invokes callbacks |
---|
| 787 | |
---|
| 788 | proc http::CopyDone {token count {error {}}} { |
---|
| 789 | variable $token |
---|
| 790 | upvar 0 $token state |
---|
| 791 | set s $state(sock) |
---|
| 792 | incr state(currentsize) $count |
---|
| 793 | if {[info exists state(-progress)]} { |
---|
| 794 | eval $state(-progress) {$token $state(totalsize) $state(currentsize)} |
---|
| 795 | } |
---|
| 796 | # At this point the token may have been reset |
---|
| 797 | if {[string length $error]} { |
---|
| 798 | Finish $token $error |
---|
| 799 | } elseif {[catch {eof $s} iseof] || $iseof} { |
---|
| 800 | Eof $token |
---|
| 801 | } else { |
---|
| 802 | CopyStart $s $token |
---|
| 803 | } |
---|
| 804 | } |
---|
| 805 | |
---|
| 806 | # http::Eof |
---|
| 807 | # |
---|
| 808 | # Handle eof on the socket |
---|
| 809 | # |
---|
| 810 | # Arguments |
---|
| 811 | # token The token returned from http::geturl |
---|
| 812 | # |
---|
| 813 | # Side Effects |
---|
| 814 | # Clean up the socket |
---|
| 815 | |
---|
| 816 | proc http::Eof {token} { |
---|
| 817 | variable $token |
---|
| 818 | upvar 0 $token state |
---|
| 819 | if {[string equal $state(state) "header"]} { |
---|
| 820 | # Premature eof |
---|
| 821 | set state(status) eof |
---|
| 822 | } else { |
---|
| 823 | set state(status) ok |
---|
| 824 | } |
---|
| 825 | set state(state) eof |
---|
| 826 | Finish $token |
---|
| 827 | } |
---|
| 828 | |
---|
| 829 | # http::wait -- |
---|
| 830 | # |
---|
| 831 | # See documentaion for details. |
---|
| 832 | # |
---|
| 833 | # Arguments: |
---|
| 834 | # token Connection token. |
---|
| 835 | # |
---|
| 836 | # Results: |
---|
| 837 | # The status after the wait. |
---|
| 838 | |
---|
| 839 | proc http::wait {token} { |
---|
| 840 | variable $token |
---|
| 841 | upvar 0 $token state |
---|
| 842 | |
---|
| 843 | if {![info exists state(status)] || [string length $state(status)] == 0} { |
---|
| 844 | # We must wait on the original variable name, not the upvar alias |
---|
| 845 | vwait $token\(status) |
---|
| 846 | } |
---|
| 847 | |
---|
| 848 | return $state(status) |
---|
| 849 | } |
---|
| 850 | |
---|
| 851 | # http::formatQuery -- |
---|
| 852 | # |
---|
| 853 | # See documentaion for details. |
---|
| 854 | # Call http::formatQuery with an even number of arguments, where |
---|
| 855 | # the first is a name, the second is a value, the third is another |
---|
| 856 | # name, and so on. |
---|
| 857 | # |
---|
| 858 | # Arguments: |
---|
| 859 | # args A list of name-value pairs. |
---|
| 860 | # |
---|
| 861 | # Results: |
---|
| 862 | # TODO |
---|
| 863 | |
---|
| 864 | proc http::formatQuery {args} { |
---|
| 865 | set result "" |
---|
| 866 | set sep "" |
---|
| 867 | foreach i $args { |
---|
| 868 | append result $sep [mapReply $i] |
---|
| 869 | if {[string equal $sep "="]} { |
---|
| 870 | set sep & |
---|
| 871 | } else { |
---|
| 872 | set sep = |
---|
| 873 | } |
---|
| 874 | } |
---|
| 875 | return $result |
---|
| 876 | } |
---|
| 877 | |
---|
| 878 | # http::mapReply -- |
---|
| 879 | # |
---|
| 880 | # Do x-www-urlencoded character mapping |
---|
| 881 | # |
---|
| 882 | # Arguments: |
---|
| 883 | # string The string the needs to be encoded |
---|
| 884 | # |
---|
| 885 | # Results: |
---|
| 886 | # The encoded string |
---|
| 887 | |
---|
| 888 | proc http::mapReply {string} { |
---|
| 889 | variable http |
---|
| 890 | variable formMap |
---|
| 891 | variable alphanumeric |
---|
| 892 | |
---|
| 893 | # The spec says: "non-alphanumeric characters are replaced by '%HH'" |
---|
| 894 | # 1 leave alphanumerics characters alone |
---|
| 895 | # 2 Convert every other character to an array lookup |
---|
| 896 | # 3 Escape constructs that are "special" to the tcl parser |
---|
| 897 | # 4 "subst" the result, doing all the array substitutions |
---|
| 898 | |
---|
| 899 | if {$http(-urlencoding) ne ""} { |
---|
| 900 | set string [encoding convertto $http(-urlencoding) $string] |
---|
| 901 | } |
---|
| 902 | regsub -all \[^$alphanumeric\] $string {$formMap(&)} string |
---|
| 903 | regsub -all {[][{})\\]\)} $string {\\&} string |
---|
| 904 | return [subst -nocommand $string] |
---|
| 905 | } |
---|
| 906 | |
---|
| 907 | # http::ProxyRequired -- |
---|
| 908 | # Default proxy filter. |
---|
| 909 | # |
---|
| 910 | # Arguments: |
---|
| 911 | # host The destination host |
---|
| 912 | # |
---|
| 913 | # Results: |
---|
| 914 | # The current proxy settings |
---|
| 915 | |
---|
| 916 | proc http::ProxyRequired {host} { |
---|
| 917 | variable http |
---|
| 918 | if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { |
---|
| 919 | if {![info exists http(-proxyport)] || \ |
---|
| 920 | ![string length $http(-proxyport)]} { |
---|
| 921 | set http(-proxyport) 8080 |
---|
| 922 | } |
---|
| 923 | return [list $http(-proxyhost) $http(-proxyport)] |
---|
| 924 | } |
---|
| 925 | } |
---|