/jabberlib/https.tcl

# https.tcl --
#
#	Package for using the HTTP CONNECT (it is a common method for
#	tunnelling HTTPS traffic, so the name is https) method for
#	connecting TCP sockets. Only client side.
#
# Copyright (c) 2007 Sergei Golovan <sgolovan@nes.ru>
#
#  This source file is distributed under the BSD license.
#
# $Id: https.tcl 1282 2007-10-26 17:40:59Z sergei $

package require base64
package require ntlm 1.0
package require autoconnect 0.2

package provide autoconnect::https 1.0

namespace eval https {
    namespace export connect

    variable debug 0

    autoconnect::register https [namespace current]::connect
}

# https::connect --
#
#       Negotiates with a HTTPS proxy server.
#
# Arguments:
#       sock:       an open socket token to the proxy server
#       addr:       the peer address, not the proxy server
#       port:       the peer port number
#       args:
#               -command    tclProc {status socket}
#               -username   userid
#               -password   password
#               -useragent  useragent
#               -timeout    millisecs (default 60000)
#
# Results:
#       The connect socket or error if no -command, else empty string.
#
# Side effects:
#	Socket is prepared for data transfer.
#	If -command specified, the callback tclProc is called with
#	status OK and socket or ERROR and error message.

proc https::connect {sock addr port args} {
    variable auth

    set token [namespace current]::$sock
    variable $token
    upvar 0 $token state

    Debug 2 "https::connect token=$token, sock=$sock, addr=$addr,\
	     port=$port, args=$args"

    array set state {
	-command    ""
	-timeout    60000
	-username   ""
	-password   ""
	-useragent  ""
	async       0
	status	    ""
    }
    array set state [list   \
	addr        $addr \
	port        $port \
	sock        $sock]
    array set state $args

    if {[string length $state(-command)]} {
	set state(async) 1
    }

    if {[catch {set state(peer) [fconfigure $sock -peername]}]} {
	catch {close $sock}
	if {$state(async)} {
	    after idle [list $state(-command) ERROR network-failure]
	    Free $token
	    return
	} else {
	    Free $token
	    return -code error network-failure
	}
    }

    PutsConnectQuery $token

    fileevent $sock readable  \
	[list [namespace current]::Readable $token]

    # Setup timeout timer.
    set state(timeoutid) \
	[after $state(-timeout) [namespace current]::Timeout $token]

    if {$state(async)} {
	return
    } else {
	# We should not return from this proc until finished!
	vwait $token\(status)

	set status $state(status)
	set sock $state(sock)

	Free $token

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

# https::Readable --
#
#	Receive the first reply from a proxy and either finish the
#	negotiations or prepare to autorization process at the proxy.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	An empty string.
#
# Side effects:
#	The negotiation is finished or the next turn is started.

proc https::Readable {token} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::Readable token=$token"

    fileevent $state(sock) readable {}
    set code [ReadProxyAnswer $token]

    if {$code >= 200 && $code < 300} {
	# Success
	while {[string length [gets $state(sock)]]} {}
	Finish $token
    } elseif {$code != 407} {
	# Failure
	Finish $token $state(result)
    } else {
	# Authorization required
	set content_length -1
	set method basic
	while {[string length [set header [gets $state(sock)]]]} {
	    switch -- [HttpHeaderName $header] {
		proxy-authenticate {
		    if {[string equal -length 4 [HttpHeaderBody $header] "NTLM"]} {
			set method ntlm
		    }
		}
		content-length {
		    set content_length [HttpHeaderBody $header]
		}
	    }
	}

	ReadProxyJunk $token $content_length
	close $state(sock)

	set state(sock) \
	    [socket -async [lindex $state(peer) 0] [lindex $state(peer) 2]]

	fileevent $state(sock) writable \
	    [list [namespace current]::Authorize $token $method]
    }

    return
}

# https::Authorize --
#
#	Start the authorization procedure.
#
# Arguments:
#	token	    A connection token.
#	method	    (basic or ntlm) authorization method.
#
# Result:
#	Empty string.
#
# Side effects:
#	Authorization is started.

proc https::Authorize {token method} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::Authorize token=$token, method=$method"

    fileevent $state(sock) writable {}

    switch -- $method {
	ntlm {
	    AuthorizeNtlmStep1 $token
	}
	default {
	    AuthorizeBasicStep1 $token
	}
    }

    return
}

