diff options
| -rw-r--r-- | library/http3/http.tcl | 301 |
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" + } + } +} |