# $Id$

package require pconnect::socks4
package require pconnect::socks5
package require pconnect::https
package require http 2

::http::config -proxyhost "" -proxyport "" -proxyfilter ""

namespace eval proxy {
    set tproxies {}
    set hproxies {}

    foreach {key varlist} [array get ::proxyconf] {
	switch -- $key {
	    tunnel -
	    http {}
	    default {
		continue
	    }
	}

	foreach varname $::proxyconf($key) {
	    upvar #0 $varname p
	    if {![info exists p(type)] || \
		    [lsearch -exact {http https socks4 socks5} $p(type)] < 0} {
		continue
	    }
	    set proxy [list type $p(type)]
	    if {[info exists p(host)]} {
		lappend proxy host $p(host)
	    } else {
		continue
	    }
	    if {[info exists p(port)]} {
		lappend proxy port $p(port)
	    } else {
		continue
	    }
	    if {[info exists p(username)]} {
		lappend proxy username $p(username)
	    }
	    if {[info exists p(password)]} {
		lappend proxy password $p(password)
	    }
	    if {[info exists p(match)]} {
		lappend proxy match $p(match)
	    }
	    if {[info exists p(exclude)]} {
		lappend proxy exclude $p(exclude)
	    }

	    switch -- $key {
		tunnel {
		    lappend tproxies $proxy
		}
		http {
		    lappend hproxies $proxy
		}
	    }
	}
    }

    if {[llength $tproxies] > 0 || [llength $hproxies] > 0} {
	# There are proxies defined in the config file

	variable proxylist [list tunnels $tproxies http $hproxies]
    }

    custom::defvar proxylist {tunnels {} http {}} \
	[::msgcat::mc "Serialized array of proxy servers to connect via."] \
	-type string -group Hidden
}

# http package doesn't work with HTTPS URLs through proxy, so workaround this:

if {![catch {package require tls}]} {
    # proxy::tlssocket --
    #
    # Arguments:
    #	    ?options? host port
    #
    # Bugs:
    #	    Doesn't work with -async

    proc proxy::tlssocket {args} {
	set host [lindex $args end-1]
	set port [lindex $args end]

	# Find tunnelling proxy
	if {![catch {proxyfilter $host $port} answer] && $answer != {}} {
	    return [::tls::import \
			[::pconnect::socket $host $port \
			    -proxyfilter [namespace current]::proxyfilter]]
	} else {
	    return [eval [list ::tls::socket] $args]
	}
    }

    ::http::register https 443 [namespace current]::proxy::tlssocket
}

# ::http::geturl --
#
#	A wrapper around http::geturl which adds proxy authorization header
#	if necessary.

rename ::http::geturl ::http::geturl:orig

proc ::http::geturl {url args} {
    # Save and remove proxy settings

    set savedProxyHost   [::http::config -proxyhost]
    set savedProxyPort   [::http::config -proxyport]
    set savedProxyFilter [::http::config -proxyfilter]

    ::http::config -proxyhost "" -proxyport "" -proxyfilter ""

    # URLmatcher is borrowed from http package.
    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>
        $
    }

    set auth {}
    if {[regexp -- $URLmatcher $url -> \
                   proto user host port srvurl]} {

	if {$proto != "https"} {
	    ::http::config -proxyfilter ::proxy::proxyfilter

	    if {![catch {eval proxyfilter $host} answer]} {
		lassign $answer phost pport pusername ppassword
		if {![string equal $pusername ""] || ![string equal $ppassword ""]} {
		    set auth [list Proxy-Authorization \
				   "Basic [base64::encode \
					        [encoding convertto \
						          $pusername:$ppassword]]"]
		}
	    }
	}
    }

    set newArgs {}
    set q 0
    foreach {key val} $args {
	switch -- $key {
	    -headers {
		lappend newArgs $key [concat $val $auth]
		set q 1
	    }
	    default {
		lappend newArgs $key $val
	    }
	}
    }
    if {!$q} {
	lappend newArgs -headers $auth
    }

    set res [eval [list ::http::geturl:orig $url] $newArgs]

    ::http::config -proxyhost $savedProxyHost \
		   -proxyport $savedProxyPort \
		   -proxyfilter $savedProxyFilter
    return $res
}

