Tcl Source Code

	-accept {string {^[^\s/]+/+[^\s/+]$} "MIME type"}
	-charset string
	-connectionclass class
	-keepalive boolean
	-proxyfilter callback
	-proxyhost string
	-proxyport integer
	-strict boolean
	-urlencoding encoding
	-useragent string
    }

    variable ConnectionConfig {
	-binary boolean
	-blocksize integer
	-channel channel
	-command callback
	-handler callback
	-headers dict
	-keepalive boolean
	-method {string ^[A-Z0-9]+$ "uppercase string"}
	-myaddr string
	-progress callback
	-protocol string
	-query string
	-queryblocksize integer
	-querychannel channel
	-queryprogress callback

	-timeout integer
	-type {string {^[^\s/]+/+[^\s/+]$} "MIME type"}
	-validate boolean
    }
    variable ConnectionDefaults {
	-binary false
	-blocksize 8192
	-queryblocksize 8192
	-validate false
	-headers {}
	-timeout 0
	-type application/x-www-form-urlencoded
	-queryprogress {}
	-protocol 1.1
    }

    oo::class create Context {
	variable config
	variable socketmap urltypes encodings charset keepalive
	variable connectionclass counter

	constructor {} {
	    array set config {
		-accept */*
		-charset iso8859-1
		-keepalive 0
		-proxyhost {}
		-proxyport {}
		-urlencoding utf-8
	    }
	    set config(-proxyfilter) [namespace code {my ProxyRequired}]
	    set connectionclass ::http::Connection

	    # We need a useragent string of this style or various servers will
	    # refuse to send us compressed content even when we ask for it.
	    # This follows the de-facto layout of user-agent strings in
	    # current browsers.  Safe interpreters do not have
	    # ::tcl_platform(os) or ::tcl_platform(osVersion).

	    if {[interp issafe]} {
		set platform "Windows; U; Windows NT 10.0"
	    } else {
		global tcl_platform
		set platform "[string totitle $tcl_platform(platform)]; U;\
			$tcl_platform(os) $tcl_platform(osVersion)"
	    }

	    array set socketmap {}

	    set urltypes(http) [list 80 ::socket]

	    set encodings [string tolower [encoding names]]
	    set charset "iso8859-1"
	    set keepalive 0

	    set counter 0
	}

	method register {proto port command} {
	    set lower [string tolower $proto]
	    try {
		return $urltypes($lower)

	    if {[info exists proxyhost] && [string length $proxyhost]} {
		if {![info exists proxyport] || ![string length $proxyport]} {
		    set proxyport 8080
		}
		return [list $proxyhost $proxyport]
	    }
	}

	method parseURL {url} {
	    # Validate URL, determine the server host and port, and check
	    # proxy case Recognize user:pass@host URLs also, although we do
	    # not do anything with that info yet.

	    # URLs have basically four parts.
	    #
	    # First, before the colon, is the protocol scheme (e.g. http).
	    #
	    # Second, for HTTP-like protocols, is the authority. The authority
	    #	is preceded by // and lasts up to (but not including) the
	    #	following / or ? and it identifies up to four parts, of which
	    #	only one, the host, is required (if an authority is present at
	    #	all). All other parts of the authority (user name, password,
	    #	port number) are optional.
	    #
	    # Third is the resource name, which is split into two parts at a ?
	    #	The first part (from the single "/" up to "?") is the path,
	    #	and the second part (from that "?" up to "#") is the
	    #	query. *HOWEVER*, we do not need to separate them; we send the
	    #	whole lot to the server.  Both, path and query are allowed to
	    #	be missing, including their delimiting character.
	    #
	    # Fourth is the fragment identifier, which is everything after the
	    #	firsts "#" in the URL. The fragment identifier MUST NOT be
	    #	sent to the server and indeed, we don't bother to validate it
	    #	(it could be an error to pass it in here, but it's cheap to
	    #	strip).
	    #
	    # An example of a URL that has all the parts:
	    #
	    #   http://joe:[email protected]:8000/foo/bar.tml?q=foo#changes
	    #
	    # The "http" is the protocol, the user is "joe", the password is
	    # "xyzzy", the host is "www.bogus.net", the port is "8000", the
	    # path is "/foo/bar.tml", the query is "q=foo", and the fragment
	    # is "changes".
	    #
	    # Note that the RE actually combines the user and password parts,
	    # as recommended in RFC 3986. Indeed, that RFC states that putting
	    # passwords in URLs is a Really Bad Idea, something with which I
	    # would agree utterly.
	    #
	    # From a validation perspective, we need to ensure that the parts
	    # of the URL that are going to the server are correctly encoded.
	    # This is only done if $config(-strict) is true.

	    set URLmatcher {(?x)	# this is _expanded_ syntax
		^
		(?: (\w+) : ) ?		# <protocol scheme>
		(?: //
		    (?:
			(
			    [^@/\#?]+	# <userinfo part of authority>
			) @
		    )?
		    (			# <host part of authority>
			[^/:\#?]+ |	# host name or IPv4 address
			\[ [^/\#?]+ \]	# IPv6 address in square brackets
		    )
		    (?: : (\d+) )?	# <port part of authority>
		)?
		( [/\?] [^\#]*)?	# <path> (including query)
		(?: \# (.*) )?		# <fragment>
		$
	    }

	    # Phase one: parse
	    if {![regexp -- $URLmatcher $url -> \
		    proto user host port srvurl fragment]} {
		return -code error "unsupported URL: $url"
	    }
	    # Phase two: validate
	    set host [string trim $host {[]}]; # strip square brackets from IPv6 address
	    if {$host eq ""} {
		# Caller has to provide a host name; we do not have a "default
		# host" that would enable us to handle relative URLs.
		return -code error "Missing host part: $url"
		# Note that we don't check the hostname for validity here; if
		# it's invalid, we'll simply fail to resolve it later on.
	    }
	    if {$port ne "" && $port > 65535} {
		return -code error "invalid port number: $port"
	    }
	    # The user identification and resource identification parts of the
	    # URL can have encoded characters in them; take care!
	    if {$user ne ""} {
		# Check for validity according to RFC 3986, Appendix A
		set validityRE {(?xi)
		    ^
		    (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
		    $
		}
		if {$config(-strict) && ![regexp -- $validityRE $user]} {
		    # Provide a better error message in this error case
		    if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
			return -code error \
			    "illegal encoding character usage \"$bad\" in URL user"
		    }
		    return -code error "illegal characters in URL user"
		}
	    }
	    if {$srvurl ne ""} {
		# RFC 3986 allows empty paths (not even a /), but servers
		# return 400 if the path in the HTTP request doesn't start
		# with / , so add it here if needed.
		if {[string index $srvurl 0] ne "/"} {
		    set srvurl /$srvurl
		}
		# Check for validity according to RFC 3986, Appendix A
		set validityRE {(?xi)
		    ^
		    # Path part (already must start with / character)
		    (?:	      [-\w.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
		    # Query part (optional, permits ? characters)
		    (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
		    $
		}
		if {$config(-strict) && ![regexp -- $validityRE $srvurl]} {
		    # Provide a better error message in this error case
		    if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
			return -code error \
			    "illegal encoding character usage \"$bad\" in URL path"
		    }
		    return -code error "illegal characters in URL path"
		}
	    }

	    return [list $proto $user $host $port $srvurl \
		    [string trimleft $fragment "#"]]
	}
    }

    oo::class create Connection {
	variable cfg urlTypes http
	variable binary state meta coding currentsize totalsize querylength
	variable queryoffset type body status httpline connection charset
	variable theURL

	constructor {context url defaults options} {
	    interp alias {} [namespace current]::Context {} $context
	    set ns [info object namespace $context]
	    my eval upvar 0 ${ns}::config http ${ns}::urlTypes urlTypes
	    foreach {opt value} $defaults {
		set cfg($opt) $value
	    }
	    set cfg(-keepalive) $http(-keepalive)
	    foreach {opt value} $options {
		set cfg($opt) $value
	    }

	    set queryoffset 0
	    set type text/html
	    set body {}
	    set status ""
	    set httpline ""
	    set connection close
	    set charset $http(-charset)

	    if {[info exists cfg(-querychannel)]&&[info exists cfg(-query)]} {
		return -code error \
		    "can't use -query and -querychannel options together"
	    }

	    lassign [Context parseURL $url] proto user host port srvurl
	    if {$srvurl eq ""} {
		set srvurl "/"
	    }
	    if {$proto eq ""} {
		set proto "http"
	    }
	    set lower [string tolower $proto]
	    if {![info exists urlTypes($lower)]} {
		return -code error "unsupported URL type \"$proto\""
	    }
	    lassign $urlTypes($lower) defport defcmd
	    if {$port eq ""} {
		set port $defport
	    }

	    # Check for the proxy's opinion
	    catch {
		if {[llength $http(-proxyfilter)]} {
		    lassign [{*}$http(-proxyfilter) $host] phost pport
		}
	    }

	    # OK, now reassemble into a full URL
	    set url ${proto}://
	    if {$user ne ""} {
		append url $user
		append url @
	    }
	    append url $host
	    if {$port != $defport} {
		append url : $port
	    }
	    append url $srvurl
	    # Don't append the fragment!
	    set theURL $url
	}

	destructor {
	}

	method reset {{why ""}} {
	}

	    }
	    return -code error \
		"bad value for $option ($value), must be $typedesc"
	}
    }

    proc Validate(callback) {option value} {
	if {![string is list $value]} {
	    return -code error \
		"bad value for $option ($value), must be command prefix"
	}
    }

    proc Validate(dict) {option value} {
	if {![string is list $value] || [llength $value] & 1} {
	    return -code error \
		"bad value for $opt ($value), must be dict"