# $Id: login.tcl 1503 2008-09-25 19:08:54Z sergei $


if {[lcontain [jlib::capabilities transport] tls]} {
    set use_tls 1
} else {
    set use_tls 0
}

if {[lcontain [jlib::capabilities transport] compress]} {
    set have_compress 1
} else {
    set have_compress 0
}

if {[lcontain [jlib::capabilities auth] sasl]} {
    set have_sasl 1
} else {
    set have_sasl 0
}

if {[llength [jlib::capabilities proxy]] > 1} {
    set have_proxy 1
} else {
    set have_proxy 0
}

if {[lcontain [jlib::capabilities transport] http_poll]} {
    set have_http_poll 1
} else {
    set have_http_poll 0
}

custom::defgroup Warnings [::msgcat::mc "Warning display options."] \
    -group Tkabber

if {$use_tls} {
    custom::defvar tls_warnings 1 [::msgcat::mc "Display SSL warnings."] \
	-group Warnings -type boolean
}

custom::defgroup Login \
    [::msgcat::mc "Login options."] \
    -group Tkabber

custom::defvar loginconf(user) "" \
    [::msgcat::mc "User name."] \
    -group Login -type string
custom::defvar loginconf(server) "localhost" \
    [::msgcat::mc "Server name."] \
    -group Login -type string
custom::defvar loginconf(password) "" \
    [::msgcat::mc "Password."] \
    -group Login -type password
custom::defvar loginconf(resource) "tkabber" \
    [::msgcat::mc "Resource."] \
    -group Login -type string
custom::defvar loginconf(priority) "8" \
    [::msgcat::mc "Priority."] \
    -group Login -type integer

custom::defvar loginconf(connect_forever) 0 \
    [::msgcat::mc "Retry to connect forever."] \
    -group Login -type boolean

custom::defvar loginconf(allowauthplain) 0 \
    [::msgcat::mc "Allow plaintext authentication mechanisms (when password\
		   is transmitted unencrypted)."] \
	-group Login -type boolean

custom::defvar loginconf(allowgoogletoken) 1 \
    [::msgcat::mc "Allow X-GOOGLE-TOKEN authentication mechanisms. It requires\
		   connection to Google via HTTPS."] \
	-group Login -type boolean

if {$have_sasl} {
    custom::defvar loginconf(usesasl) 1 \
	[::msgcat::mc "Use SASL authentication."] \
	-group Login -type boolean
}

set values [list plaintext [::msgcat::mc "Plaintext"]]
if {$have_compress} {
    lappend values compressed [::msgcat::mc "Compression"]
}
if {$use_tls} {
    lappend values encrypted [::msgcat::mc "Encryption (STARTTLS)"] \
		   ssl       [::msgcat::mc "Encryption (legacy SSL)"]
}

if {$use_tls || $have_compress} {
    custom::defvar loginconf(stream_options) plaintext \
	[::msgcat::mc "XMPP stream options when connecting to server."] \
	-group Login -type options \
	-values $values
}

if {$use_tls} {
    custom::defvar loginconf(sslcertfile) "" \
	[::msgcat::mc "SSL certificate file (optional)."] \
	-group Login -type file
    custom::defvar loginconf(sslcacertstore) "" \
	[::msgcat::mc "SSL certification authority file or directory (optional)."] \
	-group Login -type file
    custom::defvar loginconf(sslkeyfile) "" \
	[::msgcat::mc "SSL private key file (optional)."] \
	-group Login -type file
}

