1# autoproxy.tcl - Copyright (C) 2002-2008 Pat Thoyts <patthoyts@users.sf.net>
2#
3# On Unix the standard for identifying the local HTTP proxy server
4# seems to be to use the environment variable http_proxy or ftp_proxy and
5# no_proxy to list those domains to be excluded from proxying.
6#
7# On Windows we can retrieve the Internet Settings values from the registry
8# to obtain pretty much the same information.
9#
10# With this information we can setup a suitable filter procedure for the
11# Tcl http package and arrange for automatic use of the proxy.
12#
13# Example:
14#   package require autoproxy
15#   autoproxy::init
16#   set tok [http::geturl http://wiki.tcl.tk/]
17#   http::data $tok
18#
19# To support https add:
20#   package require tls
21#   http::register https 443 ::autoproxy::tls_socket
22#
23# @(#)$Id: autoproxy.tcl,v 1.13 2008/03/01 00:41:35 andreas_kupries Exp $
24
25package require http;                   # tcl
26package require uri;                    # tcllib
27package require base64;                 # tcllib
28
29namespace eval ::autoproxy {
30    variable rcsid {$Id: autoproxy.tcl,v 1.13 2008/03/01 00:41:35 andreas_kupries Exp $}
31    variable version 1.5.1
32    variable options
33
34    if {! [info exists options]} {
35        array set options {
36            proxy_host ""
37            proxy_port 80
38            no_proxy   {}
39            basic      {}
40            authProc   {}
41        }
42    }
43
44    variable uid
45    if {![info exists uid]} { set uid 0 }
46
47    variable winregkey
48    set winregkey [join {
49        HKEY_CURRENT_USER
50        Software Microsoft Windows
51        CurrentVersion "Internet Settings"
52    } \\]
53}
54
55# -------------------------------------------------------------------------
56# Description:
57#   Obtain configuration options for the server.
58#
59proc ::autoproxy::cget {option} {
60    variable options
61    switch -glob -- $option {
62        -host -
63        -proxy_h* { set options(proxy_host) }
64        -port -
65        -proxy_p* { set options(proxy_port) }
66        -no*      { set options(no_proxy) }
67        -basic    { set options(basic) }
68        -authProc { set options(authProc) }
69        default {
70            set err [join [lsort [array names options]] ", -"]
71            return -code error "bad option \"$option\":\
72                       must be one of -$err"
73        }
74    }
75}
76
77# -------------------------------------------------------------------------
78# Description:
79#  Configure the autoproxy package settings.
80#  You may only configure one type of authorisation at a time as once we hit
81#  -basic, -digest or -ntlm - all further args are passed to the protocol
82#  specific script.
83#
84#  Of course, most of the point of this package is to fill as many of these
85#  fields as possible automatically. You should call autoproxy::init to
86#  do automatic configuration and then call this method to refine the details.
87#
88proc ::autoproxy::configure {args} {
89    variable options
90
91    if {[llength $args] == 0} {
92        foreach {opt value} [array get options] {
93            lappend r -$opt $value
94        }
95        return $r
96    }
97
98    while {[string match "-*" [set option [lindex $args 0]]]} {
99        switch -glob -- $option {
100            -host -
101            -proxy_h* { set options(proxy_host) [Pop args 1]}
102            -port -
103            -proxy_p* { set options(proxy_port) [Pop args 1]}
104            -no*      { set options(no_proxy) [Pop args 1] }
105            -basic    { Pop args; configure:basic $args ; break }
106            -authProc { set options(authProc) [Pop args] }
107            --        { Pop args; break }
108            default {
109                set opts [join [lsort [array names options]] ", -"]
110                return -code error "bad option \"$option\":\
111                       must be one of -$opts"
112            }
113        }
114        Pop args
115    }
116}
117
118# -------------------------------------------------------------------------
119# Description:
120#  Initialise the http proxy information from the environment or the
121#  registry (Win32)
122#
123#  This procedure will load the http package and re-writes the
124#  http::geturl method to add in the authorisation header.
125#
126#  A better solution will be to arrange for the http package to request the
127#  authorisation key on receiving an authorisation reqest.
128#
129proc ::autoproxy::init {{httpproxy {}} {no_proxy {}}} {
130    global tcl_platform
131    global env
132    variable winregkey
133    variable options
134
135    # Look for standard environment variables.
136    if {[string length $httpproxy] > 0} {
137
138        # nothing to do
139
140    } elseif {[info exists env(http_proxy)]} {
141        set httpproxy $env(http_proxy)
142        if {[info exists env(no_proxy)]} {
143            set no_proxy $env(no_proxy)
144        }
145    } else {
146        if {$tcl_platform(platform) == "windows"} {
147            #checker -scope block exclude nonPortCmd
148            package require registry 1.0
149            array set reg {ProxyEnable 0 ProxyServer "" ProxyOverride {}}
150            catch {
151                # IE5 changed ProxyEnable from a binary to a dword value.
152                switch -exact -- [registry type $winregkey "ProxyEnable"] {
153                    dword {
154                        set reg(ProxyEnable) [registry get $winregkey "ProxyEnable"]
155                    }
156                    binary {
157                        set v [registry get $winregkey "ProxyEnable"]
158                        binary scan $v i reg(ProxyEnable)
159                    }
160                    default {
161                        return -code error "unexpected type found for\
162                               ProxyEnable registry item"
163                    }
164                }
165                set reg(ProxyServer) [GetWin32Proxy http]
166                set reg(ProxyOverride) [registry get $winregkey "ProxyOverride"]
167            }
168            if {![string is bool $reg(ProxyEnable)]} {
169                set reg(ProxyEnable) 0
170            }
171            if {$reg(ProxyEnable)} {
172                set httpproxy $reg(ProxyServer)
173                set no_proxy  $reg(ProxyOverride)
174            }
175        }
176    }
177
178    # If we found something ...
179    if {[string length $httpproxy] > 0} {
180        # The http_proxy is supposed to be a URL - lets make sure.
181        if {![regexp {\w://.*} $httpproxy]} {
182            set httpproxy "http://$httpproxy"
183        }
184
185        # decompose the string.
186        array set proxy [uri::split $httpproxy]
187
188        # turn the no_proxy value into a tcl list
189        set no_proxy [string map {; " " , " "} $no_proxy]
190
191        # configure ourselves
192        configure -proxy_host $proxy(host) \
193            -proxy_port $proxy(port) \
194            -no_proxy $no_proxy
195
196        # Lift the authentication details from the environment if present.
197        if {[string length $proxy(user)] < 1 \
198                && [info exists env(http_proxy_user)] \
199                && [info exists env(http_proxy_pass)]} {
200            set proxy(user) $env(http_proxy_user)
201            set proxy(pwd)  $env(http_proxy_pass)
202        }
203
204        # Maybe the proxy url has authentication parameters?
205        # At this time, only Basic is supported.
206        if {[string length $proxy(user)] > 0} {
207            configure -basic -username $proxy(user) -password $proxy(pwd)
208        }
209
210        # setup and configure the http package to use our proxy info.
211        http::config -proxyfilter [namespace origin filter]
212    }
213    return $httpproxy
214}
215
216# autoproxy::GetWin32Proxy --
217#
218#	Parse the Windows Internet Settings registry key and return the
219#	protocol proxy requested. If the same proxy is in use for all
220#	protocols, then that will be returned. Otherwise the string is
221#	parsed. Example:
222#	 ftp=proxy:80;http=proxy:80;https=proxy:80
223#
224proc ::autoproxy::GetWin32Proxy {protocol} {
225    variable winregkey
226    #checker exclude nonPortCmd
227    set proxies [split [registry get $winregkey "ProxyServer"] ";"]
228    foreach proxy $proxies {
229        if {[string first = $proxy] == -1} {
230            return $proxy
231        } else {
232            foreach {prot host} [split $proxy =] break
233            if {[string compare $protocol $prot] == 0} {
234                return $host
235            }
236        }
237    }
238    return -code error "failed to identify an '$protocol' proxy"
239}
240
241# -------------------------------------------------------------------------
242# Description:
243#  Pop the nth element off a list. Used in options processing.
244proc ::autoproxy::Pop {varname {nth 0}} {
245    upvar $varname args
246    set r [lindex $args $nth]
247    set args [lreplace $args $nth $nth]
248    return $r
249}
250
251# -------------------------------------------------------------------------
252# Description
253#   An example user authentication procedure.
254# Returns:
255#   A two element list consisting of the users authentication id and
256#   password.
257proc ::autoproxy::defAuthProc {{user {}} {passwd {}} {realm {}}} {
258    if {[string length $realm] > 0} {
259        set title "Realm: $realm"
260    } else {
261        set title {}
262    }
263
264    # If you are using BWidgets then the following will do:
265    #
266    #    package require BWidget
267    #    return [PasswdDlg .defAuthDlg -parent {} -transient 0 \
268    #         -title $title -logintext $user -passwdtext $passwd]
269    #
270    # if you just have Tk and no BWidgets --
271
272    set dlg [toplevel .autoproxy_defAuthProc -class Dialog]
273    wm title $dlg $title
274    wm withdraw $dlg
275    label $dlg.ll -text Login -underline 0 -anchor w
276    entry $dlg.le -textvariable [namespace current]::${dlg}:l
277    label $dlg.pl -text Password -underline 0 -anchor w
278    entry $dlg.pe -show * -textvariable [namespace current]::${dlg}:p
279    button $dlg.ok -text OK -default active -width -11 \
280        -command [list set [namespace current]::${dlg}:ok 1]
281    grid $dlg.ll $dlg.le -sticky news
282    grid $dlg.pl $dlg.pe -sticky news
283    grid $dlg.ok - -sticky e
284    grid columnconfigure $dlg 1 -weight 1
285    bind $dlg <Return> [list $dlg.ok invoke]
286    bind $dlg <Alt-l> [list focus $dlg.le]
287    bind $dlg <Alt-p> [list focus $dlg.pe]
288    variable ${dlg}:l $user; variable ${dlg}:p $passwd
289    variable ${dlg}:ok 0
290    wm deiconify $dlg; focus $dlg.pe; update idletasks
291    set old [::grab current]; grab $dlg
292    tkwait variable [namespace current]::${dlg}:ok
293    grab release $dlg ; if {[llength $old] > 0} {::grab $old}
294    set r [list [set ${dlg}:l] [set ${dlg}:p]]
295    unset ${dlg}:l; unset ${dlg}:p; unset ${dlg}:ok
296    destroy $dlg
297    return $r
298}
299
300# -------------------------------------------------------------------------
301
302# Description:
303#  Implement support for the Basic authentication scheme (RFC 1945,2617).
304# Options:
305#  -user userid  - pass in the user ID (May require Windows NT domain
306#                  as DOMAIN\\username)
307#  -password pwd - pass in the user's password.
308#  -realm realm  - pass in the http realm.
309#
310proc ::autoproxy::configure:basic {arglist} {
311    variable options
312    array set opts {user {} passwd {} realm {}}
313    foreach {opt value} $arglist {
314        switch -glob -- $opt {
315            -u* { set opts(user) $value}
316            -p* { set opts(passwd) $value}
317            -r* { set opts(realm) $value}
318            default {
319                return -code error "invalid option \"$opt\": must be one of\
320                     -username or -password or -realm"
321            }
322        }
323    }
324
325    # If nothing was provided, try calling the authProc
326    if {$options(authProc) != {} \
327            && ($opts(user) == {} || $opts(passwd) == {})} {
328        set r [$options(authProc) $opts(user) $opts(passwd) $opts(realm)]
329        set opts(user) [lindex $r 0]
330        set opts(passwd) [lindex $r 1]
331    }
332
333    # Store the encoded string to avoid re-encoding all the time.
334    set options(basic) [list "Proxy-Authorization" \
335                            [concat "Basic" \
336                                 [base64::encode $opts(user):$opts(passwd)]]]
337    return
338}
339
340# -------------------------------------------------------------------------
341# Description:
342#  An http package proxy filter. This attempts to work out if a request
343#  should go via the configured proxy using a glob comparison against the
344#  no_proxy list items. A typical no_proxy list might be
345#   [list localhost *.my.domain.com 127.0.0.1]
346#
347#  If we are going to use the proxy - then insert the proxy authorization
348#  header.
349#
350proc ::autoproxy::filter {host} {
351    variable options
352
353    if {$options(proxy_host) == {}} {
354        return {}
355    }
356
357    foreach domain $options(no_proxy) {
358        if {[string match $domain $host]} {
359            return {}
360        }
361    }
362
363    # Add authorisation header to the request (by Anders Ramdahl)
364    catch {
365        upvar state State
366        if {$options(basic) != {}} {
367            set State(-headers) [concat $options(basic) $State(-headers)]
368        }
369    }
370    return [list $options(proxy_host) $options(proxy_port)]
371}
372
373# -------------------------------------------------------------------------
374# autoproxy::tls_connect --
375#
376#	Create a connection to a remote machine through a proxy
377#	if necessary. This is used by the tls_socket command for
378#	use with the http package but can also be used more generally
379#	provided your proxy will permit CONNECT attempts to ports
380#	other than port 443 (many will not).
381#	This command defers to 'tunnel_connect' to link to the target
382#	host and then upgrades the link to SSL/TLS
383#
384proc ::autoproxy::tls_connect {args} {
385    variable options
386    if {[string length $options(proxy_host)] > 0} {
387        set s [eval [linsert $args 0 tunnel_connect]]
388        fconfigure $s -blocking 1 -buffering none -translation binary
389        if {[string equal "-async" [lindex $args end-2]]} {
390            eval [linsert [lrange $args 0 end-3] 0 ::tls::import $s]
391        } else {
392            eval [linsert [lrange $args 0 end-2] 0 ::tls::import $s]
393        }
394    } else {
395        set s [eval [linsert $args 0 ::tls::socket]]
396    }
397    return $s
398}
399
400# autoproxy::tunnel_connect --
401#
402#	Create a connection to a remote machine through a proxy
403#	if necessary. This is used by the tls_socket command for
404#	use with the http package but can also be used more generally
405#	provided your proxy will permit CONNECT attempts to ports
406#	other than port 443 (many will not).
407#	Note: this command just opens the socket through the proxy to
408#	the target machine -- no SSL/TLS negotiation is done yet.
409#
410proc ::autoproxy::tunnel_connect {args} {
411    variable options
412    variable uid
413    set code ok
414    if {[string length $options(proxy_host)] > 0} {
415        set token [namespace current]::[incr uid]
416        upvar #0 $token state
417        set state(endpoint) [lrange $args end-1 end]
418        set state(state) connect
419        set state(data) ""
420        set state(useragent) [http::config -useragent]
421        set state(sock) [::socket $options(proxy_host) $options(proxy_port)]
422        fileevent $state(sock) writable [namespace code [list tunnel_write $token]]
423        vwait [set token](state)
424
425        if {[string length $state(error)] > 0} {
426            set result $state(error)
427            close $state(sock)
428            unset state
429            set code error
430        } elseif {$state(code) >= 300 || $state(code) < 200} {
431            set result [lindex $state(headers) 0]
432            regexp {HTTP/\d.\d\s+\d+\s+(.*)} $result -> result
433            close $state(sock)
434            set code error
435        } else {
436            set result $state(sock)
437        }
438        unset state
439    } else {
440        set result [eval [linsert $args 0 ::socket]]
441    }
442    return -code $code $result
443}
444
445proc ::autoproxy::tunnel_write {token} {
446    upvar #0 $token state
447    variable options
448    fileevent $state(sock) writable {}
449    if {[catch {set state(error) [fconfigure $state(sock) -error]} err]} {
450        set state(error) $err
451    }
452    if {[string length $state(error)] > 0} {
453        set state(state) error
454        return
455    }
456    fconfigure $state(sock) -blocking 0 -buffering line -translation crlf
457    foreach {host port} $state(endpoint) break
458    puts $state(sock) "CONNECT $host:$port HTTP/1.1"
459    puts $state(sock) "Host: $host"
460    if {[string length $state(useragent)] > 0} {
461        puts $state(sock) "User-Agent: $state(useragent)"
462    }
463    puts $state(sock) "Proxy-Connection: keep-alive"
464    puts $state(sock) "Connection: keep-alive"
465    if {[string length $options(basic)] > 0} {
466        puts $state(sock) [join $options(basic) ": "]
467    }
468    puts $state(sock) ""
469
470    fileevent $state(sock) readable [namespace code [list tunnel_read $token]]
471    return
472}
473
474proc ::autoproxy::tunnel_read {token} {
475    upvar #0 $token state
476    set len [gets $state(sock) line]
477    if {[eof $state(sock)]} {
478        fileevent $state(sock) readable {}
479        set state(state) eof
480    } elseif {$len == 0} {
481        set state(code) [lindex [split [lindex $state(headers) 0] { }] 1]
482        fileevent $state(sock) readable {}
483        set state(state) ok
484    } else {
485        lappend state(headers) $line
486    }
487}
488
489# autoproxy::tls_socket --
490#
491#	This can be used to handle TLS connections independently of
492#	proxy presence. It can only be used with the Tcl http package
493#	and to use it you must do:
494#	   http::register https 443 ::autoproxy::tls_socket
495#	After that you can use the http::geturl command to access
496#	secure web pages and any proxy details will be handled for you.
497#
498proc ::autoproxy::tls_socket {args} {
499    variable options
500
501    # Look into the http package for the actual target. If a proxy is in use then
502    # The function appends the proxy host and port and not the target.
503
504    upvar host uhost port uport
505    set args [lrange $args 0 end-2]
506    lappend args $uhost $uport
507
508    set s [eval [linsert $args 0 tls_connect]]
509
510    # record the tls connection status in the http state array.
511    upvar state state
512    tls::handshake $s
513    set state(tls_status) [tls::status $s]
514
515    return $s
516}
517
518# -------------------------------------------------------------------------
519
520package provide autoproxy $::autoproxy::version
521
522# -------------------------------------------------------------------------
523#
524# Local variables:
525#   mode: tcl
526#   indent-tabs-mode: nil
527# End:
528