proc proxy::open {} {
    variable proxylist

    set w .proxy

    if {[winfo exists $w]} {
	destroy $w
    }

    Dialog $w -title [::msgcat::mc "Manage proxy servers"] \
	      -separator 1 -anchor e \
	      -default 0 -cancel 1 \
	      -modal none

    $w add -text [::msgcat::mc "Save"] \
	   -command [namespace code [list save_proxies $w]]
    $w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]

    set f [$w getframe]

    set hf [frame $w.hf]
    pack $hf -side bottom

    set nb [NoteBook $f.nb]

    set tunnels_page [$nb insert end tunnels_page -text [::msgcat::mc "Tunnel proxies"]]
    set w1 [customize_frame $tunnels_page tunnels]

    set http_page [$nb insert end http_page -text [::msgcat::mc "HTTP proxies"]]
    set w2 [customize_frame $http_page http]

    $nb compute_size
    $nb raise tunnels_page
    grid $nb -row 0 -column 0 -sticky nswe
    grid columnconfigure $f 0 -weight 1
    grid rowconfigure $f 0 -weight 1

    if {$w1 > $w2} {
	$hf configure \
	    -width [expr {$w1 + [winfo pixels $f 1c]}]
    } else {
	$hf configure \
	    -width [expr {$w2 + [winfo pixels $f 1c]}]
    }

    $w draw
}

proc proxy::customize_frame {frame type} {
    variable data
    variable proxylist

    switch -- $type {
	tunnels {
	    set add_type https
	}
	http {
	    set add_type http
	}
	default {
	    return -code error
	}
    }

    array set Proxy $proxylist

    set tools [frame $frame.tools]
    pack $tools -side bottom -fill x
    
    set sw [ScrolledWindow $frame.sw -scrollbar vertical]
    set sf [ScrollableFrame $frame.fields -constrainedwidth yes]
    pack $sw -side bottom -expand yes -fill both
    $sw setwidget $sf
    set f [$sf getframe]

    bind $f <Destroy> [namespace code [list cleanup $f $type]]

    set add [button $tools.add \
		    -text [::msgcat::mc "Add proxy"] \
		    -command [namespace code \
			[list add_proxy $f $type $add_type "" "" "" "" * \
			      "localhost* 127.0.0.* 172.* 192.168.* 10.*"]]]
    pack $add -side right -pady 2m

    set data($type,counter) 0

    add_proxy $f $type remove "" "" "" "" "" ""

    if {[info exists Proxy($type)]} {
	foreach proxy $Proxy($type) {
	    array unset Args
	    array set Args $proxy

	    set add_args {}
	    foreach idx {type host port username password match exclude} {
		if {[info exists Args($idx)]} {
		    lappend add_args $Args($idx)
		} else {
		    lappend add_args ""
		}
	    }

	    eval [list add_proxy $f $type] $add_args
	}
    }

    update idletasks
    set w [winfo reqwidth $f]

    remove_proxy $f $type 1

    return $w
}

proc proxy::cleanup {f type} {
    variable data

    array unset data $type,*
}

proc proxy::save_proxies {w} {
    variable data
    variable proxylist

    foreach type {tunnels http} {
	set proxies($type) {}
	for {set i 1} {$i <= $data($type,counter)} {incr i} {
	    if {$data($type,type,$i) == "remove"} continue

	    if {[lsearch {http https socks4 socks5} $data($type,type,$i)] < 0} {
		continue
	    }

	    lappend proxies($type) [list type $data($type,type,$i) \
					 host $data($type,host,$i) \
					 port $data($type,port,$i) \
					 username $data($type,username,$i) \
					 password $data($type,password,$i) \
					 match $data($type,match,$i) \
					 exclude $data($type,exclude,$i)] 
	}
    }

    destroy $w

    set proxylist [list tunnels $proxies(tunnels) http $proxies(http)]
}