if {$have_proxy} {
    set values {}
    foreach type [jlib::capabilities proxy] {
	switch -- $type {
	    none   {lappend values none   [::msgcat::mc "None"]}
	    socks4 {lappend values socks4 [::msgcat::mc "SOCKS4a"]}
	    socks5 {lappend values socks5 [::msgcat::mc "SOCKS5"]}
	    https  {lappend values https  [::msgcat::mc "HTTPS"]}
	}
    }
    custom::defvar loginconf(proxy) none \
	[::msgcat::mc "Proxy type to connect."] \
	-group Login -type options \
	-values $values
    custom::defvar loginconf(proxyhost) "localhost" \
	[::msgcat::mc "HTTP proxy address."] \
	-group Login -type string
    custom::defvar loginconf(proxyport) 3128 \
	[::msgcat::mc "HTTP proxy port."] \
	-group Login -type integer
    custom::defvar loginconf(proxyusername) "" \
	[::msgcat::mc "HTTP proxy username."] \
	-group Login -type string
    custom::defvar loginconf(proxypassword) "" \
	[::msgcat::mc "HTTP proxy password."] \
	-group Login -type password
    custom::defvar loginconf(proxyuseragent) \
	"Mozilla/4.0 (compatible; MSIE 6.0;\
	 $::tcl_platform(os) $::tcl_platform(osVersion))" \
	[::msgcat::mc "User-Agent string."] \
	-group Login -type string
}

custom::defvar loginconf(usealtserver) 0 \
    [::msgcat::mc "Use explicitly-specified server address and port."] \
    -group Login -type boolean
custom::defvar loginconf(altserver) "" \
    [::msgcat::mc "Server name or IP-address."] \
    -group Login -type string
custom::defvar loginconf(altport) "5222" \
    [::msgcat::mc "Server port."] \
    -group Login -type integer

custom::defvar loginconf(replace_opened) 1 \
    [::msgcat::mc "Replace opened connections."] \
    -group Login -type boolean

if {$have_http_poll} {
    custom::defvar loginconf(usehttppoll) 0 \
	[::msgcat::mc "Use HTTP poll connection method."] \
	-group Login -type boolean
    custom::defvar loginconf(pollurl) "" \
	[::msgcat::mc "URL to connect to."] \
	-group Login -type string
    custom::defvar loginconf(usepollkeys) 1 \
	[::msgcat::mc "Use HTTP poll client security keys (recommended)."] \
	-group Login -type boolean
    custom::defvar loginconf(numberofpollkeys) 100 \
	[::msgcat::mc "Number of HTTP poll client security keys to send\
before creating new key sequence."] \
	-group Login -type integer
    custom::defvar loginconf(polltimeout) 0 \
	[::msgcat::mc "Timeout for waiting for HTTP poll responses (if set\
to zero, Tkabber will wait forever)."] \
	-group Login -type integer
    custom::defvar loginconf(pollmin) 6000 \
	[::msgcat::mc "Minimum poll interval."] \
	-group Login -type integer
    custom::defvar loginconf(pollmax) 60000 \
	[::msgcat::mc "Maximum poll interval."] \
	-group Login -type integer
}

custom::defvar reasonlist {} [::msgcat::mc "List of logout reasons."] \
	-group Hidden

######################################################################

# connect errors mapping

array set connect_error [list \
	err_unknown 			[::msgcat::mc "Unknown error"] \
	timeout				[::msgcat::mc "Timeout"] \
	network-failure			[::msgcat::mc "Network failure"] \
	err_authorization_required	[::msgcat::mc "Proxy authentication required"] \
	err_version			[::msgcat::mc "Incorrect SOCKS version"] \
	err_unsupported_method		[::msgcat::mc "Unsupported SOCKS method"] \
	err_authentication_unsupported	[::msgcat::mc "Unsupported SOCKS authentication method"] \
	err_authorization		[::msgcat::mc "SOCKS authentication failed"] \
	rsp_failure			[::msgcat::mc "SOCKS request failed"] \
	rsp_errconnect			[::msgcat::mc "SOCKS server cannot identify username"] \
	rsp_erruserid			[::msgcat::mc "SOCKS server username identification failed"] \
	rsp_notallowed			[::msgcat::mc "SOCKS connection not allowed by ruleset"] \
	rsp_netunreachable		[::msgcat::mc "Network unreachable"] \
	rsp_hostunreachable		[::msgcat::mc "Host unreachable"] \
	rsp_refused			[::msgcat::mc "Connection refused by destination host"] \
	rsp_expired			[::msgcat::mc "TTL expired"] \
	rsp_cmdunsupported		[::msgcat::mc "SOCKS command not supported"] \
	rsp_addrunsupported		[::msgcat::mc "Address type not supported by SOCKS proxy"] \
	err_unknown_address_type	[::msgcat::mc "Unknown address type"]]

