1# roster.tcl --
2#
3#       This file is a part of the XMPP library. It implements basic
4#       roster routines (RFC-3921 and RFC-6121).
5#
6# Copyright (c) 2008-2014 Sergei Golovan <sgolovan@nes.ru>
7#
8# See the file "license.terms" for information on usage and redistribution
9# of this file, and for a DISCLAMER OF ALL WARRANTIES.
10#
11# $Id$
12
13package require xmpp
14
15package provide xmpp::roster 0.1
16
17namespace eval ::xmpp::roster {}
18
19# ::xmpp::roster::features --
20#
21#       Return roster features list it can be empty or include 'ver' string
22#       which means that roster versioning is supported (XEP-0237 and later
23#       RFC-6121, section 2.6)
24
25proc ::xmpp::roster::features {xlib} {
26    set features {}
27    foreach f [::xmpp::streamFeatures $xlib] {
28        ::xmpp::xml::split $f tag xmlns attrs cdata subels
29
30        if {[string equal $tag ver] &&
31                [string equal $xmlns urn:xmpp:features:rosterver]} {
32            lappend features ver
33        }
34    }
35    set features
36}
37
38# ::xmpp::roster::new --
39
40proc ::xmpp::roster::new {xlib args} {
41    variable id
42
43    if {![info exists id]} {
44        set id 0
45    }
46
47    set token [namespace current]::[incr id]
48    variable $token
49    upvar 0 $token state
50
51    set state(xlib) $xlib
52    set state(rid) 0
53    set state(items) {}
54    set state(-version) ""
55    set state(-cache) {}
56
57    foreach {key val} $args {
58        switch -- $key {
59            -version -
60            -cache -
61            -itemcommand {
62                set state($key) $val
63            }
64            default {
65                unset state
66                return -code error \
67                       [::msgcat::mc "Illegal option \"%s\"" $key]
68            }
69        }
70    }
71
72    ::xmpp::iq::RegisterIQ $xlib set * jabber:iq:roster \
73                           [namespace code [list ParsePush $token]]
74    set token
75}
76
77# ::xmpp::roster::free --
78
79proc ::xmpp::roster::free {token} {
80    variable $token
81    upvar 0 $token state
82
83    if {![info exists state(xlib)]} return
84
85    set xlib $state(xlib)
86    set version $state(-version)
87    set cache $state(-cache)
88
89    ::xmpp::iq::UnregisterIQ $xlib set * jabber:iq:roster
90
91    unset state
92    list $version $cache
93}
94
95# ::xmpp::roster::items --
96
97proc ::xmpp::roster::items {token args} {
98    variable $token
99    upvar 0 $token state
100
101    set normalized 0
102
103    foreach {key val} $args {
104        switch -- $key {
105            -normalized {
106                set normalized $val
107            }
108        }
109    }
110
111    if {$normalized} {
112        return $state(items)
113    } else {
114        set items {}
115        foreach njid $state(items) {
116            lappend items [::xmpp::xml::getAttr $state(roster,$njid) jid]
117        }
118        return $items
119    }
120}
121
122# ::xmpp::roster::item --
123
124proc ::xmpp::roster::item {token jid {key -all}} {
125    variable $token
126    upvar 0 $token state
127
128    set njid [::xmpp::jid::normalize $jid]
129
130    switch -- $key {
131        -all {
132            if {![info exists state(roster,$njid)]} {
133                return {}
134            } else {
135                return $state(roster,$njid)
136            }
137        }
138        -jid -
139        -name -
140        -subscription -
141        -ask -
142        -groups {
143            if {![info exists state(roster,$njid)]} {
144                return ""
145            } else {
146                return [::xmpp::xml::getAttr $state(roster,$njid) $key]
147            }
148        }
149        default {
150            return -code error \
151                   [::msgcat::mc "Illegal option \"%s\"" $key]
152        }
153    }
154}
155
156# ::xmpp::roster::remove --
157
158proc ::xmpp::roster::remove {token jid args} {
159    eval [list send $token -jid $jid -subscription remove] $args
160}
161
162# ::xmpp::roster::send --
163
164proc ::xmpp::roster::send {token args} {
165    variable $token
166    upvar 0 $token state
167    set xlib $state(xlib)
168
169    set timeout 0
170    set cmd {}
171    set item {}
172    set subels {}
173
174    foreach {key val} $args {
175        switch -- $key {
176            -timeout {
177                set timeout $val
178            }
179            -command {
180                set cmd [list -command $val]
181            }
182            -jid {
183                if {[llength $item] > 0} {
184                    lappend subels [eval $item]
185                }
186                set item [list ::xmpp::xml::create item -attrs [list jid $val]]
187            }
188            -name {
189                lappend item -attrs [list name $val]
190            }
191            -subscription {
192                lappend item -attrs [list subscription $val]
193            }
194            -ask {
195                lappend item -attrs [list ask $val]
196            }
197            -groups {
198                set groups {}
199                foreach group $val {
200                    lappend groups [::xmpp::xml::create group -cdata $group]
201                }
202                lappend item -subelements $groups
203            }
204            default {
205                return -code error \
206                       [::msgcat::mc "Illegal option \"%s\"" $key]
207            }
208        }
209    }
210
211    set query [::xmpp::xml::create query -xmlns jabber:iq:roster \
212                                         -subelements $subels]
213
214    eval [list ::xmpp::sendIQ $xlib set \
215                              -query $query \
216                              -timeout $timeout] $cmd
217}
218
219# ::xmpp::roster::get --
220
221proc ::xmpp::roster::get {token args} {
222    variable $token
223    upvar 0 $token state
224    set xlib $state(xlib)
225
226    set timeout 0
227    set attrs {}
228    set cmd {}
229
230    foreach {key val} $args {
231        switch -- $key {
232            -timeout {
233                set timeout $val
234            }
235            -command {
236                set cmd [list $val]
237            }
238            default {
239                return -code error \
240                       [::msgcat::mc "Illegal option \"%s\"" $key]
241            }
242        }
243    }
244
245    if {[lsearch -exact [features $xlib] ver] >= 0} {
246        lappend attrs ver $state(-version)
247    }
248
249    set rid [incr state(rid)]
250    set state(items) {}
251    array unset state roster,*
252
253    ::xmpp::sendIQ $xlib get \
254                   -query [::xmpp::xml::create query \
255                                               -xmlns jabber:iq:roster \
256                                               -attrs $attrs] \
257                   -command [namespace code [list ParseAnswer $token \
258                                                              $rid \
259                                                              $cmd]] \
260                   -timeout $timeout
261
262    if {[llength $cmd] > 0} {
263        # Asynchronous mode
264        return $token
265    } else {
266        # Synchronous mode
267        vwait $token\(status,$rid)
268
269        foreach {status msg} $state(status,$rid) break
270        unset state(status,$rid)
271
272        if {[string equal $status ok]} {
273            return $msg
274        } else {
275            if {[string equal $status abort]} {
276                return -code break $msg
277            } else {
278                return -code error $msg
279            }
280        }
281    }
282}
283
284# ::xmpp::roster::ParsePush --
285
286proc ::xmpp::roster::ParsePush {token xlib from xmlElement args} {
287    variable $token
288    upvar 0 $token state
289
290    if {![info exists state(xlib)]} return
291
292    # -to attribute contains the own JID, so check from JID to prevent
293    # malicious users to pretend they perform roster push
294    set to [::xmpp::xml::getAttr $args -to]
295
296    if {![string equal $from ""] && \
297            ![::xmpp::jid::equal $from $to] && \
298            ![::xmpp::jid::equal $from [::xmpp::jid::stripResource $to]] && \
299            ![::xmpp::jid::equal $from [::xmpp::jid::server $to]]} {
300
301        return [list error cancel service-unavailable]
302    }
303
304    ParseItems $token push $xmlElement
305
306    return [list result {}]
307}
308
309# ::xmpp::roster::ParseAnswer --
310
311proc ::xmpp::roster::ParseAnswer {token rid cmd status xmlElement} {
312    variable $token
313    upvar 0 $token state
314
315    if {![info exists state(xlib)]} return
316
317    set xlib $state(xlib)
318
319    ::xmpp::Debug $xlib 2 "$token $rid '$cmd' $status"
320
321    if {[string equal $status ok]} {
322        ParseItems $token fetch $xmlElement
323        set xmlElement ""
324    }
325
326    if {[llength $cmd] > 0} {
327        uplevel #0 [lindex $cmd 0] [list $status $xmlElement]
328    } else {
329        # Trigger vwait in [roster]
330        set state(status,$rid) [list $status $xmlElement]
331    }
332    return
333}
334
335# ::xmpp::roster::ParseItems --
336
337proc ::xmpp::roster::ParseItems {token mode xmlElement} {
338    variable $token
339    upvar 0 $token state
340
341    if {$xmlElement == {}} {
342        # Empty result, so use the cached roster
343
344        set items {}
345        foreach item $state(-cache) {
346            foreach {njid jid name subsc ask groups} $item break
347
348            lappend items $njid
349
350            set state(roster,$njid) [list jid          $jid \
351                                          name         $name \
352                                          subscription $subsc \
353                                          ask          $ask \
354                                          groups       $groups]
355
356            if {[info exists state(-itemcommand)]} {
357                uplevel #0 $state(-itemcommand) [list $njid \
358                                                      -jid          $jid \
359                                                      -name         $name \
360                                                      -subscription $subsc \
361                                                      -ask          $ask \
362                                                      -groups       $groups]
363            }
364        }
365
366        set state(items) [lsort -unique $items]
367        return
368    }
369
370    ::xmpp::xml::split $xmlElement tag xmlns attrs cdata subels
371
372    # Get the new roster version
373    set state(-version) [::xmpp::xml::getAttr $attrs ver ""]
374
375    # Empty cache but not while roster push
376    if {[string equal $mode fetch]} {
377        set state(-cache) {}
378    }
379
380    foreach subel $subels {
381        ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels
382
383        set groups {}
384        set jid    [::xmpp::xml::getAttr $sattrs jid]
385        set name   [::xmpp::xml::getAttr $sattrs name]
386        set subsc  [::xmpp::xml::getAttr $sattrs subscription]
387        set ask    [::xmpp::xml::getAttr $sattrs ask]
388
389        foreach ssubel $ssubels {
390            ::xmpp::xml::split $ssubel sstag ssxmlns ssattrs sscdata sssubels
391
392            switch -- $sstag {
393                group {
394                    lappend groups $sscdata
395                }
396            }
397        }
398
399        set njid [::xmpp::jid::normalize $jid]
400
401        switch -- $subsc {
402            remove {
403                # Removing roster item
404
405                set idx [lsearch -exact $state(items) $njid]
406                if {$idx >= 0} {
407                    set state(items) [lreplace $state(items) $idx $idx]
408                }
409
410                set idx -1
411                set i -1
412                foreach item $state(-cache) {
413                    incr i
414                    if {[string equal [lindex $item 0] $njid]} {
415                        set idx $i
416                        break
417                    }
418                }
419                if {$idx >= 0} {
420                    set state(-cache) [lreplace $state(-cache) $idx $idx]
421                }
422
423                catch {unset state(roster,$njid)}
424            }
425            default {
426                # Updating or adding roster item
427
428                set state(items) \
429                    [lsort -unique [linsert $state(items) 0 $njid]]
430
431                set state(roster,$njid) [list jid          $jid \
432                                              name         $name \
433                                              subscription $subsc \
434                                              ask          $ask \
435                                              groups       $groups]
436
437                lappend state(-cache) \
438                        [list $njid $jid $name $subsc $ask $groups]
439            }
440        }
441
442        if {[info exists state(-itemcommand)]} {
443            uplevel #0 $state(-itemcommand) [list $njid \
444                                                  -jid          $jid \
445                                                  -name         $name \
446                                                  -subscription $subsc \
447                                                  -ask          $ask \
448                                                  -groups       $groups]
449        }
450    }
451
452    return
453}
454
455# vim:ft=tcl:ts=8:sw=4:sts=4:et
456