Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Added tkchat_url.tcl (unused) from starkit |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA3-256: |
79b4beb2c8a9f55112da2b11a6fbc258 |
User & Date: | stevel 2018-12-15 23:27:19.174 |
Context
2019-01-11
| ||
00:26 | Added ChangeLog check-in: 1a5b4ccd34 user: stevel tags: trunk | |
2018-12-15
| ||
23:27 | Added tkchat_url.tcl (unused) from starkit check-in: 79b4beb2c8 user: stevel tags: trunk | |
23:16 | Added Russian message catalog to TkChat check-in: 6b67d5411b user: stevel tags: trunk | |
Changes
Added tkchat/tkchat_url.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | # Fetch a URL with added caching. Provided the request is a plain # GET and doesnt use -handler we can try caching and avoid some traffic. # This will help with the TIP index and RSS feeds. # We should also check the domain and see what cookies might be set. package require http package require sha1 namespace eval tkchat { namespace eval webcache { variable cache variable cookiejar } } proc tkchat::webcache::spliturl {url} { set URLmatcher {(?x) # this is _expanded_ syntax ^ (?: (\w+) : ) ? # <protocol scheme> (?: // (?: ( [^@/\#?]+ # <userinfo part of authority> ) @ )? ( [^/:\#?]+ ) # <host part of authority> (?: : (\d+) )? # <port part of authority> )? ( / [^\#]*)? # <path> (including query) (?: \# (.*) )? # <fragment> $ } if {![regexp -- $URLmatcher $url -> scheme user host port path]} { return -code error "unsupported url '$url'" } set query {} if {[set n [string first ? $path]] != -1} { set query [string range $path $n end] set path [string range $path 0 [incr n -1]] } return [list scheme $scheme user $user host $host port $port \ path $path query $query] } proc tkchat::webcache::appendcookies {url argsvarname} { variable cookiejar upvar 1 $argsvarname args array set parts [spliturl $url] # look in jar for cookies by domain and path and expiry set cookies [array get cookiejar $parts(host),*] # TODO: split the path and query and match path # TODO: check for expired cookies and remove them. lappend args -headers [list "X-Tkchat-Webcache" "test;q=0.1"] return } proc tkchat::webcache::log {m} {puts stderr $m} proc tkchat::webcache::geturl {url args} { variable cachedir # Switch the result to pass via our response handler set cmd {} set newargs {} foreach {opt val} $args { if {$opt eq "-command"} { set cmd $val } else { lappend newargs $opt $val } } lappend newargs -command [list [namespace origin on_response] $url $cmd] appendcookies $url newargs # TODO: avoid POST set id [sha1::sha1 -hex $url] if {[file exists [file join $cachedir $id]]} { log "HEAD $url" set tok [eval [linsert $newargs 0 http::geturl $url -validate 1]] } else { log "GET $url" set tok [eval [linsert $newargs 0 http::geturl $url]] } # was not an async request - better wait here. if {$cmd eq {}} { http::wait $tok } return $tok } proc tkchat::webcache::on_response {url cmd tok} { if {[http::status $tok] eq "ok" && [http::ncode $tok] >= 200 && [http::ncode $tok] < 300 } then { preservecookies $url $tok cacheresult $url $cmd $tok } else { uplevel #0 [linsert $cmd end $tok] } } proc tkchat::webcache::preservecookies {url tok} { variable cookiejar array set parts [spliturl $url] set domain $parts(host) foreach {name value} [http::meta $tok] { if {[string equal -nocase "set-cookie" $name]} { array set cookie [set crumbs [parsecookie $value]] set key $cookie(domain),$cookie($path),$cookie(expires) set cookiejar($key) $crumbs } } } proc tkchat::webcache::parsecookie {data} { return [list domain "" path "" expires 0] } # Process a web response. # If this was a HEAD request, compare with our cache copy and # either fixup the http token (HIT) or issue a GET request (MISS). # On a GET request, call the MISS path and update the cache. proc tkchat::webcache::cacheresult {url cmd tok} { } # unit test if {[info exists argv0] && ([info script] eq $argv0)} { namespace eval tkchat::webcache { foreach {n url test} { 1 http://www.example.com/a/b/c.html {scheme http user {} host www.example.com port {} path /a/b/c.html query {}} 2 http://www.example.com/a/b?q=1 {scheme http user {} host www.example.com port {} path /a/b query ?q=1} 3 http://www.example.com/a/b?q=1&b=2/3/4 {scheme http user {} host www.example.com port {} path /a/b query ?q=1&b=2/3/4} 4 https://www.example.com/a/b/c {scheme https user {} host www.example.com port {} path /a/b/c query {}} 5 http://www.example.com:8080/a/b/c?q=1&b=2 {scheme http user {} host www.example.com port 8080 path /a/b/c query ?q=1&b=2} 6 http://www.example.com/?q=1b=2/3 {scheme http user {} host www.example.com port {} path / query ?q=1b=2/3} 7 http://[email protected]/ {scheme http user user host www.example.com port {} path / query {}} 8 http://user:[email protected]/ {scheme http user user:pass host www.example.com port {} path / query {}} 9 http://user:[email protected]/?q=1@2 {scheme http user user:pass host www.example.com port {} path / query ?q=1@2} } { if {[spliturl $url] ne $test} { puts "failed: spliturl-$n\n\t$test\n\t[spliturl $url]" } } # parsecookie foreach {n str test} { 1.0 {Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"} {} 1.1 {Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"} {} 3.0 {CommunityServer-LastVisitUpdated-1001=; path=/} {} 3.1 {CommunityServer-UserCookie1001=lv=1/1/1999 12:00:00 AM&mra=1/27/2010 4:54:21 AM; expires=Thu, 27-Jan-2011 12:54:22 GMT; path=/} {} } { if {[parsecookie $str] ne $test} { puts "failed parsecookie-$n\n\t$test\n\t[parsecookie $str]" } } } } |