# TLS info
#
# [::msgcat::mc "Certificate has expired"]
# [::msgcat::mc "Self signed certificate"]

######################################################################
proc login {logindata} {
    global connect_error
    global login_after_time
    global login_after_id

    array set lc $logindata
    set user $lc(user)@$lc(server)/$lc(resource)
    if {[info exists login_after_id($user)]} {
	after cancel $login_after_id($user)
	unset login_after_id($user)
    }
    debugmsg login "Starting login"
    if {[catch {login_connect $logindata} connid] > 0} {
	# Nasty thing has happened.
	debugmsg login "Failed to connect: $connid"
	if {$lc(connect_forever)} {
	    login_retry $logindata
	} else {
	    if {[winfo exists .connect_err]} {
		destroy .connect_err
	    }
	    if {[info exists connect_error($connid)]} {
		set msg $connect_error($connid)
	    } else {
		set msg $connid
	    }
	    set res [MessageDlg .connect_err -width 600 -icon error \
		-message [format [::msgcat::mc "Failed to connect: %s"] $msg] \
		-type user -buttons [list abort [::msgcat::mc "Keep trying"]] \
		-default 0 -cancel 0]
	    if {$res} {
		set lc(connect_forever) 1
		set logindata [array get lc]
		login_retry $logindata
	    }
	}
	return
    }
    # OK, connected.
    debugmsg login "Connect successful ($user) $connid"
    set login_after_time 15000
    login_login $logindata $connid
}

proc login_retry {logindata} {
    global login_after_time
    global login_after_id

    if {![info exists login_after_time]} {set login_after_time 15000}
    if {$login_after_time < 1800000} {
	# 1800000 == 30 * 60 * 1000 == 30min
	# the sequence goes: 30s, 1min, 2min, 4min, 8min, 16min, 32min, 32min...
	set login_after_time [expr {$login_after_time * 2}]
    }
    array set lc $logindata
    set user $lc(user)@$lc(server)/$lc(resource)
    debugmsg login "Scheduling connect retry for $user in ${login_after_time}ms"
    if {[info exists login_after_id($user)]} {
	after cancel $login_after_id($user)
    }
    set login_after_id($user) [after $login_after_time [list login $logindata]]
}

proc client:tls_callback {connid args} {
    global tls_result tls_warnings
    global ssl_certificate_fields
    global tls_warning_info

    switch -- [lindex $args 0] {
	info {
	    set_status [lindex $args 4]
	}

	verify {
	    if {[cequal [set reason [lindex $args 5]] ""]} {
		return 1
	    }
	    set info [::msgcat::mc [string totitle $reason 0 0]]
	    append tls_warning_info($connid) "$info\n"
	    if {!$tls_warnings} {
		return 1
	    }
	    append info [::msgcat::mc ". Proceed?\n\n"]
	    foreach {k v} [lindex $args 3] {
		switch -- $k {
		    subject - issuer {
			set v [regsub -all {\s*[/,]\s*(\w+=)} $v \n\t\\1]
		    }
		}
		if {![cequal $v ""]} {
		    if {[info exists ssl_certificate_fields($k)]} {
			append info [format "%s: %s\n" \
					    $ssl_certificate_fields($k) $v]
		    } else {
			append info [format "%s: %s\n" $k $v]
		    }
		}
	    }

	    set blocking [fconfigure [set fd [lindex $args 1]] -blocking]
	    fconfigure $fd -blocking 1
	    set readable [fileevent $fd readable]
	    fileevent $fd readable {}

	    set res [MessageDlg .tls_callback -aspect 50000 -icon warning \
			        -type user -buttons {yes no} -default 1 \
			        -cancel 1 \
			        -message [string trim $info]]

	    fileevent $fd readable $readable
	    fconfigure $fd -blocking $blocking

	    if {$res} {
		set res 0
	    } else {
		set res 1
	    }
	    return $res
	}

	error {
	    set tls_result [join [lrange $args 2 end] " "]
	}

	default {
	}
    }
}

