# $Id: transports.tcl 1282 2007-10-26 17:40:59Z sergei $

namespace eval transport {
    variable capabilities [list tcp http_poll]
    variable disconnect quick
}

proc transport::capabilities {} {
    variable capabilities
    return $capabilities
}

######################################################################
#
# TCP Socket Support
#
######################################################################

namespace eval transport::tcp {}

proc transport::tcp::connect {connid server port args} {
    variable $connid
    upvar 0 $connid lib

    set sock [eval [list autoconnect::socket $server $port] $args]
    fconfigure $sock -blocking 0 -buffering none \
	       -translation auto -encoding utf-8
    set lib(socket) $sock

    fileevent $sock readable \
	      [list [namespace current]::inmsg $connid $sock]

    return $sock
}

proc transport::tcp::outmsg {connid msg} {
    variable $connid
    upvar 0 $connid lib

    if {![info exists lib(socket)]} {
	::LOG "error ([namespace current]::outmsg)\
	       Cannot write to socket: socket for\
	       connection $connid doesn't exist"
	return -2
    }

    if {[catch { puts -nonewline $lib(socket) $msg }]} {
	::LOG "error ([namespace current]::outmsg)\
	       Cannot write to socket: $lib(socket)"
	return -2
    }
}

proc transport::tcp::start_stream {connid server args} {
    return [outmsg $connid \
		   [eval [list jlib::wrapper:streamheader $server] $args]]
}

proc transport::tcp::finish_stream {connid args} {
    return [outmsg $connid [jlib::wrapper:streamtrailer]]
}

proc transport::tcp::disconnect {connid} {
    variable $connid
    upvar 0 $connid lib

    catch {
	if {[set [namespace parent]::disconnect] == "quick"} {
	    flush $lib(socket)
	} else {
	    fconfigure $lib(socket) -blocking 1
	    flush $lib(socket)
	    vwait [namespace current]::${connid}(socket)
	}
    }
}

proc transport::tcp::close {connid} {
    variable $connid
    upvar 0 $connid lib

    catch {fileevent $lib(socket) readable {}}
    catch {::close $lib(socket)}

    catch {unset lib}
}

######################################################################
proc transport::tcp::inmsg {connid sock} {
    set msg ""
    catch { set msg [read $sock] }

    jlib::inmsg $connid $msg [eof $sock]
}

######################################################################
# TODO Cleanup
proc transport::tcp::to_compress {connid method} {
    variable $connid
    upvar 0 $connid lib

    set [namespace parent]::${method}::${connid}(socket) $lib(socket)
    eval [list [namespace parent]::${method}::import $connid]
    set ::jlib::lib($connid,transport) $method

    catch {unset lib}
}

proc transport::tcp::to_tls {connid args} {
    variable $connid
    upvar 0 $connid lib

    set [namespace parent]::tls::${connid}(socket) $lib(socket)
    eval [list [namespace parent]::tls::tls_import $connid] $args
    set ::jlib::lib($connid,transport) tls

    catch {unset lib}
}


######################################################################
#
# Zlib Compressed Socket Support
#
######################################################################

if {![catch { package require zlib 1.0 }]} {
    lappend transport::capabilities compress
}

namespace eval transport::zlib {}

proc transport::zlib::connect {connid server port args} {
    variable $connid
    upvar 0 $connid lib

    set sock [eval [list autoconnect::socket $server $port] $args]

    set lib(socket) $sock
    import $connid

    return $sock
}

proc transport::zlib::outmsg {connid msg} {
    variable $connid
    upvar 0 $connid lib

    if {![info exists lib(socket)]} {
	::LOG "error ([namespace current]::outmsg)\
	       Cannot write to socket: socket for connection\
	       $connid doesn't exist"
	return -2
    }

    if {[catch { puts -nonewline $lib(socket) $msg }]} {
	::LOG "error ([namespace current]::outmsg)\
	       Cannot write to socket: $lib(socket)"
	return -2
    }
    flush $lib(socket)
    fconfigure $lib(socket) -flush output
}