# https::AuthorizeBasicStep1 --
#
#	The first step of basic authorization procedure: send authorization
#	credentials to a socket.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	Empty string.
#
# Side effects:
#	Authorization info is sent to a socket.

proc https::AuthorizeBasicStep1 {token} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::AuthorizeBasicStep1 token=$token"

    set auth \
	[string map {\n {}} \
	     [base64::encode \
		  [encoding convertto "$state(-username):$state(-$password)"]]]

    PutsConnectQuery $token "Basic $auth"

    fileevent $state(sock) readable \
	[list [namespace current]::AuthorizeBasicStep2 $token]

    return
}

# https::AuthorizeBasicStep2 --
#
#	The second step of basic authorization procedure: receive and
#	analyze server reply.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	Empty string.
#
# Side effects:
#	Server reply is received from a socket.

proc https::AuthorizeBasicStep2 {token} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::AuthorizeBasicStep2 token=$token"

    fileevent $state(sock) readable {}

    set code [ReadProxyAnswer $token]

    if {$code >= 200 && $code < 300} {
	# Success
	while {[string length [gets $sock]]} { }
	Finish $token
    } else {
	# Failure
	Finish $token $state(result)
    }
    return
}

# https::AuthorizeNtlmStep1 --
#
#	The first step of NTLM authorization procedure: send NTLM
#	message 1 to a socket.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	Empty string.
#
# Side effects:
#	Authorization info is sent to a socket.

proc https::AuthorizeNtlmStep1 {token} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::AuthorizeNtlmStep1 token=$token"

    set domain ""
    set host [info hostname]

    # if username is domain/username or domain\username
    # then set domain and username
    set username $state(-username)
    regexp {(\w+)[\\/](.*)} $username -> domain username

    set ntlmtok [NTLM::new -domain $domain \
			   -host $host \
			   -username $username \
			   -password $state(-password)]
    set message1 [$ntlmtok type1Message]
    set state(ntlmtok) $ntlmtok

    PutsConnectQuery $token "NTLM $message1"

    fileevent $state(sock) readable \
	[list [namespace current]::AuthorizeNtlmStep2 $token]

    return
}

# https::AuthorizeNtlmStep2 --
#
#	The first step of basic authorization procedure: send authorization
#	credentials to a socket.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	Empty string.
#
# Side effects:
#	Authorization info is sent to a socket.

proc https::AuthorizeNtlmStep2 {token} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::AuthorizeNtlmStep2 token=$token"

    fileevent $state(sock) readable {}

    set code [ReadProxyAnswer $token]

    if {$code >= 200 && $code < 300} {
	# Success
	while {[string length [gets $state(sock)]]} { }
	Finish $token
	return
    } elseif {$code != 407} {
	# Failure
	Finish $token $state(result)
	return
    }

    set content_length -1
    set message2 ""
    while {![string equal [set header [gets $state(sock)]] ""]} {
	switch -- [HttpHeaderName $header] {
	    proxy-authenticate {
		set body [HttpHeaderBody $header]
		if {[string equal -length 5 $body "NTLM "]} {
		    set message2 [string trim [string range $body 5 end]]
		}
	    }
	    content-length {
		set content_length [HttpHeaderBody $header]
	    }
	}
    }

    ReadProxyJunk $token $content_length

    $state(ntlmtok) parseType2Message -message $message2
    set message3 [$state(ntlmtok) type3Message]
    $state(ntlmtok) free

    PutsConnectQuery $token "NTLM $message3"

    fileevent $state(sock) readable \
	[list [namespace current]::AuthorizeNtlmStep3 $token]

    return
}

# https::AuthorizeNtlmStep3 --
#
#	The third step of NTLM authorization procedure: receive and
#	analyze server reply.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	Empty string.
#
# Side effects:
#	Server reply is received from a socket.

proc https::AuthorizeNtlmStep3 {token} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::AuthorizeNtlmStep3 token=$token"

    fileevent $state(sock) readable {}

    set code [ReadProxyAnswer $token]

    if {$code >= 200 && $code < 300} {
	# Success
	while {[string length [gets $state(sock)]]} { }
	Finish $token
    } else {
	# Failure
	Finish $token $state(result)
    }
    return
}

# https::PutsConnectQuery --
#
#	Sends CONNECT query to a proxy server.
#
# Arguments:
#	token	    A connection token.
#	auth	    (optional) A proxy authorization string.
#
# Result:
#	Empty string.
#
# Side effects:
#	Some info is sent to a proxy.