proc login_connect {logindata} {
    global use_tls have_compress have_sasl have_http_poll have_proxy
    global tls_warning_info

    array set lc $logindata

    set connid [jlib::new -user $lc(user) \
			  -server $lc(server) \
			  -resource $lc(resource)]

    set tls_warning_info($connid) ""

    set args [list -password $lc(password) \
		   -allowauthplain $lc(allowauthplain) \
		   -allowgoogletoken $lc(allowgoogletoken)]
    if {$have_sasl} {
	lappend args -usesasl $lc(usesasl)
    }

    if {$have_proxy} {
	if {($lc(proxy) != "none")} {
	    lappend args -proxy $lc(proxy)
	    lappend args -proxyhost $lc(proxyhost)
	    lappend args -proxyport $lc(proxyport)
	    lappend args -proxyusername $lc(proxyusername)
	    lappend args -proxypassword $lc(proxypassword)
	    lappend args -proxyuseragent $lc(proxyuseragent)
	} else {
	    lappend args -proxy ""
	}
    }

    set ascii_server [idna::domain_toascii $lc(server)]

    if {$have_http_poll && $lc(usehttppoll)} {
	if {$lc(pollurl) != ""} {
	    set url $lc(pollurl)
	} else {
	    set url [jlibdns::get_http_poll_url $ascii_server]
	}
	return [eval [list jlib::connect $connid \
				-transport http_poll \
				-polltimeout $lc(polltimeout) \
				-pollint $lc(pollmin) \
				-pollmin $lc(pollmin) \
				-pollmax $lc(pollmax) \
				-httpurl $url \
				-httpusekeys $lc(usepollkeys) \
				-httpnumkeys $lc(numberofpollkeys)] $args]
    } else {
	if {$have_compress && $lc(stream_options) == "compressed"} {
	    lappend args -usecompression 1
	}
   
	if {$lc(usealtserver)} {
	    set hosts {}
	} else {
	    set hosts [jlibdns::get_addr_port $ascii_server]
	    if {[lempty $hosts]} {
		set hosts [list [list $ascii_server 5222]]
	    }
	}
	set transport tcp
	set sslopts {}
	if {$use_tls} {
	    switch -- $lc(stream_options) {
		ssl {
		    set usestarttls 0
		    set transport tls
		    # Do some heuristic.
		    # Traditionally legacy SSL port is 5223,
		    # so let's add 1 to all ports from SRV reply
		    set hosts1 {}
		    foreach hp $hosts {
			lappend hosts1 \
				[list [lindex $hp 0] \
				      [expr {[lindex $hp 1] + 1}]]
		    }
		    set hosts $hosts1
		}
		encrypted {
		    set usestarttls 1
		}
		default {
		    set usestarttls 0
		}
	    }
	    set sslopts [list -usestarttls $usestarttls \
	                      -certfile $lc(sslcertfile) \
			      -cacertstore $lc(sslcacertstore) \
			      -keyfile $lc(sslkeyfile)]
	}

	if {$lc(usealtserver)} {
	    set hosts [list [list [idna::domain_toascii $lc(altserver)] $lc(altport)]]
	}

	return [eval [list jlib::connect $connid \
				-transport $transport \
				-hosts $hosts] \
				$sslopts $args]
    }
}

########################################################################

proc login_login {logindata connid} {
    global loginconf_hist
    global gr_nick gr_server gra_server

    array set lc $logindata
    set loginconf_hist($connid) $logindata

    set gr_nick $lc(user)
    set gr_server conference.$lc(server)
    set gra_server conference.$lc(server)

    jlib::login $connid [list recv_auth_result $connid $logindata]
}

########################################################################

set reconnect_retries 0

proc logout {{connid {}}} {
    global reconnect_retries
    global login_after_id

    debugmsg login "LOGOUT $connid"

    # TODO
    foreach user [array names login_after_id] {
	after cancel $login_after_id($user)
	unset login_after_id($user)
    }

    if {$connid == {}} {
	foreach connid [jlib::connections] {
	    disconnected $connid
	}
    } else {
	disconnected $connid
    }

    set reconnect_retries 0
}

proc client:disconnect {connid} {
    logout $connid
}