proc transport::zlib::start_stream {connid server args} {
    return [outmsg $connid \
		   [eval [list jlib::wrapper:streamheader $server] $args]]
}

proc transport::zlib::finish_stream {connid args} {
    return [outmsg $connid [jlib::wrapper:streamtrailer]]
}

proc transport::zlib::disconnect {connid} {
    variable $connid
    upvar 0 $connid lib

    catch {
	if {[set [namespace parent]::disconnect] == "quick"} {
	    flush $lib(socket)
	    fconfigure $lib(socket) -finish output
	} else {
	    fconfigure $lib(socket) -blocking 1
	    flush $lib(socket)
	    fconfigure $lib(socket) -finish output
	    vwait [namespace current]::${connid}(socket)
	}
    }
}

proc transport::zlib::close {connid} {
    variable $connid
    upvar 0 $connid lib

    catch {fileevent $lib(socket) readable {}}
    catch {::close $lib(socket)}

    catch {unset lib}
}

######################################################################
proc transport::zlib::inmsg {connid sock} {
    set msg ""
    catch {
	fconfigure $sock -flush input
	set msg [read $sock]
    }

    jlib::inmsg $connid $msg [eof $sock]
}

######################################################################
proc transport::zlib::import {connid args} {
    variable $connid
    upvar 0 $connid lib

    set sock $lib(socket)
    fconfigure $sock -blocking 0 -buffering none \
	       -translation auto -encoding utf-8
    zlib stream $sock RDWR -output compress -input decompress

    fileevent $sock readable \
	      [list [namespace current]::inmsg $connid $sock]
}

######################################################################
#
# TLS Socket Support
#
######################################################################

if {![catch { package require tls 1.4 }]} {
    lappend transport::capabilities tls
}

namespace eval transport::tls {}

proc transport::tls::connect {connid server port args} {
    variable $connid
    upvar 0 $connid lib

    set tlsargs {}
    foreach {opt val} $args {
	switch -- $opt {
	    -cacertstore {
		if {$val != ""} {
		    if {[file isdirectory $val]} {
			lappend tlsargs -cadir $val
		    } else {
			lappend tlsargs -cafile $val
		    }
		}
	    }
	    -certfile  -
	    -keyfile   {
		if {$val != ""} {
		    lappend tlsargs $opt $val
		}
	    }
	}
    }

    set sock [eval [list autoconnect::socket $server $port] $args]

    fconfigure $sock -encoding binary -translation binary

    set lib(socket) $sock
    eval [list tls_import $connid] $tlsargs

    return $sock
}

proc transport::tls::outmsg {connid msg} {
    variable $connid
    upvar 0 $connid lib

    if {![info exists lib(socket)]} {
	::LOG "error ([namespace current]::outmsg)\
	       Cannot write to socket: socket for connection\
	       $connid doesn't exist"
	return -2
    }

    if {[catch { puts -nonewline $lib(socket) $msg }]} {
	::LOG "error ([namespace current]::outmsg)\
	       Cannot write to socket: $lib(socket)"
	return -2
    }
}

proc transport::tls::start_stream {connid server args} {
    return [outmsg $connid \
		   [eval [list jlib::wrapper:streamheader $server] $args]]
}

proc transport::tls::finish_stream {connid args} {
    return [outmsg $connid [jlib::wrapper:streamtrailer]]
}

proc transport::tls::disconnect {connid} {
    variable $connid
    upvar 0 $connid lib

    catch {
	if {[set [namespace parent]::disconnect] == "quick"} {
	    flush $lib(socket)
	} else {
	    fconfigure $lib(socket) -blocking 1
	    flush $lib(socket)
	    vwait [namespace current]::${connid}(socket)
	}
    }
}

proc transport::tls::close {connid} {
    variable $connid
    upvar 0 $connid lib

    catch {fileevent $lib(socket) readable {}}
    catch {::close $lib(socket)}

    catch {unset lib}
}

######################################################################
proc transport::tls::inmsg {connid sock} {
    set msg ""
    catch { set msg [read $sock] }

    jlib::inmsg $connid $msg [eof $sock]
}