proc proxy::add_proxy {f type ptype host port username password match exclude} {
    variable data

    switch -- $type {
	tunnels {
	    if {[lsearch -exact {remove https socks4 socks5} $ptype] < 0} return
	}
	http {
	    if {[lsearch -exact {remove http} $ptype] < 0} return
	}
	default {
	    return
	}
    }

    set i [incr data($type,counter)]

    set data($type,type,$i) $ptype
    set data($type,host,$i) $host
    set data($type,port,$i) $port
    set data($type,username,$i) $username
    set data($type,password,$i) $password
    set data($type,match,$i) $match
    set data($type,exclude,$i) $exclude

    set erow [lindex [grid size $f] 1]

    set ff [frame $f.p$i -borderwidth 2 -relief groove -padx 2m -pady 2m]
    grid $ff -row $erow -column 0 -rowspan 3 -sticky nwes -padx 1m -pady 1m

    set row 0

    label $ff.lproxy$i -text [::msgcat::mc "Proxy type:"]
    grid $ff.lproxy$i -row $row -column 0 -sticky e
    frame $ff.proxy$i
    grid $ff.proxy$i -row $row -column 1 -columnspan 3 -sticky w

    set col 0

    if {$type == "tunnels"} {
	radiobutton $ff.proxy$i.https -text [::msgcat::mc "HTTPS"] \
		    -variable [namespace current]::data($type,type,$i) -value https
	grid $ff.proxy$i.https -row 0 -column [incr col] -sticky w

	radiobutton $ff.proxy$i.socks4 -text [::msgcat::mc "SOCKS4a"] \
		    -variable [namespace current]::data($type,type,$i) -value socks4
	grid $ff.proxy$i.socks4 -row 0 -column [incr col] -sticky w

	radiobutton $ff.proxy$i.socks5 -text [::msgcat::mc "SOCKS5"] \
		    -variable [namespace current]::data($type,type,$i) -value socks5
	grid $ff.proxy$i.socks5 -row 0 -column [incr col] -sticky w
    } else {
	label $ff.proxy$i.https -text [::msgcat::mc "HTTP"]
	grid $ff.proxy$i.https -row 0 -column [incr col] -sticky w
    }

    incr row

    label $ff.lhost$i -text [::msgcat::mc "Host:"]
    entry $ff.host$i -textvariable [namespace current]::data($type,host,$i)
    label $ff.lport$i -text [::msgcat::mc "Port:"]
    Spinbox $ff.port$i 0 65535 1 [namespace current]::data($type,port,$i)

    grid $ff.lhost$i -row $row -column 0 -sticky e
    grid $ff.host$i  -row $row -column 1 -sticky ew
    grid $ff.lport$i -row $row -column 2 -sticky e
    grid $ff.port$i  -row $row -column 3 -sticky ew

    incr row

    label $ff.lusername$i -text [::msgcat::mc "Username:"]
    entry $ff.username$i -textvariable [namespace current]::data($type,username,$i)
    label $ff.lpassword$i -text [::msgcat::mc "Password:"]
    entry $ff.password$i -show * -textvariable [namespace current]::data($type,password,$i)

    grid $ff.lusername$i -row $row -column 0 -sticky e
    grid $ff.username$i  -row $row -column 1 -sticky ew
    grid $ff.lpassword$i -row $row -column 2 -sticky e
    grid $ff.password$i  -row $row -column 3 -sticky ew

    incr row

    label $ff.lmatch$i -text [::msgcat::mc "Match:"]
    entry $ff.match$i \
	  -textvariable [namespace current]::data($type,match,$i)

    grid $ff.lmatch$i -row $row -column 0 -sticky e
    grid $ff.match$i  -row $row -column 1 -columnspan 3 -sticky ew

    incr row

    label $ff.lexclude$i -text [::msgcat::mc "Exclude:"]
    entry $ff.exclude$i \
	  -textvariable [namespace current]::data($type,exclude,$i)

    grid $ff.lexclude$i -row $row -column 0 -sticky e
    grid $ff.exclude$i  -row $row -column 1 -columnspan 3 -sticky ew

    grid columnconfigure $ff 1 -weight 3
    grid columnconfigure $ff 2 -weight 1
    grid columnconfigure $ff 3 -weight 3

    button $f.moveup$i -text [::msgcat::mc "Move up"] \
	   -command [namespace code [list move_proxy_up $f $type $i]]
    button $f.movedown$i -text [::msgcat::mc "Move down"] \
	   -command [namespace code [list move_proxy_down $f $type $i]]
    button $f.remov$i -text [::msgcat::mc "Remove"] \
	   -command [namespace code [list remove_proxy $f $type $i]]

    grid $f.moveup$i -row $erow -column 1 -sticky ews -padx 1m
    grid $f.movedown$i -row [expr {$erow+1}] -column 1 -sticky ewns -padx 1m
    grid $f.remov$i -row [expr {$erow+2}] -column 1 -sticky ewn -padx 1m

    grid rowconfigure $f $erow -weight 1
    grid rowconfigure $f [expr {$erow+2}] -weight 1
    grid columnconfigure $f 0 -weight 1
}