# TODO
proc client:reconnect {connid} {
    global reconnect_retries
    global loginconf_hist

    debugmsg login "RECONNECT $connid"

    disconnected $connid

    if {[incr reconnect_retries] <= 3} {
        after 1000 [list login $loginconf_hist($connid)]
    }
}

proc connected {connid logindata} {
    hook::run connected_hook $connid
}

# TODO
proc disconnected {connid} {
    global curuserstatus userstatusdesc

    hook::run predisconnected_hook $connid

    jlib::disconnect $connid
    roster::clean_connection $connid

    if {[jlib::connections] == {}} {
	set_status "Disconnected"

	set curuserstatus unavailable
	set userstatusdesc [::msgcat::mc "Not logged in"]
	hook::run change_our_presence_post_hook unavailable
    }

    hook::run disconnected_hook $connid
}

proc recv_auth_result {connid logindata res args} {
    array set lc $logindata

    if {$res == "OK"} {
	connected $connid $logindata
    } else {
	if {[winfo exists .auth_err$connid]} {
	    destroy .auth_err$connid
	}
	lassign [error_type_condition [lindex $args 0]] type cond
	if {($type == "sasl") || ($type == "auth" && $cond == "not-authorized")} {
	    set res [MessageDlg .auth_err$connid -aspect 50000 -icon error \
			 -message [format \
			     [::msgcat::mc "Authentication failed: %s\nCreate new account?"] \
			     [error_to_string [lindex $args 0]]] \
			 -type user -buttons {yes no} -default 0 -cancel 1]
	    if {!$res} {
		jlib::send_iq set \
		    [jlib::wrapper:createtag query \
			 -vars {xmlns jabber:iq:register} \
			 -subtags [list [jlib::wrapper:createtag username \
					     -chdata $lc(user)] \
					[jlib::wrapper:createtag password \
					     -chdata $lc(password)]]] \
		    -connection $connid \
		    -command [list recv_register_result $connid $logindata]
		return
	    }
	} else {
	    MessageDlg .auth_err$connid -aspect 50000 -icon error \
		-message [format \
			     [::msgcat::mc "Authentication failed: %s"] \
			     [error_to_string [lindex $args 0]]] \
		-type user -buttons {ok} -default 0 -cancel 0
	}
	logout $connid
    }
}

proc recv_register_result {connid logindata res args} {
    if {$res == "OK"} {
	jlib::disconnect $connid
	login $logindata
    } else {
	if {[winfo exists .auth_err$connid]} {
	    destroy .auth_err$connid
	}
	MessageDlg .auth_err$connid -aspect 50000 -icon error \
	    -message [format [::msgcat::mc "Registration failed: %s"] \
			  [error_to_string [lindex $args 0]]] \
	    -type user -buttons ok -default 0 -cancel 0
	logout $connid
    }
}

# TODO
proc change_password_dialog {} {
    global oldpassword newpassword password

    set oldpassword ""
    set newpassword ""
    set password ""

    if {[winfo exists .passwordchange]} {
	destroy .passwordchange
    }
    
    Dialog .passwordchange -title [::msgcat::mc "Change password"] \
	-separator 1 -anchor e -default 0 -cancel 1

    .passwordchange add -text [::msgcat::mc "OK"] -command {
	destroy .passwordchange
	send_change_password
    }
    .passwordchange add -text [::msgcat::mc "Cancel"] -command [list destroy .passwordchange]


    set p [.passwordchange getframe]
    
    label $p.loldpass -text [::msgcat::mc "Old password:"]
    ecursor_entry [entry $p.oldpass -show * -textvariable oldpassword]
    label $p.lnewpass -text [::msgcat::mc "New password:"]
    ecursor_entry [entry $p.newpass -show * -textvariable newpassword]
    label $p.lpassword -text [::msgcat::mc "Repeat new password:"]
    ecursor_entry [entry $p.password -show * -textvariable password]

    grid $p.loldpass  -row 0 -column 0 -sticky e
    grid $p.oldpass   -row 0 -column 1 -sticky ew
    grid $p.lnewpass  -row 1 -column 0 -sticky e
    grid $p.newpass   -row 1 -column 1 -sticky ew
    grid $p.lpassword -row 2 -column 0 -sticky e
    grid $p.password  -row 2 -column 1 -sticky ew

    focus $p.oldpass
    .passwordchange draw

}

