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