1# $Id$
2# Entity capabilities support (XEP-0115)
3
4package require sha1
5package require md5
6package require base64
7
8namespace eval caps {
9    set ::NS(caps) http://jabber.org/protocol/caps
10    variable caps_node ""
11
12    custom::defgroup Plugins \
13	[::msgcat::mc "Plugins options."] \
14	-group Tkabber
15
16    custom::defgroup Caps \
17	[::msgcat::mc "Options for entity capabilities plugin."] \
18	-group Plugins
19
20    custom::defvar options(enable) 1 \
21	[::msgcat::mc "Enable announcing entity capabilities in\
22		       every outgoing presence."] \
23	-group Caps -type boolean
24
25    custom::defvar options(hash) sha-1 \
26	[::msgcat::mc "Use the specified function to hash supported\
27		       features list."] \
28	-group Caps -type options -values {md5 MD5 sha-1 SHA-1}
29}
30
31proc caps::hash {identities features extras hash} {
32    debugmsg caps "$identities; $features; $extras; $hash"
33
34    set binidentities {}
35    foreach id $identities {
36	set category [::xmpp::xml::getAttr $id category]
37	set type [::xmpp::xml::getAttr $id type]
38	set lang [::xmpp::xml::getAttr $id xml:lang]
39	set name [::xmpp::xml::getAttr $id name]
40	lappend binidentities [encoding convertto utf-8 $category/$type/$lang/$name]
41    }
42
43    set binfeatures {}
44    foreach fe $features {
45	lappend binfeatures [encoding convertto utf-8 $fe]
46    }
47
48    set binextra {}
49    foreach eform $extras {
50	set bineform {}
51	foreach {etag extra} $eform {
52	    lassign $extra var type label values
53	    switch -- $var/$type {
54		FORM_TYPE/hidden {
55		    set form_type [encoding convertto utf-8 [lindex $values 0]]
56		}
57		default {
58		    set binex {}
59		    foreach val $values {
60			lappend binex [encoding convertto utf-8 $val]
61		    }
62		    lappend bineform \
63			    [linsert [lsort -ascii $binex] 0 \
64				     [encoding convertto utf-8 $var]]
65		}
66	    }
67	}
68	set bineform1 {}
69	foreach ex [lsort -ascii -index 0 $bineform] {
70	    lappend bineform1 [join $ex "<"]
71	}
72	lappend binextra [linsert $bineform1 0 $form_type]
73    }
74
75    set binextra1 {}
76    foreach b [lsort -ascii -index 0 $binextra] {
77	lappend binextra1 [join $b "<"]
78    }
79
80    debugmsg caps "$binidentities; $binfeatures; $binextra1"
81
82    set binstr [join [concat [lsort -ascii $binidentities] \
83			     [lsort -ascii $binfeatures] \
84			     $binextra1] "<"]
85
86    debugmsg caps "$binstr"
87
88    if {[string equal $binstr ""]} {
89	return ""
90    }
91
92    append binstr "<"
93
94    switch -- $hash {
95	md5 {
96	    if {[catch {::md5::md5 -hex $binstr} hex]} {
97		# Old md5 package.
98		set hex [::md5::md5 $binstr]
99	    }
100	    set binhash [binary format H32 $hex]
101	}
102	sha-1 {
103	    set binhash [binary format H40 [::sha1::sha1 $binstr]]
104	}
105	default {
106	    # Unsupported hash type
107	    return ""
108	}
109    }
110    return [base64::encode $binhash]
111}
112
113proc caps::get_presence_x {varname xlib status} {
114    variable options
115    variable caps_node
116    upvar 2 $varname var
117
118    if {!$options(enable)} return
119
120    lassign [disco::info_query_get_handler $xlib "" "" en] \
121	    status identities features extras
122
123    debugmsg caps "$status; $identities; $features; $extras"
124
125    if {![string equal $status result]} return
126
127    set ver [hash $identities $features $extras $options(hash)]
128    if {[string equal $ver ""]} return
129
130    lappend var [::xmpp::xml::create c \
131			-xmlns $::NS(caps) \
132			-attrs [list hash $options(hash) \
133				     node http://tkabber.jabber.ru/ \
134				     ver $ver]]
135
136    set caps_node http://tkabber.jabber.ru/#$ver
137
138    debugmsg caps "$caps_node"
139
140    return
141}
142
143hook::add presence_xlist_hook [namespace current]::caps::get_presence_x
144
145proc caps::disco_reply {varname type node xlib from lang} {
146    variable caps_node
147    upvar 2 $varname res
148
149    if {$type != "info" || $node != $caps_node} return
150
151    set res [disco::info_query_get_handler $xlib "" "" en]
152
153    return stop
154}
155
156hook::add disco_node_reply_hook [namespace current]::caps::disco_reply
157
158# TODO match caps hash to a set of features
159proc caps::process_presence {xlib from type x args} {
160    variable htype
161    variable hnode
162    variable hver
163
164    switch -- $type {
165	unavailable {
166	    catch {unset htype($xlib,$from)}
167	    catch {unset hnode($xlib,$from)}
168	    catch {unset hver($xlib,$from)}
169	}
170	available {
171	    foreach xs $x {
172		::xmpp::xml::split $xs tag xmlns attrs cdata subels
173		if {[string equal $xmlns $::NS(caps)]} {
174		    set htype($xlib,$from) [::xmpp::xml::getAttr $attrs hash]
175		    set hnode($xlib,$from) [::xmpp::xml::getAttr $attrs node]
176		    set hver($xlib,$from)  [::xmpp::xml::getAttr $attrs ver]
177		    return
178		}
179	    }
180	    # Unset caps if they aren't included in <presence/>
181	    catch {unset htype($xlib,$from)}
182	    catch {unset hnode($xlib,$from)}
183	    catch {unset hver($xlib,$from)}
184	}
185    }
186}
187
188hook::add client_presence_hook [namespace current]::caps::process_presence
189
190proc caps::clean {xlib} {
191    variable htype
192    variable hnode
193    variable hver
194
195    array unset htype $xlib,*
196    array unset hnode $xlib,*
197    array unset hver $xlib,*
198}
199
200hook::add disconnected_hook [namespace current]::caps::clean
201
202proc caps::request_info {xlib jid} {
203    variable hnode
204    variable hver
205
206    if {![info exists hver($xlib,$jid)] || ![info exists hnode($xlib,$jid)]} {
207	after idle [namespace code [list info_receive $xlib $jid error {} {} {}]]
208	return
209    }
210
211    ::disco::request_info $xlib $jid \
212	    -node $hnode($xlib,$jid)#$hver($xlib,$jid) \
213	    -cache yes \
214	    -command [namespace code [list info_receive $xlib $jid]]
215}
216
217proc caps::info_receive {xlib jid status identities features extras} {
218    variable hidentities
219    variable hfeatures
220    variable htype
221    variable hnode
222    variable hver
223
224    debugmsg caps "$xlib; $jid; $status; $identities; $features; $extras"
225
226    if {![string equal $status ok]} return
227
228    if {![info exists hver($xlib,$jid)] || ![info exists htype($xlib,$jid)]} return
229
230    if {[string equal $htype($xlib,$jid) ""]} {
231	debugmsg caps "Legacy caps ver $hver($xlib,$jid) for $jid"
232
233	# TODO: legacy caps support
234    } else {
235	set hash [hash $identities $features $extras $htype($xlib,$jid)]
236	if {![string equal $hash $hver($xlib,$jid)]} {
237	    debugmsg caps "Mismatched caps ver for $jid, expected $hver($xlib,$jid), calculated $hash"
238
239	    # TODO: Treat mismatched ver as legacy one
240	    return
241	}
242
243	debugmsg caps "Caps ver $hash for $jid matches its disco#info"
244
245	set hidentities($htype($xlib,$jid),$hver($xlib,$jid)) $identities
246	set hfeatures($htype($xlib,$jid),$hver($xlib,$jid)) $features
247    }
248}
249
250