proc proxy::remove_proxy {f type i} {
    variable data

    destroy $f.p$i
    destroy $f.moveup$i
    destroy $f.movedown$i
    destroy $f.remov$i

    set data($type,type,$i) remove
}

proc proxy::move_proxy_up {f type i} {
    variable data

    set j $i
    incr j -1
    while {$j > 0 && $data($type,type,$j) == "remove"} {
	incr j -1
    }

    if {$j > 0} {
	switch_proxies $f $type $i $j
    }
}


proc proxy::move_proxy_down {f type i} {
    variable data

    set j $i
    incr j 1
    while {$j <= $data($type,counter) && $data($type,type,$j) == "remove"} {
	incr j 1
    }

    if {$j <= $data($type,counter)} {
	switch_proxies $f $type $i $j
    }
}


proc proxy::switch_proxies {f type i j} {
    variable data

    set ptype    $data($type,type,$i)
    set host     $data($type,host,$i)
    set port     $data($type,port,$i)
    set username $data($type,username,$i)
    set password $data($type,password,$i)
    set match    $data($type,match,$i)
    set exclude  $data($type,exclude,$i)
    
    set data($type,type,$i)     $data($type,type,$j)
    set data($type,host,$i)     $data($type,host,$j)
    set data($type,port,$i)     $data($type,port,$j)
    set data($type,username,$i) $data($type,username,$j)
    set data($type,password,$i) $data($type,password,$j)
    set data($type,match,$i)    $data($type,match,$j)
    set data($type,exclude,$i)  $data($type,exclude,$j)

    set data($type,type,$j)     $ptype
    set data($type,host,$j)     $host
    set data($type,port,$j)     $port
    set data($type,username,$j) $username
    set data($type,password,$j) $password
    set data($type,match,$j)    $match
    set data($type,exclude,$j)  $exclude
}

proc proxy::proxyfilter {host {port -1}} {
    variable proxylist

    array set Proxy $proxylist

    if {$port < 0} {
	# HTTP proxy

	set plist $Proxy(http)
    } else {
	# Tunnel proxy

	set plist $Proxy(tunnels)
    }

    foreach proxy $plist {
	array unset Args
	array set Args $proxy

	if {[lsearch -exact {http https socks4 socks5} $Args(type)] < 0} {
	    continue
	}

	if {![info exists Args(host)] || [string length $Args(host)] == 0} {
	    continue
	}

	if {![info exists Args(port)] || ![string is integer -strict $Args(port)] || \
	        $Args(port) < 0 || $Args(port) >= 65536} {
	    continue
	}

	set m 0
	if {[info exists Args(match)]} {
	    foreach pattern [split $Args(match)] {
		if {[string match -nocase $pattern $host]} {
		    set m 1
		    break
		}
	    }
	}

	set x 0
	if {[info exists Args(exclude)]} {
	    foreach pattern [split $Args(exclude)] {
		if {[string match -nocase $pattern $host]} {
		    set x 1
		    break
		}
	    }
	}

	if {$m && !$x} {
	    if {$port < 0} {
		set res [list $Args(host) $Args(port)]
	    } else {
		set res [list $Args(type) $Args(host) $Args(port)]
	    }

	    if {[info exists Args(username)] && [info exists Args(password)]} {
		lappend res $Args(username) $Args(password)
	    }

	    return $res
	}
    }

    return {}
}