# autoproxy.tcl - Copyright (C) 2002-2008, 2017 Pat Thoyts <[email protected]>
#
# On Unix the standard for identifying the local HTTP proxy server
# seems to be to use the environment variable http_proxy or ftp_proxy and
# no_proxy to list those domains to be excluded from proxying.
#
# On Windows we can retrieve the Internet Settings values from the registry
# to obtain pretty much the same information.
#
# With this information we can setup a suitable filter procedure for the
# Tcl http package and arrange for automatic use of the proxy.
#
# Example:
# package require autoproxy
# autoproxy::init
# set tok [http::geturl http://wiki.tcl.tk/]
# http::data $tok
#
# To support https add:
# package require tls
# http::register https 443 ::autoproxy::tls_socket
package require http; # tcl
package require uri; # tcllib
package require base64; # tcllib
namespace eval ::autoproxy {
variable options
if {! [info exists options]} {
array set options {
proxy_host ""
proxy_port 80
no_proxy {}
basic {}
authProc {}
tls_package tls
}
}
variable uid
if {![info exists uid]} { set uid 0 }
variable winregkey
set winregkey [join {
HKEY_CURRENT_USER
Software Microsoft Windows
CurrentVersion "Internet Settings"
} \\]
}
# -------------------------------------------------------------------------
# Description:
# Obtain configuration options for the server.
#
proc ::autoproxy::cget {option} {
variable options
switch -glob -- $option {
-host -
-proxy_h* { set options(proxy_host) }
-port -
-proxy_p* { set options(proxy_port) }
-no* { set options(no_proxy) }
-basic { set options(basic) }
-authProc { set options(authProc) }
-tls_package { set options(tls_package) }
default {
set err [join [lsort [array names options]] ", -"]
return -code error "bad option \"$option\":\
must be one of -$err"
}
}
}
# -------------------------------------------------------------------------
# Description:
# Configure the autoproxy package settings.
# You may only configure one type of authorisation at a time as once we hit
# -basic, -digest or -ntlm - all further args are passed to the protocol
# specific script.
#
# Of course, most of the point of this package is to fill as many of these
# fields as possible automatically. You should call autoproxy::init to
# do automatic configuration and then call this method to refine the details.
#
proc ::autoproxy::configure {args} {
variable options
if {[llength $args] == 0} {
foreach {opt value} [array get options] {
lappend r -$opt $value
}
return $r
}
while {[string match "-*" [set option [lindex $args 0]]]} {
switch -glob -- $option {
-host -
-proxy_h* { set options(proxy_host) [Pop args 1]}
-port -
-proxy_p* { set options(proxy_port) [Pop args 1]}
-no* { set options(no_proxy) [Pop args 1] }
-basic { Pop args; configure:basic $args ; break }
-authProc { set options(authProc) [Pop args 1] }
-tls_package {
set tls_package [Pop args 1]
if {$tls_package ni {tls twapi}} {
error "Invalid TLS package option '$tls_package'. Must be 'tls' or 'twapi'"
}
set options(tls_package) $tls_package
}
-- { Pop args; break }
default {
set opts [join [lsort [array names options]] ", -"]
return -code error "bad option \"$option\":\
must be one of -$opts"
}
}
Pop args
}
}
# -------------------------------------------------------------------------
# Description:
# Initialise the http proxy information from the environment or the
# registry (Win32)
#
# This procedure will load the http package and re-writes the
# http::geturl method to add in the authorisation header.
#
# A better solution will be to arrange for the http package to request the
# authorisation key on receiving an authorisation reqest.
#
proc ::autoproxy::init {{httpproxy {}} {no_proxy {}}} {
global tcl_platform
global env
variable winregkey
variable options
# Look for standard environment variables.
if {[string length $httpproxy] > 0} {
# nothing to do
} elseif {[info exists env(http_proxy)]} {
set httpproxy $env(http_proxy)
if {[info exists env(no_proxy)]} {
set no_proxy $env(no_proxy)
}
} else {
if {$tcl_platform(platform) == "windows"} {
#checker -scope block exclude nonPortCmd
package require registry 1.0
array set reg {ProxyEnable 0 ProxyServer "" ProxyOverride {}}
catch {
# IE5 changed ProxyEnable from a binary to a dword value.
switch -exact -- [registry type $winregkey "ProxyEnable"] {
dword {
set reg(ProxyEnable) [registry get $winregkey "ProxyEnable"]
}
binary {
set v [registry get $winregkey "ProxyEnable"]
binary scan $v i reg(ProxyEnable)
}
default {
return -code error "unexpected type found for\
ProxyEnable registry item"
}
}
set reg(ProxyServer) [GetWin32Proxy http]
set reg(ProxyOverride) [registry get $winregkey "ProxyOverride"]
}
if {![string is bool $reg(ProxyEnable)]} {
set reg(ProxyEnable) 0
}
if {$reg(ProxyEnable)} {
set httpproxy $reg(ProxyServer)
set no_proxy $reg(ProxyOverride)
}
}
}
# If we found something ...
if {[string length $httpproxy] > 0} {
# The http_proxy is supposed to be a URL - lets make sure.
if {![regexp {\w://.*} $httpproxy]} {
set httpproxy "http://$httpproxy"
}
# decompose the string.
array set proxy [uri::split $httpproxy]
# turn the no_proxy value into a tcl list
set no_proxy [string map {; " " , " "} $no_proxy]
# configure ourselves
configure -proxy_host $proxy(host) \
-proxy_port $proxy(port) \
-no_proxy $no_proxy
# Lift the authentication details from the environment if present.
if {[string length $proxy(user)] < 1 \
&& [info exists env(http_proxy_user)] \
&& [info exists env(http_proxy_pass)]} {
set proxy(user) $env(http_proxy_user)
set proxy(pwd) $env(http_proxy_pass)
}
# Maybe the proxy url has authentication parameters?
# At this time, only Basic is supported.
if {[string length $proxy(user)] > 0} {
configure -basic -username $proxy(user) -password $proxy(pwd)
}
# setup and configure the http package to use our proxy info.
http::config -proxyfilter [namespace origin filter]
}
return $httpproxy
}
# autoproxy::GetWin32Proxy --
#
# Parse the Windows Internet Settings registry key and return the
# protocol proxy requested. If the same proxy is in use for all
# protocols, then that will be returned. Otherwise the string is
# parsed. Example:
# ftp=proxy:80;http=proxy:80;https=proxy:80
#
proc ::autoproxy::GetWin32Proxy {protocol} {
variable winregkey
#checker exclude nonPortCmd
set proxies [split [registry get $winregkey "ProxyServer"] ";"]
foreach proxy $proxies {
if {[string first = $proxy] == -1} {
return $proxy
} else {
foreach {prot host} [split $proxy =] break
if {[string compare $protocol $prot] == 0} {
return $host
}
}
}
return -code error "failed to identify an '$protocol' proxy"
}
# -------------------------------------------------------------------------
# Description:
# Pop the nth element off a list. Used in options processing.
proc ::autoproxy::Pop {varname {nth 0}} {
upvar $varname args
set r [lindex $args $nth]
set args [lreplace $args $nth $nth]
return $r
}
# -------------------------------------------------------------------------
# Description
# An example user authentication procedure.
# Returns:
# A two element list consisting of the users authentication id and
# password.
proc ::autoproxy::defAuthProc {{user {}} {passwd {}} {realm {}}} {
if {[string length $realm] > 0} {
set title "Realm: $realm"
} else {
set title {}
}
# If you are using BWidgets then the following will do:
#
# package require BWidget
# return [PasswdDlg .defAuthDlg -parent {} -transient 0 \
# -title $title -logintext $user -passwdtext $passwd]
#
# if you just have Tk and no BWidgets --
set dlg [toplevel .autoproxy_defAuthProc -class Dialog]
wm title $dlg $title
wm withdraw $dlg
label $dlg.ll -text Login -underline 0 -anchor w
entry $dlg.le -textvariable [namespace current]::${dlg}:l
label $dlg.pl -text Password -underline 0 -anchor w
entry $dlg.pe -show * -textvariable [namespace current]::${dlg}:p
button $dlg.ok -text OK -default active -width -11 \
-command [list set [namespace current]::${dlg}:ok 1]
grid $dlg.ll $dlg.le -sticky news
grid $dlg.pl $dlg.pe -sticky news
grid $dlg.ok - -sticky e
grid columnconfigure $dlg 1 -weight 1
bind $dlg <Return> [list $dlg.ok invoke]
bind $dlg <Alt-l> [list focus $dlg.le]
bind $dlg <Alt-p> [list focus $dlg.pe]
variable ${dlg}:l $user; variable ${dlg}:p $passwd
variable ${dlg}:ok 0
wm deiconify $dlg; focus $dlg.pe; update idletasks
set old [::grab current]; grab $dlg
tkwait variable [namespace current]::${dlg}:ok
grab release $dlg ; if {[llength $old] > 0} {::grab $old}
set r [list [set ${dlg}:l] [set ${dlg}:p]]
unset ${dlg}:l; unset ${dlg}:p; unset ${dlg}:ok
destroy $dlg
return $r
}
# -------------------------------------------------------------------------
# Description:
# Implement support for the Basic authentication scheme (RFC 1945,2617).
# Options:
# -user userid - pass in the user ID (May require Windows NT domain
# as DOMAIN\\username)
# -password pwd - pass in the user's password.
# -realm realm - pass in the http realm.
#
proc ::autoproxy::configure:basic {arglist} {
variable options
array set opts {user {} passwd {} realm {}}
foreach {opt value} $arglist {
switch -glob -- $opt {
-u* { set opts(user) $value}
-p* { set opts(passwd) $value}
-r* { set opts(realm) $value}
-- { break }
default {
return -code error "invalid option \"$opt\": must be one of\
-username or -password or -realm"
}
}
}
# If nothing was provided, try calling the authProc
if {$options(authProc) != {} \
&& ($opts(user) == {} || $opts(passwd) == {})} {
set r [$options(authProc) $opts(user) $opts(passwd) $opts(realm)]
set opts(user) [lindex $r 0]
set opts(passwd) [lindex $r 1]
}
if {$opts(user) eq ""} {
set options(basic) ""
} else {
# Store the encoded string to avoid re-encoding all the time.
set options(basic) [list "Proxy-Authorization" \
[concat "Basic" \
[base64::encode $opts(user):$opts(passwd)]]]
}
return
}
# -------------------------------------------------------------------------
# Description:
# An http package proxy filter. This attempts to work out if a request
# should go via the configured proxy using a glob comparison against the
# no_proxy list items. A typical no_proxy list might be
# [list localhost *.my.domain.com 127.0.0.1]
#
# If we are going to use the proxy - then insert the proxy authorization
# header.
#
proc ::autoproxy::filter {host} {
variable options
if {$options(proxy_host) == {}} {
return {}
}
foreach domain $options(no_proxy) {
if {[string match $domain $host]} {
return {}
}
}
# Add authorisation header to the request (by Anders Ramdahl)
catch {
upvar state State
if {$options(basic) != {}} {
set State(-headers) [concat $options(basic) $State(-headers)]
}
}
return [list $options(proxy_host) $options(proxy_port)]
}
# -------------------------------------------------------------------------
# autoproxy::tls_connect --
#
# Create a connection to a remote machine through a proxy
# if necessary. This is used by the tls_socket command for
# use with the http package but can also be used more generally
# provided your proxy will permit CONNECT attempts to ports
# other than port 443 (many will not).
# This command defers to 'tunnel_connect' to link to the target
# host and then upgrades the link to SSL/TLS
#
proc ::autoproxy::tls_connect {args} {
variable options
set peersubject [lindex $args end-1]
if {[string length $options(proxy_host)] > 0} {
set s [eval [linsert $args 0 tunnel_connect]]
fconfigure $s -blocking 1 -buffering none -translation binary
if {[string equal "-async" [lindex $args end-2]]} {
if {$options(tls_package) eq "twapi"} {
set s [eval [linsert [lrange $args 0 end-3] 0 ::twapi::starttls $s -peersubject $peersubject]]
} else {
eval [linsert [lrange $args 0 end-3] 0 ::tls::import $s]
}
} else {
if {$options(tls_package) eq "twapi"} {
set s [eval [linsert [lrange $args 0 end-2] 0 ::twapi::starttls $s -peersubject $peersubject]]
} else {
eval [linsert [lrange $args 0 end-2] 0 ::tls::import $s]
}
}
} else {
if {$options(tls_package) eq "twapi"} {
set s [eval [linsert $args 0 ::twapi::tls_socket]]
} else {
set s [eval [linsert $args 0 ::tls::socket]]
}
}
return $s
}
# autoproxy::tunnel_connect --
#
# Create a connection to a remote machine through a proxy
# if necessary. This is used by the tls_socket command for
# use with the http package but can also be used more generally
# provided your proxy will permit CONNECT attempts to ports
# other than port 443 (many will not).
# Note: this command just opens the socket through the proxy to
# the target machine -- no SSL/TLS negotiation is done yet.
#
proc ::autoproxy::tunnel_connect {args} {
variable options
variable uid
set code ok
# args = ... host port
# and the host/port is the actual endpoint we want to talk to,
# regardless of any proxying. See our caller tls_connect for
# ensuring this by peeking into the http package internals.
# To handle proxying properly we have to run through 'filter'
# (again), to ensure that proxy exceptions are correctly taken
# into account.
set proxy [filter [lindex $args end-1]]
if {[llength $proxy]} {
foreach {proxy_host proxy_port} $proxy break
set token [namespace current]::[incr uid]
upvar #0 $token state
set state(endpoint) [lrange $args end-1 end]
set state(state) connect
set state(data) ""
set state(useragent) [http::config -useragent]
set state(sock) [::socket $proxy_host $proxy_port]
fileevent $state(sock) writable [namespace code [list tunnel_write $token]]
vwait [set token](state)
if {[string length $state(error)] > 0} {
set result $state(error)
close $state(sock)
unset state
set code error
} elseif {[info exists state(code)] &&
(($state(code) >= 300) ||
($state(code) < 200))} {
set result [lindex $state(headers) 0]
regexp {HTTP/\d.\d\s+\d+\s+(.*)} $result -> result
close $state(sock)
set code error
} else {
set result $state(sock)
}
unset state
} else {
set result [eval [linsert $args 0 ::socket]]
}
return -code $code $result
}
proc ::autoproxy::tunnel_write {token} {
upvar #0 $token state
variable options
fileevent $state(sock) writable {}
if {[catch {set state(error) [fconfigure $state(sock) -error]} err]} {
set state(error) $err
}
if {[string length $state(error)] > 0} {
set state(state) error
return
}
fconfigure $state(sock) -blocking 0 -buffering line -translation crlf
foreach {host port} $state(endpoint) break
puts $state(sock) "CONNECT $host:$port HTTP/1.1"
puts $state(sock) "Host: $host"
if {[string length $state(useragent)] > 0} {
puts $state(sock) "User-Agent: $state(useragent)"
}
puts $state(sock) "Proxy-Connection: keep-alive"
puts $state(sock) "Connection: keep-alive"
if {[string length $options(basic)] > 0} {
puts $state(sock) [join $options(basic) ": "]
}
puts $state(sock) ""
fileevent $state(sock) readable [namespace code [list tunnel_read $token]]
return
}
proc ::autoproxy::tunnel_read {token} {
upvar #0 $token state
set len [gets $state(sock) line]
if {[eof $state(sock)]} {
fileevent $state(sock) readable {}
set state(state) eof
} elseif {$len == 0} {
set state(code) [lindex [split [lindex $state(headers) 0] { }] 1]
fileevent $state(sock) readable {}
set state(state) ok
} else {
lappend state(headers) $line
}
}
# autoproxy::tls_socket --
#
# This can be used to handle TLS connections independently of
# proxy presence. It can only be used with the Tcl http package
# and to use it you must do:
# http::register https 443 ::autoproxy::tls_socket
# After that you can use the http::geturl command to access
# secure web pages and any proxy details will be handled for you.
#
proc ::autoproxy::tls_socket {args} {
variable options
# Look into the http package for the actual target. If a proxy is in use then
# The function appends the proxy host and port and not the target.
upvar host uhost port uport
set args [lrange $args 0 end-2]
lappend args $uhost $uport
set s [eval [linsert $args 0 tls_connect]]
# record the tls connection status in the http state array.
upvar state state
if {$options(tls_package) eq "twapi"} {
set security_context [fconfigure $s -context]
set cert [twapi::sspi_remote_cert $security_context]
set cert_info [twapi::cert_info $cert]
twapi::cert_release $cert
dict set state(tls_status) issuer [dict get $cert_info -issuer]
dict set state(tls_status) subject [dict get $cert_info -subject]
dict set state(tls_status) notBefore [dict get $cert_info -start]
dict set state(tls_status) notAfter [dict get $cert_info -end]
# Note: binary encode hex was not available in older Tcl, use twapi::hex
dict set state(tls_status) serial [twapi::hex [dict get $cert_info -serialnumber]]
# TBD - dict set state(tls_status) cipher
# TBD - dict set state(tls_status) sbits
} else {
tls::handshake $s
set state(tls_status) [tls::status $s]
}
return $s
}
# -------------------------------------------------------------------------
package provide autoproxy 1.7
# -------------------------------------------------------------------------
#
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
