Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: data/media/tcl8.5/http/http.tcl @ 5528

Last change on this file since 5528 was 5167, checked in by rgrieder, 16 years ago

added svn property svn:eol-style native to all tcl files
  • Property svn:eol-style set to native
File size: 38.6 KB
Line 
1# http.tcl --
2#
3#       Client-side HTTP for GET, POST, and HEAD commands. These routines can
4#       be used in untrusted code that uses the Safesock security policy. These
5#       procedures use a callback interface to avoid using vwait, which is not
6#       defined in the safe base.
7#
8# See the file "license.terms" for information on usage and redistribution of
9# this file, and for a DISCLAIMER OF ALL WARRANTIES.
10#
11# RCS: @(#) $Id: http.tcl,v 1.67 2008/03/12 10:01:02 hobbs Exp $
12
13package require Tcl 8.4
14# Keep this in sync with pkgIndex.tcl and with the install directories
15# in Makefiles
16package provide http 2.7
17
18namespace eval http {
19    # Allow resourcing to not clobber existing data
20
21    variable http
22    if {![info exists http]} {
23        array set http {
24            -accept */*
25            -proxyhost {}
26            -proxyport {}
27            -proxyfilter http::ProxyRequired
28            -urlencoding utf-8
29        }
30        set http(-useragent) "Tcl http client package [package provide http]"
31    }
32
33    proc init {} {
34        # Set up the map for quoting chars. RFC3986 Section 2.3 say percent
35        # encode all except: "... percent-encoded octets in the ranges of ALPHA
36        # (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period (%2E),
37        # underscore (%5F), or tilde (%7E) should not be created by URI
38        # producers ..."
39        for {set i 0} {$i <= 256} {incr i} {
40            set c [format %c $i]
41            if {![string match {[-._~a-zA-Z0-9]} $c]} {
42                set map($c) %[format %.2x $i]
43            }
44        }
45        # These are handled specially
46        set map(\n) %0d%0a
47        variable formMap [array get map]
48
49        # Create a map for HTTP/1.1 open sockets
50        variable socketmap
51        if {[info exists socketmap]} {
52            # Close but don't remove open sockets on re-init
53            foreach {url sock} [array get socketmap] {
54                catch {close $sock}
55            }
56        }
57        array set socketmap {}
58    }
59    init
60
61    variable urlTypes
62    if {![info exists urlTypes]} {
63        set urlTypes(http) [list 80 ::socket]
64    }
65
66    variable encodings [string tolower [encoding names]]
67    # This can be changed, but iso8859-1 is the RFC standard.
68    variable defaultCharset
69    if {![info exists defaultCharset]} {
70        set defaultCharset "iso8859-1"
71    }
72
73    # Force RFC 3986 strictness in geturl url verification?
74    variable strict
75    if {![info exists strict]} {
76        set strict 1
77    }
78
79    # Let user control default keepalive for compatibility
80    variable defaultKeepalive
81    if {![info exists defaultKeepalive]} {
82        set defaultKeepalive 0
83    }
84
85    namespace export geturl config reset wait formatQuery register unregister
86    # Useful, but not exported: data size status code
87}
88
89# http::Log --
90#
91#       Debugging output -- define this to observe HTTP/1.1 socket usage.
92#       Should echo any args received.
93#
94# Arguments:
95#     msg       Message to output
96#
97proc http::Log {args} {}
98
99# http::register --
100#
101#     See documentation for details.
102#
103# Arguments:
104#     proto           URL protocol prefix, e.g. https
105#     port            Default port for protocol
106#     command         Command to use to create socket
107# Results:
108#     list of port and command that was registered.
109
110proc http::register {proto port command} {
111    variable urlTypes
112    set urlTypes($proto) [list $port $command]
113}
114
115# http::unregister --
116#
117#     Unregisters URL protocol handler
118#
119# Arguments:
120#     proto           URL protocol prefix, e.g. https
121# Results:
122#     list of port and command that was unregistered.
123
124proc http::unregister {proto} {
125    variable urlTypes
126    if {![info exists urlTypes($proto)]} {
127        return -code error "unsupported url type \"$proto\""
128    }
129    set old $urlTypes($proto)
130    unset urlTypes($proto)
131    return $old
132}
133
134# http::config --
135#
136#       See documentation for details.
137#
138# Arguments:
139#       args            Options parsed by the procedure.
140# Results:
141#        TODO
142
143proc http::config {args} {
144    variable http
145    set options [lsort [array names http -*]]
146    set usage [join $options ", "]
147    if {[llength $args] == 0} {
148        set result {}
149        foreach name $options {
150            lappend result $name $http($name)
151        }
152        return $result
153    }
154    set options [string map {- ""} $options]
155    set pat ^-([join $options |])$
156    if {[llength $args] == 1} {
157        set flag [lindex $args 0]
158        if {[regexp -- $pat $flag]} {
159            return $http($flag)
160        } else {
161            return -code error "Unknown option $flag, must be: $usage"
162        }
163    } else {
164        foreach {flag value} $args {
165            if {[regexp -- $pat $flag]} {
166                set http($flag) $value
167            } else {
168                return -code error "Unknown option $flag, must be: $usage"
169            }
170        }
171    }
172}
173
174# http::Finish --
175#
176#       Clean up the socket and eval close time callbacks
177#
178# Arguments:
179#       token       Connection token.
180#       errormsg    (optional) If set, forces status to error.
181#       skipCB      (optional) If set, don't call the -command callback. This
182#                   is useful when geturl wants to throw an exception instead
183#                   of calling the callback. That way, the same error isn't
184#                   reported to two places.
185#
186# Side Effects:
187#        Closes the socket
188
189proc http::Finish { token {errormsg ""} {skipCB 0}} {
190    variable $token
191    upvar 0 $token state
192    global errorInfo errorCode
193    if {$errormsg ne ""} {
194        set state(error) [list $errormsg $errorInfo $errorCode]
195        set state(status) "error"
196    }
197    if {($state(status) eq "timeout") || ($state(status) eq "error")
198        || ([info exists state(connection)] && ($state(connection) eq "close"))
199    } {
200        CloseSocket $state(sock) $token
201    }
202    if {[info exists state(after)]} { after cancel $state(after) }
203    if {[info exists state(-command)] && !$skipCB} {
204        if {[catch {eval $state(-command) {$token}} err]} {
205            if {$errormsg eq ""} {
206                set state(error) [list $err $errorInfo $errorCode]
207                set state(status) error
208            }
209        }
210        # Command callback may already have unset our state
211        unset -nocomplain state(-command)
212    }
213}
214
215# http::CloseSocket -
216#
217#       Close a socket and remove it from the persistent sockets table.
218#       If possible an http token is included here but when we are called
219#       from a fileevent on remote closure we need to find the correct
220#       entry - hence the second section.
221
222proc ::http::CloseSocket {s {token {}}} {
223    variable socketmap
224    catch {fileevent $s readable {}}
225    set conn_id {}
226    if {$token ne ""} {
227        variable $token
228        upvar 0 $token state
229        if {[info exists state(socketinfo)]} {
230            set conn_id $state(socketinfo)
231        }
232    } else {
233        set map [array get socketmap]
234        set ndx [lsearch -exact $map $s]
235        if {$ndx != -1} {
236            incr ndx -1
237            set conn_id [lindex $map $ndx]
238        }
239    }
240    if {$conn_id eq {} || ![info exists socketmap($conn_id)]} {
241        Log "Closing socket $s (no connection info)"
242        if {[catch {close $s} err]} { Log "Error: $err" }
243    } else {
244        if {[info exists socketmap($conn_id)]} {
245            Log "Closing connection $conn_id (sock $socketmap($conn_id))"
246            if {[catch {close $socketmap($conn_id)} err]} { Log "Error: $err" }
247            unset socketmap($conn_id)
248        } else {
249            Log "Cannot close connection $conn_id - no socket in socket map"
250        }
251    }
252}
253
254# http::reset --
255#
256#       See documentation for details.
257#
258# Arguments:
259#       token   Connection token.
260#       why     Status info.
261#
262# Side Effects:
263#       See Finish
264
265proc http::reset { token {why reset} } {
266    variable $token
267    upvar 0 $token state
268    set state(status) $why
269    catch {fileevent $state(sock) readable {}}
270    catch {fileevent $state(sock) writable {}}
271    Finish $token
272    if {[info exists state(error)]} {
273        set errorlist $state(error)
274        unset state
275        eval ::error $errorlist
276    }
277}
278
279# http::geturl --
280#
281#       Establishes a connection to a remote url via http.
282#
283# Arguments:
284#       url             The http URL to goget.
285#       args            Option value pairs. Valid options include:
286#                               -blocksize, -validate, -headers, -timeout
287# Results:
288#       Returns a token for this connection. This token is the name of an array
289#       that the caller should unset to garbage collect the state.
290
291proc http::geturl { url args } {
292    variable http
293    variable urlTypes
294    variable defaultCharset
295    variable defaultKeepalive
296    variable strict
297
298    # Initialize the state variable, an array. We'll return the name of this
299    # array as the token for the transaction.
300
301    if {![info exists http(uid)]} {
302        set http(uid) 0
303    }
304    set token [namespace current]::[incr http(uid)]
305    variable $token
306    upvar 0 $token state
307    reset $token
308
309    # Process command options.
310
311    array set state {
312        -binary         false
313        -blocksize      8192
314        -queryblocksize 8192
315        -validate       0
316        -headers        {}
317        -timeout        0
318        -type           application/x-www-form-urlencoded
319        -queryprogress  {}
320        -protocol       1.1
321        binary          0
322        state           header
323        meta            {}
324        coding          {}
325        currentsize     0
326        totalsize       0
327        querylength     0
328        queryoffset     0
329        type            text/html
330        body            {}
331        status          ""
332        http            ""
333        connection      close
334    }
335    set state(-keepalive) $defaultKeepalive
336    set state(-strict) $strict
337    # These flags have their types verified [Bug 811170]
338    array set type {
339        -binary         boolean
340        -blocksize      integer
341        -queryblocksize integer
342        -strict         boolean
343        -timeout        integer
344        -validate       boolean
345    }
346    set state(charset)  $defaultCharset
347    set options {
348        -binary -blocksize -channel -command -handler -headers -keepalive
349        -method -myaddr -progress -protocol -query -queryblocksize
350        -querychannel -queryprogress -strict -timeout -type -validate
351    }
352    set usage [join [lsort $options] ", "]
353    set options [string map {- ""} $options]
354    set pat ^-([join $options |])$
355    foreach {flag value} $args {
356        if {[regexp -- $pat $flag]} {
357            # Validate numbers
358            if {[info exists type($flag)] &&
359                ![string is $type($flag) -strict $value]} {
360                unset $token
361                return -code error "Bad value for $flag ($value), must be $type($flag)"
362            }
363            set state($flag) $value
364        } else {
365            unset $token
366            return -code error "Unknown option $flag, can be: $usage"
367        }
368    }
369
370    # Make sure -query and -querychannel aren't both specified
371
372    set isQueryChannel [info exists state(-querychannel)]
373    set isQuery [info exists state(-query)]
374    if {$isQuery && $isQueryChannel} {
375        unset $token
376        return -code error "Can't combine -query and -querychannel options!"
377    }
378
379    # Validate URL, determine the server host and port, and check proxy case
380    # Recognize user:pass@host URLs also, although we do not do anything with
381    # that info yet.
382
383    # URLs have basically four parts.
384    # First, before the colon, is the protocol scheme (e.g. http)
385    # Second, for HTTP-like protocols, is the authority
386    #   The authority is preceded by // and lasts up to (but not including)
387    #   the following / and it identifies up to four parts, of which only one,
388    #   the host, is required (if an authority is present at all). All other
389    #   parts of the authority (user name, password, port number) are optional.
390    # Third is the resource name, which is split into two parts at a ?
391    #   The first part (from the single "/" up to "?") is the path, and the
392    #   second part (from that "?" up to "#") is the query. *HOWEVER*, we do
393    #   not need to separate them; we send the whole lot to the server.
394    # Fourth is the fragment identifier, which is everything after the first
395    #   "#" in the URL. The fragment identifier MUST NOT be sent to the server
396    #   and indeed, we don't bother to validate it (it could be an error to
397    #   pass it in here, but it's cheap to strip).
398    #
399    # An example of a URL that has all the parts:
400    #   http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes
401    # The "http" is the protocol, the user is "jschmoe", the password is
402    # "xyzzy", the host is "www.bogus.net", the port is "8000", the path is
403    # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes".
404    #
405    # Note that the RE actually combines the user and password parts, as
406    # recommended in RFC 3986. Indeed, that RFC states that putting passwords
407    # in URLs is a Really Bad Idea, something with which I would agree utterly.
408    # Also note that we do not currently support IPv6 addresses.
409    #
410    # From a validation perspective, we need to ensure that the parts of the
411    # URL that are going to the server are correctly encoded.
412    # This is only done if $state(-strict) is true (inherited from
413    # $::http::strict).
414
415    set URLmatcher {(?x)                # this is _expanded_ syntax
416        ^
417        (?: (\w+) : ) ?                 # <protocol scheme>
418        (?: //
419            (?:
420                (
421                    [^@/\#?]+           # <userinfo part of authority>
422                ) @
423            )?
424            ( [^/:\#?]+ )               # <host part of authority>
425            (?: : (\d+) )?              # <port part of authority>
426        )?
427        ( / [^\#?]* (?: \? [^\#?]* )?)? # <path> (including query)
428        (?: \# (.*) )?                  # <fragment>
429        $
430    }
431
432    # Phase one: parse
433    if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
434        unset $token
435        return -code error "Unsupported URL: $url"
436    }
437    # Phase two: validate
438    if {$host eq ""} {
439        # Caller has to provide a host name; we do not have a "default host"
440        # that would enable us to handle relative URLs.
441        unset $token
442        return -code error "Missing host part: $url"
443        # Note that we don't check the hostname for validity here; if it's
444        # invalid, we'll simply fail to resolve it later on.
445    }
446    if {$port ne "" && $port > 65535} {
447        unset $token
448        return -code error "Invalid port number: $port"
449    }
450    # The user identification and resource identification parts of the URL can
451    # have encoded characters in them; take care!
452    if {$user ne ""} {
453        # Check for validity according to RFC 3986, Appendix A
454        set validityRE {(?xi)
455            ^
456            (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
457            $
458        }
459        if {$state(-strict) && ![regexp -- $validityRE $user]} {
460            unset $token
461            # Provide a better error message in this error case
462            if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
463                return -code error \
464                        "Illegal encoding character usage \"$bad\" in URL user"
465            }
466            return -code error "Illegal characters in URL user"
467        }
468    }
469    if {$srvurl ne ""} {
470        # Check for validity according to RFC 3986, Appendix A
471        set validityRE {(?xi)
472            ^
473            # Path part (already must start with / character)
474            (?:       [-\w.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
475            # Query part (optional, permits ? characters)
476            (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
477            $
478        }
479        if {$state(-strict) && ![regexp -- $validityRE $srvurl]} {
480            unset $token
481            # Provide a better error message in this error case
482            if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
483                return -code error \
484                        "Illegal encoding character usage \"$bad\" in URL path"
485            }
486            return -code error "Illegal characters in URL path"
487        }
488    } else {
489        set srvurl /
490    }
491    if {$proto eq ""} {
492        set proto http
493    }
494    if {![info exists urlTypes($proto)]} {
495        unset $token
496        return -code error "Unsupported URL type \"$proto\""
497    }
498    set defport [lindex $urlTypes($proto) 0]
499    set defcmd [lindex $urlTypes($proto) 1]
500
501    if {$port eq ""} {
502        set port $defport
503    }
504    if {![catch {$http(-proxyfilter) $host} proxy]} {
505        set phost [lindex $proxy 0]
506        set pport [lindex $proxy 1]
507    }
508
509    # OK, now reassemble into a full URL
510    set url ${proto}://
511    if {$user ne ""} {
512        append url $user
513        append url @
514    }
515    append url $host
516    if {$port != $defport} {
517        append url : $port
518    }
519    append url $srvurl
520    # Don't append the fragment!
521    set state(url) $url
522
523    # If a timeout is specified we set up the after event and arrange for an
524    # asynchronous socket connection.
525
526    set sockopts [list]
527    if {$state(-timeout) > 0} {
528        set state(after) [after $state(-timeout) \
529                [list http::reset $token timeout]]
530        lappend sockopts -async
531    }
532
533    # If we are using the proxy, we must pass in the full URL that includes
534    # the server name.
535
536    if {[info exists phost] && ($phost ne "")} {
537        set srvurl $url
538        set targetAddr [list $phost $pport]
539    } else {
540        set targetAddr [list $host $port]
541    }
542    # Proxy connections aren't shared among different hosts.
543    set state(socketinfo) $host:$port
544
545    # See if we are supposed to use a previously opened channel.
546    if {$state(-keepalive)} {
547        variable socketmap
548        if {[info exists socketmap($state(socketinfo))]} {
549            if {[catch {fconfigure $socketmap($state(socketinfo))}]} {
550                Log "WARNING: socket for $state(socketinfo) was closed"
551                unset socketmap($state(socketinfo))
552            } else {
553                set sock $socketmap($state(socketinfo))
554                Log "reusing socket $sock for $state(socketinfo)"
555                catch {fileevent $sock writable {}}
556                catch {fileevent $sock readable {}}
557            }
558        }
559        # don't automatically close this connection socket
560        set state(connection) {}
561    }
562    if {![info exists sock]} {
563        # Pass -myaddr directly to the socket command
564        if {[info exists state(-myaddr)]} {
565            lappend sockopts -myaddr $state(-myaddr)
566        }
567        if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
568            # something went wrong while trying to establish the
569            # connection. Clean up after events and such, but DON'T call the
570            # command callback (if available) because we're going to throw an
571            # exception from here instead.
572
573            set state(sock) $sock
574            Finish $token "" 1
575            cleanup $token
576            return -code error $sock
577        }
578    }
579    set state(sock) $sock
580    Log "Using $sock for $state(socketinfo)" \
581        [expr {$state(-keepalive)?"keepalive":""}]
582    if {$state(-keepalive)} {
583        set socketmap($state(socketinfo)) $sock
584    }
585
586    # Wait for the connection to complete.
587
588    if {$state(-timeout) > 0} {
589        fileevent $sock writable [list http::Connect $token]
590        http::wait $token
591
592        if {![info exists state]} {
593            # If we timed out then Finish has been called and the users
594            # command callback may have cleaned up the token. If so
595            # we end up here with nothing left to do.
596            return $token
597        } elseif {$state(status) eq "error"} {
598            # Something went wrong while trying to establish the connection.
599            # Clean up after events and such, but DON'T call the command
600            # callback (if available) because we're going to throw an
601            # exception from here instead.
602            set err [lindex $state(error) 0]
603            cleanup $token
604            return -code error $err
605        } elseif {$state(status) ne "connect"} {
606            # Likely to be connection timeout
607            return $token
608        }
609        set state(status) ""
610    }
611
612    # Send data in cr-lf format, but accept any line terminators
613
614    fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
615
616    # The following is disallowed in safe interpreters, but the socket is
617    # already in non-blocking mode in that case.
618
619    catch {fconfigure $sock -blocking off}
620    set how GET
621    if {$isQuery} {
622        set state(querylength) [string length $state(-query)]
623        if {$state(querylength) > 0} {
624            set how POST
625            set contDone 0
626        } else {
627            # There's no query data.
628            unset state(-query)
629            set isQuery 0
630        }
631    } elseif {$state(-validate)} {
632        set how HEAD
633    } elseif {$isQueryChannel} {
634        set how POST
635        # The query channel must be blocking for the async Write to
636        # work properly.
637        fconfigure $state(-querychannel) -blocking 1 -translation binary
638        set contDone 0
639    }
640    if {[info exists state(-method)] && $state(-method) ne ""} {
641        set how $state(-method)
642    }
643
644    if {[catch {
645        puts $sock "$how $srvurl HTTP/$state(-protocol)"
646        puts $sock "Accept: $http(-accept)"
647        array set hdrs $state(-headers)
648        if {[info exists hdrs(Host)]} {
649            # Allow Host spoofing [Bug 928154]
650            puts $sock "Host: $hdrs(Host)"
651        } elseif {$port == $defport} {
652            # Don't add port in this case, to handle broken servers.
653            # [Bug #504508]
654            puts $sock "Host: $host"
655        } else {
656            puts $sock "Host: $host:$port"
657        }
658        unset hdrs
659        puts $sock "User-Agent: $http(-useragent)"
660        if {$state(-protocol) == 1.0 && $state(-keepalive)} {
661            puts $sock "Connection: keep-alive"
662        }
663        if {$state(-protocol) > 1.0 && !$state(-keepalive)} {
664            puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
665        }
666        if {[info exists phost] && ($phost ne "") && $state(-keepalive)} {
667            puts $sock "Proxy-Connection: Keep-Alive"
668        }
669        set accept_encoding_seen 0
670        foreach {key value} $state(-headers) {
671            if {[string equal -nocase $key "host"]} { continue }
672            if {[string equal -nocase $key "accept-encoding"]} {
673                set accept_encoding_seen 1
674            }
675            set value [string map [list \n "" \r ""] $value]
676            set key [string trim $key]
677            if {[string equal -nocase $key "content-length"]} {
678                set contDone 1
679                set state(querylength) $value
680            }
681            if {[string length $key]} {
682                puts $sock "$key: $value"
683            }
684        }
685        # Soft zlib dependency check - no package require
686        if {!$accept_encoding_seen && [llength [package provide zlib]]
687            && !([info exists state(-channel)] || [info exists state(-handler)])
688        } {
689            puts $sock "Accept-Encoding: gzip, identity, *;q=0.1"
690        }
691        if {$isQueryChannel && $state(querylength) == 0} {
692            # Try to determine size of data in channel. If we cannot seek, the
693            # surrounding catch will trap us
694
695            set start [tell $state(-querychannel)]
696            seek $state(-querychannel) 0 end
697            set state(querylength) \
698                    [expr {[tell $state(-querychannel)] - $start}]
699            seek $state(-querychannel) $start
700        }
701
702        # Flush the request header and set up the fileevent that will either
703        # push the POST data or read the response.
704        #
705        # fileevent note:
706        #
707        # It is possible to have both the read and write fileevents active at
708        # this point. The only scenario it seems to affect is a server that
709        # closes the connection without reading the POST data. (e.g., early
710        # versions TclHttpd in various error cases). Depending on the platform,
711        # the client may or may not be able to get the response from the server
712        # because of the error it will get trying to write the post data.
713        # Having both fileevents active changes the timing and the behavior,
714        # but no two platforms (among Solaris, Linux, and NT) behave the same,
715        # and none behave all that well in any case. Servers should always read
716        # their POST data if they expect the client to read their response.
717
718        if {$isQuery || $isQueryChannel} {
719            puts $sock "Content-Type: $state(-type)"
720            if {!$contDone} {
721                puts $sock "Content-Length: $state(querylength)"
722            }
723            puts $sock ""
724            fconfigure $sock -translation {auto binary}
725            fileevent $sock writable [list http::Write $token]
726        } else {
727            puts $sock ""
728            flush $sock
729            fileevent $sock readable [list http::Event $sock $token]
730        }
731
732        if {! [info exists state(-command)]} {
733            # geturl does EVERYTHING asynchronously, so if the user calls it
734            # synchronously, we just do a wait here.
735
736            wait $token
737            if {$state(status) eq "error"} {
738                # Something went wrong, so throw the exception, and the
739                # enclosing catch will do cleanup.
740                return -code error [lindex $state(error) 0]
741            }
742        }
743    } err]} {
744        # The socket probably was never connected, or the connection dropped
745        # later.
746
747        # Clean up after events and such, but DON'T call the command callback
748        # (if available) because we're going to throw an exception from here
749        # instead.
750
751        # if state(status) is error, it means someone's already called Finish
752        # to do the above-described clean up.
753        if {$state(status) ne "error"} {
754            Finish $token $err 1
755        }
756        cleanup $token
757        return -code error $err
758    }
759
760    return $token
761}
762
763# Data access functions:
764# Data - the URL data
765# Status - the transaction status: ok, reset, eof, timeout
766# Code - the HTTP transaction code, e.g., 200
767# Size - the size of the URL data
768
769proc http::data {token} {
770    variable $token
771    upvar 0 $token state
772    return $state(body)
773}
774proc http::status {token} {
775    if {![info exists $token]} { return "error" }
776    variable $token
777    upvar 0 $token state
778    return $state(status)
779}
780proc http::code {token} {
781    variable $token
782    upvar 0 $token state
783    return $state(http)
784}
785proc http::ncode {token} {
786    variable $token
787    upvar 0 $token state
788    if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
789        return $numeric_code
790    } else {
791        return $state(http)
792    }
793}
794proc http::size {token} {
795    variable $token
796    upvar 0 $token state
797    return $state(currentsize)
798}
799proc http::meta {token} {
800    variable $token
801    upvar 0 $token state
802    return $state(meta)
803}
804proc http::error {token} {
805    variable $token
806    upvar 0 $token state
807    if {[info exists state(error)]} {
808        return $state(error)
809    }
810    return ""
811}
812
813# http::cleanup
814#
815#       Garbage collect the state associated with a transaction
816#
817# Arguments
818#       token   The token returned from http::geturl
819#
820# Side Effects
821#       unsets the state array
822
823proc http::cleanup {token} {
824    variable $token
825    upvar 0 $token state
826    if {[info exists state]} {
827        unset state
828    }
829}
830
831# http::Connect
832#
833#       This callback is made when an asyncronous connection completes.
834#
835# Arguments
836#       token   The token returned from http::geturl
837#
838# Side Effects
839#       Sets the status of the connection, which unblocks
840#       the waiting geturl call
841
842proc http::Connect {token} {
843    variable $token
844    upvar 0 $token state
845    global errorInfo errorCode
846    if {[eof $state(sock)] ||
847        [string length [fconfigure $state(sock) -error]]} {
848            Finish $token "connect failed [fconfigure $state(sock) -error]" 1
849    } else {
850        set state(status) connect
851        fileevent $state(sock) writable {}
852    }
853    return
854}
855
856# http::Write
857#
858#       Write POST query data to the socket
859#
860# Arguments
861#       token   The token for the connection
862#
863# Side Effects
864#       Write the socket and handle callbacks.
865
866proc http::Write {token} {
867    variable $token
868    upvar 0 $token state
869    set sock $state(sock)
870
871    # Output a block.  Tcl will buffer this if the socket blocks
872    set done 0
873    if {[catch {
874        # Catch I/O errors on dead sockets
875
876        if {[info exists state(-query)]} {
877            # Chop up large query strings so queryprogress callback can give
878            # smooth feedback.
879
880            puts -nonewline $sock \
881                [string range $state(-query) $state(queryoffset) \
882                     [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
883            incr state(queryoffset) $state(-queryblocksize)
884            if {$state(queryoffset) >= $state(querylength)} {
885                set state(queryoffset) $state(querylength)
886                puts $sock ""
887                set done 1
888            }
889        } else {
890            # Copy blocks from the query channel
891
892            set outStr [read $state(-querychannel) $state(-queryblocksize)]
893            puts -nonewline $sock $outStr
894            incr state(queryoffset) [string length $outStr]
895            if {[eof $state(-querychannel)]} {
896                set done 1
897            }
898        }
899    } err]} {
900        # Do not call Finish here, but instead let the read half of the socket
901        # process whatever server reply there is to get.
902
903        set state(posterror) $err
904        set done 1
905    }
906    if {$done} {
907        catch {flush $sock}
908        fileevent $sock writable {}
909        fileevent $sock readable [list http::Event $sock $token]
910    }
911
912    # Callback to the client after we've completely handled everything.
913
914    if {[string length $state(-queryprogress)]} {
915        eval $state(-queryprogress) \
916            [list $token $state(querylength) $state(queryoffset)]
917    }
918}
919
920# http::Event
921#
922#       Handle input on the socket
923#
924# Arguments
925#       sock    The socket receiving input.
926#       token   The token returned from http::geturl
927#
928# Side Effects
929#       Read the socket and handle callbacks.
930
931proc http::Event {sock token} {
932    variable $token
933    upvar 0 $token state
934
935    if {![info exists state]} {
936        Log "Event $sock with invalid token '$token' - remote close?"
937        if {! [eof $sock]} {
938            if {[string length [set d [read $sock]]] != 0} {
939                Log "WARNING: additional data left on closed socket"
940            }
941        }
942        CloseSocket $sock
943        return
944    }
945    if {$state(state) eq "header"} {
946        if {[catch {gets $sock line} n]} {
947            return [Finish $token $n]
948        } elseif {$n == 0} {
949            # We have now read all headers
950            # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
951            if {$state(http) == "" || [lindex $state(http) 1] == 100} { return }
952
953            set state(state) body
954
955            # If doing a HEAD, then we won't get any body
956            if {$state(-validate)} {
957                Eof $token
958                return
959            }
960
961            # For non-chunked transfer we may have no body -- in this case we
962            # may get no further file event if the connection doesn't close and
963            # no more data is sent. We can tell and must finish up now - not
964            # later.
965            if {!(([info exists state(connection)]
966                   && ($state(connection) eq "close"))
967                  || [info exists state(transfer)])
968                &&  $state(totalsize) == 0
969            } then {
970                Log "body size is 0 and no events likely - complete."
971                Eof $token
972                return
973            }
974
975            # We have to use binary translation to count bytes properly.
976            fconfigure $sock -translation binary
977
978            if {$state(-binary) || ![string match -nocase text* $state(type)]} {
979                # Turn off conversions for non-text data
980                set state(binary) 1
981            }
982            if {$state(binary) || [string match *gzip* $state(coding)]
983                || [string match *compress* $state(coding)]} {
984                if {[info exists state(-channel)]} {
985                    fconfigure $state(-channel) -translation binary
986                }
987            }
988            if {[info exists state(-channel)] &&
989                ![info exists state(-handler)]} {
990                # Initiate a sequence of background fcopies
991                fileevent $sock readable {}
992                CopyStart $sock $token
993                return
994            }
995        } elseif {$n > 0} {
996            # Process header lines
997            if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
998                switch -- [string tolower $key] {
999                    content-type {
1000                        set state(type) [string trim [string tolower $value]]
1001                        # grab the optional charset information
1002                        regexp -nocase {charset\s*=\s*(\S+?);?} \
1003                            $state(type) -> state(charset)
1004                    }
1005                    content-length {
1006                        set state(totalsize) [string trim $value]
1007                    }
1008                    content-encoding {
1009                        set state(coding) [string trim $value]
1010                    }
1011                    transfer-encoding {
1012                        set state(transfer) \
1013                            [string trim [string tolower $value]]
1014                    }
1015                    proxy-connection -
1016                    connection {
1017                        set state(connection) \
1018                            [string trim [string tolower $value]]
1019                    }
1020                }
1021                lappend state(meta) $key [string trim $value]
1022            } elseif {[string match HTTP* $line]} {
1023                set state(http) $line
1024            }
1025        }
1026    } else {
1027        # Now reading body
1028        if {[catch {
1029            if {[info exists state(-handler)]} {
1030                set n [eval $state(-handler) [list $sock $token]]
1031            } elseif {[info exists state(transfer_final)]} {
1032                set line [getTextLine $sock]
1033                set n [string length $line]
1034                if {$n > 0} {
1035                    Log "found $n bytes following final chunk"
1036                    append state(transfer_final) $line
1037                } else {
1038                    Log "final chunk part"
1039                    Eof $token
1040                }
1041            } elseif {[info exists state(transfer)]
1042                      && $state(transfer) eq "chunked"} {
1043                set size 0
1044                set chunk [getTextLine $sock]
1045                set n [string length $chunk]
1046                if {[string trim $chunk] ne ""} {
1047                    scan $chunk %x size
1048                    if {$size != 0} {
1049                        set bl [fconfigure $sock -blocking]
1050                        fconfigure $sock -blocking 1
1051                        set chunk [read $sock $size]
1052                        fconfigure $sock -blocking $bl
1053                        set n [string length $chunk]
1054                        if {$n >= 0} {
1055                            append state(body) $chunk
1056                        }
1057                        if {$size != [string length $chunk]} {
1058                            Log "WARNING: mis-sized chunk:\
1059                                was [string length $chunk], should be $size"
1060                        }
1061                        getTextLine $sock
1062                    } else {
1063                        set state(transfer_final) {}
1064                    }
1065                }
1066            } else {
1067                #Log "read non-chunk $state(currentsize) of $state(totalsize)"
1068                set block [read $sock $state(-blocksize)]
1069                set n [string length $block]
1070                if {$n >= 0} {
1071                    append state(body) $block
1072                }
1073            }
1074            if {[info exists state]} {
1075                if {$n >= 0} {
1076                    incr state(currentsize) $n
1077                }
1078                # If Content-Length - check for end of data.
1079                if {($state(totalsize) > 0)
1080                    && ($state(currentsize) >= $state(totalsize))} {
1081                    Eof $token
1082                }
1083            }
1084        } err]} {
1085            return [Finish $token $err]
1086        } else {
1087            if {[info exists state(-progress)]} {
1088                eval $state(-progress) \
1089                    [list $token $state(totalsize) $state(currentsize)]
1090            }
1091        }
1092    }
1093
1094    # catch as an Eof above may have closed the socket already
1095    if {![catch {eof $sock} eof] && $eof} {
1096        if {[info exists $token]} {
1097            set state(connection) close
1098            Eof $token
1099        } else {
1100            # open connection closed on a token that has been cleaned up.
1101            CloseSocket $sock
1102        }
1103        return
1104    }
1105}
1106
1107# http::getTextLine --
1108#
1109#       Get one line with the stream in blocking crlf mode
1110#
1111# Arguments
1112#       sock    The socket receiving input.
1113#
1114# Results:
1115#       The line of text, without trailing newline
1116
1117proc http::getTextLine {sock} {
1118    set tr [fconfigure $sock -translation]
1119    set bl [fconfigure $sock -blocking]
1120    fconfigure $sock -translation crlf -blocking 1
1121    set r [gets $sock]
1122    fconfigure $sock -translation $tr -blocking $bl
1123    return $r
1124}
1125
1126# http::CopyStart
1127#
1128#       Error handling wrapper around fcopy
1129#
1130# Arguments
1131#       sock    The socket to copy from
1132#       token   The token returned from http::geturl
1133#
1134# Side Effects
1135#       This closes the connection upon error
1136
1137proc http::CopyStart {sock token} {
1138    variable $token
1139    upvar 0 $token state
1140    if {[catch {
1141        fcopy $sock $state(-channel) -size $state(-blocksize) -command \
1142            [list http::CopyDone $token]
1143    } err]} {
1144        Finish $token $err
1145    }
1146}
1147
1148# http::CopyDone
1149#
1150#       fcopy completion callback
1151#
1152# Arguments
1153#       token   The token returned from http::geturl
1154#       count   The amount transfered
1155#
1156# Side Effects
1157#       Invokes callbacks
1158
1159proc http::CopyDone {token count {error {}}} {
1160    variable $token
1161    upvar 0 $token state
1162    set sock $state(sock)
1163    incr state(currentsize) $count
1164    if {[info exists state(-progress)]} {
1165        eval $state(-progress) \
1166            [list $token $state(totalsize) $state(currentsize)]
1167    }
1168    # At this point the token may have been reset
1169    if {[string length $error]} {
1170        Finish $token $error
1171    } elseif {[catch {eof $sock} iseof] || $iseof} {
1172        Eof $token
1173    } else {
1174        CopyStart $sock $token
1175    }
1176}
1177
1178# http::Eof
1179#
1180#       Handle eof on the socket
1181#
1182# Arguments
1183#       token   The token returned from http::geturl
1184#
1185# Side Effects
1186#       Clean up the socket
1187
1188proc http::Eof {token {force 0}} {
1189    variable $token
1190    upvar 0 $token state
1191    if {$state(state) eq "header"} {
1192        # Premature eof
1193        set state(status) eof
1194    } else {
1195        set state(status) ok
1196    }
1197
1198    if {($state(coding) eq "gzip") && [string length $state(body)] > 0} {
1199        if {[catch {
1200            set state(body) [Gunzip $state(body)]
1201        } err]} {
1202            return [Finish $token $err]
1203        }
1204    }
1205
1206    if {!$state(binary)} {
1207
1208        # If we are getting text, set the incoming channel's
1209        # encoding correctly.  iso8859-1 is the RFC default, but
1210        # this could be any IANA charset.  However, we only know
1211        # how to convert what we have encodings for.
1212
1213        set enc [CharsetToEncoding $state(charset)]
1214        if {$enc ne "binary"} {
1215            set state(body) [encoding convertfrom $enc $state(body)]
1216        }
1217
1218        # Translate text line endings.
1219        set state(body) [string map {\r\n \n \r \n} $state(body)]
1220    }
1221
1222    Finish $token
1223}
1224
1225# http::wait --
1226#
1227#       See documentation for details.
1228#
1229# Arguments:
1230#       token   Connection token.
1231#
1232# Results:
1233#        The status after the wait.
1234
1235proc http::wait {token} {
1236    variable $token
1237    upvar 0 $token state
1238
1239    if {![info exists state(status)] || $state(status) eq ""} {
1240        # We must wait on the original variable name, not the upvar alias
1241        vwait ${token}(status)
1242    }
1243
1244    return [status $token]
1245}
1246
1247# http::formatQuery --
1248#
1249#       See documentation for details.  Call http::formatQuery with an even
1250#       number of arguments, where the first is a name, the second is a value,
1251#       the third is another name, and so on.
1252#
1253# Arguments:
1254#       args    A list of name-value pairs.
1255#
1256# Results:
1257#       TODO
1258
1259proc http::formatQuery {args} {
1260    set result ""
1261    set sep ""
1262    foreach i $args {
1263        append result $sep [mapReply $i]
1264        if {$sep eq "="} {
1265            set sep &
1266        } else {
1267            set sep =
1268        }
1269    }
1270    return $result
1271}
1272
1273# http::mapReply --
1274#
1275#       Do x-www-urlencoded character mapping
1276#
1277# Arguments:
1278#       string  The string the needs to be encoded
1279#
1280# Results:
1281#       The encoded string
1282
1283proc http::mapReply {string} {
1284    variable http
1285    variable formMap
1286
1287    # The spec says: "non-alphanumeric characters are replaced by '%HH'". Use
1288    # a pre-computed map and [string map] to do the conversion (much faster
1289    # than [regsub]/[subst]). [Bug 1020491]
1290
1291    if {$http(-urlencoding) ne ""} {
1292        set string [encoding convertto $http(-urlencoding) $string]
1293        return [string map $formMap $string]
1294    }
1295    set converted [string map $formMap $string]
1296    if {[string match "*\[\u0100-\uffff\]*" $converted]} {
1297        regexp {[\u0100-\uffff]} $converted badChar
1298        # Return this error message for maximum compatability... :^/
1299        return -code error \
1300            "can't read \"formMap($badChar)\": no such element in array"
1301    }
1302    return $converted
1303}
1304
1305# http::ProxyRequired --
1306#       Default proxy filter.
1307#
1308# Arguments:
1309#       host    The destination host
1310#
1311# Results:
1312#       The current proxy settings
1313
1314proc http::ProxyRequired {host} {
1315    variable http
1316    if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
1317        if {![info exists http(-proxyport)] || \
1318                ![string length $http(-proxyport)]} {
1319            set http(-proxyport) 8080
1320        }
1321        return [list $http(-proxyhost) $http(-proxyport)]
1322    }
1323}
1324
1325# http::CharsetToEncoding --
1326#
1327#       Tries to map a given IANA charset to a tcl encoding.
1328#       If no encoding can be found, returns binary.
1329#
1330
1331proc http::CharsetToEncoding {charset} {
1332    variable encodings
1333
1334    set charset [string tolower $charset]
1335    if {[regexp {iso-?8859-([0-9]+)} $charset - num]} {
1336        set encoding "iso8859-$num"
1337    } elseif {[regexp {iso-?2022-(jp|kr)} $charset - ext]} {
1338        set encoding "iso2022-$ext"
1339    } elseif {[regexp {shift[-_]?js} $charset -]} {
1340        set encoding "shiftjis"
1341    } elseif {[regexp {(windows|cp)-?([0-9]+)} $charset - - num]} {
1342        set encoding "cp$num"
1343    } elseif {$charset eq "us-ascii"} {
1344        set encoding "ascii"
1345    } elseif {[regexp {(iso-?)?lat(in)?-?([0-9]+)} $charset - - - num]} {
1346        switch -- $num {
1347            5 {set encoding "iso8859-9"}
1348            1 -
1349            2 -
1350            3 {set encoding "iso8859-$num"}
1351        }
1352    } else {
1353        # other charset, like euc-xx, utf-8,...  may directly maps to encoding
1354        set encoding $charset
1355    }
1356    set idx [lsearch -exact $encodings $encoding]
1357    if {$idx >= 0} {
1358        return $encoding
1359    } else {
1360        return "binary"
1361    }
1362}
1363
1364# http::Gunzip --
1365#
1366#       Decompress data transmitted using the gzip transfer coding.
1367#
1368
1369# FIX ME: redo using zlib sinflate
1370proc http::Gunzip {data} {
1371    binary scan $data Scb5icc magic method flags time xfl os
1372    set pos 10
1373    if {$magic != 0x1f8b} {
1374        return -code error "invalid data: supplied data is not in gzip format"
1375    }
1376    if {$method != 8} {
1377        return -code error "invalid compression method"
1378    }
1379
1380    foreach {f_text f_crc f_extra f_name f_comment} [split $flags ""] break
1381    set extra ""
1382    if { $f_extra } {
1383        binary scan $data @${pos}S xlen
1384        incr pos 2
1385        set extra [string range $data $pos $xlen]
1386        set pos [incr xlen]
1387    }
1388
1389    set name ""
1390    if { $f_name } {
1391        set ndx [string first \0 $data $pos]
1392        set name [string range $data $pos $ndx]
1393        set pos [incr ndx]
1394    }
1395
1396    set comment ""
1397    if { $f_comment } {
1398        set ndx [string first \0 $data $pos]
1399        set comment [string range $data $pos $ndx]
1400        set pos [incr ndx]
1401    }
1402
1403    set fcrc ""
1404    if { $f_crc } {
1405        set fcrc [string range $data $pos [incr pos]]
1406        incr pos
1407    }
1408
1409    binary scan [string range $data end-7 end] ii crc size
1410    set inflated [zlib inflate [string range $data $pos end-8]]
1411
1412    if { $crc != [set chk [zlib crc32 $inflated]] } {
1413        return -code error "invalid data: checksum mismatch $crc != $chk"
1414    }
1415    return $inflated
1416}
1417
1418# Local variables:
1419# indent-tabs-mode: t
1420# End:
Note: See TracBrowser for help on using the repository browser.