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