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 6 2009-02-03 00:37:42Z jcw@equi4.com $ 24 25package require http; # tcl 26package require uri; # tcllib 27package require base64; # tcllib 28 29namespace eval ::autoproxy { 30 variable rcsid {$Id: autoproxy.tcl 6 2009-02-03 00:37:42Z jcw@equi4.com $} 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