You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2048 lines
56 KiB
2048 lines
56 KiB
# Package implementing the HTTP protocol. The http package shipping with Tcl |
|
# is too cumbersome and has too many issues to be used effectively. |
|
|
|
# Test sites: |
|
# http://jigsaw.w3.org/HTTP/ |
|
# http://httpbin.org/ |
|
|
|
package require platform |
|
package require Thread |
|
package require sqlite3 |
|
|
|
if {$tcl_platform(platform) ne "windows"} { |
|
# Need the fix for bug f583715154 |
|
package require Tcl 8.6.11- |
|
} |
|
|
|
proc ::oo::Helpers::callback {method args} { |
|
list [uplevel 1 {::namespace which my}] $method {*}$args |
|
} |
|
|
|
namespace eval www { |
|
variable schemes { |
|
http {port 80 command {} secure 0} |
|
https {port 443 command www::encrypt secure 1} |
|
} |
|
variable encodings { |
|
gzip {decode gzip} |
|
deflate {decode deflate} |
|
} |
|
variable config { |
|
-proxy defaultproxy |
|
-pipeline 0 |
|
-urlencoding utf-8 |
|
-socketcmd socket |
|
} |
|
variable headers { |
|
Accept {*/*} |
|
Accept-Encoding {identity} |
|
} |
|
dict set headers User-Agent [format {Tcl-www/%s (%s)} \ |
|
[package present www] [platform::generic]] |
|
|
|
variable formmap [apply [list {} { |
|
set map {} |
|
for {set i 0} {$i <= 256} {incr i} { |
|
set c [format %c $i] |
|
if {![string match {[-._~a-zA-Z0-9]} $c]} { |
|
dict set map $c %[format %.2X $i] |
|
} |
|
} |
|
return $map |
|
}]] |
|
variable tlscfg {} |
|
variable defaultproxy {} |
|
variable logpfx list |
|
variable timer {} |
|
variable persist 300000 |
|
variable maxconn 256 |
|
|
|
# Track the persistent connections using an in-memory sqlite db |
|
sqlite3 [namespace current]::db :memory: |
|
db eval { |
|
create table reuse ( |
|
connection text primary key, |
|
scheme text, |
|
host text, |
|
port text, |
|
persistent boolean default 1 |
|
); |
|
} |
|
|
|
namespace ensemble create -subcommands { |
|
get post head put delete log configure register certify cookiedb |
|
header urlencode cookies |
|
} -map { |
|
log logpfx |
|
cookiedb cookies::dbfile |
|
} |
|
|
|
namespace ensemble create -command cert -parameters pass -map { |
|
error errcmd info nop verify vfycmd message nop session nop |
|
} -unknown [namespace code unknown] |
|
|
|
namespace ensemble create -command stdcert -parameters pass -map { |
|
error errcmd info nop verify stdvfy message nop session nop |
|
} -unknown [namespace code unknown] |
|
|
|
namespace ensemble create -command nocert -parameters pass -map { |
|
error errcmd info nop verify novfy message nop session nop |
|
} -unknown [namespace code unknown] |
|
|
|
dict set tlscfg -command [list [namespace which nocert] 1] |
|
dict set tlscfg -validatecommand [list [namespace which nocert] 1] |
|
} |
|
|
|
proc www::log {str} { |
|
variable logpfx |
|
if {[catch {uplevel #0 [list {*}$logpfx $str]}]} {logpfx ""} |
|
} |
|
|
|
proc www::logpfx {prefix} { |
|
variable logpfx $prefix |
|
if {$prefix eq ""} {set logpfx list} |
|
} |
|
|
|
# Load the TLS package on the first use of a secure url. |
|
proc www::encrypt {sock host} { |
|
variable tlscfg |
|
package require tls |
|
if {[namespace which ::tls::validate_command] eq ""} { |
|
# Old version of tls uses only -command |
|
dict unset tlscfg -validatecommand |
|
} |
|
proc encrypt {sock host} { |
|
variable tlscfg |
|
::tls::import $sock -servername $host {*}$tlscfg |
|
} |
|
tailcall encrypt $sock $host |
|
} |
|
|
|
# Execute a script when a variable is accessed |
|
proc www::varevent {name ops {script ""}} { |
|
set cmd {{cmd var arg op} {catch {uplevel #0 $cmd}}} |
|
foreach n [uplevel 1 [list trace info variable $name]] { |
|
lassign $n op prefix |
|
if {$op eq $ops && \ |
|
[lindex $prefix 0] eq "apply" && [lindex $prefix 1] eq $cmd} { |
|
if {[llength [info level 0]] < 4} { |
|
return [lindex $prefix 2] |
|
} |
|
uplevel 1 [list trace remove variable $name $ops $prefix] |
|
} |
|
} |
|
if {$script ne ""} { |
|
uplevel 1 \ |
|
[list trace add variable $name $ops [list apply $cmd $script]] |
|
} |
|
return |
|
} |
|
|
|
oo::class create www::connection { |
|
constructor {host port {transform ""}} { |
|
namespace path [linsert [namespace path] 0 ::www] |
|
variable fd "" timeout 30000 id "" |
|
variable translation {crlf crlf} |
|
variable waiting {} pending {} |
|
# Copy the arguments to namespace variables with the same name |
|
namespace eval [namespace current] \ |
|
[list variable host $host port $port transform $transform] |
|
} |
|
|
|
destructor { |
|
my Disconnect |
|
} |
|
|
|
method Disconnect {} { |
|
my variable fd id |
|
after cancel $id |
|
if {$fd ne ""} { |
|
rename ::www::$fd "" |
|
if {[catch {close $fd} err]} {log "Disconnect: $err"} |
|
set fd "" |
|
} |
|
} |
|
|
|
method Failed {code info {index 0}} { |
|
my variable pending |
|
my Disconnect |
|
set callback [dict get [lindex $pending $index] Request callback] |
|
set opts [dict create -code 1 -level 1 -errorcode $code] |
|
# Clean up the pending request before invoking the callback in case |
|
# the coroutine generates another request for the same connection |
|
set pending [lreplace $pending $index $index] |
|
$callback -options $opts $info |
|
} |
|
|
|
method Failure {args} { |
|
if {[llength $args] == 1} { |
|
set opts [lindex $args] |
|
} else { |
|
set opts [dict create -code 1 -level 1] |
|
lassign $args errorcode result |
|
dict set opts -errorcode $errorcode |
|
} |
|
my variable waiting pending |
|
foreach n [concat $pending $waiting] { |
|
# Inform the caller of the failure |
|
if {[catch {uplevel #0 [linsert [dict get $n callback] end $opts]} err opts]} { |
|
log "Failure: $err" |
|
} |
|
} |
|
my destroy |
|
} |
|
|
|
method Pending {} { |
|
my variable pending |
|
set num 0 |
|
foreach transaction $pending { |
|
if {[dict get $transaction Attempt] > 5} { |
|
my Failed {WWW MAXATTEMPTS} {too many attempts} $num |
|
} else { |
|
incr num |
|
} |
|
} |
|
return [expr {$num > 0}] |
|
} |
|
|
|
method Process {} { |
|
my variable fd waiting pending |
|
if {[llength $waiting] == 0} return |
|
set count [llength $pending] |
|
if {$count && [dict get [lindex $waiting 0] pipeline] == 0} return |
|
if {$count && $fd eq ""} return |
|
# Start processing the next request |
|
set request [my PushRequest] |
|
if {$fd eq ""} { |
|
my Connect |
|
} else { |
|
my Request $count |
|
} |
|
} |
|
|
|
# Connect the socket in another thread to be totally non-blocking |
|
method Connect {} { |
|
my Disconnect |
|
if {![my Pending]} return |
|
coroutine connect my Initiate |
|
} |
|
|
|
method Initiate {} { |
|
if {[my Contact]} { |
|
if {[catch {my Request} err opts]} { |
|
log "Request: $err" |
|
log [dict get $opts -errorinfo] |
|
} |
|
} |
|
} |
|
|
|
method Timeout {} { |
|
my variable pending timeout |
|
if {[dict exists [lindex $pending 0] Request timeout]} { |
|
return [dict get [lindex $pending 0] Request timeout] |
|
} else { |
|
return $timeout |
|
} |
|
} |
|
|
|
method UserVar {data} { |
|
if {[dict exists $data Request result]} { |
|
upvar #0 [dict get $data Request result] var |
|
set var [dict filter $data key {[a-z]*}] |
|
} |
|
} |
|
|
|
method Contact {} { |
|
my variable fd host port connect transform |
|
|
|
# Build a command to open a socket in a separate thread |
|
set cmd [list {cmd} { |
|
global fd result |
|
if {![catch $cmd fd opts]} { |
|
fileevent $fd writable {set result socket} |
|
vwait result |
|
fileevent $fd writable {} |
|
if {[fconfigure $fd -connecting]} { |
|
close $fd |
|
set msg {connection timed out} |
|
set fd "couldn't open socket: $msg" |
|
dict set opts -code 1 |
|
dict set opts -errorcode [list POSIX ETIMEDOUT $msg] |
|
} else { |
|
set error [fconfigure $fd -error] |
|
if {$error eq ""} { |
|
thread::detach $fd |
|
} else { |
|
close $fd |
|
set fd "couldn't open socket: $error" |
|
dict set opts -code 1 |
|
switch $error { |
|
{connection refused} { |
|
dict set opts \ |
|
-errorcode [list POSIX ECONNREFUSED $error] |
|
} |
|
{host is unreachable} { |
|
dict set opts \ |
|
-errorcode [list POSIX EHOSTUNREACH $error] |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return [list $fd $opts] |
|
}] |
|
|
|
set socketcmd [linsert [cget -socketcmd] end -async $host $port] |
|
set script [list apply $cmd $socketcmd] |
|
# Open a plain socket in a helper thread |
|
set tid [thread::create] |
|
set ms [my Timeout] |
|
set id [after $ms [list thread::send -async $tid {set result timeout}]] |
|
set var [namespace which -variable connect] |
|
thread::send -async $tid $script $var |
|
trace add variable $var write [list [info coroutine]] |
|
yieldto list |
|
trace remove variable $var write [list [info coroutine]] |
|
after cancel $id |
|
lassign $connect result opts |
|
thread::release $tid |
|
# Check the socket was opened successfully |
|
if {[dict get $opts -code] == 0} { |
|
set fd $result |
|
coroutine ::www::$fd my Monitor |
|
thread::attach $fd |
|
fconfigure $fd -blocking 0 |
|
# Apply any transformations, such as importing TLS |
|
if {$transform ne ""} { |
|
try { |
|
{*}$transform $fd $host |
|
} trap WWW {result opts} { |
|
# Immediately return WWW errors, without retrying |
|
my Failed [dict get $opts -errorcode] $result |
|
} on error {err opts} { |
|
log "Transform: $err" |
|
} |
|
} |
|
return 1 |
|
} else { |
|
my Failed [list WWW CONNECT $result] $result |
|
} |
|
return 0 |
|
} |
|
|
|
method Monitor {} { |
|
set result [yield] |
|
my Failed [list WWW CONNECT $result] $result |
|
} |
|
|
|
method Request {{num 0}} { |
|
my variable fd pending id |
|
if {[eof $fd]} { |
|
my Connect |
|
} |
|
|
|
my Result connection [self] |
|
set transaction [lindex $pending $num] |
|
dict incr transaction Attempt |
|
lset pending $num $transaction |
|
# Do not report the failure at this point because the callback may |
|
# create a new request that would mess up the order of the messages |
|
if {[dict get $transaction Attempt] > 5} {tailcall my Pending} |
|
try { |
|
my Transmit [dict get $transaction Request] |
|
} trap {POSIX EPIPE} {} { |
|
# Force eof condition |
|
read $fd |
|
tailcall my Connect |
|
} |
|
# Now report any problems to the callers |
|
my Pending |
|
|
|
if {$num == 0} {my Response} |
|
tailcall my Process |
|
} |
|
|
|
method Transmit {request} { |
|
my variable fd |
|
fconfigure $fd -translation [set translation {crlf crlf}] |
|
set method [dict get $request method] |
|
set resource [dict get $request resource] |
|
set head [list "$method $resource HTTP/1.1"] |
|
lappend head "Host: [dict get $request host]" |
|
if {[dict exists $request upgrade]} { |
|
dict update request headers hdrs upgrade upgrade { |
|
header add hdrs Connection Upgrade |
|
header add hdrs Upgrade {*}[dict keys $upgrade] |
|
} |
|
} |
|
foreach {key val} [dict get $request headers] { |
|
lappend head "$key: $val" |
|
} |
|
lappend head "" |
|
set str [join $head \n] |
|
log $str |
|
puts $fd $str |
|
if {[dict exists $request body]} { |
|
fconfigure $fd -translation [lset translation 1 binary] |
|
puts -nonewline $fd [dict get $request body] |
|
} |
|
flush $fd |
|
} |
|
|
|
method Result {args} { |
|
my variable pending |
|
set response [lindex $pending 0] |
|
if {[llength $args] > 1} { |
|
lset pending 0 [dict set response {*}$args] |
|
my UserVar $response |
|
} elseif {[llength $args] == 0} { |
|
return $response |
|
} elseif {[dict exists $response {*}$args]} { |
|
return [dict get $response {*}$args] |
|
} |
|
return |
|
} |
|
|
|
method Response {} { |
|
my variable fd translation id |
|
set ms [my Timeout] |
|
set id [after $ms [callback Timedout]] |
|
fconfigure $fd -translation [lset translation 0 crlf] |
|
# When the tls handshake fails, the readable event doesn't always |
|
# fire. Adding a writable event as well improves reliability. |
|
fileevent $fd readable [callback Statusline] |
|
fileevent $fd writable [callback Statusline] |
|
} |
|
|
|
method Statusline {} { |
|
my variable fd |
|
try { |
|
fileevent $fd writable {} |
|
if {[eof $fd]} { |
|
my Connect |
|
} elseif {[gets $fd line] >= 0} { |
|
log $line |
|
if {[scan $line {HTTP/%s %d %n} version code pos] != 3} { |
|
my Failed [list WWW DATA STATUS] "invalid status line" |
|
} |
|
set reason [string range $line $pos end] |
|
my Result status [dict create line $line \ |
|
version HTTP/$version code $code reason $reason] |
|
fileevent $fd readable [callback Responsehead] |
|
} elseif {[chan pending input $fd] > 1024} { |
|
# A status line shouldn't be this long. |
|
my Failed [list WWW DATA STATUS] "status line too long" |
|
} |
|
} trap {POSIX ECONNABORTED} {msg opts} { |
|
# This happens if there is a problem with the certificate |
|
my Failed [dict get $opts -errorcode] $msg |
|
} |
|
} |
|
|
|
method Responsehead {} { |
|
my variable fd |
|
if {[eof $fd]} { |
|
tailcall my Connect |
|
} |
|
set head [my Result Head] |
|
while {[gets $fd line] >= 0} { |
|
if {$line eq ""} { |
|
set headers [my Headers $head] |
|
my Result Head {} |
|
my Result headers $headers |
|
tailcall my Responsebody $headers |
|
} |
|
lappend head $line |
|
} |
|
my Result Head $head |
|
} |
|
|
|
method Headers {head} { |
|
# Unfold headers |
|
foreach x [lreverse [lsearch -all -regexp $head {^\s}]] { |
|
set str [string trimright [lindex $head [expr {$x - 1}]]] |
|
append str " " [string trimleft [lindex $head $x]] |
|
set head [lreplace $head [expr {$x - 1}] $x $str] |
|
} |
|
log [join $head \n]\n |
|
# Parse headers into a list |
|
set rc {} |
|
foreach str $head { |
|
lassign [slice $str] name value |
|
lappend rc [string tolower $name] $value |
|
} |
|
return $rc |
|
} |
|
|
|
method Responsebody {headers} { |
|
my variable fd translation |
|
set code [dict get [my Result status] code] |
|
variable size 0 length 0 |
|
if {[dict get [my Result Request] method] eq "HEAD"} { |
|
# All responses to the HEAD request method MUST NOT include |
|
# a message-body, even though the presence of entity-header |
|
# fields might lead one to believe they do |
|
tailcall my Finished |
|
} elseif {$code eq "101" && [header exists $headers upgrade]} { |
|
tailcall my Upgrade $headers |
|
} elseif {[string match 1?? $code] || $code in {204 304}} { |
|
# All 1xx (informational), 204 (no content), and 304 (not |
|
# modified) responses MUST NOT include a message-body |
|
tailcall my Finished |
|
} |
|
set enc [header get $headers content-encoding all -lowercase] |
|
set transfer [header get $headers transfer-encoding all -lowercase] |
|
foreach n $transfer {if {$n ni {chunked identity}} {lappend enc $n}} |
|
if {[llength $transfer] == 0} {set transfer [list identity]} |
|
my Result Encoding [lmap name [lreverse $enc] { |
|
set coro encodingcoro_$name |
|
coroutine $coro {*}[encodingcmd $name] |
|
set coro |
|
}] |
|
if {"identity" ni $transfer} { |
|
fileevent $fd readable [callback Responsechunks] |
|
} elseif {[header exists $headers content-length]} { |
|
set length [header get $headers content-length last] |
|
if {$length} { |
|
fconfigure $fd -translation [lset translation 0 binary] |
|
fileevent $fd readable [callback Responsecontent] |
|
} else { |
|
my Finished |
|
} |
|
} elseif {[header get $headers content-type last] \ |
|
eq "multipart/byteranges"} { |
|
# Not currently implemented |
|
my Failure |
|
} else { |
|
# Read data until the connection is closed |
|
fconfigure $fd -translation [lset translation 0 binary] |
|
fileevent $fd readable [callback Responserest] |
|
} |
|
} |
|
|
|
method Responsecontent {} { |
|
my variable fd size length |
|
if {[eof $fd]} { |
|
tailcall my Connect |
|
} |
|
set data [read $fd [expr {$length - $size}]] |
|
if {$data ne ""} { |
|
incr size [string length $data] |
|
my Progress $data |
|
log "Received $size/$length" |
|
if {$size >= $length} { |
|
my Finished |
|
} |
|
} |
|
} |
|
|
|
method Responsechunks {} { |
|
my variable fd translation size length |
|
if {[eof $fd]} { |
|
tailcall my Finished |
|
} |
|
if {$length == 0} { |
|
if {[gets $fd line] <= 0} return |
|
lassign [slice $line {;}] hex ext |
|
scan $hex %x length |
|
if {$length == 0} { |
|
fileevent $fd readable [callback Responsetrailer] |
|
return |
|
} |
|
set size 0 |
|
fconfigure $fd -translation [lset translation 0 binary] |
|
} |
|
set data [read $fd [expr {$length - $size}]] |
|
if {$data ne ""} { |
|
incr size [string length $data] |
|
# log "$size/$length" |
|
my Progress $data |
|
if {$size >= $length} { |
|
fconfigure $fd -translation [lset translation 0 crlf] |
|
set length 0 |
|
} |
|
} |
|
} |
|
|
|
method Responsetrailer {} { |
|
my variable fd |
|
set tail [my Result Tail] |
|
if {[eof $fd]} { |
|
set done 1 |
|
} else { |
|
set done 0 |
|
while {[gets $fd line] >= 0} { |
|
if {$line eq ""} { |
|
set done 1 |
|
break |
|
} |
|
lappend tail $line |
|
} |
|
} |
|
if {$done} { |
|
if {$tail ne ""} { |
|
my Result Tail {} |
|
set headers [my Result headers] |
|
my Result headers [dict merge $headers [my Headers $tail]] |
|
} |
|
tailcall my Finished |
|
} else { |
|
my Result Tail $tail |
|
} |
|
} |
|
|
|
method Responserest {} { |
|
my variable fd |
|
if {[eof $fd]} { |
|
tailcall my Finished |
|
} |
|
my Progress [read $fd] |
|
} |
|
|
|
method Responseidle {} { |
|
my variable fd |
|
read $fd |
|
if {[eof $fd]} { |
|
my destroy |
|
} |
|
} |
|
|
|
method Progress {{data ""}} { |
|
set finish [expr {$data eq ""}] |
|
foreach n [my Result Encoding] { |
|
if {$data ne ""} {set data [$n $data]} |
|
if {$finish} {append data [$n]} |
|
} |
|
if {$data eq ""} return |
|
|
|
set request [my Result Request] |
|
set handler \ |
|
[if {[dict exists $request handler]} {dict get $request handler}] |
|
|
|
if {$handler eq ""} { |
|
set body [my Result Body] |
|
my Result Body [append body $data] |
|
} else { |
|
uplevel #0 [linsert $handler end $data] |
|
} |
|
} |
|
|
|
method PushRequest {} { |
|
# Move the next request from the waiting queue to the pending queue |
|
my variable waiting pending |
|
set waiting [lassign $waiting request] |
|
set transaction [dict create Request $request Attempt 0] |
|
# Provide some information back to the caller |
|
dict set transaction url [dict get $request url] |
|
dict set transaction uri [dict get $request resource] |
|
lappend pending $transaction |
|
return $request |
|
} |
|
|
|
method PopRequest {} { |
|
my variable pending |
|
set pending [lassign $pending result] |
|
return $result |
|
} |
|
|
|
method Finished {} { |
|
my variable fd id pending waiting |
|
# Process any leftover data and end the coroutines |
|
my Progress |
|
set result [my PopRequest] |
|
if {[scan [dict get $result status version] HTTP/%s version] != 1} { |
|
tailcall my Failure \ |
|
"invalid HTTP version: [dict get $result status version]" |
|
} |
|
set connection \ |
|
[header get [dict get $result headers] connection all -lowercase] |
|
after cancel $id |
|
if {[llength $pending]} { |
|
my Response |
|
} else { |
|
fileevent $fd readable [callback Responseidle] |
|
} |
|
if {![package vsatisfies $version 1.1] || "close" in $connection} { |
|
my Disconnect |
|
my Return $result |
|
if {[llength $pending] == 0 && [llength $waiting] == 0} { |
|
# Nothing left to do. Destroy the object, if it still exists. |
|
if {[self] ne ""} {my destroy} |
|
return |
|
} |
|
} else { |
|
keep [self] |
|
my Return $result |
|
} |
|
# The callback may have destroyed the object |
|
if {[self] ne ""} {my Process} |
|
} |
|
|
|
method Return {result} { |
|
set callback [dict get $result Request callback] |
|
set data [if {[dict exists $result Body]} {dict get $result Body}] |
|
dict unset result connection |
|
my UserVar $result |
|
# Just like in TclOO, public names start with a lowercase letter |
|
$callback -options [dict filter $result key {[a-z]*}] $data |
|
} |
|
|
|
method Upgrade {headers} { |
|
my variable fd id |
|
set upgrade [header get $headers upgrade] |
|
# Unfortunately (some) upgrade protocol names are not case sensitive |
|
try { |
|
dict for {name mixin} [dict get [my Result Request] upgrade] { |
|
if {![string equal -nocase $name $upgrade]} continue |
|
after cancel $id |
|
oo::objdefine [self] mixin $mixin |
|
my Startup $headers |
|
return |
|
} |
|
my Failed {WWW UPGRADE} "protocol not supported: $upgrade" |
|
} on error {msg info} { |
|
log [dict get $info -errorinfo] |
|
} |
|
} |
|
|
|
method Timedout {} { |
|
my Failed {WWW DATA TIMEOUT} "timeout waiting for a response" |
|
} |
|
|
|
method request {data} { |
|
my variable waiting |
|
dict set data callback [info coroutine] |
|
lappend waiting $data |
|
return {*}[yieldto my Process] |
|
} |
|
|
|
method fd {} { |
|
my variable fd |
|
return $fd |
|
} |
|
|
|
method disconnect {} { |
|
my Finished |
|
} |
|
} |
|
|
|
# Use a derived class to simplify setting up an HTTP tunnel to a proxy server |
|
oo::class create www::proxyconnect { |
|
superclass www::connection |
|
|
|
constructor {fh} { |
|
namespace path [linsert [namespace path] 0 ::www] |
|
variable fd $fh timeout 30000 id "" |
|
variable translation {crlf crlf} |
|
variable waiting {} pending {} |
|
} |
|
|
|
destructor { |
|
# Obscure the connection destructor, which would disconnect the socket |
|
} |
|
|
|
method connect {resource} { |
|
set request {headers {}} |
|
dict set request method CONNECT |
|
dict set request resource $resource |
|
dict set request host $resource |
|
dict set request url $resource |
|
dict set request path $resource |
|
try { |
|
my request $request |
|
} on ok {data opts} { |
|
set code [dict get $opts status code] |
|
if {![string match 2?? $code]} { |
|
set codegrp [string replace $code 1 2 XX] |
|
set reason [dict get $opts status reason] |
|
dict set opts -code 1 |
|
dict set opts -errorcode [list WWW CODE $codegrp $code $reason] |
|
} |
|
return -options [dict incr opts -level] $data |
|
} |
|
} |
|
|
|
method Responsebody {headers} { |
|
set code [dict get [my Result status] code] |
|
if {[string match 2?? $code]} { |
|
# A "200 Connection established" response doesn't have a body |
|
tailcall my Finished |
|
} else { |
|
# All other responses are treated normally, but will finally fail |
|
next $headers |
|
} |
|
} |
|
} |
|
|
|
namespace eval www::cookies { |
|
variable cookiejar "" |
|
namespace path [namespace parent] |
|
namespace ensemble create -subcommands {delete get store} |
|
} |
|
|
|
proc www::cookies::dbfile {filename} { |
|
variable cookiejar $filename |
|
} |
|
|
|
proc www::cookies::db {args} { |
|
variable cookiejar |
|
sqlite3 [namespace current]::db $cookiejar |
|
set create { |
|
create table if not exists %s.cookies ( |
|
domain text, |
|
path text, |
|
name text, |
|
value text, |
|
created int, |
|
accessed int, |
|
expires int not null default 4294967295, |
|
attributes text, |
|
primary key (domain, path, name) |
|
); |
|
} |
|
db transaction { |
|
db eval [format $create main] |
|
# Add a temporary database to hold the session cookies |
|
db eval {attach database "" as sess} |
|
db eval [format $create sess] |
|
# Create a view combining the two tables to simplify access |
|
# This must be a temporary view to allow combining two databases |
|
db eval { |
|
create temp view cookieview as \ |
|
select domain, path, name, value, \ |
|
created, accessed, expires, attributes \ |
|
from main.cookies \ |
|
union all \ |
|
select domain, path, name, value, \ |
|
created, accessed, expires, attributes \ |
|
from sess.cookies |
|
} |
|
# Clean up expired cookies |
|
set now [clock seconds] |
|
db eval {delete from cookies where expires < $now} |
|
} |
|
tailcall db {*}$args |
|
} |
|
|
|
proc www::cookies::date {str} { |
|
# Implement most of the weird date and time parsing rules of RFC 6265 |
|
# https://tools.ietf.org/html/rfc6265#section-5.1.1 |
|
set time {} |
|
foreach token [regexp -all -inline -nocase {[0-9A-Z:]+} $str] { |
|
switch -nocase -regexp -matchvar match $token { |
|
{^\d\d?:\d\d?:\d\d?} { |
|
if {![dict exists $time %T]} { |
|
dict set time %T $match |
|
} |
|
} |
|
{^\d{5}} {} |
|
{^\d{4}} { |
|
if {![dict exists $time %Y]} { |
|
dict set time %Y $match |
|
} |
|
} |
|
{^\d{3}} {} |
|
{^\d{2}} { |
|
if {![dict exists $time %d]} { |
|
dict set time %d $match |
|
} elseif {![dict exists $time %Y]} { |
|
incr match [expr {$match < 70 ? 2000 : 1900}] |
|
dict set time %Y $match |
|
} |
|
} |
|
^jan - ^feb - ^mar - ^apr - |
|
^may - ^jun - ^jul - ^aug - |
|
^sep - ^oct - ^nov - ^dec { |
|
if {![dict exists $time %b]} { |
|
dict set time %b $match |
|
} |
|
} |
|
} |
|
} |
|
if {[dict size $time] == 4} { |
|
return [clock scan [join [dict values $time]] \ |
|
-format [join [dict keys $time]] -timezone :UTC] |
|
} |
|
# invalid expiry date |
|
} |
|
|
|
proc www::cookies::store {url args} { |
|
set rec [parseurl $url] |
|
set now [clock seconds] |
|
db transaction { |
|
foreach n $args { |
|
set args {} |
|
foreach av [lassign [split $n {;}] pair] { |
|
lassign [slice $av =] key value |
|
dict set args [string tolower $key] $value |
|
} |
|
lassign [slice $pair =] name value |
|
array unset arg |
|
set host [dict get $rec host] |
|
if {[dict exists $args domain]} { |
|
set str [dict get $args domain] |
|
if {[string index $str 0] eq "."} { |
|
set str [string range $str 1 end] |
|
} |
|
set pat [format {*.%s} [string tolower $str]] |
|
if {$host eq $str || [string match $pat $host]} { |
|
set arg(domain) $pat |
|
} else { |
|
# Reject the cookie because of an invalid domain |
|
continue |
|
} |
|
} else { |
|
set arg(domain) $host |
|
} |
|
set path [dict get $rec path] |
|
set arg(path) [file join [if {[dict exists $args path]} { |
|
dict get $args path |
|
} else { |
|
file dirname $path |
|
}] *] |
|
if {![string match $arg(path) $path]} { |
|
# Reject the cookie because of an invalid path |
|
continue |
|
} |
|
if {[dict exists $args max-age]} { |
|
set maxage [dict get $args max-age] |
|
if {[string is integer -strict $maxage]} { |
|
set arg(expires) [expr {[clock seconds] + $maxage}] |
|
} |
|
} elseif {[dict exists $args expires]} { |
|
set sec [date [dict get $args expires]] |
|
if {$sec ne ""} {set arg(expires) $sec} |
|
} |
|
if {[dict exists $args secure]} { |
|
lappend arg(attr) secure |
|
} |
|
if {[dict exists $args httponly]} { |
|
lappend arg(attr) httponly |
|
} |
|
set arg(created) $now |
|
set arg(accessed) $now |
|
db eval { |
|
select created, attributes from cookies \ |
|
where name = $name \ |
|
and domain = $arg(domain) and path = $arg(path) |
|
} { |
|
set arg(created) $created |
|
} |
|
if {[info exists arg(expires)]} {set db main} else {set db sess} |
|
db eval [format { |
|
replace into %s.cookies \ |
|
(domain, path, name, value, created, accessed, expires, attributes) \ |
|
values ($arg(domain), $arg(path), $name, $value, $arg(created), $arg(accessed), $arg(expires), $arg(attr)) |
|
} $db] |
|
} |
|
} |
|
} |
|
|
|
proc www::cookies::get {url} { |
|
set rec [parseurl $url] |
|
set host [dict get $rec host] |
|
set path [dict get $rec path] |
|
set scheme [dict get $rec scheme] |
|
set attr {} |
|
if {[secure $scheme]} {lappend attr secure} |
|
if {$scheme in {http https}} {lappend attr httponly} |
|
set now [clock seconds] |
|
set rc {} |
|
db eval { |
|
select name, value, attributes, expires from cookieview \ |
|
where (domain = '*.' || $host or $host glob domain) \ |
|
and $path glob path \ |
|
order by length(path), created |
|
} { |
|
set allowed [expr {$expires >= $now}] |
|
foreach a $attributes { |
|
if {$a ni $attr} {set allowed 0} |
|
} |
|
if {$allowed} { |
|
lappend rc $name $value |
|
} |
|
} |
|
return $rc |
|
} |
|
|
|
proc www::cookies::delete {url args} { |
|
set rec [parseurl $url] |
|
set host [dict get $rec host] |
|
set where [list {domain = $host}] |
|
if {$host ne $url} { |
|
set path [dict get $rec path] |
|
lappend where {$path glob path} |
|
} |
|
set i 0 |
|
set names [lmap n $args { |
|
set arg([incr i]) $n |
|
format {$arg(%d)} $i |
|
}] |
|
if {$i} {lappend where [format {name in (%s)} [join $names ,]]} |
|
set query "delete from %s where [join $where { and }]" |
|
db eval [format $query main.cookies] |
|
db eval [format $query sess.cookies] |
|
} |
|
|
|
proc www::slice {str {sep :}} { |
|
set x [string first $sep $str] |
|
if {$x < 0} {return [list [string trim $str]]} |
|
return [list [string trim [string range $str 0 [expr {$x - 1}]]] \ |
|
[string trim [string range $str [expr {$x + [string length $sep]}] end]]] |
|
} |
|
|
|
proc www::secure {scheme} { |
|
variable schemes |
|
if {[dict exists $schemes $scheme secure]} { |
|
return [dict get $schemes $scheme secure] |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
proc www::urljoin {url args} { |
|
foreach n $args { |
|
switch -glob $n { |
|
*://* { |
|
# Absolute URL |
|
set url $n |
|
} |
|
//* { |
|
# URL relative on current scheme |
|
set x [string first :// $url] |
|
set url [string replace $url [expr {$x + 1} end $n] |
|
} |
|
/* { |
|
# URL relative to the root of the website |
|
set x [string first :// $url] |
|
set x [string first / $url [expr {$x + 3}]] |
|
if {$x < 0} { |
|
append url $n |
|
} else { |
|
set url [string replace $url $x end $n] |
|
} |
|
} |
|
* { |
|
# Relative URL |
|
set x [string first ? $url] |
|
if {$x < 0} { |
|
set x [string first # $url] |
|
if {$x < 0} { |
|
set x [string length $url] |
|
} |
|
} |
|
set x [string last / $url $x] |
|
if {$x < [string first :// $url] + 3} { |
|
append url / $n |
|
} else { |
|
set url [string replace $url $x end $n] |
|
} |
|
} |
|
} |
|
} |
|
return $url |
|
} |
|
|
|
proc www::parseurl {url} { |
|
variable schemes |
|
set list [slice $url ://] |
|
if {[llength $list] < 2} {set list [list http $url]} |
|
lassign $list scheme str |
|
if {![dict exists $schemes $scheme port]} { |
|
throw {WWW URL SCHEME} "unknown scheme: $scheme" |
|
} |
|
lassign [slice $str /] authority str |
|
lassign [slice /$str #] resource fragment |
|
lassign [slice $resource ?] path query |
|
set rc [dict create url $url scheme $scheme host localhost \ |
|
port [dict get $schemes $scheme port] \ |
|
command [dict get $schemes $scheme command] \ |
|
resource $resource path $path fragment $fragment] |
|
set slice [slice $authority @] |
|
dict set rc host [lindex $slice end] |
|
if {[llength $slice] > 1} { |
|
lassign [slice [lindex $slice 0]] username password |
|
dict set rc username $username |
|
dict set rc password $password |
|
} |
|
return $rc |
|
} |
|
|
|
proc www::getopt {var list body} { |
|
upvar 1 $var value |
|
dict for {pat code} $body { |
|
switch -glob -- $pat { |
|
-- {# end-of-options option} |
|
-?*:* {# option requiring an argument |
|
set opt [lindex [split $pat :] 0] |
|
set arg($opt) [dict create pattern $pat argument 1] |
|
# set arg(-$opt) $arg($opt) |
|
} |
|
-?* {# option without an argument |
|
set arg($pat) [dict create pattern $pat argument 0] |
|
# set arg(-$pat) $arg($pat) |
|
} |
|
} |
|
} |
|
while {[llength $list]} { |
|
set rest [lassign $list opt] |
|
# Does it look like an option? |
|
if {$opt eq "-" || [string index $opt 0] ne "-"} break |
|
# Is it the end-of-options option? |
|
if {$opt eq "--"} {set list $rest; break} |
|
set value 1 |
|
if {![info exists arg($opt)]} { |
|
throw {WWW GETOPT OPTION} "unknown option: $opt" |
|
} elseif {[dict get $arg($opt) argument]} { |
|
if {![llength $rest]} { |
|
throw {WWW GETOPT ARGUMENT} \ |
|
"option requires an argument: $opt" |
|
} |
|
set rest [lassign $rest value] |
|
} |
|
uplevel 1 [list switch -- [dict get $arg($opt) pattern] $body] |
|
set list $rest |
|
} |
|
return $list |
|
} |
|
|
|
proc www::stdopts {{body {}}} { |
|
return [dict merge { |
|
-timeout:milliseconds { |
|
dict set request timeout $arg |
|
} |
|
-auth:data { |
|
dict set request headers \ |
|
Authorization "Basic [binary encode base64 $arg]" |
|
} |
|
-digest:cred { |
|
dict set request digest [slice $arg] |
|
} |
|
-persistent:bool { |
|
if {[string is false -strict $arg]} { |
|
dict set request headers Connection close |
|
} |
|
} |
|
-headers:dict { |
|
dict update request headers hdrs { |
|
foreach {name value} $arg { |
|
header append hdrs $name $value |
|
} |
|
} |
|
} |
|
-upgrade:dict { |
|
dict set request upgrade $arg |
|
} |
|
-handler:cmdprefix { |
|
dict set request handler $arg |
|
} |
|
-maxredir:cnt { |
|
dict set request maxredir $arg |
|
} |
|
-infovariable:var { |
|
dict set request result $arg |
|
} |
|
} $body] |
|
} |
|
|
|
proc www::postopts {} { |
|
return { |
|
-multipart:type { |
|
dict set request multipart $arg |
|
} |
|
-name:string { |
|
dict set request partdata name $arg |
|
} |
|
-type:mediatype { |
|
dict set request partdata type $arg |
|
} |
|
-file:file { |
|
dict set request partdata file $arg |
|
dict lappend request parts [dict get $request partdata] |
|
dict unset request partdata file |
|
} |
|
-value:string { |
|
dict set request partdata value $arg |
|
dict lappend request parts [dict get $request partdata] |
|
dict unset request partdata value |
|
} |
|
} |
|
} |
|
|
|
proc www::configure {args} { |
|
variable config |
|
variable headers |
|
set args [getopt arg $args { |
|
-accept:mimetypes { |
|
header add headers Accept {*}$arg |
|
} |
|
-maxconnections:count { |
|
if {[string is integer -strict $arg] && $arg > 0} { |
|
variable maxconn $arg |
|
} else { |
|
return -code error -errorcode {WWW CONFIGURE INVALID} \ |
|
"bad argument \"$arg\": must be a positive integer" |
|
} |
|
} |
|
-persist:milliseconds { |
|
if {[string is integer -strict $arg] && $arg > 0} { |
|
variable persist $arg |
|
} else { |
|
return -code error -errorcode {WWW CONFIGURE INVALID} \ |
|
"bad argument \"$arg\": must be a positive integer" |
|
} |
|
} |
|
-pipeline:boolean { |
|
if {[catch {expr {!!$arg}} arg]} { |
|
return -code error -errorcode {WWW CONFIGURE INVALID} \ |
|
"bad argument \"$arg\": must be a boolean value" |
|
} else { |
|
dict set config -pipeline $arg |
|
} |
|
} |
|
-proxy:cmdprefix { |
|
dict set config -proxy $arg |
|
} |
|
-socketcmd:prefix { |
|
dict set config -socketcmd $arg |
|
} |
|
-useragent:string { |
|
header replace headers User-Agent $arg |
|
} |
|
}] |
|
} |
|
|
|
proc www::cget {opt} { |
|
variable config |
|
if {[dict exists $config $opt]} { |
|
return [dict get $config $opt] |
|
} |
|
set valid [lsort [dict keys $config]] |
|
if {[llength $valid] > 1} {lset valid end "or [lindex $valid end]"} |
|
retrun -code error -errorcode {WWW CONFIGURE UNKNOWN} \ |
|
[format {unknown option: "%s"; must be %s} $opt [join $valid ,]] |
|
} |
|
|
|
proc www::certify {cainfo {prefix ""}} { |
|
variable tlscfg |
|
variable cacheck $prefix |
|
set status 0 |
|
if {$cainfo eq ""} { |
|
set status 1 |
|
dict unset tlscfg -cadir |
|
dict unset tlscfg -cafile |
|
} elseif {[file isdir $cainfo]} { |
|
dict set tlscfg -cadir $cainfo |
|
dict unset tlscfg -cafile |
|
} else { |
|
dict set tlscfg -cafile $cainfo |
|
dict unset tlscfg -cadir |
|
} |
|
if {$prefix ne ""} { |
|
set callback [list [namespace which cert] $status] |
|
} elseif {$cainfo ne ""} { |
|
set callback [list [namespace which stdcert] $status] |
|
} else { |
|
set callback [list [namespace which nocert] $status] |
|
} |
|
dict set tlscfg -command $callback |
|
if {[dict exists $tlscfg -validatecommand]} { |
|
dict set tlscfg -validatecommand $callback |
|
} |
|
# Prevent reusing old connections that were created using a different |
|
# certification strategy. |
|
db eval {select connection from reuse where scheme = 'https'} { |
|
$connection destroy |
|
} |
|
} |
|
|
|
proc www::unknown {args} { |
|
return [list [namespace which nop]] |
|
} |
|
|
|
proc www::nop args {} |
|
|
|
proc www::novfy {args} { |
|
# Accept anything |
|
return 1 |
|
} |
|
|
|
proc www::stdvfy {pass chan depth cert status args} { |
|
return $status |
|
} |
|
|
|
proc www::vfycmd {pass chan depth cert status args} { |
|
variable cacheck |
|
try { |
|
if {$pass} {set status 1} |
|
set rc [uplevel #0 [linsert $cacheck end $depth $cert]] |
|
if {[string is boolean -strict $rc]} {set status [string is true $rc]} |
|
} on error msg { |
|
log "Error: $msg" |
|
} |
|
return $status |
|
} |
|
|
|
proc www::errcmd {pass sock msg} { |
|
# Errors aren't necessarily fatal |
|
# Handshake not complete, will retry later |
|
# Resource temporarily unavailable |
|
#$sock $msg |
|
} |
|
|
|
proc www::encodingcmd {name} { |
|
variable encodings |
|
return [dict get $encodings $name] |
|
} |
|
|
|
namespace eval www { |
|
# The three compression formats deflate, compress, and gzip are all the |
|
# same, except for headers and checksums. The Tcl zlib package uses the |
|
# following mapping: |
|
# deflate: raw compressed data only |
|
# compress: 2-byte header (78 ..) + data + ADLER32 checksum |
|
# gzip: 10-byte header (1F 8B 08 ...) + data + CRC-32 checksum |
|
# The http 1.1 spec rfc2616 uses the same names with the following mapping: |
|
# deflate: 2-byte header (78 ..) + data + ADLER32 checksum |
|
# compress: different compression method used by unix compress command |
|
# gzip: 10-byte header (1F 8B 08 ...) + data + CRC-32 checksum |
|
# One additional complication is that Microsoft got it wrong again and |
|
# made IE to expect a bare deflate stream for content-encoding deflate, |
|
# so some sites may provide that instead of the correct format. Other |
|
# browsers adapted by accepting both types. |
|
namespace ensemble create -command decode \ |
|
-subcommands {gzip compress deflate} |
|
} |
|
|
|
proc www::gzip {} { |
|
set cmd [zlib stream gunzip] |
|
set data [yield] |
|
while {$data ne ""} { |
|
set data [yield [$cmd add $data]] |
|
} |
|
set rc [if {![$cmd eof]} {$cmd add -finalize {}}] |
|
$cmd close |
|
return $rc |
|
} |
|
|
|
proc www::deflate {} { |
|
set cmd [zlib stream decompress] |
|
set data [yield] |
|
if {$data ne ""} { |
|
try { |
|
$cmd add $data |
|
} trap {TCL ZLIB DATA} {} { |
|
# log "Decompress failed, trying inflate" |
|
$cmd close |
|
set cmd [zlib stream inflate] |
|
set data [$cmd add $data] |
|
} on ok {data} { |
|
} |
|
set data [yield $data] |
|
while {$data ne ""} { |
|
set data [yield [$cmd add $data]] |
|
} |
|
} |
|
set rc [if {![$cmd eof]} {$cmd add -finalize {}}] |
|
$cmd close |
|
return $rc |
|
} |
|
|
|
proc www::proxies {rec} { |
|
variable config |
|
set cmd [dict get $config -proxy] |
|
if {$cmd eq ""} {return [list DIRECT]} |
|
set host [dict get $rec host] |
|
set scheme [dict get $rec scheme] |
|
if {$scheme eq "https"} { |
|
set url [format %s://%s/ $scheme $host] |
|
} else { |
|
set url [dict get $rec url] |
|
} |
|
try { |
|
return [uplevel 0 [linsert $cmd end $url $host]] |
|
} on error {err opts} { |
|
return [list DIRECT] |
|
} |
|
} |
|
|
|
proc www::noproxy {url host} { |
|
return [list DIRECT] |
|
} |
|
|
|
proc www::defaultproxy {url host} { |
|
variable defaultproxy |
|
if {[dict size $defaultproxy] == 0} { |
|
global env |
|
dict set defaultproxy no {} |
|
foreach n [array names env -regexp {(?i)_proxy$}] { |
|
set scheme [string tolower [string range $n 0 end-6]] |
|
set proxy $env($n) |
|
if {$scheme eq "no"} { |
|
dict set defaultproxy no [split $proxy {;,}] |
|
continue |
|
} elseif {[string match *://* $proxy]} { |
|
set proxy [dict get [parseurl $env(http_proxy)] host] |
|
} |
|
dict set defaultproxy $scheme [list [list PROXY $proxy]] |
|
} |
|
} |
|
set scheme [lindex [slice $url ://] 0] |
|
if {[dict exists $defaultproxy $scheme]} { |
|
foreach domain [dict get $defaultproxy no] { |
|
if {[string match $domain $host]} { |
|
return [list DIRECT] |
|
} |
|
} |
|
return [dict get $defaultproxy $scheme] |
|
} |
|
return [list DIRECT] |
|
} |
|
|
|
proc www::httpproxy {server url host} { |
|
return [list "HTTP $server"] |
|
} |
|
|
|
proc www::httpsproxy {server url host} { |
|
return [list "HTTPS $server"] |
|
} |
|
|
|
proc www::socksproxy {server url host} { |
|
return [list "SOCKS $server"] |
|
} |
|
|
|
proc www::socks4proxy {server url host} { |
|
return [list "SOCKS4 $server"] |
|
} |
|
|
|
proc www::socks5proxy {server url host} { |
|
return [list "SOCKS5 $server"] |
|
} |
|
|
|
proc www::register {scheme port {command ""} {secure 0}} { |
|
variable schemes |
|
dict set schemes $scheme \ |
|
[dict create port $port command $command secure $secure] |
|
return |
|
} |
|
|
|
proc www::urlencode {str} { |
|
variable config |
|
variable formmap |
|
set string [encoding convertto [dict get $config -urlencoding] $str] |
|
return [string map $formmap $str] |
|
} |
|
|
|
proc www::challenge {str} { |
|
scan $str {%s %n} type pos |
|
set rc {} |
|
foreach n [split [string range $str $pos end] ,] { |
|
lassign [slice $n =] key val |
|
if {[string match {"*"} $val]} {set val [string range $val 1 end-1]} |
|
dict set rc $key $val |
|
} |
|
return [list $type $rc] |
|
} |
|
|
|
proc www::hostport {dest {defaultport 80}} { |
|
# Extract host and port from the destination specification |
|
if {[regexp {^\[([[:xdigit:]:]+)\]} $dest ipv6 host]} { |
|
set l [string length $ipv6] |
|
if {$l == [string length $spec]} { |
|
return [list $host $defaultport] |
|
} elseif {[string index $spec $l] eq ":"} { |
|
return [list $host [string range $spec [expr {$l + 1}] end]] |
|
} else { |
|
throw {WWW URL HOSTSPEC} "invalid host specification" |
|
} |
|
} else { |
|
set rc [slice $dest] |
|
if {[llength $rc] < 2} {lappend rc $defaultport} |
|
return $rc |
|
} |
|
} |
|
|
|
proc www::reuse {scheme host port cmd} { |
|
variable timer |
|
variable maxconn |
|
# Check if a connection to the requested destination already exists |
|
db eval {select connection from reuse \ |
|
where scheme = $scheme and host = $host and port = $port} { |
|
after cancel [dict get $timer $connection] |
|
dict unset timer $connection |
|
dict set timer $connection {} |
|
return $connection |
|
} |
|
if {[dict size $timer] >= $maxconn} { |
|
# Delete the oldest connection |
|
dict for {key val} $timer { |
|
$key destroy |
|
break |
|
} |
|
} |
|
set conn [{*}$cmd] |
|
db eval {insert into reuse (connection, scheme, host, port) \ |
|
values($conn, $scheme, $host, $port)} |
|
|
|
# Arrange to update the administration when the object disappears |
|
trace add command $conn delete [list apply [list {obj args} { |
|
release $obj |
|
} [namespace current]]] |
|
|
|
dict set timer $conn {} |
|
return $conn |
|
} |
|
|
|
proc www::release {obj} { |
|
variable timer |
|
log "Deleting connection $obj" |
|
db eval {delete from reuse where connection = $obj} |
|
log "deleted [db changes] rows" |
|
after cancel [dict get $timer $obj] |
|
dict unset timer $obj |
|
} |
|
|
|
proc www::keep {obj} { |
|
variable timer |
|
variable persist |
|
# Stop the timer and move the connection to the end of the dict |
|
after cancel [dict get $timer $obj] |
|
dict unset timer $obj |
|
dict set timer $obj [after $persist [list $obj destroy]] |
|
} |
|
|
|
proc www::headers {extra} { |
|
variable headers |
|
variable encodings |
|
set hdrs $headers |
|
header add hdrs Accept-Encoding {*}[dict keys $encodings] |
|
foreach {name value} $extra { |
|
header replace hdrs $name $value |
|
} |
|
return $hdrs |
|
} |
|
|
|
namespace eval www::header { |
|
namespace ensemble create -subcommands {exists get replace append add} |
|
|
|
proc indexlist {hdrs name} { |
|
return [lmap n [lsearch -all -nocase -exact $hdrs $name] { |
|
if {$n % 2} continue else {expr {$n + 1}} |
|
}] |
|
} |
|
|
|
proc exists {hdrs name} { |
|
# Usage: header exists headerlist name |
|
# Check if a header with the specified name exists |
|
return [expr {[llength [indexlist $hdrs $name]] != 0}] |
|
} |
|
|
|
proc get {hdrs name args} { |
|
# Usage: header get headerlist name ?index? ?-lowercase? |
|
# Return the value of the requested header, if any. By default all |
|
# entries are joined together, separated with a comma and a space. |
|
# The resulting string is returned. |
|
# If an index is specified, that is taken as an indication that the |
|
# header value is defined as a comma-separated list. In that case, |
|
# a Tcl list is constructed from the individual elements of all |
|
# entries. The requested index from the resulting list is returned. |
|
# The special index "all" causes the complete list to be returned. |
|
# When the -lowercase option is specified, all values are converted |
|
# to lower case. |
|
if {[lindex $args 0] eq "-lowercase"} { |
|
set cmd [list string tolower] |
|
set index [lindex $args 1] |
|
} else { |
|
set cmd [list string cat] |
|
set index [lindex $args 0] |
|
} |
|
if {$index eq ""} { |
|
return [join [lmap n [indexlist $hdrs $name] { |
|
{*}$cmd [lindex $hdrs $n] |
|
}] {, }] |
|
} |
|
set list [indexlist $hdrs $name] |
|
set rc {} |
|
if {[string equal -nocase $name Set-Cookie]} { |
|
# The Set-Cookie header is special |
|
foreach h $list {lappend rc [lindex $hdrs $h]} |
|
} else { |
|
foreach h $list { |
|
foreach v [split [lindex $hdrs $h] ,] { |
|
lappend rc [{*}$cmd [string trim $v]] |
|
} |
|
} |
|
} |
|
if {$index eq "all"} { |
|
return $rc |
|
} elseif {$index eq "last"} { |
|
return [lindex $rc end] |
|
} else { |
|
return [lindex $rc $index] |
|
} |
|
} |
|
|
|
proc add {var name args} { |
|
# Usage: header add headerlistvar name ?-nocase? value ?...? |
|
# Add one or more values to a header, if they are not alread present |
|
# The -nocase option makes the compare operation case insensitive. |
|
upvar 1 $var hdrs |
|
set list [get [lappend hdrs] $name all] |
|
set opts -exact |
|
if {[lindex $args 0] eq "-nocase"} { |
|
lappend opts -nocase |
|
set args [lrange $args 1 end] |
|
} |
|
foreach arg $args { |
|
if {[lsearch {*}$opts $list $arg] < 0} { |
|
lappend list $arg |
|
} |
|
} |
|
return [replace hdrs $name [join $list {, }]] |
|
} |
|
|
|
proc append {var name args} { |
|
# Usage: header append headerlistvar name ?value? ?...? |
|
# Set a new value for a header in addition to any existing values |
|
upvar 1 $var hdrs |
|
set list [indexlist [lappend hdrs] $name] |
|
set values [linsert $args 0 {*}[lmap n $list {lindex $hdrs $n}]] |
|
set index end |
|
foreach index [lreverse $list] { |
|
set hdrs [lreplace $hdrs [expr {$index - 1}] $index] |
|
incr index -1 |
|
} |
|
set hdrs [linsert $hdrs $index $name [join $values {, }]] |
|
} |
|
|
|
proc replace {var name args} { |
|
# Usage: header replace headerlistvar name ?value? ?...? |
|
# Set a new value for a header replacing all existing entries. |
|
# Multiple values are joined together into a comma-separated list. |
|
# If no values are specified, all entries for the header are removed. |
|
upvar 1 $var hdrs |
|
set index end |
|
foreach index [lreverse [indexlist [lappend hdrs] $name]] { |
|
set hdrs [lreplace $hdrs [expr {$index - 1}] $index] |
|
incr index -1 |
|
} |
|
if {[llength $args]} { |
|
set hdrs [linsert $hdrs $index $name [join $args {, }]] |
|
} |
|
return $hdrs |
|
} |
|
} |
|
|
|
proc www::boundary {} { |
|
# Generate a unique boundary string |
|
for {set i 0} {$i < 6} {incr i} { |
|
lappend data [expr {int(rand() * 0x100000000)}] |
|
} |
|
# ModSecurity 2.9.2 complains about some characters in the boundary |
|
# string that are perfectly legal according to RFC 2046. "/" is one |
|
# of them. (It looks like this is fixed in ModSecurity 2.9.3.) |
|
# Wireshark also has issues when the boundary contains a "/". |
|
return [string map {/ -} [binary encode base64 [binary format I* $data]]] |
|
} |
|
|
|
proc www::formdata {list} { |
|
return [lmap {name value} $list { |
|
dict create name $name value $value |
|
}] |
|
} |
|
|
|
proc www::multipart {sep parts {disp ""}} { |
|
set rc {} |
|
foreach part $parts { |
|
lassign [bodypart $part $disp] body hdrs |
|
lappend rc "--$sep" |
|
foreach {hdr val} $hdrs { |
|
lappend rc "$hdr: $val" |
|
} |
|
lappend rc "" $body |
|
} |
|
lappend rc --$sep-- |
|
return [join $rc \r\n] |
|
} |
|
|
|
proc www::mimetype {file} { |
|
return application/octet-string |
|
} |
|
|
|
proc www::bodypart {data {disp ""}} { |
|
if {$disp ne ""} { |
|
if {[dict exists $data name]} { |
|
set name [dict get $data name] |
|
} else { |
|
set name value |
|
} |
|
set dispstr [format {%s; name="%s"} $disp $name] |
|
if {[dict exists $data file]} { |
|
set filename [file tail [dict get $data file]] |
|
append dispstr [format {; filename="%s"} $filename] |
|
} |
|
header replace hdrs Content-Disposition $dispstr |
|
} |
|
if {$disp eq "" || ![dict exists $data value]} { |
|
if {[dict exists $data type]} { |
|
set type [dict get $data type] |
|
} elseif {[dict exists $data file]} { |
|
set type [mimetype [dict get $data file]] |
|
} else { |
|
set type application/octet-string |
|
} |
|
header replace hdrs Content-Type $type |
|
} |
|
if {[dict exists $data value]} { |
|
set body [dict get $data value] |
|
} elseif {[dict exists $data file]} { |
|
set f [open [dict get $data file] rb] |
|
set body [read $f] |
|
close $f |
|
} else { |
|
set body {} |
|
} |
|
return [list $body $hdrs] |
|
} |
|
|
|
proc www::bodybuilder {method url request args} { |
|
dict lappend request headers |
|
dict lappend request parts |
|
if {[llength $args] % 2} { |
|
dict set request partdata value [lindex $args end] |
|
set args [lrange $args 0 end-1] |
|
dict lappend request parts [dict get $request partdata] |
|
} |
|
if {$method in {POST}} { |
|
if {[llength [dict get $request parts]] == 0} { |
|
set type application/x-www-form-urlencoded |
|
} elseif {[llength [dict get $request parts]] > 1 || [llength $args]} { |
|
set type multipart/form-data |
|
} else { |
|
set type application/octet-string |
|
} |
|
} elseif {[llength [dict get $request parts]] > 1} { |
|
set type multipart/mixed |
|
} elseif {[llength [dict get $request parts]]} { |
|
set type application/octet-string |
|
} else { |
|
set type "" |
|
} |
|
|
|
if {[dict exists $request multipart]} { |
|
switch [dict get $request multipart] { |
|
"" { |
|
set type "" |
|
} |
|
formdata { |
|
set type multipart/form-data |
|
} |
|
default { |
|
set type multipart/[dict get $request multipart] |
|
} |
|
} |
|
} |
|
|
|
set query {} |
|
set parts [if {[dict exists $request parts]} {dict get $request parts}] |
|
if {$type eq "multipart/form-data"} { |
|
set sep [boundary] |
|
set body [multipart $sep [concat $parts [formdata $args]] form-data] |
|
append type "; boundary=$sep" |
|
} elseif {$type eq "application/x-www-form-urlencoded"} { |
|
set body [join [lmap {key val} $args { |
|
string cat [urlencode $key] = [urlencode $val] |
|
}] &] |
|
} else { |
|
set query $args |
|
if {[string match multipart/* $type]} { |
|
set sep [boundary] |
|
set body [multipart $sep $parts] |
|
append type "; boundary=$sep" |
|
} elseif {[llength $parts]} { |
|
lassign [bodypart [lindex $parts 0]] body hdrs |
|
set type [header get $hdrs Content-Type] |
|
} |
|
} |
|
if {[llength $query]} { |
|
append url ? [join [lmap {key val} $args { |
|
string cat [urlencode $key] = [urlencode $val] |
|
}] &] |
|
} |
|
dict set request url $url |
|
if {$type ne ""} { |
|
dict set request body $body |
|
dict set request headers Content-Type $type |
|
} |
|
return $request |
|
} |
|
|
|
proc www::request {method url request args} { |
|
variable requestid |
|
set request [bodybuilder $method $url $request {*}$args] |
|
# Get a local copy of the requestid, because the requestcoro may need to |
|
# perform a new request to obtain proxies, which would change requestid |
|
set id [incr requestid] |
|
set cmdline [list coroutine request$id requestcoro $method $request] |
|
set coro [info coroutine] |
|
if {$coro ne ""} { |
|
{*}$cmdline [list $coro] |
|
lassign [yield] data opts |
|
} else { |
|
variable result |
|
{*}$cmdline [list set [namespace which -variable result]($id)] |
|
vwait [namespace which -variable result]($id) |
|
lassign $result($id) data opts |
|
unset result($id) |
|
} |
|
if {[dict get $opts -code]} { |
|
return -options [dict incr opts -level] $data |
|
} |
|
set code [dict get $opts status code] |
|
if {$code in {101 200 201 202 204 207 304}} { |
|
# 101 Switching protocols |
|
# 200 OK |
|
# 201 Created |
|
# 202 Accepted |
|
# 204 No Content |
|
# 207 Multi-Status (WEBDAV) |
|
# 304 Not Modified |
|
return -options [dict incr opts -level] $data |
|
} elseif {$code in {301 302 303 307 308}} { |
|
# 301 Moved Permanently |
|
# 302 Found |
|
# 303 See Other |
|
# 307 Temporary Redirect |
|
# 308 Permanent Redirect |
|
set redir [dict get $request maxredir] |
|
if {$redir > 0} { |
|
dict incr request maxredir -1 |
|
} |
|
if {$redir} { |
|
if {$code eq "303"} { |
|
set method GET |
|
dict unset request body |
|
# Remove any Content-Length headers |
|
dict update request headers hdrs { |
|
header replace hdrs Content-Length |
|
} |
|
} |
|
set url [dict get $request url] |
|
set location [header get [dict get $opts headers] location] |
|
log "Redirected to: $location" |
|
tailcall request $method [urljoin $url $location] $request |
|
} |
|
} elseif {$code eq "401" \ |
|
&& [header exists [dict get $opts headers] www-authenticate]} { |
|
# 401 Unauthorized |
|
set challenge [header get [dict get $opts headers] www-authenticate] |
|
lassign [challenge $challenge] type args |
|
# RFC 2068 10.4.2: If the request already included Authorization |
|
# credentials, then the 401 response indicates that authorization |
|
# has been refused for those credentials. |
|
# RFC 2069 2.1.1: stale - A flag, indicating that the previous |
|
# request from the client was rejected because the nonce value was |
|
# stale. If stale is TRUE (in upper or lower case), the client may |
|
# wish to simply retry the request with a new encrypted response, |
|
# without reprompting the user for a new username and password. |
|
set stale [expr {[dict exists $args stale] \ |
|
&& [string equal -nocase [dict get $args stale] true]}] |
|
set auth [header get [dict get $request headers] Authorization] |
|
if {$auth ne "" && !$stale} { |
|
# Credentials must be incorrect |
|
} elseif {$type eq "Digest" && [dict exists $request digest]} { |
|
package require www::digest |
|
lassign [dict get $request digest] user password |
|
set body \ |
|
[if {[dict exists $request body]} {dict get $request body}] |
|
set uri [dict get $opts uri] |
|
dict update request headers hdrs { |
|
set cred \ |
|
[digest::digest $args $user $password $method $uri $body] |
|
header replace hdrs Authorization $cred |
|
} |
|
tailcall request $method [dict get $opts url] $request |
|
} |
|
} |
|
set codegrp [string replace $code 1 2 XX] |
|
set reason [dict get $opts status reason] |
|
dict set opts -code 1 |
|
dict set opts -errorcode [list WWW CODE $codegrp $code $reason] |
|
return -options [dict incr opts -level] $data |
|
} |
|
|
|
proc www::requestcoro {method request callback} { |
|
variable config |
|
variable headers |
|
variable schemes |
|
set url [dict get $request url] |
|
set hdrs [dict get $request headers] |
|
set cookies [lmap {n v} [cookies get $url] {string cat $n = $v}] |
|
if {[llength $cookies]} { |
|
header replace hdrs Cookie [join $cookies {; }] |
|
} else { |
|
header replace hdrs Cookie |
|
} |
|
set rec [parseurl $url] |
|
set proxies [proxies $rec] |
|
foreach n $proxies { |
|
lassign $n keyword arg |
|
set scheme [dict get $rec scheme] |
|
switch $keyword { |
|
PROXY - HTTP - HTTPS { |
|
if {$keyword eq "HTTPS"} { |
|
set version https |
|
} else { |
|
set version http |
|
} |
|
set transform [dict get $schemes $scheme command] |
|
if {[llength $transform]} { |
|
# If a transformation must be applied, an HTTP tunnel is |
|
# needed via the CONNECT method |
|
# Once the tunnel is established, the connection is to the |
|
# remote server. Scheme, host and port must point there. |
|
set host [dict get $rec host] |
|
set port [dict get $rec port] |
|
set transform \ |
|
[list proxyinit $version $host $port $transform] |
|
lassign [hostport $arg 8080] phost pport |
|
set command [list connection new $phost $pport $transform] |
|
# The resource is just the local path |
|
set resource [dict get $rec resource] |
|
} else { |
|
# The connection is to the proxy, so the scheme, host and |
|
# port must point to that for reuse |
|
lassign [hostport $arg 8080] host port |
|
set scheme $version |
|
set transform [dict get $schemes $scheme command] |
|
set command [list connection new $host $port $transform] |
|
# The resource is the full remote path |
|
set resource $url |
|
} |
|
} |
|
SOCKS - SOCKS4 - SOCKS5 { |
|
package require www::socks |
|
if {$keyword eq "SOCKS5"} { |
|
set version socks5 |
|
} else { |
|
set version socks4 |
|
} |
|
lassign [hostport [dict get $rec host] [dict get $rec port]] \ |
|
host port |
|
lassign [hostport $arg 1080] phost pport |
|
set transform [dict get $schemes $scheme command] |
|
set transform [list socksinit $version $host $port $transform] |
|
set command [list connection new $phost $pport $transform] |
|
set scheme $version+$scheme |
|
set resource [dict get $rec resource] |
|
} |
|
default { |
|
# DIRECT |
|
lassign [hostport [dict get $rec host] [dict get $rec port]] \ |
|
host port |
|
set transform [dict get $schemes $scheme command] |
|
set command [list connection new $host $port $transform] |
|
set resource [dict get $rec resource] |
|
} |
|
} |
|
|
|
set conn [reuse $scheme $host $port $command] |
|
|
|
dict set rec method $method |
|
dict set rec pipeline [dict get $config -pipeline] |
|
if {[dict exists $request body]} { |
|
header replace hdrs \ |
|
Content-Length [string length [dict get $request body]] |
|
dict set rec body [dict get $request body] |
|
} |
|
foreach key {timeout upgrade handler result} { |
|
if {[dict exists $request $key]} { |
|
dict set rec $key [dict get $request $key] |
|
} |
|
} |
|
dict set rec headers [headers $hdrs] |
|
dict set rec callback [list [info coroutine]] |
|
try { |
|
$conn request [dict replace $rec resource $resource] |
|
} on ok {data opts} { |
|
} trap {WWW CONNECT} {data opts} { |
|
log "proxy $n failed: $data" |
|
continue |
|
} on error {data opts} { |
|
log "requestcoro error: $data" |
|
} |
|
# log "requestcoro: $opts" |
|
if {[dict exists $opts headers]} { |
|
set cookies [header get [dict get $opts headers] set-cookie all] |
|
if {[llength $cookies]} { |
|
cookies store $url {*}$cookies |
|
} |
|
} |
|
{*}$callback [list $data $opts] |
|
return |
|
} |
|
log "All proxies exhausted: $proxies" |
|
# Retry with http -> https ? |
|
{*}$callback [list $data $opts] |
|
} |
|
|
|
proc www::parseopts {optspec arglist} { |
|
set request {headers {} maxredir 20} |
|
# Call getopts twice to allow options to be specified before and after the url |
|
set args [getopt arg [lassign [getopt arg $arglist $optspec] url] $optspec] |
|
return [linsert $args 0 $url $request] |
|
} |
|
|
|
proc www::get {args} { |
|
set args [lassign [parseopts [stdopts] $args] url request] |
|
if {[llength $args] % 2} { |
|
throw {WWW ARGS} "expected key/value pairs" |
|
} |
|
request GET $url $request {*}$args |
|
} |
|
|
|
proc www::head {args} { |
|
set args [lassign [parseopts [stdopts] $args] url request] |
|
if {[llength $args] % 2} { |
|
throw {WWW ARGS} "expected key/value pairs" |
|
} |
|
request HEAD $url $request {*}$args |
|
} |
|
|
|
proc www::post {args} { |
|
request POST {*}[parseopts [stdopts [postopts]] $args] |
|
} |
|
|
|
proc www::put {args} { |
|
request PUT {*}[parseopts [stdopts [postopts]] $args] |
|
} |
|
|
|
proc www::delete {args} { |
|
request DELETE {*}[parseopts [stdopts [postopts]] $args] |
|
} |
|
|
|
proc www::proxyinit {scheme host port cmd fd args} { |
|
variable schemes |
|
# Apply a transformation for the connection to the proxy, if necessary |
|
set transform [dict get $schemes $scheme command] |
|
if {[llength $transform]} {{*}$transform $fd {*}$args} |
|
if {[llength $cmd]} { |
|
# Create a proxyconnect object for the CONNECT transaction to the proxy |
|
set obj [proxyconnect new $fd] |
|
# Actually start the connection |
|
try { |
|
$obj connect $host:$port |
|
} finally { |
|
$obj destroy |
|
} |
|
# Apply the transformation on the tunneled connection to the server |
|
{*}$cmd $fd $host |
|
} |
|
} |
|
|
|
proc www::socksinit {version host port cmd fd args} { |
|
socks $version $fd $host $port |
|
if {[llength $cmd]} { |
|
{*}$cmd $fd {*}$args |
|
} |
|
}
|
|
|