######################################################################
proc ::client:tls_callback {args} {
    return 1
}

######################################################################
proc transport::tls::tls_import {connid args} {
    variable $connid
    upvar 0 $connid lib

    set sock $lib(socket)

    fileevent $sock readable {}
    fileevent $sock writable {}
    fconfigure $sock -blocking 1

    eval [list tls::import $sock \
	       -command [list client:tls_callback $connid] \
	       -ssl2    false \
	       -ssl3    true \
	       -tls1    true \
	       -request true \
	       -require false \
	       -server  false] $args

    if {[catch {tls::handshake $sock} tls_result]} {
	catch {::close $sock}
	error $tls_result
    }

    fconfigure $sock -blocking 0 -buffering none \
               -translation auto -encoding utf-8

    fileevent $sock readable \
	      [list [namespace current]::inmsg $connid $sock]
}

######################################################################
# TODO Cleanup
proc transport::tls::to_compress {connid method} {
    variable $connid
    upvar 0 $connid lib

    set [namespace parent]::${method}::${connid}(socket) $lib(socket)
    eval [list [namespace parent]::${method}::import $connid]
    set ::jlib::lib($connid,transport) $method

    catch {unset lib}
}

######################################################################
#
# HTTP Polling
#
######################################################################

package require sha1

namespace eval transport::http_poll {
    variable http_version [package require http]
}

if {![catch { package require tls 1.4 }]} {
    ::http::register https 443 ::tls::socket
}

proc transport::http_poll::connect {connid server port args} {
    variable $connid
    upvar 0 $connid lib

    set lib(polltimeout)    0
    set lib(pollint)        6000
    set lib(pollmin)        6000
    set lib(pollmax)        60000
    set lib(proxyhost)      ""
    set lib(proxyport)      ""
    set lib(proxyusername)  ""
    set lib(proxypassword)  ""
    set lib(proxyuseragent) ""
    set lib(httpurl)        ""
    set lib(httpusekeys)    1
    set lib(httpnumkeys)    100

    foreach {opt val} $args {
	switch -- $opt {
	    -polltimeout    { set lib(polltimeout)    $val }
	    -pollint        { set lib(pollint)        $val }
	    -pollmin        { set lib(pollmin)        $val }
	    -pollmax        { set lib(pollmax)        $val }
	    -httpurl        { set lib(httpurl)        $val }
	    -httpusekeys    { set lib(httpusekeys)    $val }
	    -httpnumkeys    { set lib(httpnumkeys)    $val }
	    -proxyhost      { set lib(proxyhost)      $val }
	    -proxyport      { set lib(proxyport)      $val }
	    -proxyusername  { set lib(proxyusername)  $val }
	    -proxypassword  { set lib(proxypassword)  $val }
	    -proxyuseragent { set lib(proxyuseragent) $val }
	}
    }

    set lib(httpwait)    disconnected
    set lib(httpoutdata) ""
    set lib(httpseskey)  0
    set lib(httpid)      ""
    set lib(httpkeys)    {}

    if {$lib(proxyuseragent) != ""} {
	::http::config -useragent $lib(proxyuseragent)
    }

    if {($lib(proxyhost) != "") && ($lib(proxyport) != "")} {
	::http::config -proxyhost $lib(proxyhost) -proxyport $lib(proxyport)

	if {$lib(proxyusername) != ""} {
	    set auth \
		[base64::encode \
                     [encoding convertto \
			  "$lib(proxyusername):$lib(proxypassword)"]]
	    set lib(proxyauth) [list "Proxy-Authorization" "Basic $auth"]
	} else {
	    set lib(proxyauth) {}
	}
    } else {
	    set lib(proxyauth) {}
    }

    if {$lib(httpusekeys)} {
        # generate keys
	::HTTP_LOG "connect ($connid): generating keys"
        set seed [rand 1000000000]
        set oldkey $seed
        set key_count $lib(httpnumkeys)
        while {$key_count > 0} {
            set nextkey [base64::encode [hex_decode [sha1::sha1 $oldkey]]]
            # skip the initial seed
            lappend lib(httpkeys) $nextkey
            set oldkey $nextkey
            incr key_count -1
        }
    }

    set_httpwait $connid connected
}

