1# blocking.tcl -- 2# 3# This file is part of the XMPP library. It implements interface to 4# Simple Communications Blocking (XEP-0191) 5# 6# Copyright (c) 2009-2010 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::iq 14 15package provide xmpp::blocking 0.1 16 17namespace eval ::xmpp::blocking { 18 namespace export blocklist block unblock register unregister 19} 20 21# ::xmpp::blocking::blocklist -- 22# 23# Request blocking list from the own XMPP server. 24# 25# Arguments: 26# xlib XMPP token. 27# -timeout msecs (optional) Timeout in milliseconds of waiting for 28# answer. 29# -command cmd (optional) Command to call back on receiving reply. 30# 31# Result: 32# ID of outgoing IQ. 33# 34# Side effects: 35# A blocklist request is sent over the XMPP connection $xlib. 36 37proc ::xmpp::blocking::blocklist {xlib args} { 38 set commands {} 39 set timeout 0 40 foreach {key val} $args { 41 switch -- $key { 42 -timeout { 43 set timeout $val 44 } 45 -command { 46 set commands [list $val] 47 } 48 default { 49 return -code error \ 50 [::msgcat::mc "Illegal option \"%s\"" $key] 51 } 52 } 53 } 54 55 ::xmpp::sendIQ $xlib get \ 56 -query [::xmpp::xml::create blocklist -xmlns urn:xmpp:blocking] \ 57 -command [namespace code [list ParseBlocklistAnswer $commands]] \ 58 -timeout $timeout 59} 60 61# ::xmpp::blocking::ParseBlocklistAnswer -- 62# 63# A helper procedure which is called upon blocklist is received. 64# It calls back the status and error message if any. 65# 66# Arguments: 67# commands A list of callbacks to call (only the first of them 68# is invoked. Status and list of blocked jids or error 69# stanza are appended to the called command. 70# status blocking request status (ok, error, abort, timeout). 71# xml Error message or result. 72# 73# Result: 74# Empty string. 75# 76# Side effects: 77# A callback is called if their list isn't empty. 78 79proc ::xmpp::blocking::ParseBlocklistAnswer {commands status xml} { 80 if {[llength $commands] == 0} return 81 82 if {[string equal $status ok]} { 83 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 84 set items {} 85 foreach subel $subels { 86 ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels 87 switch -- $stag/$sxmlns { 88 item/urn:xmpp:blocking { 89 if {[::xmpp::xml::isAttr $sattrs jid]} { 90 lappend items [::xmpp::xml::getAttr $sattrs jid] 91 } 92 } 93 } 94 } 95 96 uplevel #0 [lindex $commands 0] [list $status $items] 97 } else { 98 uplevel #0 [lindex $commands 0] [list $status $xml] 99 } 100 return 101} 102 103# ::xmpp::blocking::block -- 104# 105# Block specified JIDs. If no JIDs are specified then error is returned. 106# 107# Arguments: 108# xlib XMPP token. 109# -jid jid JID to block (may appear multiple times). 110# -jids jids List of JIDs to block (may appear multiple times). 111# -timeout msecs (optional) Timeout in milliseconds of waiting for 112# answer. 113# -command cmd (optional) Command to call back on receiving reply. 114# 115# Result: 116# ID of outgoing IQ. 117# 118# Side effects: 119# A block request is sent over the XMPP connection $xlib. 120 121proc ::xmpp::blocking::block {xlib args} { 122 set commands {} 123 set timeout 0 124 set items {} 125 foreach {key val} $args { 126 switch -- $key { 127 -jid { 128 if {![string equal $val ""]} { 129 lappend items [::xmpp::xml::create item \ 130 -attrs [list jid $val]] 131 } 132 } 133 -jids { 134 foreach jid $val { 135 if {![string equal $jid ""]} { 136 lappend items [::xmpp::xml::create item \ 137 -attrs [list jid $jid]] 138 } 139 } 140 } 141 -timeout { 142 set timeout $val 143 } 144 -command { 145 set commands [list $val] 146 } 147 default { 148 return -code error \ 149 [::msgcat::mc "Illegal option \"%s\"" $key] 150 } 151 } 152 } 153 154 if {[llength $items] == 0} { 155 return -code error \ 156 [::msgcat::mc "Nothing to block"] 157 } 158 159 ::xmpp::sendIQ $xlib set \ 160 -query [::xmpp::xml::create block \ 161 -xmlns urn:xmpp:blocking \ 162 -subelements $items] \ 163 -command [namespace code [list ParseBlockAnswer $commands]] \ 164 -timeout $timeout 165} 166 167# ::xmpp::blocking::ParseBlockAnswer -- 168# 169# A helper procedure which is called upon block result is received. 170# It calls back the status and error message if any. 171# 172# Arguments: 173# commands A list of callbacks to call (only the first of them 174# is invoked. Status and result or error 175# stanza are appended to the called command. 176# status Blocking request status (ok, error, abort, timeout). 177# xml Error message or result. 178# 179# Result: 180# Empty string. 181# 182# Side effects: 183# A callback is called if their list isn't empty. 184 185proc ::xmpp::blocking::ParseBlockAnswer {commands status xml} { 186 if {[llength $commands] > 0} { 187 uplevel #0 [lindex $commands 0] [list $status $xml] 188 } 189 return 190} 191 192# ::xmpp::blocking::unblock -- 193# 194# Unblock specified JIDs. If no JIDs are specified then all blocked JIDs 195# are unblocked. 196# 197# Arguments: 198# xlib XMPP token. 199# -jid jid JID to unblock (may appear multiple times). 200# -jids jids List of JIDs to unblock (may appear multiple times). 201# -timeout msecs (optional) Timeout in milliseconds of waiting for 202# answer. 203# -command cmd (optional) Command to call back on receiving reply. 204# 205# Result: 206# ID of outgoing IQ. 207# 208# Side effects: 209# A block request is sent over the XMPP connection $xlib. 210 211proc ::xmpp::blocking::unblock {xlib args} { 212 set commands {} 213 set timeout 0 214 set items {} 215 foreach {key val} $args { 216 switch -- $key { 217 -jid { 218 if {![string equal $val ""]} { 219 lappend items [::xmpp::xml::create item \ 220 -attrs [list jid $val]] 221 } 222 } 223 -jids { 224 foreach jid $val { 225 if {![string equal $jid ""]} { 226 lappend items [::xmpp::xml::create item \ 227 -attrs [list jid $jid]] 228 } 229 } 230 } 231 -timeout { 232 set timeout $val 233 } 234 -command { 235 set commands [list $val] 236 } 237 default { 238 return -code error \ 239 [::msgcat::mc "Illegal option \"%s\"" $key] 240 } 241 } 242 } 243 244 ::xmpp::sendIQ $xlib set \ 245 -query [::xmpp::xml::create unblock \ 246 -xmlns urn:xmpp:blocking \ 247 -subelements $items] \ 248 -command [namespace code [list ParseUnblockAnswer $commands]] \ 249 -timeout $timeout 250} 251 252# ::xmpp::blocking::ParseUnblockAnswer -- 253# 254# A helper procedure which is called upon unblock result is received. 255# It calls back the status and error message if any. 256# 257# Arguments: 258# commands A list of callbacks to call (only the first of them 259# is invoked. Status and result or error 260# stanza are appended to the called command. 261# status Unblocking request status (ok, error, abort, timeout). 262# xml Error message or result. 263# 264# Result: 265# Empty string. 266# 267# Side effects: 268# A callback is called if their list isn't empty. 269 270proc ::xmpp::blocking::ParseUnblockAnswer {commands status xml} { 271 if {[llength $commands] > 0} { 272 uplevel #0 [lindex $commands 0] [list $status $xml] 273 } 274 return 275} 276 277# ::xmpp::blocking::register -- 278# 279# Register handler to process blocking IQ pushes. 280# 281# Arguments: 282# -command cmd (optional) Command to call when blocking push is 283# arrived. The result of the command is sent back. 284# It must be either {result {}}, or {error type condition}, 285# or empty string if the application will reply to the 286# request separately. 287# The command's arguments are xlib, from, xml, and 288# optional parameters -to, -id, -lang. 289# 290# Result: 291# Empty string. 292# 293# Side effects: 294# XMPP blocking push callback is registered. 295 296proc ::xmpp::blocking::register {args} { 297 set commands {} 298 foreach {key val} $args { 299 switch -- $key { 300 -command { 301 set commands [list $val] 302 } 303 default { 304 return -code error \ 305 [::msgcat::mc "Illegal option \"%s\"" $key] 306 } 307 } 308 } 309 310 ::xmpp::iq::register set * urn:xmpp:blocking \ 311 [namespace code [list ParsePush $commands]] 312 return 313} 314 315# ::xmpp::blocking::ParsePush -- 316# 317# A helper procedure which is called on any incoming XMPP blocking request. 318# It either calls a command specified during registration or simply 319# returns result (if there weren't any command). 320# 321# Arguments: 322# commands A list of commands to call (only the first one 323# will be invoked). 324# xlib XMPP token where request was received. 325# from JID of user who sent the request. 326# xml Request XML element (in blocking requests it is empty). 327# args optional arguments (-lang, -to, -id). 328# 329# Result: 330# Either {result, {}}, or {error type condition}, or empty string, if 331# the application desided to reply later. 332# 333# Side effects: 334# Side effects of the called command. 335 336proc ::xmpp::blocking::ParsePush {commands xlib from xml args} { 337 # -to attribute contains the own JID, so check from JID to prevent 338 # malicious users to pretend they perform blocking push 339 set to [::xmpp::xml::getAttr $args -to] 340 341 if {![string equal $from ""] && \ 342 ![::xmpp::jid::equal $from $to] && \ 343 ![::xmpp::jid::equal $from [::xmpp::jid::stripResource $to]] && \ 344 ![::xmpp::jid::equal $from [::xmpp::jid::server $to]]} { 345 346 return [list error cancel service-unavailable] 347 } 348 349 ::xmpp::xml::split $xml tag xmlns attrs cdata subels 350 351 switch -- $tag/$xmlns { 352 block/urn:xmpp:blocking - 353 unblock/urn:xmpp:blocking {} 354 default { 355 return [list error modify bad-request] 356 } 357 } 358 359 set items {} 360 foreach subel $subels { 361 ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels 362 switch -- $stag/$sxmlns { 363 item/urn:xmpp:blocking { 364 if {[::xmpp::xml::isAttr $sattrs jid]} { 365 lappend items [::xmpp::xml::getAttr $sattrs jid] 366 } 367 } 368 } 369 } 370 371 if {[llength $commands] > 0} { 372 return [uplevel #0 [lindex $commands 0] [list $xlib $tag $items] $args] 373 } else { 374 return [list result {}] 375 } 376} 377 378# ::xmpp::blocking::unregister -- 379# 380# Unregister handler which used to answer XMPP blocking IQ pushes. 381# 382# Arguments: 383# None. 384# 385# Result: 386# Empty string. 387# 388# Side effects: 389# XMPP blocking push callback is registered. 390 391proc ::xmpp::blocking::unregister {} { 392 ::xmpp::iq::unregister set * urn:xmpp:blocking 393 394 return 395} 396 397# vim:ts=8:sw=4:sts=4:et 398