Start of work on developing a new major version of the HTTP package.

1 files changed, 301 insertions, 0 deletions

diff --git a/library/http3/http.tcl b/library/http3/http.tcl
new file mode 100644
index 0000000..0b234a3
--- /dev/null
+++ b/library/http3/http.tcl
@@ -0,0 +1,301 @@
+package require Tcl 8.7-
+package provided http 3
+
+namespace eval ::http {
+    if {[info command ::http::Log] eq {}} {proc ::http::Log {args} {}}
+
+    variable ContextConfiguration {
+	-accept accept
+	-proxyfilter proxyfilter
+	-proxyhost proxyhost
+	-proxyport proxyport
+	-urlencoding urlencoding
+	-useragent useragent
+    }
+    variable ContextCfgType {
+	-accept {string {^[^\s/]+/+[^\s/+]$} "MIME type"}
+	-proxyfilter callback
+	-proxyhost string
+	-proxyport integer
+	-urlencoding encoding
+	-useragent string
+    }
+
+    variable ConnectionConfiguration {
+	-binary isBinary
+	-blocksize blocksize
+	-channel channel
+	-command cmdCallback
+	-handler handlerCallback
+	-headers headers
+	-keepalive keepalive
+	-method method
+	-myaddr myaddr
+	-progress progressCallback
+	-protocol protocol
+	-query queryData
+	-queryblocksize queryBlocksize
+	-querychannel queryChannel
+	-queryprogress queryCallback
+	-strict strict
+	-timeout timeout
+	-type mimetype
+	-validate validate
+    }
+    variable ConnectionCfgType {
+	-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
+	-strict boolean
+	-timeout integer
+	-type {string {^[^\s/]+/+[^\s/+]$} "MIME type"}
+	-validate boolean
+    }
+
+    oo::class create Context {
+	variable accept proxyhost proxyport proxyfilter urlencoding strict
+	variable useragent socketmap urltypes encodings charset keepalive 
+
+	constructor {} {
+	    set accept */*
+	    set proxyhost {}
+	    set proxyport {}
+	    set proxyfilter [namespace code {my ProxyRequired}]
+	    set urlencoding utf-8
+
+	    # 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 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 strict 1
+	}
+
+	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::ContextConfiguration
+	    variable ::http::ContextCfgType
+
+	    set options [dict keys $ContextConfiguration]
+	    set usage [join $options ", "]
+	    if {[llength $args] == 0} {
+		set result {}
+		dict for {option var} $ContextConfiguration {
+		    upvar 0 [my varname $var] v
+		    lappend result $option $v
+		}
+		return $result
+	    }
+	    if {[llength $args] == 1} {
+		set opt [::tcl::prefix match $options [lindex $args 0]]
+		upvar 0 [my varname [dict get $ContextConfiguration $opt]] v
+		return $v
+	    }
+	    foreach {option value} $args {
+		set opt [::tcl::prefix match $options $option]
+		upvar 0 [my varname [dict get $ContextConfiguration $opt]] v
+		set typeinfo [lassign [dict get $ContextCfgType $opt] type]
+		::http::Validate($type) $opt $value {*}$typeinfo
+		set v $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::ConnectionCfgType
+	    if {[llength $args] & 1} {
+		return -code error "missing configuration option"
+	    }
+	    set names [dict keys $ConnectionCfgType]
+	    set options [dict map {opt value} $args {
+		set opt [::tcl::prefix match $names $opt]
+		set typeinfo [lassign [dict get $ConnectionCfgType $opt] type]
+		::http::Validate($type) $opt $value {*}$typeinfo
+		set value
+	    }]
+	    ::http::Connection new [self] $url $options
+	}
+    }
+
+    oo::class create Connection {
+	constructor {config url options} {
+	    variable ::http::ConnectionConfiguration
+	}
+
+	destructor {
+	}
+
+	method reset {{why ""}} {
+	}
+
+	method wait {} {
+	}
+
+	method data {} {
+	}
+
+	method error {} {
+	}
+
+	method status {} {
+	}
+
+	method code {} {
+	}
+
+	method ncode {} {
+	}
+
+	method meta {} {
+	}
+    }
+
+    # ----------------------------------------------------------------------
+    # 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] || [llength $value] == 0} {
+	    return -code error \
+		"bad value for $option ($value), must be non-empty callback"
+	}
+    }
+
+    proc Validate(dict) {option value} {
+	if {![string is list $value] || [llength $value] & 1} {
+	    return -code error \
+		"bad value for $opt ($value), must be dict"
+	}
+    }
+}