[Tkabber-dev] [tclxmpp] r118 committed - * xmpp/ping.tcl: Fixed IQ registering (register ping tag instead of...

codesite-noreply at google.com codesite-noreply at google.com
Wed Aug 12 00:02:14 MSD 2009


Revision: 118
Author: sgolovan
Date: Tue Aug 11 13:01:22 2009
Log: 	* xmpp/ping.tcl: Fixed IQ registering (register ping tag instead of
	  query) and removed received XML from regitered callback invocation
	  because it's useless as it's supposed to be always empty.

	* xmpp/blocking.tcl: Added support for Simple Communication Blocking
	  (XEP-0191). It is untested because there's no server implementations
	  yet.

http://code.google.com/p/tclxmpp/source/detail?r=118

Added:
  /trunk/xmpp/blocking.tcl
Modified:
  /trunk/ChangeLog
  /trunk/xmpp/ping.tcl

=======================================
--- /dev/null
+++ /trunk/xmpp/blocking.tcl	Tue Aug 11 13:01:22 2009
@@ -0,0 +1,397 @@
+# blocking.tcl --
+#
+#       This file is part of the XMPP library. It implements interface to
+#       Simple Communications Blocking (XEP-0191)
+#
+# Copyright (c) 2009 Sergei Golovan <sgolovan at nes.ru>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAMER OF ALL WARRANTIES.
+#
+# $Id$
+
+package require xmpp::iq
+
+package provide xmpp::blocking 0.1
+
+namespace eval ::xmpp::blocking {
+    namespace export blocklist block unblock register unregister
+}
+
+# ::xmpp::blocking::blocklist --
+#
+#       Request blocking list from the own XMPP server.
+#
+# Arguments:
+#       xlib            XMPP token.
+#       -timeout msecs  (optional) Timeout in milliseconds of waiting for
+#                       answer.
+#       -command cmd    (optional) Command to call back on receiving reply.
+#
+# Result:
+#       ID of outgoing IQ.
+#
+# Side effects:
+#       A blocklist request is sent over the XMPP connection $xlib.
+
+proc ::xmpp::blocking::blocklist {xlib args} {
+    set commands {}
+    set timeout 0
+    foreach {key val} $args {
+        switch -- $key {
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    ::xmpp::sendIQ $xlib get \
+	    -query [::xmpp::xml::create blocklist -xmlns urn:xmpp:blocking] \
+	    -command [namespace code [list ParseBlocklistAnswer $commands]] \
+            -timeout $timeout
+}
+
+# ::xmpp::blocking::ParseBlocklistAnswer --
+#
+#       A helper procedure which is called upon blocklist is received.
+#       It calls back the status and error message if any.
+#
+# Arguments:
+#       commands        A list of callbacks to call (only the first of them
+#                       is invoked. Status and list of blocked jids or  
error
+#                       stanza are appended to the called command.
+#       status          blocking request status (ok, error, abort,  
timeout).
+#       xml             Error message or result.
+#
+# Result:
+#       Empty string.
+#
+# Side effects:
+#       A callback is called if their list isn't empty.
+
+proc ::xmpp::blocking::ParseBlocklistAnswer {commands status xml} {
+    if {[llength $commands] == 0} return
+
+    if {[string equal $status ok]} {
+        ::xmpp::xml::split $xml tag xmlns attrs cdata subels
+        set items {}
+        foreach subel $subels {
+            ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels
+            switch -- $stag/$sxmlns {
+                item/urn:xmpp:blocking {
+                    if {[::xmpp::xml::isAttr $sattrs jid]} {
+                        lappend items [::xmpp::xml::getAttr $sattrs jid]
+                    }
+                }
+            }
+        }
+
+        uplevel #0 [lindex $commands 0] [list $status $items]
+    } else {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+    }
+    return
+}
+
+# ::xmpp::blocking::block --
+#
+#       Block specified JIDs. If no JIDs are specified then error is  
returned.
+#
+# Arguments:
+#       xlib            XMPP token.
+#       -jid jid        JID to block (may appear multiple times).
+#       -jids jids      List of JIDs to block (may appear multiple times).
+#       -timeout msecs  (optional) Timeout in milliseconds of waiting for
+#                       answer.
+#       -command cmd    (optional) Command to call back on receiving reply.
+#
+# Result:
+#       ID of outgoing IQ.
+#
+# Side effects:
+#       A block request is sent over the XMPP connection $xlib.
+
+proc ::xmpp::blocking::block {xlib args} {
+    set commands {}
+    set timeout 0
+    set items {}
+    foreach {key val} $args {
+        switch -- $key {
+            -jid {
+                if {![string equal $val ""]} {
+                    lappend items [::xmpp::xml::create item \
+                                        -attrs [list jid $val]]
+                }
+            }
+            -jids {
+                foreach jid $val {
+                    if {![string equal $jid ""]} {
+                        lappend items [::xmpp::xml::create item \
+                                            -attrs [list jid $jid]]
+                    }
+                }
+            }
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    if {[llength $items] == 0} {
+        return -code error \
+               -errorcode [::msgcat::mc "Nothing to block"]
+    }
+
+    ::xmpp::sendIQ $xlib set \
+	    -query [::xmpp::xml::create block \
+                            -xmlns urn:xmpp:blocking \
+                            -subelements $items] \
+	    -command [namespace code [list ParseBlockAnswer $commands]] \
+            -timeout $timeout
+}
+
+# ::xmpp::blocking::ParseBlockAnswer --
+#
+#       A helper procedure which is called upon block result is received.
+#       It calls back the status and error message if any.
+#
+# Arguments:
+#       commands        A list of callbacks to call (only the first of them
+#                       is invoked. Status and result or error
+#                       stanza are appended to the called command.
+#       status          Blocking request status (ok, error, abort,  
timeout).
+#       xml             Error message or result.
+#
+# Result:
+#       Empty string.
+#
+# Side effects:
+#       A callback is called if their list isn't empty.
+
+proc ::xmpp::blocking::ParseBlockAnswer {commands status xml} {
+    if {[llength $commands] > 0} {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+    }
+    return
+}
+
+# ::xmpp::blocking::unblock --
+#
+#       Unblock specified JIDs. If no JIDs are specified then all blocked  
JIDs
+#       are unblocked.
+#
+# Arguments:
+#       xlib            XMPP token.
+#       -jid jid        JID to unblock (may appear multiple times).
+#       -jids jids      List of JIDs to unblock (may appear multiple  
times).
+#       -timeout msecs  (optional) Timeout in milliseconds of waiting for
+#                       answer.
+#       -command cmd    (optional) Command to call back on receiving reply.
+#
+# Result:
+#       ID of outgoing IQ.
+#
+# Side effects:
+#       A block request is sent over the XMPP connection $xlib.
+
+proc ::xmpp::blocking::unblock {xlib args} {
+    set commands {}
+    set timeout 0
+    set items {}
+    foreach {key val} $args {
+        switch -- $key {
+            -jid {
+                if {![string equal $val ""]} {
+                    lappend items [::xmpp::xml::create item \
+                                        -attrs [list jid $val]]
+                }
+            }
+            -jids {
+                foreach jid $val {
+                    if {![string equal $jid ""]} {
+                        lappend items [::xmpp::xml::create item \
+                                            -attrs [list jid $jid]]
+                    }
+                }
+            }
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    ::xmpp::sendIQ $xlib set \
+	    -query [::xmpp::xml::create unblock \
+                            -xmlns urn:xmpp:blocking \
+                            -subelements $items] \
+	    -command [namespace code [list ParseUnblockAnswer $commands]] \
+            -timeout $timeout
+}
+
+# ::xmpp::blocking::ParseUnblockAnswer --
+#
+#       A helper procedure which is called upon unblock result is received.
+#       It calls back the status and error message if any.
+#
+# Arguments:
+#       commands        A list of callbacks to call (only the first of them
+#                       is invoked. Status and result or error
+#                       stanza are appended to the called command.
+#       status          Unblocking request status (ok, error, abort,  
timeout).
+#       xml             Error message or result.
+#
+# Result:
+#       Empty string.
+#
+# Side effects:
+#       A callback is called if their list isn't empty.
+
+proc ::xmpp::blocking::ParseUnblockAnswer {commands status xml} {
+    if {[llength $commands] > 0} {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+    }
+    return
+}
+
+# ::xmpp::blocking::register --
+#
+#       Register handler to process blocking IQ pushes.
+#
+# Arguments:
+#       -command cmd    (optional) Command to call when blocking push is
+#                       arrived. The result of the command is sent back.
+#                       It must be either {result {}}, or {error type  
condition},
+#                       or empty string if the application will reply to  
the
+#                       request separately.
+#                       The command's arguments are xlib, from, xml, and
+#                       optional parameters -to, -id, -lang.
+#
+# Result:
+#       Empty string.
+#
+# Side effects:
+#       XMPP blocking push callback is registered.
+
+proc ::xmpp::blocking::register {args} {
+    set commands {}
+    foreach {key val} $args {
+        switch -- $key {
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    ::xmpp::iq::register set * urn:xmpp:blocking \
+                         [namespace code [list ParsePush $commands]]
+    return
+}
+
+# ::xmpp::blocking::ParsePush --
+#
+#       A helper procedure which is called on any incoming XMPP blocking  
request.
+#       It either calls a command specified during registration or simply
+#       returns result (if there weren't any command).
+#
+# Arguments:
+#       commands            A list of commands to call (only the first one
+#                           will be invoked).
+#       xlib                XMPP token where request was received.
+#       from                JID of user who sent the request.
+#       xml                 Request XML element (in blocking requests it  
is empty).
+#       args                optional arguments (-lang, -to, -id).
+#
+# Result:
+#       Either {result, {}}, or {error type condition}, or empty string, if
+#       the application desided to reply later.
+#
+# Side effects:
+#       Side effects of the called command.
+
+proc ::xmpp::blocking::ParsePush {commands xlib from xml args} {
+    # -to attribute contains the own JID, so check from JID to prevent
+    # malicious users to pretend they perform blocking push
+    set to [::xmpp::xml::getAttr $args -to]
+
+    if {![string equal $from ""] && \
+            ![::xmpp::jid::equal $from $to] && \
+            ![::xmpp::jid::equal $from [::xmpp::jid::stripResource $to]]  
&& \
+            ![::xmpp::jid::equal $from [::xmpp::jid::server $to]]} {
+
+        return [list error cancel service-unavailable]
+    }
+
+    ::xmpp::xml::split $xml tag xmlns attrs cdata subels
+
+    switch -- $tag/$xmlns {
+        block/urn:xmpp:blocking -
+        unblock/urn:xmpp:blocking {}
+        default {
+            return [list error modify bad-request]
+        }
+    }
+
+    set items {}
+    foreach subel $subels {
+        ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels
+        switch -- $stag/$sxmlns {
+            item/urn:xmpp:blocking {
+                if {[::xmpp::xml::isAttr $sattrs jid]} {
+                    lappend items [::xmpp::xml::getAttr $sattrs jid]
+                }
+            }
+        }
+    }
+
+    if {[llength $commands] > 0} {
+        return [uplevel #0 [lindex $commands 0] [list $xlib $tag $items]  
$args]
+    } else {
+        return [list result {}]
+    }
+}
+
+# ::xmpp::blocking::unregister --
+#
+#       Unregister handler which used to answer XMPP blocking IQ pushes.
+#
+# Arguments:
+#       None.
+#
+# Result:
+#       Empty string.
+#
+# Side effects:
+#       XMPP blocking push callback is registered.
+
+proc ::xmpp::blocking::unregister {} {
+    ::xmpp::iq::unregister set * urn:xmpp:blocking
+
+    return
+}
+
+# vim:ts=8:sw=4:sts=4:et
=======================================
--- /trunk/ChangeLog	Mon Aug  3 09:51:53 2009
+++ /trunk/ChangeLog	Tue Aug 11 13:01:22 2009
@@ -1,3 +1,13 @@
+2009-08-11  Sergei Golovan  <sgolovan at nes.ru>
+
+	* xmpp/ping.tcl: Fixed IQ registering (register ping tag instead of
+	  query) and removed received XML from regitered callback invocation
+	  because it's useless as it's supposed to be always empty.
+
+	* xmpp/blocking.tcl: Added support for Simple Communication Blocking
+	  (XEP-0191). It is untested because there's no server implementations
+	  yet.
+
  2009-08-03  Sergei Golovan  <sgolovan at nes.ru>

  	* xmpp/ping.tcl, xmpp/pkgIndex.tcl: Added support for XMPP Ping
=======================================
--- /trunk/xmpp/ping.tcl	Mon Aug  3 09:51:53 2009
+++ /trunk/xmpp/ping.tcl	Tue Aug 11 13:01:22 2009
@@ -120,7 +120,7 @@
          }
      }

-    ::xmpp::iq::register get query urn:xmpp:ping \
+    ::xmpp::iq::register get ping urn:xmpp:ping \
                           [namespace code [list ParseRequest $commands]]
      return
  }
@@ -148,7 +148,7 @@

  proc ::xmpp::ping::ParseRequest {commands xlib from xml args} {
      if {[llength $commands] > 0} {
-        return [uplevel #0 [lindex $commands 0] [list $xlib $from $xml]  
$args]
+        return [uplevel #0 [lindex $commands 0] [list $xlib $from] $args]
      } else {
          return [list result {}]
      }
@@ -168,7 +168,7 @@
  #       XMPP ping callback is registered.

  proc ::xmpp::ping::unregister {} {
-    ::xmpp::iq::unregister get query urn:xmpp:ping
+    ::xmpp::iq::unregister get ping urn:xmpp:ping

      return
  }


More information about the Tkabber-dev mailing list