TclApps Library Source Code
Check-in [79b4beb2c8]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Added tkchat_url.tcl (unused) from starkit
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 79b4beb2c8a9f55112da2b11a6fbc258cb6036fa9457d2ef8aa21093da1b9a7c
User & Date: stevel 2018-12-15 23:27:19
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
Hide Diffs Unified Diffs Ignore Whitespace Patch

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]/[email protected]
              {scheme http user user:pass host www.example.com port {} path / query [email protected]}
        } {
            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]"
            }
        }
    }
}