1# $Id$
2
3package require xmpp::dns
4package require xmpp::auth
5package require xmpp::register
6
7if {[catch {package require xmpp::starttls}]} {
8    set use_tls 0
9} else {
10    set use_tls 1
11}
12
13if {[catch {package require xmpp::compress}]} {
14    set have_compress 0
15} else {
16    set have_compress 1
17}
18
19if {[catch {package require xmpp::sasl}]} {
20    set have_sasl 0
21} else {
22    set have_sasl 1
23}
24
25if {[catch {package require xmpp::transport::bosh}]} {
26    set have_bosh 0
27} else {
28    set have_bosh 1
29}
30
31if {[catch {package require xmpp::transport::poll}]} {
32    set have_http_poll 0
33} else {
34    set have_http_poll 1
35}
36
37custom::defgroup Warnings [::msgcat::mc "Warning display options."] \
38    -group Tkabber
39
40if {$use_tls} {
41    custom::defvar tls_warnings 1 [::msgcat::mc "Display SSL warnings."] \
42	-group Warnings -type boolean
43}
44
45custom::defgroup Login \
46    [::msgcat::mc "Login options."] \
47    -group Tkabber
48
49custom::defvar autologin 0 \
50    [::msgcat::mc "Whether to automatically login to server or\
51		   show the login window."] \
52    -group Login -type options \
53    -values [list 0  [::msgcat::mc "Show the login window"] \
54		  1  [::msgcat::mc "Autologin to the server"] \
55		  -1 [::msgcat::mc "Don't show the login window"]]
56
57custom::defvar loginconf(user) "" \
58    [::msgcat::mc "User name."] \
59    -group Login -type string
60custom::defvar loginconf(server) "localhost" \
61    [::msgcat::mc "Server name."] \
62    -group Login -type string
63custom::defvar loginconf(password) "" \
64    [::msgcat::mc "Password."] \
65    -group Login -type password
66custom::defvar loginconf(resource) "tkabber" \
67    [::msgcat::mc "Resource."] \
68    -group Login -type string
69custom::defvar loginconf(priority) "8" \
70    [::msgcat::mc "Priority."] \
71    -group Login -type integer
72
73custom::defvar loginconf(connect_forever) 0 \
74    [::msgcat::mc "Retry to connect forever."] \
75    -group Login -type boolean
76
77custom::defvar loginconf(allowauthplain) 0 \
78    [::msgcat::mc "Allow plaintext authentication mechanisms (when password\
79		   is transmitted unencrypted)."] \
80	-group Login -type boolean
81
82custom::defvar loginconf(allowgoogletoken) 1 \
83    [::msgcat::mc "Allow X-GOOGLE-TOKEN authentication mechanisms. It requires\
84		   connection to Google via HTTPS."] \
85	-group Login -type boolean
86
87if {$have_sasl} {
88    custom::defvar loginconf(usesasl) 1 \
89	[::msgcat::mc "Use SASL authentication."] \
90	-group Login -type boolean
91}
92
93set values [list plaintext [::msgcat::mc "Plaintext"]]
94if {$have_compress} {
95    lappend values compressed [::msgcat::mc "Compression"]
96}
97if {$use_tls} {
98    lappend values encrypted [::msgcat::mc "Encryption (STARTTLS)"] \
99		   ssl       [::msgcat::mc "Encryption (legacy SSL)"]
100}
101
102if {$use_tls || $have_compress} {
103    custom::defvar loginconf(stream_options) plaintext \
104	[::msgcat::mc "XMPP stream options when connecting to server."] \
105	-group Login -type options \
106	-values $values
107}
108
109if {$use_tls} {
110    custom::defvar loginconf(sslcertfile) "" \
111	[::msgcat::mc "SSL certificate file (optional)."] \
112	-group Login -type file
113    custom::defvar loginconf(sslcacertstore) "" \
114	[::msgcat::mc "SSL certification authority file or directory (optional)."] \
115	-group Login -type file
116    custom::defvar loginconf(sslkeyfile) "" \
117	[::msgcat::mc "SSL private key file (optional)."] \
118	-group Login -type file
119}
120
121custom::defvar loginconf(usealtserver) 0 \
122    [::msgcat::mc "Use explicitly-specified server address and port."] \
123    -group Login -type boolean
124custom::defvar loginconf(altserver) "" \
125    [::msgcat::mc "Server name or IP-address."] \
126    -group Login -type string
127custom::defvar loginconf(altport) "5222" \
128    [::msgcat::mc "Server port."] \
129    -group Login -type integer
130
131custom::defvar loginconf(replace_opened) 1 \
132    [::msgcat::mc "Replace opened connections."] \
133    -group Login -type boolean
134
135if {$have_bosh} {
136    custom::defvar loginconf(usebosh) 0 \
137	[::msgcat::mc "Use BOSH connection method."] \
138	-group Login -type boolean
139    custom::defvar loginconf(boshurl) "" \
140	[::msgcat::mc "URL to connect to using BOSH."] \
141	-group Login -type string
142    custom::defvar loginconf(usekeys) 1 \
143	[::msgcat::mc "Use BOSH client security keys (recommended)."] \
144	-group Login -type boolean
145    custom::defvar loginconf(numberofboshkeys) 100 \
146	[::msgcat::mc "Number of BOSH client security keys to send\
147		       before creating new key sequence."] \
148	-group Login -type integer
149    custom::defvar loginconf(boshtimeout) 0 \
150	[::msgcat::mc "Timeout for waiting for BOSH responses (if set\
151		       to zero, Tkabber will wait forever)."] \
152	-group Login -type integer
153    custom::defvar loginconf(boshwait) 30000 \
154	[::msgcat::mc "Interval server can wait before responding to BOSH request\
155		       (in milliseconds)."] \
156	-group Login -type integer
157    custom::defvar loginconf(boshhold) 1 \
158	[::msgcat::mc "Maximum number of requests the connection manager is\
159		       allowed to keep waiting at any time."] \
160	-group Login -type integer
161}
162
163if {$have_http_poll} {
164    custom::defvar loginconf(usehttppoll) 0 \
165	[::msgcat::mc "Use HTTP poll connection method."] \
166	-group Login -type boolean
167    custom::defvar loginconf(pollurl) "" \
168	[::msgcat::mc "URL to connect to."] \
169	-group Login -type string
170    custom::defvar loginconf(usepollkeys) 1 \
171	[::msgcat::mc "Use HTTP poll client security keys (recommended)."] \
172	-group Login -type boolean
173    custom::defvar loginconf(numberofpollkeys) 100 \
174	[::msgcat::mc "Number of HTTP poll client security keys to send\
175		       before creating new key sequence."] \
176	-group Login -type integer
177    custom::defvar loginconf(polltimeout) 0 \
178	[::msgcat::mc "Timeout for waiting for HTTP poll responses (if set\
179		       to zero, Tkabber will wait forever)."] \
180	-group Login -type integer
181    custom::defvar loginconf(pollmin) 6000 \
182	[::msgcat::mc "Minimum poll interval."] \
183	-group Login -type integer
184    custom::defvar loginconf(pollmax) 60000 \
185	[::msgcat::mc "Maximum poll interval."] \
186	-group Login -type integer
187}
188
189custom::defvar reasonlist {} [::msgcat::mc "List of logout reasons."] \
190	-group Hidden
191
192######################################################################
193
194# connect errors mapping
195
196array set connect_error [list \
197	err_unknown 			[::msgcat::mc "Unknown error"] \
198	timeout				[::msgcat::mc "Timeout"] \
199	network-failure			[::msgcat::mc "Network failure"] \
200	err_authorization_required	[::msgcat::mc "Proxy authentication required"] \
201	err_version			[::msgcat::mc "Incorrect SOCKS version"] \
202	err_unsupported_method		[::msgcat::mc "Unsupported SOCKS method"] \
203	err_authentication_unsupported	[::msgcat::mc "Unsupported SOCKS authentication method"] \
204	err_authorization		[::msgcat::mc "SOCKS authentication failed"] \
205	rsp_failure			[::msgcat::mc "SOCKS request failed"] \
206	rsp_errconnect			[::msgcat::mc "SOCKS server cannot identify username"] \
207	rsp_erruserid			[::msgcat::mc "SOCKS server username identification failed"] \
208	rsp_notallowed			[::msgcat::mc "SOCKS connection not allowed by ruleset"] \
209	rsp_netunreachable		[::msgcat::mc "Network unreachable"] \
210	rsp_hostunreachable		[::msgcat::mc "Host unreachable"] \
211	rsp_refused			[::msgcat::mc "Connection refused by destination host"] \
212	rsp_expired			[::msgcat::mc "TTL expired"] \
213	rsp_cmdunsupported		[::msgcat::mc "SOCKS command not supported"] \
214	rsp_addrunsupported		[::msgcat::mc "Address type not supported by SOCKS proxy"] \
215	err_unknown_address_type	[::msgcat::mc "Unknown address type"]]
216
217# TLS info
218#
219# [::msgcat::mc "Certificate has expired"]
220# [::msgcat::mc "Self signed certificate"]
221
222######################################################################
223
224if {![info exists connections]} {
225    set connections {}
226}
227
228proc connections {{all 0}} {
229    global connections
230
231    set res {}
232    foreach c $connections {
233	if {$all || [lindex $c 1]} {
234	    lappend res [lindex $c 0]
235	}
236    }
237    return $res
238}
239
240proc add_to_connection {active xlib} {
241    global connections
242
243    set idx [lsearch -exact $connections [list $xlib 0]]
244    set connections [lreplace $connections $idx $idx]
245    set idx [lsearch -exact $connections [list $xlib 1]]
246    set connections [lreplace $connections $idx $idx]
247    lappend connections [list $xlib $active]
248}
249
250hook::add connected_hook [list add_to_connection 1] 1
251
252proc remove_from_connection {xlib} {
253    global connections
254
255    set idx [lsearch -exact $connections [list $xlib 0]]
256    set connections [lreplace $connections $idx $idx]
257    set idx [lsearch -exact $connections [list $xlib 1]]
258    set connections [lreplace $connections $idx $idx]
259}
260
261hook::add disconnected_hook remove_from_connection 1
262
263proc connection_jid {xlib} {
264    global connjid
265    return $connjid($xlib)
266}
267
268proc connection_bare_jid {xlib} {
269    global connjid
270    return [::xmpp::jid::stripResource $connjid($xlib)]
271}
272
273proc connection_user {xlib} {
274    global connjid
275    return [::xmpp::jid::node $connjid($xlib)]
276}
277
278proc connection_server {xlib} {
279    global connjid
280    return [::xmpp::jid::server $connjid($xlib)]
281}
282
283proc connection_resource {xlib} {
284    global connjid
285    return [::xmpp::jid::resource $connjid($xlib)]
286}
287
288proc connection_requested_jid {xlib} {
289    global connrjid
290    return $connrjid($xlib)
291}
292
293proc connection_requested_user {xlib} {
294    global connrjid
295    return [::xmpp::jid::node $connrjid($xlib)]
296}
297
298proc connection_requested_server {xlib} {
299    global connrjid
300    return [::xmpp::jid::server $connrjid($xlib)]
301}
302
303proc connection_requested_resource {xlib} {
304    global connrjid
305    return [::xmpp::jid::resource $connrjid($xlib)]
306}
307
308######################################################################
309
310proc login {logindata} {
311    global login_after_id
312
313    array set lc $logindata
314
315    set jid [::xmpp::jid::normalize [::xmpp::jid::jid $lc(user) \
316						      $lc(server) \
317						      $lc(resource)]]
318    set lc(jid) $jid
319    set logindata [array get lc]
320
321    if {[info exists login_after_id($jid)]} {
322	after cancel $login_after_id($jid)
323	unset login_after_id($jid)
324    }
325
326    login_log $jid ok [::msgcat::mc "Starting login"]
327
328    debugmsg login "Starting login ($jid)"
329    set_status [::msgcat::mc "Connecting to %s" $lc(server)]
330
331    login_connect $logindata
332}
333
334proc login_connected {xlib logindata status msg} {
335    global connect_error
336    global login_after_time
337
338    array set lc $logindata
339
340    switch -- $status {
341	ok {
342	    # OK, connected.
343	    add_to_connection 0 $xlib
344	    debugmsg login "Connect successful $xlib"
345
346	    set login_after_time 7500
347	    login_login $xlib $logindata
348	}
349	abort {
350	    # TODO
351	    debugmsg login "Connect aborted: $xlib $msg"
352	    login_log $lc(jid) abort $msg
353	}
354	default {
355	    # Nasty thing has happened.
356	    # $msg contains error message here.
357	    debugmsg login "Failed to connect: $xlib $status $msg"
358	    login_log $lc(jid) $status $msg
359
360	    if {$lc(connect_forever)} {
361		login_retry $logindata
362	    } else {
363		if {[winfo exists .connect_err]} {
364		    destroy .connect_err
365		}
366		if {[info exists connect_error($msg)]} {
367		    set msg $connect_error($msg)
368		}
369		set res [MessageDlg .connect_err -width 600 -icon error \
370		    -message [::msgcat::mc "Failed to connect: %s" $msg] \
371		    -type user -buttons [list abort [::msgcat::mc "Keep trying"]] \
372		    -default 0 -cancel 0]
373		if {$res} {
374		    set lc(connect_forever) 1
375		    set logindata [array get lc]
376		    login_retry $logindata
377		}
378	    }
379	}
380    }
381}
382
383proc login_retry {logindata} {
384    global login_after_time
385    global login_after_id
386
387    if {![info exists login_after_time]} {
388	set login_after_time 7500
389    }
390    if {$login_after_time < 1800000} {
391	# 1800000 == 30 * 60 * 1000 == 30min
392	# the sequence goes: 15s, 30s, 1min, 2min, 4min, 8min, 16min, 32min, 32min...
393	set login_after_time [expr {$login_after_time * 2}]
394    }
395    array set lc $logindata
396    set jid $lc(jid)
397
398    debugmsg login "Scheduling connect retry for $jid in ${login_after_time}ms"
399    if {[info exists login_after_id($jid)]} {
400	after cancel $login_after_id($jid)
401	unset login_after_id($jid)
402    }
403    login_retry1 $login_after_time $jid $logindata
404}
405
406proc login_retry1 {interval jid logindata} {
407    global login_after_id
408
409    incr interval -1000
410
411    if {$interval <= 0} {
412	login $logindata
413    } else {
414	set login_after_id($jid) [after 1000 [list login_retry1 $interval $jid $logindata]]
415	set_status [::msgcat::mc "Login retry for %s in %s" $jid \
416				 [format_time [expr {$interval/1000}]]]
417    }
418}
419
420proc client:tls_callback {xlib args} {
421    global tls_result tls_warnings
422    global ssl_certificate_fields
423    global tls_warning_info
424
425    switch -- [lindex $args 0] {
426	info {
427	    set_status [lindex $args 4]
428	}
429
430	verify {
431	    if {[cequal [set reason [lindex $args 5]] ""]} {
432		return 1
433	    }
434	    set info [::msgcat::mc [string totitle $reason 0 0]]
435	    append tls_warning_info($xlib) "$info\n"
436	    if {!$tls_warnings} {
437		return 1
438	    }
439	    append info [::msgcat::mc ". Proceed?\n\n"]
440	    foreach {k v} [lindex $args 3] {
441		switch -- $k {
442		    subject - issuer {
443			set v [regsub -all {\s*[/,]\s*(\w+=)} $v \n\t\\1]
444		    }
445		}
446		if {![cequal $v ""]} {
447		    if {[info exists ssl_certificate_fields($k)]} {
448			append info [format "%s: %s\n" \
449					    $ssl_certificate_fields($k) $v]
450		    } else {
451			append info [format "%s: %s\n" $k $v]
452		    }
453		}
454	    }
455
456	    set blocking [fconfigure [set fd [lindex $args 1]] -blocking]
457	    fconfigure $fd -blocking 1
458	    set readable [fileevent $fd readable]
459	    fileevent $fd readable {}
460
461	    set res [MessageDlg .tls_callback -aspect 50000 -icon warning \
462			        -type user -buttons {yes no} -default 1 \
463			        -cancel 1 \
464			        -message [string trim $info]]
465
466	    fileevent $fd readable $readable
467	    fconfigure $fd -blocking $blocking
468
469	    if {$res} {
470		set res 0
471	    } else {
472		set res 1
473	    }
474	    return $res
475	}
476
477	error {
478	    set tls_result [join [lrange $args 2 end] " "]
479	}
480
481	default {
482	}
483    }
484}
485
486proc create_xlib {jid} {
487    global connhist connrjid connjid
488
489    set njid [::xmpp::jid::normalize $jid]
490    if {[info exists connhist($njid)] && \
491	    [lsearch -exact [connections] $connhist($njid)] < 0} {
492	set xlib $connhist($njid)
493    } else {
494	set xlib [::xmpp::new -messagecommand    client:message    \
495			      -presencecommand   client:presence   \
496			      -iqcommand         client:iq         \
497			      -disconnectcommand client:disconnect \
498			      -statuscommand     client:status     \
499			      -errorcommand      client:error      \
500			      -logcommand        client:log]
501    }
502
503    if {![info exists connhist($njid)]} {
504	set connhist($njid) $xlib
505    }
506
507    set connrjid($xlib) $jid
508    set connjid($xlib) $jid
509
510    disco::new $xlib
511
512    return $xlib
513}
514
515proc login_connect {logindata} {
516    global use_tls have_compress have_sasl have_bosh have_http_poll
517    global tls_warning_info
518    global reconnect
519
520    array set lc $logindata
521
522    set jid [::xmpp::jid::jid $lc(user) \
523			      $lc(server) \
524			      $lc(resource)]
525
526    set xlib [create_xlib $jid]
527
528    set tls_warning_info($xlib) ""
529    set reconnect($xlib) 0
530
531    set ascii_server [idna::domain_toascii $lc(server)]
532
533    set args {-proxyfilter ::proxy::proxyfilter}
534
535    if {$have_bosh && $lc(usebosh)} {
536	if {$lc(boshurl) != ""} {
537	    set url $lc(boshurl)
538	} else {
539	    # TODO: Asynchronous DNS resolution
540	    if {[catch {::xmpp::dns::resolveBOSH $ascii_server} urls]} {
541		set urls {}
542	    }
543	    if {[llength $urls] == 0} {
544		set url ""
545	    } else {
546		set url [lindex $urls 0]
547	    }
548	}
549
550	set transport bosh
551	lappend args -transport bosh \
552		     -timeout   $lc(boshtimeout) \
553		     -wait      $lc(boshwait) \
554		     -hold      $lc(boshhold) \
555		     -url       $url \
556		     -usekeys   $lc(useboshkeys) \
557		     -numkeys   $lc(numberofboshkeys) \
558
559	eval [list ::xmpp::connect $xlib \
560				   -command [list login_connect_result $xlib {} $logindata $args]] \
561				   $args
562    } elseif {$have_http_poll && $lc(usehttppoll)} {
563	if {$lc(pollurl) != ""} {
564	    set url $lc(pollurl)
565	} else {
566	    # TODO: Asynchronous DNS resolution
567	    if {[catch {::xmpp::dns::resolveHTTPPoll $ascii_server} urls]} {
568		set urls {}
569	    }
570	    if {[llength $urls] == 0} {
571		set url ""
572	    } else {
573		set url [lindex $urls 0]
574	    }
575	}
576
577	set transport poll
578	lappend args -transport poll \
579		     -timeout   $lc(polltimeout) \
580		     -int       $lc(pollmin) \
581		     -min       $lc(pollmin) \
582		     -max       $lc(pollmax) \
583		     -url       $url \
584		     -usekeys   $lc(usepollkeys) \
585		     -numkeys   $lc(numberofpollkeys) \
586
587	eval [list ::xmpp::connect $xlib \
588				   -command [list login_connect_result $xlib {} $logindata $args]] \
589				   $args
590    } else {
591	if {$lc(usealtserver)} {
592	    set hosts {}
593	} else {
594	    # TODO: Asynchronous DNS resolution
595	    if {[catch {::xmpp::dns::resolveXMPPClient $ascii_server} hosts]} {
596		set hosts {}
597	    }
598	    if {[llength $hosts] == 0} {
599		set hosts [list [list $ascii_server 5222]]
600	    }
601	}
602	set transport tcp
603	if {$use_tls && $lc(stream_options) == "ssl"} {
604	    set transport tls
605	    # Do some heuristic.
606	    # Traditionally legacy SSL port is 5223,
607	    # so let's add 1 to all ports from SRV reply
608	    set hosts1 {}
609	    foreach hp $hosts {
610		lassign $hp host port
611		lappend hosts1 [list $host [incr port]]
612	    }
613	    set hosts $hosts1
614	    lappend args -tls1          1 \
615			 -certfile      $lc(sslcertfile) \
616			 -castore       $lc(sslcacertstore) \
617			 -keyfile       $lc(sslkeyfile) \
618			 -verifycommand [list client:tls_callback $xlib] \
619			 -infocommand   [list update_tls_info $xlib]
620	}
621
622	lappend args -transport $transport
623
624	if {$lc(usealtserver)} {
625	    set hosts [list [list [idna::domain_toascii $lc(altserver)] \
626			    $lc(altport)]]
627	}
628
629	set hosts [lassign $hosts hp]
630	lassign $hp host port
631
632	global xmppTransport
633	set xmppTransport($xlib) $transport
634
635	eval [list ::xmpp::connect $xlib $host $port \
636				   -command [list login_connect_result $xlib $hosts $logindata $args]] \
637				   $args
638    }
639}
640
641proc login_connect_result {xlib hosts logindata args status msg} {
642    if {$status == "ok" || $status == "abort" || [llength $hosts] == 0} {
643	login_connected $xlib $logindata $status $msg
644    } else {
645	set hosts [lassign $hosts hp]
646	lassign $hp host port
647
648	eval [list ::xmpp::connect $xlib $host $port \
649				   -command [list login_connect_result $xlib $hosts $logindata $args]] \
650				   $args
651    }
652}
653
654########################################################################
655
656proc login_login {xlib logindata} {
657    global use_tls have_compress have_sasl
658    global loginconf_hist
659
660    set loginconf_hist($xlib) $logindata
661
662    array set lc $logindata
663
664    if {($use_tls && $lc(stream_options) == "encrypted") || \
665	    ($have_compress && $lc(stream_options) == "compressed") || \
666	    ($have_sasl && $lc(usesasl))} {
667	::xmpp::openStream $xlib $lc(server) \
668			   -version 1.0 \
669			   -command [list login_login1 $xlib $logindata]
670    } else {
671	::xmpp::openStream $xlib $lc(server) \
672			   -command [list login_login1 $xlib $logindata]
673    }
674}
675
676proc login_login1 {xlib logindata status sessionid} {
677    global use_tls have_compress
678
679    if {$status != "ok"} {
680	recv_auth_result $xlib $logindata $status $sessionid
681	return
682    }
683
684    array set lc $logindata
685
686    if {!$lc(usebosh) && !$lc(usehttppoll) && \
687	    $use_tls && $lc(stream_options) == "encrypted"} {
688	::xmpp::starttls::starttls $xlib \
689			-command       [list login_login2 $xlib $logindata] \
690			-tls1          1 \
691			-certfile      $lc(sslcertfile) \
692			-castore       $lc(sslcacertstore) \
693			-keyfile       $lc(sslkeyfile) \
694			-verifycommand [list client:tls_callback $xlib] \
695			-infocommand   [list update_tls_info $xlib]
696    } elseif {!$lc(usebosh) && !$lc(usehttppoll) && \
697	    $have_compress && $lc(stream_options) == "compressed"} {
698	::xmpp::compress::compress $xlib \
699			-command     [list login_login2 $xlib $logindata]
700    } else {
701	login_login2 $xlib $logindata $status $sessionid
702    }
703}
704
705proc login_login2 {xlib logindata status sessionid} {
706    global have_sasl
707
708    if {$status != "ok"} {
709	recv_auth_result $xlib $logindata $status $sessionid
710	return
711    }
712
713    array set lc $logindata
714
715    if {$lc(allowauthplain)} {
716	set digest auto
717    } else {
718	set digest true
719    }
720
721    if {$lc(allowgoogletoken)} {
722	set disable {}
723    } else {
724	set disable {X-GOOGLE-TOKEN}
725    }
726
727    if {$have_sasl && $lc(usesasl)} {
728	# SASL authentication
729        ::xmpp::sasl::auth $xlib -username $lc(user) \
730                                 -password $lc(password) \
731                                 -resource $lc(resource) \
732				 -digest   $digest \
733				 -disable  $disable \
734				 -command  [list recv_auth_result $xlib \
735								 $logindata]
736    } else {
737	# Non-SASL authentication
738        ::xmpp::auth::auth $xlib -sessionid $sessionid \
739                                 -username  $lc(user) \
740                                 -password  $lc(password) \
741                                 -resource  $lc(resource) \
742				 -digest    $digest \
743				 -command [list recv_auth_result $xlib \
744								 $logindata]
745    }
746}
747
748########################################################################
749
750proc logout {{xlib {}}} {
751    global login_after_id
752
753    debugmsg login "LOGOUT $xlib"
754
755    if {$xlib == {}} {
756	foreach jid [array names login_after_id] {
757	    after cancel $login_after_id($jid)
758	    unset login_after_id($jid)
759	}
760
761	foreach xlib [connections 1] {
762	    login_log [connection_jid $xlib] ok "Logout"
763	    disconnected $xlib
764	}
765    } else {
766	login_log [connection_jid $xlib] ok [::msgcat::mc "Logout"]
767	disconnected $xlib
768    }
769}
770
771proc client:disconnect {xlib} {
772    global reconnect
773    global loginconf_hist
774
775    login_log [connection_jid $xlib] error [::msgcat::mc "Forced logout"]
776
777    if {$reconnect($xlib)} {
778	debugmsg login "RECONNECT $xlib"
779    } else {
780	debugmsg login "DISCONNECT $xlib"
781    }
782
783    disconnected $xlib
784
785    if {$reconnect($xlib)} {
786	after 1000 [list login $loginconf_hist($xlib)]
787    }
788}
789
790proc connected {xlib logindata} {
791    hook::run connected_hook $xlib
792}
793
794# TODO
795proc disconnected {xlib} {
796    remove_from_login_after_id $xlib
797
798    if {[lsearch -exact [connections] $xlib] < 0} {
799	::xmpp::disconnect $xlib
800	return
801    }
802
803    hook::run disconnected_hook $xlib
804}
805
806hook::add disconnected_hook ::xmpp::disconnect 10
807
808proc client:log {xlib dir type msg} {
809    hook::run log_hook $xlib $dir $type $msg
810}
811
812proc remove_from_login_after_id {xlib} {
813    global login_after_id
814
815    set jid [::xmpp::jid::normalize [connection_requested_jid $xlib]]
816    if {[info exists login_after_id($jid)]} {
817	after cancel $login_after_id($jid)
818	unset login_after_id($jid)
819    }
820}
821
822proc recv_auth_result {xlib logindata status xml} {
823    global connjid
824    global reconnect
825
826    array set lc $logindata
827
828    switch -- $status {
829	ok {
830	    set connjid($xlib) $xml
831	    set reconnect($xlib) 1
832	    login_log $xml ok [::msgcat::mc "Login is successful"]
833	    connected $xlib $logindata
834	}
835	abort {
836	    # TODO
837	    debugmsg login "Authentication aborted: $xlib [error_to_string $xml]"
838	    login_log $lc(jid) abort [error_to_string $xml]
839	    logout $xlib
840	}
841	default {
842	    login_log $lc(jid) $status [error_to_string $xml]
843
844	    lassign [error_type_condition $xml] type cond
845	    if {($type == "sasl") || ($type == "auth" && $cond == "not-authorized")} {
846		set res [MessageDlg [epath] -aspect 50000 -icon error \
847			     -message [::msgcat::mc "Authentication failed:\
848						     %s\nCreate new account?" \
849						    [error_to_string $xml]] \
850			     -type user -buttons {yes no} -default 0 -cancel 1]
851		if {!$res} {
852		    ::register::open $xlib $lc(server) \
853			    -command [list recv_register_result $xlib $logindata]
854		    return
855		}
856	    } else {
857		MessageDlg [epath] -aspect 50000 -icon error \
858		    -message [::msgcat::mc "Authentication failed: %s" \
859					   [error_to_string $xml]] \
860		    -type user -buttons {ok} -default 0 -cancel 0
861	    }
862
863	    logout $xlib
864	}
865    }
866}
867
868proc recv_register_result {xlib logindata status xml} {
869    logout $xlib
870
871    switch -- $status {
872	ok {
873	    login $logindata
874	}
875    }
876}
877
878proc client:error {xlib condition message} {
879    global reconnect
880
881    login_log [connection_jid $xlib] error $message
882
883    if {[winfo exists .client_error]} {
884	destroy .client_error
885    }
886
887    switch -- $condition {
888	bad-format -
889	connection-timeout -
890	invalid-from -
891	invalid-id -
892	invalid-namespace -
893	invalid-xml -
894	remote-connection-failed -
895	restricted-xml -
896	unsupported-encoding -
897	unsupported-stanza-type -
898	xml-not-well-formed {
899	    set reconnect($xlib) 1
900	}
901	default {
902	    set reconnect($xlib) 0
903	}
904    }
905
906    NonmodalMessageDlg .client_error -aspect 50000 -icon error \
907				     -message $message
908}
909
910# TODO
911proc show_logout_dialog {} {
912    global reason reasonlist
913
914    set lw .logout
915
916    if {[winfo exists $lw]} {
917	destroy $lw
918    }
919
920    Dialog $lw -title [::msgcat::mc "Logout with reason"] \
921	    -separator 1 -anchor e -default 0 -cancel 1
922
923    set lf [$lw getframe]
924    grid columnconfigure $lf 1 -weight 1
925
926    if {[llength $reasonlist]} {set reason [lindex $reasonlist 0]}
927
928    label $lf.lreason   -text    [::msgcat::mc "Reason:"]
929    ecursor_entry [ComboBox $lf.reason -textvariable reason \
930	    -values $reasonlist -width 35].e
931    label $lf.lpriority -text    [::msgcat::mc "Priority:"]
932    ecursor_entry [entry $lf.priority -textvariable loginconf(priority)]
933
934    grid $lf.lreason   -row 0 -column 0 -sticky e
935    grid $lf.reason    -row 0 -column 1 -sticky ew
936    grid $lf.lpriority -row 1 -column 0 -sticky e
937    grid $lf.priority  -row 1 -column 1 -sticky ew
938
939    $lw add -text [::msgcat::mc "Log out"] -command logout_reason
940    $lw add -text [::msgcat::mc "Cancel"] -command "$lw withdraw"
941
942    $lw draw $lf.reason
943}
944
945proc logout_reason {} {
946    global logoutuserstatus logouttextstatus logoutpriority reason reasonlist
947
948    set reasonlist [update_combo_list $reasonlist $reason 10]
949
950    set lw .logout
951    if {[winfo exists $lw]} {
952	destroy $lw
953    }
954
955    # TODO
956    set logoutpriority $::loginconf(priority)
957    set logouttextstatus $reason
958    set logoutuserstatus unavailable
959
960    logout
961}
962
963proc login_log_window {} {
964    global login_log
965
966    if {![info exists login_log]} {
967	set login_log {}
968    }
969
970    set w .login_log
971
972    if {[winfo exists $w]} {
973	raise_win $w
974	return
975    }
976
977    add_win $w -title [::msgcat::mc "Login log"] \
978	       -tabtitle [::msgcat::mc "Login log"] \
979	       -class Chat \
980	       -raisecmd [list focus $w.body]
981
982    [ScrolledWindow $w.sw] setwidget \
983			   [text $w.body -state disabled -takefocus 1]
984    bind $w.body <1> [list focus $w.body]
985
986    pack $w.sw -side bottom -fill both -expand yes
987
988    $w.body tag configure jid   \
989            -foreground [option get $w meforeground Chat]
990    $w.body tag configure ok \
991            -foreground [option get $w theyforeground Chat]
992    $w.body tag configure error  \
993            -foreground [option get $w errforeground Chat]
994
995    # TODO
996    #search::setup_panel $w
997
998    foreach {timestamp jid status message} $login_log {
999	log_window_append $timestamp $jid $status $message
1000    }
1001
1002    $w.body see end
1003    raise_win $w
1004}
1005
1006proc log_window_append {timestamp jid status message} {
1007    set w .login_log
1008
1009    if {![winfo exists $w.body]} return
1010
1011    $w.body configure -state normal
1012
1013    set scroll [expr {[lindex [$w.body yview] 1] == 1}]
1014
1015    $w.body insert end [clock format $timestamp -format "\[%m/%d %T\] "] "" \
1016		       $jid jid " "
1017
1018    switch -- $status {
1019	ok {set tag ok}
1020	default {set tag error}
1021    }
1022
1023    $w.body insert end $status $tag " "
1024
1025    $w.body insert end [string trim $message]
1026    $w.body insert end "\n"
1027
1028    if {$scroll} {
1029        $w.body see end
1030    }
1031
1032    $w.body configure -state disabled
1033}
1034
1035proc login_log {jid status message} {
1036    global login_log
1037
1038    if {![info exists login_log]} {
1039	set login_log {}
1040    }
1041
1042    set timestamp [clock seconds]
1043    lappend login_log $timestamp $jid $status $message
1044    log_window_append $timestamp $jid $status $message
1045}
1046
1047# vim:ts=8:sw=4:sts=4:noet
1048