proc https::PutsConnectQuery {token {auth ""}} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::PutsConnectQuery token=$token auth=$auth"

    fconfigure $state(sock) -buffering line -translation auto

    puts $state(sock) "CONNECT $state(addr):$state(port) HTTP/1.1"
    puts $state(sock) "Proxy-Connection: keep-alive"
    if {[string length $state(-useragent)]} {
	puts $state(sock) "User-Agent: $state(-useragent)"
    }
    if {[string length $auth]} {
	puts $state(sock) "Proxy-Authorization: $auth"
    }
    puts $state(sock) ""
    return
}

# https::ReadProxyAnswer --
#
#	Reads the first line of a proxy answer with a result code.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	The HTTP result code.
#
# Side effects:
#	Status line is read form a socket.
#	Variable state(result) is set to a just read line.

proc https::ReadProxyAnswer {token} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::ReadProxyAnswer token=$token"

    fconfigure $state(sock) -buffering line -translation auto

    set state(result) [gets $state(sock)]
    set code [lindex [split $state(result) { }] 1]
    if {[string is integer -strict $code]} {
	return $code
    } else {
	# Invalid code
	return 0
    }
}

# https::ReadProxyJunk --
#
#	Reads the body part of a proxy answer.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	Empty string.
#
# Side effects:
#	Some info is read from a socket and discarded.

proc https::ReadProxyJunk {token length} {
    variable $token
    upvar 0 $token state

    Debug 2 "https::ReadProxyJunk token=$token, length=$length"

    fconfigure $state(sock) -buffering none -translation binary
    if {$length != -1} {
	read $state(sock) $length
    } else {
	read $state(sock)
    }
    return
}

# https::HttpHeaderName --
#
#	Returns HTTP header name (converted to lowercase).
#
# Arguments:
#	header	    A HTTP header.
#
# Result:
#	A header name.
#
# Side effects
#	None.

proc https::HttpHeaderName {header} {
    set hlist [split $header ":"]
    return [string tolower [lindex $hlist 0]]
}

# https::HttpHeaderBody --
#
#	Returns HTTP header body.
#
# Arguments:
#	header	    A HTTP header.
#
# Result:
#	A header body.
#
# Side effects
#	None.

proc https::HttpHeaderBody {header} {
    set hlist [split $header ":"]
    set body [join [lrange $hlist 1 end] ":"]
    return [string trim $body]
}

# https::Timeout --
#
#	This proc is called in case of timeout.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	An empty string.
#
# Side effects:
#	A proxy negotiation is finished with error.

proc https::Timeout {token} {
    Finish $token timeout
    return
}

# https::Free --
#
#	Frees a connection token.
#
# Arguments:
#	token	    A connection token.
#
# Result:
#	An empty string.
#
# Side effects:
#	A connection token and its state informationa are destroyed.

proc https::Free {token} {
    variable $token
    upvar 0 $token state

    catch {after cancel $state(timeoutid)}
    catch {unset state}
    return
}

# https::Finish --
#
#	Finishes a negotiation process.
#
# Arguments:
#	token	    A connection token.
#	errormsg    (optional) error message.
#
# Result:
#	An empty string.
#
# Side effects:
#	If connection is asynchronous then a callback is executed.
#	Otherwise state(status) is set to allow https::connect to return
#	with either success or error.

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

    Debug 2 "https::Finish token=$token, errormsg=$errormsg"

    catch {after cancel $state(timeoutid)}

    if {$state(async)} {
	if {[string length $errormsg]} {
	    catch {close $state(sock)}
	    uplevel #0 $state(-command) [list ERROR $errormsg]
	} else {
	    uplevel #0 $state(-command) [list OK $state(sock)]
	}
	Free $token
    } else {
	if {[string length $errormsg]} {
	    catch {close $state(sock)}
	    set state(sock) $errormsg
	    set state(status) ERROR
	} else {
	    set state(status) OK
	}
    }
    return
}

# https::Debug --
#
#	Prints debug information.
#
# Arguments:
#	num	A debug level.
#	str	A debug message.
#
# Result:
#	An empty string.
#
# Side effects:
#	A debug message is printed to the console if the value of
#	https::debug variable is not less than num.

proc https::Debug {num str} {
    variable debug

    if {$num <= $debug} {
	puts $str
    }

    return
}

# Test
if {0} {
    set s [socket 192.168.0.1 3128]
    set t [https::connect $s google.com 443]
    puts $t
    close $t

    set s [socket 192.168.0.1 3128]
    set t [https::connect $s google.com 80]
    puts $t
    close $t
}