proc transport::http_poll::outmsg {connid msg} {
    variable $connid
    upvar 0 $connid lib

    if {![info exists lib(httpwait)]} {
	return
    }

    switch -- $lib(httpwait) {
	disconnected -
	waiting -
	disconnecting { }
	default { poll $connid $msg }
    }
}

proc transport::http_poll::start_stream {connid server args} {
    return [outmsg $connid \
		   [eval [list jlib::wrapper:streamheader $server] $args]]
}

proc transport::http_poll::finish_stream {connid args} {
    return [outmsg $connid [jlib::wrapper:streamtrailer]]
}

proc transport::http_poll::disconnect {connid} {
    variable $connid
    upvar 0 $connid lib

    if {![info exists lib(httpwait)]} {
	return
    }

    switch -- $lib(httpwait) {
	disconnected -
	waiting { }
	polling { set_httpwait $connid waiting }
	default { set_httpwait $connid disconnecting }
    }

    if {[set [namespace parent]::disconnect] == "quick"} return

    while {[info exists lib(httpwait)] && $lib(httpwait) != "disconnected"} {
	vwait [namespace current]::${connid}(httpwait)
    }
}

proc transport::http_poll::close {connid} {
    variable $connid
    upvar 0 $connid lib

    set_httpwait $connid disconnected

    catch {unset lib}
}

######################################################################
proc transport::http_poll::inmsg {connid body} {
    if {[string length $body] > 2} {
	jlib::inmsg $connid $body 0
    }
}

######################################################################
proc ::HTTP_LOG {args} {}

######################################################################
proc transport::http_poll::set_httpwait {connid opt} {
    variable $connid
    upvar 0 $connid lib

    set lib(httpwait) $opt
    if {$opt == "disconnected" && \
	    [info exists lib(httpid)] && $lib(httpid) != ""} {
	after cancel $lib(httpid)
    }
}

proc transport::http_poll::process_httpreply {connid try query token} {
    variable $connid
    upvar 0 $connid lib
    upvar #0 $token state

    if {[::http::ncode $token] != 200} {
	::HTTP_LOG "error (process_httpreply) ($connid)\
		    Http returned [::http::ncode $token] $state(status)"
	if {$try < 3} {
	    get_url $connid [expr {$try + 1}] $query
	} else {
	    set_httpwait $connid disconnected
	    jlib::emergency_disconnect $connid
	}
	::http::cleanup $token
	return
    }

    foreach {name value} $state(meta) {
	if {[string equal -nocase "Set-Cookie" $name]} {
	    ::HTTP_LOG "process_httpreply ($connid): Set-Cookie: $value"
	    set start 0
	    set end [string first ";" $value]
	    if {$end < 1} {
		set end [string length $value]
	    }
	    if {[string equal -nocase -length 3 "ID=" $value]} {
		set start 3
	    }
	    set lib(httpseskey) [string range $value $start [expr {$end - 1}]]
	}
    }

    set inmsg [encoding convertfrom utf-8 $state(body)]
    ::HTTP_LOG "process_httpreply ($connid): '$inmsg'"
    ::http::cleanup $token

    if {[regexp {:0$} $lib(httpseskey)] || [regexp {%3A0$} $lib(httpseskey)]} {
	::HTTP_LOG "error (process_httpreply) Cookie Error"
	set_httpwait $connid disconnected
	jlib::emergency_disconnect $connid
	return
    }

    if {[string length $inmsg] > 5 } {
	set lib(pollint) [expr $lib(pollint) / 2]
	if {$lib(pollint) < $lib(pollmin)} {
	    set lib(pollint) $lib(pollmin)
	}
    } else {
	set lib(pollint) [expr $lib(pollint) * 11 / 10]
	if {$lib(pollint) > $lib(pollmax)} {
	    set lib(pollint) $lib(pollmax)
	}
    }

    inmsg $connid $inmsg

    switch -- $lib(httpwait) {
	waiting { set_httpwait $connid disconnecting }
	polling { set_httpwait $connid connected }
    }
}

