Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | } |