Checkpoint of work in progress.

library/http3/http.tcl

@@ -0,0 +1,700 @@
+package require Tcl 8.7-
+package provided http 3
+
+namespace eval ::http {
+    if {[info command ::http::Log] eq {}} {proc ::http::Log {args} {}}
+
+    variable ContextConfig {
+	-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)"
+	    }
+	    set config(-useragent) "Mozilla/5.0 ($platform)\
+		    http/[package provide http] Tcl/[package provide Tcl]"
+
+	    # Create a map for HTTP/1.1 open sockets
+	    if {[info exists socketmap]} {
+		# Close but don't remove open sockets on re-init
+		foreach {url sock} [array get socketmap] {
+		    catch {close $sock}
+		}
+	    }
+	    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)
+	    } on error {} {
+		return {}
+	    } finally {
+		set urltypes($lower) [list $port $command]
+	    }
+	}
+
+	method unregister {proto} {
+	    set lower [string tolower $proto]
+	    if {![info exists urlTypes($lower)]} {
+		return -code error "unsupported url type \"$proto\""
+	    }
+	    try {
+		return $urlTypes($lower)
+	    } finally {
+		unset -nocomplain urlTypes($lower)
+	    }
+	}
+
+	method configure {args} {
+	    variable ::http::ContextConfig
+
+	    set options [dict keys $ContextConfig]
+	    if {[llength $args] == 0} {
+		set result {}
+		dict for {option typeinfo} $ContextConfig {
+		    lappend result $option $config($option)
+		}
+		return $result
+	    }
+	    if {[llength $args] == 1} {
+		set opt [::tcl::prefix match $options [lindex $args 0]]
+		return $config($opt)
+	    }
+	    foreach {option value} $args {
+		set opt [::tcl::prefix match $options $option]
+		set typeinfo [lassign [dict get $ContextConfig $opt] type]
+		::http::Validate($type) $opt $value {*}$typeinfo
+		set config($opt) $value
+	    }
+	}
+
+	method formatQuery args {
+	    set result ""
+	    set sep ""
+	    foreach i $args {
+		append result $sep [my mapReply $i]
+		if {$sep eq "="} {
+		    set sep &
+		} else {
+		    set sep =
+		}
+	    }
+	    return $result
+	}
+
+	method mapReply {string} {
+	    # The spec says: "non-alphanumeric characters are replaced by
+	    # '%HH'". [Bug 1020491] [regsub -command] is *designed* for this.
+
+	    if {$urlencoding ne ""} {
+		set string [encoding convertto $urlencoding $string]
+	    }
+
+	    set RE "(\r?\n)|(\[^._~a-zA-Z0-9\])"
+	    return [regsub -all -command -- $RE $string {apply {{- nl ch} {
+		# RFC3986 Section 2.3 say percent encode all except:
+		# "... percent-encoded octets in the ranges of ALPHA (%41-%5A
+		# and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period (%2E),
+		# underscore (%5F), or tilde (%7E) should not be created by
+		# URI producers ..."
+		#
+		# Note that newline is a special case
+		if {$nl ne ""} {return %0D%0A}
+		scan $ch %c c
+		return [format %%%.2X $c]
+	    }}}]
+	}
+
+	method geturl {url args} {
+	    variable ::http::ConnectionConfig
+	    variable ::http::ConnectionDefaults
+	    if {[llength $args] & 1} {
+		return -code error "missing configuration option"
+	    }
+	    set names [dict keys $ConnectionConfig]
+	    set options [dict map {opt value} $args {
+		set opt [::tcl::prefix match $names $opt]
+		set typeinfo [lassign [dict get $ConnectionConfig $opt] type]
+		::http::Validate($type) $opt $value {*}$typeinfo
+		set value
+	    }]
+	    $connectionclass create [incr counter] \
+		[self] $url $ConnectionDefaults $options
+	}
+
+	method ProxyRequred {host} {
+	    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:xyzzy@www.bogus.net: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 after socketinfo sock acceptTypes
+
+	constructor {context url defaults options} {
+	    interp alias {} [namespace current]::Context {} $context
+	    set ns [info object namespace $context]
+	    my eval namespace upvar $ns \
+		config http urlTypes urlTypes socketmap socketmap
+	    foreach {opt value} $defaults {
+		set cfg($opt) $value
+	    }
+	    set cfg(-keepalive) $http(-keepalive)
+	    foreach {opt value} $options {
+		set cfg($opt) $value
+	    }
+
+	    my reset
+
+	    set binary 0
+	    set state connecting
+	    set meta {}
+	    set coding {}
+	    set currentsize 0
+	    set totalsize 0
+	    set querylength 0
+	    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
+
+	    # If a timeout is specified we set up the after event and arrange
+	    # for an asynchronous socket connection.
+
+	    set sockopts [list -async]
+	    if {$cfg(-timeout) > 0} {
+		set after [after $cfg(-timeout) [namespace code {
+		    my reset timeout
+		}]]
+	    }
+
+	    # If we are using the proxy, we must pass in the full URL that
+	    # includes the server name.
+
+	    if {[info exists phost] && ($phost ne "")} {
+		set srvurl $url
+		set targetAddr [list $phost $pport]
+	    } else {
+		set targetAddr [list $host $port]
+	    }
+	    # Proxy connections aren't shared among different hosts.
+	    set socketinfo $host:$port
+
+	    # Save the accept types at this point to prevent a race condition.
+	    # [Bug c11a51c482]
+	    set acceptTypes $http(-accept)
+
+	    # See if we are supposed to use a previously opened channel.
+	    if {$cfg(-keepalive)} {
+		if {[info exists socketmap($socketinfo)]} {
+		    if {[catch {fconfigure $socketmap($socketinfo)}]} {
+			Log "WARNING: socket for $socketinfo was closed"
+			unset socketmap($socketinfo)
+		    } else {
+			set sock $socketmap($socketinfo)
+			Log "reusing socket $sock for $socketinfo"
+			catch {fileevent $sock writable {}}
+			catch {fileevent $sock readable {}}
+		    }
+		}
+		# don't automatically close this connection socket
+		set connection {}
+	    }
+	    if {![info exists sock]} {
+		# Pass -myaddr directly to the socket command
+		if {[info exists cfg(-myaddr)]} {
+		    lappend sockopts -myaddr $cfg(-myaddr)
+		}
+		try {
+		    set sock [{*}$defcmd {*}$sockopts {*}$targetAddr]
+		} on error {msg} {
+		    # 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.
+		    my Finish "" 1
+		    return -code error $msg
+		}
+	    }
+	    Log "Using $sock for $socketinfo" \
+		[expr {$cfg(-keepalive) ? "keepalive" : ""}]
+	    if {$cfg(-keepalive)} {
+		set socketmap($socketinfo) $sock
+	    }
+
+	    if {![info exists phost]} {
+		set phost ""
+	    }
+	    fileevent $sock writable [namespace code [list \
+		my Connect $proto $phost $srvurl]]
+
+	    # Wait for the connection to complete.
+	    if {![info exists cfg(-command)]} {
+		# geturl does EVERYTHING asynchronously, so if the user calls
+		# it synchronously, we just do a wait here.
+		my wait
+
+		if {![info exists status]} {
+		    # If we timed out then Finish has been called and the
+		    # users command callback may have cleaned up the token. If
+		    # so we end up here with nothing left to do.
+		    return
+		} elseif {$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.
+		    return -code error [lindex $error 0]
+		}
+	    }
+	}
+
+	method Connect {proto phost srvurl} {
+	    
+	}
+
+	destructor {
+	}
+
+	method reset {{why ""}} {
+	}
+
+	method wait {} {
+	    if {![info exists status] || $status eq ""} {
+		# We must wait on the true variable name, not the local
+		# unqualified version.
+		vwait [my varname status]
+	    }
+
+	    return [my status]
+	}
+
+	method data {} {
+	    return $body
+	}
+
+	method error {} {
+	    if {[info exists error]} {
+		return $error
+	    }
+	    return ""
+	}
+
+	method status {} {
+	    if {![info exists status]} {
+		return "error"
+	    }
+	    return $status
+	}
+
+	method code {} {
+	    return $httpline
+	}
+
+	method ncode {} {
+	    set thecode [my code]
+	    if {[regexp {[0-9]{3}} $thecode numeric_code]} {
+		return $numeric_code
+	    } else {
+		return $thecode
+	    }
+	}
+
+	method size {} {
+	    return $currentsize
+	}
+
+	method meta {} {
+	    return $meta
+	}
+
+	# Return the list of content-encoding transformations we need to do in
+	# order.
+	method ContentEncoding {} {
+	    set r {}
+	    if {[info exists coding]} {
+		foreach c [split $coding ,] {
+		    switch -exact -- $c {
+			deflate { lappend r inflate }
+			gzip - x-gzip { lappend r gunzip }
+			compress - x-compress { lappend r decompress }
+			identity {}
+			default {
+			    return -code error \
+				"unsupported content-encoding \"$c\""
+			}
+		    }
+		}
+	    }
+	    return $r
+	}
+    }
+
+    # ----------------------------------------------------------------------
+    # General type validators
+
+    proc Validate(boolean) {option value} {
+	if {![string is boolean -strict $value]} {
+	    return -code error \
+		"bad value for $option ($value), must be boolean"
+	}
+    }
+
+    proc Validate(integer) {option value} {
+	if {![string is integer -strict $value] || $value < 0} {
+	    return -code error \
+		"bad value for $option ($value), must be non-negative integer"
+	}
+    }
+
+    proc Validate(channel) {option value} {
+	if {$value ni [channel names]} {
+	    return -code error \
+		"bad value for $option ($value), must be open channel"
+	}
+    }
+
+    proc Validate(encoding) {option value} {
+	if {$value ni [encoding names]} {
+	    return -code error \
+		"bad value for $option ($value), must be encoding"
+	}
+    }
+
+    proc Validate(string) {option value {regexp ""} {typedesc ""}} {
+	if {$regexp ne "" && ![regexp -- $regexp $value]} {
+	    if {$typedesc eq ""} {
+		set typedesc "match for $regexp"
+	    }
+	    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"
+	}
+    }
+
+    proc Validate(class) {option value} {
+	if {![info object isa class $value]} {
+	    return -code error \
+		"bad value for $opt ($value), must be class"
+	}
+    }
+
+    # http::CharsetToEncoding --
+    #
+    #	Tries to map a given IANA charset to a tcl encoding.  If no encoding
+    #	can be found, returns binary.
+    #
+
+    proc CharsetToEncoding {charset} {
+	variable encodings
+
+	set charset [string tolower $charset]
+	if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} {
+	    set encoding "iso8859-$num"
+	} elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} {
+	    set encoding "iso2022-$ext"
+	} elseif {[regexp {shift[-_]?js} $charset]} {
+	    set encoding "shiftjis"
+	} elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} {
+	    set encoding "cp$num"
+	} elseif {$charset eq "us-ascii"} {
+	    set encoding "ascii"
+	} elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} {
+	    switch -- $num {
+		5 {set encoding "iso8859-9"}
+		1 - 2 - 3 {
+		    set encoding "iso8859-$num"
+		}
+	    }
+	} else {
+	    # other charset, like euc-xx, utf-8,... may directly map to
+	    # encoding
+	    set encoding $charset
+	}
+	set idx [lsearch -exact $encodings $encoding]
+	if {$idx >= 0} {
+	    return $encoding
+	} else {
+	    return "binary"
+	}
+    }
+}
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: t
+# End: