# Client-side HTTP for GET, POST, and HEAD commands.
# These routines can be used in untrusted code that uses
# the Safesock security policy. These procedures use a
# callback interface to avoid using vwait, which is not
# defined in the safe base.
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# RCS: @(#) $Id: http.tcl,v 1.43.2.6 2005/01/06 15:16:03 dkf Exp $
# 1.0 Old http_get interface
# 2.0 http:: namespace and http::geturl
# 2.1 Added callbacks to handle arriving data, and timeouts
# 2.2 Added ability to fetch into a channel
# 2.3 Added SSL support, and ability to post from a channel
# This version also cleans up error cases and eliminates the
# "ioerror" status in favor of raising an error
# 2.4 Added -binary option to http::geturl and charset element
# keep this in sync with pkgIndex.tcl
# and with the install directories in Makefiles
package provide
http 2.5.1
-proxyfilter http::ProxyRequired
set http(-useragent) "Tcl http client package [package provide http]"
# Set up the map for quoting chars
# The spec says: "non-alphanumeric characters are replaced by '%HH'"
for {set i
0} {$i <= 256} {incr i
} {
if {![string match
{[a-zA-Z0-9
]} $c]} {
set map
($c) %[format %.2x
$i]
# These are handled specially
array set map
{ " " + \n %0d
%0a
}
variable formMap
[array get map
]
variable encodings
[string tolower
[encoding names
]]
# This can be changed, but iso8859-1 is the RFC standard.
variable defaultCharset
"iso8859-1"
namespace export geturl config reset wait formatQuery register unregister
# Useful, but not exported: data size status code
# See documentaion for details.
# proto URL protocol prefix, e.g. https
# port Default port for protocol
# command Command to use to create socket
# list of port and command that was registered.
proc http::register {proto port command
} {
set urlTypes
($proto) [list $port $command]
# Unregisters URL protocol handler
# proto URL protocol prefix, e.g. https
# list of port and command that was unregistered.
proc http::unregister {proto
} {
if {![info exists urlTypes
($proto)]} {
return -code error "unsupported url type \"$proto\""
set old
$urlTypes($proto)
# See documentaion for details.
# args Options parsed by the procedure.
proc http::config {args
} {
set options [lsort [array names
http -*]]
set usage
[join $options ", "]
if {[llength $args] == 0} {
lappend result
$name $http($name)
set options [string map
{- ""} $options]
set pat ^
-([join $options |
])$
if {[llength $args] == 1} {
set flag
[lindex $args 0]
if {[regexp -- $pat $flag]} {
return -code error "Unknown option $flag, must be: $usage"
foreach {flag value
} $args {
if {[regexp -- $pat $flag]} {
return -code error "Unknown option $flag, must be: $usage"
# Clean up the socket and eval close time callbacks
# token Connection token.
# errormsg (optional) If set, forces status to error.
# skipCB (optional) If set, don't call the -command callback. This
# is useful when geturl wants to throw an exception instead
# of calling the callback. That way, the same error isn't
# reported to two places.
proc http::Finish { token
{errormsg
""} {skipCB
0}} {
global errorInfo errorCode
if {[string length
$errormsg] != 0} {
set state
(error) [list $errormsg $errorInfo $errorCode]
catch {close $state(sock
)}
catch {after cancel
$state(after)}
if {[info exists state
(-command)] && !$skipCB} {
if {[catch {eval $state(-command) {$token}} err
]} {
if {[string length
$errormsg] == 0} {
set state
(error) [list $err $errorInfo $errorCode]
if {[info exists state
(-command)]} {
# Command callback may already have unset our state
# See documentaion for details.
# token Connection token.
proc http::reset { token
{why reset
} } {
catch {fileevent $state(sock
) readable
{}}
catch {fileevent $state(sock
) writable
{}}
if {[info exists state
(error)]} {
set errorlist
$state(error)
# Establishes a connection to a remote url via http.
# url The http URL to goget.
# args Option value pairs. Valid options include:
# -blocksize, -validate, -headers, -timeout
# Returns a token for this connection.
# This token is the name of an array that the caller should
# unset to garbage collect the state.
proc http::geturl { url args
} {
# Initialize the state variable, an array. We'll return the
# name of this array as the token for the transaction.
if {![info exists
http(uid
)]} {
set token
[namespace current
]::[incr http(uid
)]
# Process command options.
-type application
/x-www-form-urlencoded
# These flags have their types verified [Bug 811170]
set state
(charset
) $defaultCharset
set options {-binary -blocksize -channel -command -handler -headers \
-progress -query -queryblocksize -querychannel -queryprogress\
-validate -timeout -type}
set usage
[join $options ", "]
set options [string map
{- ""} $options]
set pat ^
-([join $options |
])$
foreach {flag value
} $args {
if {[regexp $pat $flag]} {
if {[info exists type
($flag)] && \
![string is
$type($flag) -strict $value]} {
return -code error "Bad value for $flag ($value), must be $type($flag)"
return -code error "Unknown option $flag, can be: $usage"
# Make sure -query and -querychannel aren't both specified
set isQueryChannel
[info exists state
(-querychannel)]
set isQuery
[info exists state
(-query)]
if {$isQuery && $isQueryChannel} {
return -code error "Can't combine -query and -querychannel options!"
# Validate URL, determine the server host and port, and check proxy case
# Recognize user:pass@host URLs also, although we do not do anything
set exp
{^
(([^
:]*)://)?
([^
@]+@)?
([^
/:]+)(:([0-9]+))?
(/.
*)?
$}
if {![regexp -nocase $exp $url x prefix proto user host y port srvurl
]} {
return -code error "Unsupported URL: $url"
if {[string length
$proto] == 0} {
if {![info exists urlTypes
($proto)]} {
return -code error "Unsupported URL type \"$proto\""
set defport
[lindex $urlTypes($proto) 0]
set defcmd
[lindex $urlTypes($proto) 1]
if {[string length
$port] == 0} {
if {[string length
$srvurl] == 0} {
if {[string length
$proto] == 0} {
if {![catch {$http(-proxyfilter) $host} proxy
]} {
set phost
[lindex $proxy 0]
set pport
[lindex $proxy 1]
# If a timeout is specified we set up the after event
# and arrange for an asynchronous socket connection.
if {$state(-timeout) > 0} {
set state
(after) [after $state(-timeout) \
[list http::reset $token timeout
]]
# If we are using the proxy, we must pass in the full URL that
# includes the server name.
if {[info exists phost
] && [string length
$phost]} {
set conStat
[catch {eval $defcmd $async {$phost $pport}} s
]
set conStat
[catch {eval $defcmd $async {$host $port}} s
]
# something went wrong while trying to establish the connection
# Clean up after events and such, but DON'T call the command callback
# (if available) because we're going to throw an exception from here
# Wait for the connection to complete
if {$state(-timeout) > 0} {
fileevent $s writable
[list http::Connect $token]
if {$state(status
) eq
"error"} {
# something went wrong while trying to establish the connection
# Clean up after events and such, but DON'T call the command
# callback (if available) because we're going to throw an
# exception from here instead.
set err
[lindex $state(error) 0]
} elseif
{$state(status
) ne
"connect"} {
# Likely to be connection timeout
# Send data in cr-lf format, but accept any line terminators
fconfigure $s -translation {auto crlf
} -buffersize $state(-blocksize)
# The following is disallowed in safe interpreters, but the socket
# is already in non-blocking mode in that case.
catch {fconfigure $s -blocking off
}
set state
(querylength
) [string length
$state(-query)]
if {$state(querylength
) > 0} {
} elseif
{$state(-validate)} {
} elseif
{$isQueryChannel} {
# The query channel must be blocking for the async Write to
fconfigure $state(-querychannel) -blocking 1 -translation binary
puts $s "$how $srvurl HTTP/1.0"
puts $s "Accept: $http(-accept)"
# Don't add port in this case, to handle broken servers.
puts $s "Host: $host:$port"
puts $s "User-Agent: $http(-useragent)"
foreach {key value
} $state(-headers) {
set value
[string map
[list \n "" \r ""] $value]
set key
[string trim
$key]
if {$key eq
"Content-Length"} {
set state
(querylength
) $value
if {[string length
$key]} {
if {$isQueryChannel && $state(querylength
) == 0} {
# Try to determine size of data in channel
# If we cannot seek, the surrounding catch will trap us
set start
[tell $state(-querychannel)]
seek $state(-querychannel) 0 end
[expr {[tell $state(-querychannel)] - $start}]
seek $state(-querychannel) $start
# Flush the request header and set up the fileevent that will
# either push the POST data or read the response.
# It is possible to have both the read and write fileevents active
# at this point. The only scenario it seems to affect is a server
# that closes the connection without reading the POST data.
# (e.g., early versions TclHttpd in various error cases).
# Depending on the platform, the client may or may not be able to
# get the response from the server because of the error it will
# get trying to write the post data. Having both fileevents active
# changes the timing and the behavior, but no two platforms
# (among Solaris, Linux, and NT) behave the same, and none
# behave all that well in any case. Servers should always read thier
# POST data if they expect the client to read their response.
if {$isQuery ||
$isQueryChannel} {
puts $s "Content-Type: $state(-type)"
puts $s "Content-Length: $state(querylength)"
fconfigure $s -translation {auto
binary}
fileevent $s writable
[list http::Write $token]
fileevent $s readable
[list http::Event $token]
if {! [info exists state
(-command)]} {
# geturl does EVERYTHING asynchronously, so if the user
# calls it synchronously, we just do a wait here.
if {$state(status
) eq
"error"} {
# Something went wrong, so throw the exception, and the
# enclosing catch will do cleanup.
return -code error [lindex $state(error) 0]
# The socket probably was never connected,
# or the connection dropped later.
# Clean up after events and such, but DON'T call the command callback
# (if available) because we're going to throw an exception from here
# if state(status) is error, it means someone's already called Finish
# to do the above-described clean up.
if {$state(status
) eq
"error"} {
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
# Size - the size of the URL data
proc http::data {token
} {
proc http::status {token
} {
proc http::code {token
} {
proc http::ncode {token
} {
if {[regexp {[0-9]{3}} $state(http) numeric_code
]} {
proc http::size {token
} {
return $state(currentsize
)
proc http::error {token
} {
if {[info exists state
(error)]} {
# Garbage collect the state associated with a transaction
# token The token returned from http::geturl
proc http::cleanup {token
} {
if {[info exists state
]} {
# This callback is made when an asyncronous connection completes.
# token The token returned from http::geturl
# Sets the status of the connection, which unblocks
# the waiting geturl call
proc http::Connect {token
} {
global errorInfo errorCode
if {[eof $state(sock
)] ||
[string length
[fconfigure $state(sock
) -error]]} {
Finish
$token "connect failed [fconfigure $state(sock) -error]" 1
set state
(status
) connect
fileevent $state(sock
) writable
{}
# Write POST query data to the socket
# token The token for the connection
# Write the socket and handle callbacks.
proc http::Write {token
} {
# Output a block. Tcl will buffer this if the socket blocks
# Catch I/O errors on dead sockets
if {[info exists state
(-query)]} {
# Chop up large query strings so queryprogress callback
# can give smooth feedback
[string range
$state(-query) $state(queryoffset
) \
[expr {$state(queryoffset
) + $state(-queryblocksize) - 1}]]
incr state
(queryoffset
) $state(-queryblocksize)
if {$state(queryoffset
) >= $state(querylength
)} {
set state
(queryoffset
) $state(querylength
)
# Copy blocks from the query channel
set outStr
[read $state(-querychannel) $state(-queryblocksize)]
puts -nonewline $s $outStr
incr state
(queryoffset
) [string length
$outStr]
if {[eof $state(-querychannel)]} {
# Do not call Finish here, but instead let the read half of
# the socket process whatever server reply there is to get.
set state
(posterror
) $err
fileevent $s readable
[list http::Event $token]
# Callback to the client after we've completely handled everything
if {[string length
$state(-queryprogress)]} {
eval $state(-queryprogress) [list $token $state(querylength
)\
# Handle input on the socket
# token The token returned from http::geturl
# Read the socket and handle callbacks.
proc http::Event {token
} {
if {$state(state
) eq
"header"} {
if {[catch {gets $s line
} n
]} {
if {$state(-binary) ||
![string match
-nocase text* $state(type
)]
||
[string match
*gzip
* $state(coding
)]
||
[string match
*compress
* $state(coding
)]} {
# Turn off conversions for non-text data
fconfigure $s -translation binary
if {[info exists state
(-channel)]} {
fconfigure $state(-channel) -translation binary
# If we are getting text, set the incoming channel's
# encoding correctly. iso8859-1 is the RFC default, but
# this could be any IANA charset. However, we only know
# how to convert what we have encodings for.
set idx
[lsearch -exact $encodings \
[string tolower
$state(charset
)]]
fconfigure $s -encoding [lindex $encodings $idx]
if {[info exists state
(-channel)] && \
![info exists state
(-handler)]} {
# Initiate a sequence of background fcopies
if {[regexp -nocase {^content-type
:(.
+)$} $line x type
]} {
set state
(type
) [string trim
$type]
# grab the optional charset information
regexp -nocase {charset
\s
*=\s
*(\S
+)} $type x state
(charset
)
if {[regexp -nocase {^content-length
:(.
+)$} $line x length
]} {
set state
(totalsize
) [string trim
$length]
if {[regexp -nocase {^content-encoding
:(.
+)$} $line x coding
]} {
set state
(coding
) [string trim
$coding]
if {[regexp -nocase {^
([^
:]+):(.
+)$} $line x key value
]} {
lappend state
(meta
) $key [string trim
$value]
} elseif
{[string match HTTP
* $line]} {
if {[info exists state
(-handler)]} {
set n
[eval $state(-handler) {$s $token}]
set block
[read $s $state(-blocksize)]
set n
[string length
$block]
append state
(body
) $block
incr state
(currentsize
) $n
if {[info exists state
(-progress)]} {
{$token $state(totalsize
) $state(currentsize
)}
# Error handling wrapper around fcopy
# s The socket to copy from
# token The token returned from http::geturl
# This closes the connection upon error
proc http::CopyStart {s token
} {
fcopy $s $state(-channel) -size $state(-blocksize) -command \
[list http::CopyDone $token]
# fcopy completion callback
# token The token returned from http::geturl
# count The amount transfered
proc http::CopyDone {token count
{error {}}} {
incr state
(currentsize
) $count
if {[info exists state
(-progress)]} {
eval $state(-progress) {$token $state(totalsize
) $state(currentsize
)}
# At this point the token may have been reset
if {[string length
$error]} {
} elseif
{[catch {eof $s} iseof
] ||
$iseof} {
# Handle eof on the socket
# token The token returned from http::geturl
if {$state(state
) eq
"header"} {
# See documentaion for details.
# token Connection token.
# The status after the wait.
proc http::wait {token
} {
if {![info exists state
(status
)] ||
[string length
$state(status
)] == 0} {
# We must wait on the original variable name, not the upvar alias
# See documentaion for details.
# Call http::formatQuery with an even number of arguments, where
# the first is a name, the second is a value, the third is another
# args A list of name-value pairs.
proc http::formatQuery {args
} {
append result
$sep [mapReply
$i]
# Do x-www-urlencoded character mapping
# string The string the needs to be encoded
proc http::mapReply {string} {
# The spec says: "non-alphanumeric characters are replaced by '%HH'"
# Use a pre-computed map and [string map] to do the conversion
# (much faster than [regsub]/[subst]). [Bug 1020491]
if {$http(-urlencoding) ne
""} {
set string [encoding convertto
$http(-urlencoding) $string]
return [string map
$formMap $string]
set converted
[string map
$formMap $string]
if {[string match
"*\[\u0100-\uffff\]*" $converted]} {
regexp {[\u0100-\uffff]} $converted badChar
# Return this error message for maximum compatability... :^/
"can't read \"formMap($badChar)\": no such element in array"
# host The destination host
# The current proxy settings
proc http::ProxyRequired {host
} {
if {[info exists
http(-proxyhost)] && [string length
$http(-proxyhost)]} {
if {![info exists
http(-proxyport)] ||
\
![string length
$http(-proxyport)]} {
set http(-proxyport) 8080
return [list $http(-proxyhost) $http(-proxyport)]