# TODO
proc send_change_password {} {
    global loginconf
    global oldpassword newpassword password

    if {$oldpassword != $loginconf(password)} {
	MessageDlg .auth_err -aspect 50000 -icon error \
	        -message [::msgcat::mc "Old password is incorrect"] \
		-type user -buttons ok -default 0 -cancel 0
	return
    }
    if {$newpassword != $password} {
	MessageDlg .auth_err -aspect 50000 -icon error \
	        -message [::msgcat::mc "New passwords do not match"] \
		-type user -buttons ok -default 0 -cancel 0
	return
    }

    set connid [jlib::route $loginconf(server)]

    jlib::send_iq set \
	    [jlib::wrapper:createtag query \
		    -vars {xmlns jabber:iq:register} \
		    -subtags [list [jlib::wrapper:createtag username \
					-chdata $loginconf(user)] \
				   [jlib::wrapper:createtag password \
					-chdata $password]]] \
	    -to $loginconf(server) \
	    -connection $connid \
	    -command recv_change_password_result
}

# TODO
proc recv_change_password_result {res args} {
    global loginconf
    global newpassword

    if {$res == "OK"} {
	MessageDlg .shpasswd_result -aspect 50000 -icon info \
		-message [::msgcat::mc "Password is changed"] \
		-type user -buttons ok -default 0 -cancel 0
	for {set i 1} {[info exists ::loginconf$i]} {incr i} {
	    if {!([info exists ::loginconf${i}(user)] && \
		    [info exists ::loginconf${i}(server)] && \
		    [info exists ::loginconf${i}(password)])} {
		continue
	    }
	    upvar ::loginconf${i}(user) user
	    upvar ::loginconf${i}(server) server
	    upvar ::loginconf${i}(password) password
	    if {[string equal $user $loginconf(user)] && \
		    [string equal $server $loginconf(server)] && \
		    [string equal $password $loginconf(password)]} {
		set password $newpassword
	    }
	}
	set loginconf(password) $newpassword
    } else {
	MessageDlg .shpasswd_result -aspect 50000 -icon error \
	    -message [format [::msgcat::mc "Password change failed: %s"] [error_to_string [lindex $args 0]]] \
	    -type user -buttons ok -default 0 -cancel 0
    }
}

# TODO
proc show_logout_dialog {} {
    global reason reasonlist

    set lw .logout

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

    Dialog $lw -title [::msgcat::mc "Logout with reason"] \
	    -separator 1 -anchor e -default 0 -cancel 1

    set lf [$lw getframe]
    grid columnconfigure $lf 1 -weight 1

    if {[llength $reasonlist]} {set reason [lindex $reasonlist 0]}

    label $lf.lreason   -text    [::msgcat::mc "Reason:"]
    ecursor_entry [ComboBox $lf.reason -textvariable reason \
	    -values $reasonlist -width 35].e
    label $lf.lpriority -text    [::msgcat::mc "Priority:"]
    ecursor_entry [entry $lf.priority -textvariable loginconf(priority)]

    grid $lf.lreason   -row 0 -column 0 -sticky e
    grid $lf.reason    -row 0 -column 1 -sticky ew
    grid $lf.lpriority -row 1 -column 0 -sticky e
    grid $lf.priority  -row 1 -column 1 -sticky ew

    $lw add -text [::msgcat::mc "Log out"] -command logout_reason
    $lw add -text [::msgcat::mc "Cancel"] -command "$lw withdraw"

    $lw draw $lf.reason
}

proc logout_reason {} {
    global logoutuserstatus logouttextstatus logoutpriority reason reasonlist

    set reasonlist [update_combo_list $reasonlist $reason 10]

    set lw .logout
    if {[winfo exists $lw]} {
	destroy $lw
    }

    # TODO
    set logoutpriority $::loginconf(priority)
    set logouttextstatus $reason
    set logoutuserstatus unavailable

    logout
}

# vim:ts=8:sw=4:sts=4:noet
