#  autoconnect.tcl ---
#
#      Interface to socks4/5 or https to make usage of 'socket' transparent.
#      Can also be used as a wrapper for the 'socket' command without any
#      proxy configured.
#
#  Copyright (c) 2007  Mats Bengtsson
#  Modifications Copyright (c) Sergei Golovan <sgolovan@nes.ru>
#
#  This source file is distributed under the BSD license.
#
# $Id: autoconnect.tcl 1282 2007-10-26 17:40:59Z sergei $

package provide autoconnect 0.2

namespace eval autoconnect {
    variable options
    array set options {
	-proxy          ""
	-proxyhost      ""
	-proxyport      ""
	-proxyusername  ""
	-proxypassword  ""
	-proxyuseragent ""
	-proxyno        ""
	-proxyfilter    autoconnect::filter
    }

    variable packs
    array set packs {}
}

# autoconnect::register --

proc autoconnect::register {proxy connectCmd} {
    variable packs

    set packs($proxy) $connectCmd
}

# autoconnect::proxies --

proc autoconnect::proxies {} {
    variable packs

    return [linsert [lsort [array names packs]] 0 none]
}

# autoconnect::configure --
#
#       Get or set configuration options for the proxy.
#
# Arguments:
#       args:
#           -proxy            ""|socks4|socks5|https
#           -proxyhost        hostname
#           -proxyport        port number
#           -proxyusername    user ID
#           -proxypassword    password
#           -proxyno          glob list of hosts to not use proxy
#           -proxyfilter      tclProc {host}
#
# Results:
#       one or many option values depending on arguments.

proc autoconnect::configure {args} {
    variable options
    variable packs

    if {[llength $args] == 0} {
	return [array get options]
    } elseif {[llength $args] == 1} {
	return $options($args)
    } else {
	set idx [lsearch $args -proxy]
	if {$idx >= 0} {
	    set proxy [lindex $args [incr idx]]
	    if {[string length $proxy] && ![info exists packs($proxy)]} {
		return -code error "unsupported proxy \"$proxy\""
	    }
	}
	array set options $args
    }
}

proc autoconnect::init {} {
    # @@@ Here we should get default settings from some system API.
}

# autoconnect::socket --
#
#       Subclassing the 'socket' command. Only client side.
#       We use -command tclProc instead of -async + fileevent writable.
#
# Arguments:
#       host:       the peer address, not SOCKS server
#       port:       the peer's port number
#       args:
#           -command    tclProc {token status}
#                       the 'status' is any of:
#                       ok, error, timeout, network-failure,
#                       rsp_*, err_* (see socks4/5)
# Results:
#	A socket if -command is not specified or an empty string.

proc autoconnect::socket {host port args} {
    variable options

    set argsA(-command) ""
    array set argsA $args
    set proxy $options(-proxy)

    set hostport [$options(-proxyfilter) $host]
    if {[llength $hostport]} {
	set ahost [lindex $hostport 0]
	set aport [lindex $hostport 1]
    } else {
	set ahost $host
	set aport $port
    }

    # Connect ahost + aport.
    set sock [::socket -async $ahost $aport]
    set token [namespace current]::$sock
    fconfigure $sock -blocking 0
    fileevent $sock writable [namespace code [list writable $token]]

    variable $token
    upvar 0 $token state

    set state(host) $host
    set state(port) $port
    set state(sock) $sock
    set state(cmd)  $argsA(-command)

    if {[string length $state(cmd)]} {
	return
    } else {
	vwait $token\(status)

	set status $state(status)
	set sock $state(sock)
	catch {unset state}

	if {[string equal $status OK]} {
	    return $sock
	} else {
	    catch {close $sock}
	    return -code error $sock
	}
    }
}

proc autoconnect::get_opts {} {
    variable options

    set opts [list]
    if {[string length $options(-proxyusername)]} {
	lappend opts -username $options(-proxyusername)
    }
    if {[string length $options(-proxypassword)]} {
	lappend opts -password $options(-proxypassword)
    }
    if {[string length $options(-proxyuseragent)]} {
	lappend opts -useragent $options(-proxyuseragent)
    }
    return $opts
}

proc autoconnect::writable {token} {
    variable options
    variable packs
    variable $token
    upvar 0 $token state

    set proxy $options(-proxy)
    set sock $state(sock)
    fileevent $sock writable {}

    if {[catch {fconfigure $sock -peername}]} {
	Finish $token network-failure
    } else {
	if {[string length $proxy]} {
	    eval {$packs($proxy) $sock $state(host) $state(port) \
		      -command [namespace code [list SocksCb $token]]} [get_opts]
	} else {
	    Finish $token
	}
    }
    return
}

proc autoconnect::SocksCb {token status sock} {
    variable $token
    upvar 0 $token state

    if {[string equal $status OK]} {
	set state(sock) $sock
	Finish $token
    } else {
	Finish $token $sock
    }
    return
}

proc autoconnect::Finish {token {errormsg ""}} {
    variable $token
    upvar 0 $token state
    variable options

    if {[string length $state(cmd)]} {
	if {[string length $errormsg]} {
	    catch {close $state(sock)}
	    uplevel #0 $state(cmd) [list ERROR $errormsg]
	} else {
	    uplevel #0 $state(cmd) [list OK $state(sock)]
	}
	catch {unset state}
    } else {
	if {[string length $errormsg]} {
	    catch {close $state(sock)}
	    set state(sock) $errormsg
	    set state(status) ERROR
	} else {
	    set state(status) OK
	}
    }
    return
}

proc autoconnect::filter {host} {
    variable options
    if {[llength $options(-proxy)]} {
	foreach domain $options(-proxyno) {
	    if {[string match $domain $host]} {
		return [list]
	    }
	}
	return [list $options(-proxyhost) $options(-proxyport)]
    } else {
	return [list]
    }
}
