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