proc transport::http_poll::poll {connid what} {
    variable $connid
    upvar 0 $connid lib

    ::HTTP_LOG "poll ($connid): '$what'"

    if {![info exists lib(httpwait)]} {
	set_httpwait $connid disconnected
	return
    }

    append lib(httpoutdata) [encoding convertto utf-8 $what]
    switch -- $lib(httpwait) {
	disconnected {
	    ::HTTP_LOG "poll ($connid): DISCONNECTED"
	    return
	}
	disconnecting {
	    ::HTTP_LOG "poll ($connid): DISCONNECTING"
	    if {$lib(httpoutdata) == ""} {
		set_httpwait $connid disconnected
		return
	    }
	}
	waiting -
	polling {
	    ::HTTP_LOG "poll ($connid): RESCHEDULING"
	    if {[info exists lib(httpid)]} {
		after cancel $lib(httpid)
	    }
	    ::HTTP_LOG "poll ($connid): $lib(pollint)"
	    set lib(httpid) \
		[after $lib(pollint) \
		       [list [namespace current]::poll $connid ""]]
	    return
	}
    }

    if {$lib(httpusekeys)} {
	# regenerate 
	set firstkey [lindex $lib(httpkeys) end]
	set secondkey ""
	if {[llength $lib(httpkeys)] == 1} {
	    ::HTTP_LOG "poll ($connid): regenerating keys"
	    set lib(httpkeys) {}
	    set seed [rand 1000000000]
	    set oldkey $seed
	    set key_count $lib(httpnumkeys)
	    while {$key_count > 0} {
		set nextkey [base64::encode [hex_decode [sha1::sha1 $oldkey]]]
		# skip the initial seed
		lappend lib(httpkeys) $nextkey
		set oldkey $nextkey
		incr key_count -1
	    }
	    set secondkey [lindex $lib(httpkeys) end]
	}
	set l [llength $lib(httpkeys)]
	set lib(httpkeys) [lrange $lib(httpkeys) 0 [expr {$l - 2}]]

	if {[string length $firstkey]} {
	    set firstkey ";$firstkey"
        }

        if {[string length $secondkey]} {
            set secondkey ";$secondkey"
        }

        set query "$lib(httpseskey)$firstkey$secondkey,$lib(httpoutdata)"
    } else {
        set query "$lib(httpseskey),$lib(httpoutdata)"
    }
    switch -- $lib(httpwait) {
	disconnecting { set_httpwait $connid waiting }
	default { set_httpwait $connid polling }
    }
    ::HTTP_LOG "poll ($connid): query: '[encoding convertfrom utf-8 $query]'"

    get_url $connid 0 $query

    set lib(httpoutdata) ""

    if {[info exists lib(httpid)]} {
        after cancel $lib(httpid)
    }
    ::HTTP_LOG "poll ($connid): $lib(pollint)"
    set lib(httpid) \
	[after $lib(pollint) [list [namespace current]::poll $connid ""]]
}

proc transport::http_poll::get_url {connid try query} {
    variable http_version
    variable $connid
    upvar 0 $connid lib

    set get_url_args [list -headers $lib(proxyauth)]
    if {[package vcompare 2.3.3 $http_version] <= 0} {
	lappend get_url_args -binary 1
    }

    eval [list ::http::geturl $lib(httpurl) -query $query \
	       -command [list [namespace current]::process_httpreply $connid $try $query] \
	       -timeout $lib(polltimeout)] $get_url_args
}

proc transport::http_poll::hex_decode {hexstring} {
    set result ""
    while { [string length $hexstring] } {
	scan [string range $hexstring 0 1] "%x" X
	regsub "^.." $hexstring "" hexstring
	set result [binary format "a*c" $result $X]
    }
    return $result
}

