From: Pat Thoyts <patthoyts@users.sourceforge.net>
Date: Sat, 17 Oct 2020 09:46:59 +0000 (+0100)
Subject: demos: reworked the chime demo using the jcp hooks.
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=60b64605832aa9adca71c0e77b4a0264df96ce69;p=tclxmppd.git

demos: reworked the chime demo using the jcp hooks.
---

diff --git a/demos/chime.tcl b/demos/chime.tcl
index d8475d2..6ec45c3 100644
--- a/demos/chime.tcl
+++ b/demos/chime.tcl
@@ -13,14 +13,19 @@
 # -------------------------------------------------------------------------
 
 set auto_path [linsert $auto_path 0 \
-                   [file join [file dirname [file dirname [info script]]]]]
+                   [file dirname [file dirname [file normalize [info script]]]]]
 package require xmppd::jcp;             # tclxmppd
 package require xmppd::wrapper;         # jabberlib
 
 namespace eval ::chime {
-    variable version 1.1.0
+    variable version 1.2.0
     variable rcsid {$Id: chime.tcl,v 1.3 2006/04/13 11:50:31 pat Exp $}
+    variable uid; if {![info exists uid]} { set uid 0 }
 
+    # The options array holds configuration information for this component.
+    # We use the LoadConfig procedure to load the actual configuration from
+    # a file to avoid committing passwords into the code repository.
+    #
     variable Options
     if {![info exists Options]} {
         array set Options {
@@ -38,174 +43,301 @@ namespace eval ::chime {
         }
     }
     
-    variable Component
+    # The NS array holds some standard XMPP XML namespaces.
+    variable NS
+    array set NS {
+        discoinfo  "http://jabber.org/protocol/disco#info"
+        discoitems "http://jabber.org/protocol/disco#items"
+        muc        "http://jabber.org/protocols/muc"
+        version    "jabber:iq:version"
+    }
+
+    namespace import ::xmppd::jcp::jid ::xmppd::jcp::Log
 }
 
 # chime::start --
 #
 #	Start the chime component. This uses the jabber component protocol
 #	to connect to the server and schedules the chimes.
-#	We join the chat by sending an appropriate presence message once
-#	we are fully connected.
+#	We configure callbacks for the xmpp stanzas. Note that for info/query
+#	stanzas we specify a callback per iq namespace as there is specific
+#	XMPP requirements for non-handled iq stanzas that are covered by the
+#	JCP core.
 #
 proc ::chime::start {} {
     variable Options
-    variable Component
-    xmppd::jcp::configure \
-        -component $Options(JID) \
-        -secret    $Options(Secret) \
-        -loglevel  $Options(LogLevel) \
-        -handler   [namespace current]::Handler
+    variable NS
+    variable uid
+
+    # Create a state array and command for our chime instance
+    set Chime [namespace current]::chime[incr uid]
+    upvar #0 $Chime chime
+    proc $Chime {cmd args} "eval \[linsert \$args 0 \$cmd $Chime\]"
+
+    set Options(JID) [stringprep::stringprep nameprep $Options(JID)]
     set Component [xmppd::jcp::create \
-                       $Options(JabberServer) $Options(JabberPort)]
-    chimes start
-    return
+                       -component $Options(JID) \
+                       -secret    $Options(Secret) \
+                       -server    $Options(JabberServer) \
+                       -port      $Options(JabberPort) \
+                       -loglevel  $Options(LogLevel)]
+    $Component configure -connectproc [namespace code [list OnConnect $Chime]]
+    $Component configure -disconnectproc [namespace code [list OnDisconnect $Chime]]
+    $Component configure -messageproc [namespace code [list OnMessage $Chime]]
+    $Component configure -presenceproc [namespace code [list OnPresence $Chime]]
+
+    $Component iq_register get $NS(discoinfo) \
+        [namespace code [list OnIqDiscoInfo $Chime]]
+    $Component iq_register get $NS(version) \
+        [namespace code [list OnIqVersion $Chime]]
+    $Component iq_register get jabber:iq:time \
+        [namespace code [list OnIqTimeLegacy $Chime]]
+    $Component iq_register get urn:xmpp:time \
+        [namespace code [list OnIqTime $Chime]]
+
+    set chime(component) $Component
+    set chime(mainjid) [jid normalize "$Options(Name)@$Options(JID)/$Options(Resource)"]
+    set chime(nickjid) [jid normalize "$Options(Conference)/$Options(Name)"]
+    set chime(conference) [jid normalize $Options(Conference)]
+    set chime(nick) [stringprep::stringprep resourceprep $Options(Name)]
+    set chime(uid) 0
+
+    # Connect the component.
+    $Component connect
+    return $Chime
 }
 
 # chime::stop --
 #
 #	Halt the chime component. We disconnect from the configures chat
 #	by sending a presence unavailable and then destroy the component.
+#	Once the XMPP stream is terminated we will have our disconnect
+#	callback called where we can cleanup any resources.
 #
-proc ::chime::stop {} {
-    variable Options
-    variable Component
-    chimes stop
-    set jid "$Options(Name)@$Options(JID)/$Options(Resource)"
-    set nick "$Options(Conference)/$Options(Name)"
-    presence $jid $nick unavailable
-    xmppd::jcp::destroy $Component
+proc ::chime::stop {Chime} {
+    upvar #0 $Chime chime
+    $Chime chimes stop
+    set jid $chime(mainjid)
+    $chime(component) send_presence $jid $chime(conference) unavailable
+    $chime(component) send_presence $jid {} unavailable
+    $chime(component) destroy
 }
 
-# chime::Handler --
+# chime::OnConnect --
 #
-#	Jabber message routing. For this component, we don't need to
-#	do anything as all we do is issue a time message on the hour.
+#	Called once the component XMPP stream has connected and authorized.
 #
-proc ::chime::Handler {xmllist} {
-    variable Options
-    array set a {from {} to {} type {}}
-    array set a [wrapper::getattrlist $xmllist]
-
-    switch -exact -- [set type [wrapper::gettag $xmllist]] {
-        handshake {
-            # A handshake stanza in the accept namespace indicates that
-            # we have a valid connection to our server and can route.
-            if {$a(xmlns) eq "jabber:component:accept"} {
-                set jid "$Options(Name)@$Options(JID)/$Options(Resource)"
-                set nick "$Options(Conference)/$Options(Name)"
-                after idle [namespace code \
-                                [list presence $jid $nick \
-                                     {} online {Hourly chime bot}]]
-            }
+proc ::chime::OnConnect {Chime xmllist} {
+    upvar #0 $Chime chime
+
+    # initial presence from the bridge client (no 'to')
+    $chime(component) send_presence $chime(mainjid)
+
+    # Join the configured conference
+    join_muc $chime(component) $chime(mainjid) $chime(conference) $chime(nick)
+
+    # Schedule the alarm timer
+    # NB: should be done on the presence message that confirms our entry into the muc.
+    $Chime chimes start
+
+    return
+}
+
+# chime::OnDisconnect --
+#
+#	The xmpp stream has been closed at this point. Just cleanup any
+#	resources.
+#
+proc ::chime::OnDisconnect {Chime} {
+    upvar #0 $Chime chime
+    rename $Chime {}
+    unset $Chime
+}
+
+# chime::OnMessage --
+#
+#	We are not interested in messages in this sample.
+#
+proc ::chime::OnMessage {Chime xmllist} {
+    upvar #0 $Chime chime
+    array set a [linsert [wrapper::getattrlist $xmllist] 0 id [incr chime(uid)] type normal]
+
+    if {$a(type) eq "normal" || $a(type) eq "chat"} {
+        if {[jid equal $a(from) $chime(nickjid)]
+            || [jid equal [jid domain $a(from)] [jid domain $chime(mainjid)]]
+        } then {
+            # Message sent by us to us (eg: MUC chat), ignore.
+            return
         }
-        message {}
-        presence {}
-        iq {
-            switch -exact -- $a(type) {
-                get {
-                    set children [wrapper::getchildswithtag $xmllist query]
-                    foreach child $children {
-                        HandleIQ $child $a(id) $a(to) $a(from)
-                    }
-                }
-            }            
+        
+        if {[jid equal $a(to) [jid domain $chime(mainjid)]] 
+            || [jid equal [jid !resource $a(to)] [jid !resource $chime(mainjid)]]
+            || [jid equal $a(to) $chime(nickjid)]
+        } then {
+            lappend body [wrapper::createtag body -chdata \
+                              "You are trying to converse with a clock."]
+            set stanza [wrapper::createtag message -subtags $body \
+                            -attrlist [list xmlns jabber:client type $a(type) \
+                                           id $a(id) to $a(from) from $a(to)]]
+            $chime(component) route [wrapper::createxml $stanza]
         }
-        default {}
     }
     return
 }
 
-# chime::HandleIQ --
+# chime::OnPresence --
 #
-#	I am sure some of this could be factored into the component package.
-#	Basically all components should register for some minimal IQ handling
-#	just to provide their name and version if nothing else.
+#	Handle presence stanzas. We are not interested in presence but should
+#	actively refuse subscription requests.
 #
-proc ::chime::HandleIQ {child id self requester} {
-    variable Options
-    variable Component
-    variable version
-
-    set query [wrapper::getattribute $child xmlns]
-    set rsp {}
-    set parts {}
-    switch -exact -- $query {
-        jabber:iq:version {
-            lappend parts [list name {} 0 $Options(Name) {}]
-            lappend parts [list version {} 0 $version {}]
-            lappend parts [list os {} 0 "Tcl/[info patchlevel]" {}]
-            lappend qr [list query [list xmlns $query] 0 {} $parts]
-            set ra [list xmlns jabber:client type result id $id \
-                to $requester from $self]
-            set rsp [list iq $ra 0 {} $qr]
+proc ::chime::OnPresence {Chime xmllist} {
+    upvar #0 $Chime chime
+    array set a [linsert [wrapper::getattrlist $xmllist] 0 type available]
+    switch -exact -- $a(type) {
+        subscribe {
+            # always refuse subscription requests
+            $chime(component) send_presence $a(to) $a(from) unsubscribed
+            return -code break
         }
-        "http://jabber.org/protocol/disco#info" {
-            set node [wrapper::getattribute $child node]
-            if {[string length $node] == 0} {
-                lappend parts [list identity \
-                                   [list name $Options(Name) \
-                                        type chime category service] 1 {} {}]
-                lappend parts [list feature {var jabber:iq:version} 1 {} {}]
-                lappend parts [list feature {var iq} 1 {} {}]
-                lappend parts [list feature {var message} 1 {} {}]
-                lappend parts [list feature {var "http://jabber.org/protocol/disco#info"} 1 {} {}]
-                lappend parts [list feature {var "http://jabber.org/protocol/disco#items"} 1 {} {}]
-                
-                lappend qr [list query [list xmlns $query] 0 {} $parts]
-                set rsp [list iq [list xmlns jabber:client type result id $id \
-                                  to $requester from $self] 0 {} $qr]
-            }
-        }
-        default {
-            set rsp [RaiseIQ $query feature-not-implemented $id $self $requester]
+        available - unavailable - unsubscribe - 
+        subscribed - unsubscribed - probe - error {
+            # not interested and no response required
         }
     }
-    if {$rsp ne {}} {
-        xmppd::jcp::route $Component [wrapper::createxml $rsp]
-    }
     return
 }
 
-# chime::RaiseIQ --
-#	
-#	Raise an error response for invalid queries or for queries we do not intend
-#	to handle.
-#
-proc ::chime::RaiseIQ {query type id self requester} {
-    lappend p [list $type {xmlns urn:ietf:params:xml:ns:xmpp-stanzas} 1 {} {}]
-    lappend qr [list query [list xmlns $query] 1 {} {}]
-    lappend qr [list error {type cancel code 501} 0 {} $p]
-    set ra [list xmlns jabber:client type error id $id \
-        to $requester from $self]
-    set rsp [list iq $ra 0 {} $qr]
+# chime::OnIqVersion --
+#
+#	Handler for jabber:iq:version (XEP-0092)
+#	Note: we only respond for JIDs that refer to this bare domain
+#	or are specific to this chime instance.
+#
+proc ::chime::OnIqVersion {Chime xmllist} {
+    variable Options
+    variable version
+    upvar #0 $Chime chime
+    array set a [linsert [wrapper::getattrlist $xmllist] 0 id 0]
+    if {[jid equal $a(to) $Options(JID)] 
+        || [jid equal [jid !resource $a(to)] [jid !resource $chime(mainjid)]]
+    } then {
+        lappend parts [wrapper::createtag name -chdata $chime(nick)]
+        lappend parts [wrapper::createtag version -chdata $version]
+        lappend parts [wrapper::createtag os -chdata "Tcl/[info patchlevel]"]
+        lappend child [wrapper::createtag query -subtags $parts \
+                           -attrlist {xmlns jabber:iq:version}]
+        set rx [wrapper::createtag iq -subtags $child \
+                    -attrlist [list xmlns jabber:client type result \
+                                   id $a(id) to $a(from) from $a(to)]]
+        $chime(component) route [wrapper::createxml $rx]
+        return -code break
+    }
+    return
 }
 
-# chime::presence --
+# chime::OnIqTimeLegacy --
 #
-#	Send a jabber presence message
+#	Handler for jabber:iq:time (XEP-0090)
 #
-proc ::chime::presence {from to type {show {online}} {status {}} {user {}}} {
-    variable Component
+proc ::chime::OnIqTimeLegacy {Chime xmllist} {
+    variable Options
+    upvar #0 $Chime chime
+    array set a [linsert [wrapper::getattrlist $xmllist] 0 id 0]
+    if {[jid equal $a(to) $Options(JID)] 
+        || [jid equal [jid !resource $a(to)] [jid !resource $chime(mainjid)]] 
+    } then {
+        set xep0090fmt "%Y%m%dT%H:%M:%S"
+        set time [clock format [clock seconds] -format $xep0090fmt -gmt 1]
+        set display [clock format [clock seconds] -format "%a %b %d %H:%M:%S %Y %Z"]
+        set tz [clock format [clock seconds] -format "%Z"]
+        lappend parts [wrapper::createtag utc -chdata $time]
+        lappend parts [wrapper::createtag tz -chdata $tz]
+        lappend parts [wrapper::createtag display -chdata $display]
+        lappend child [wrapper::createtag query -subtags $parts \
+                           -attrlist {xmlns jabber:iq:time}]
+        set rx [wrapper::createtag iq -subtags $child \
+                    -attrlist [list xmlns jabber:client type result \
+                                   id $a(id) to $a(from) from $a(to)]]
+        $chime(component) route [wrapper::createxml $rx]
+        return -code break
+    }
+    return
+}
 
-    set kids {} ; set hist {}
-    set ts [clock format [clock seconds] -format %Y%m%dT%H:%M:%S -gmt 1]
-    lappend hist [list history [list maxchars 0 maxstanzas 0] 1 "" {}]
-    lappend kids [list x {xmlns http://jabber.org/protocols/muc} 0 "" $hist]
-    if {$show ne {}} {
-        lappend kids [list show {} 0 $show {}]
+# chime::OnIqTime --
+#
+#	Handler for urn:xmpp:time (XEP-0202)
+#
+proc ::chime::OnIqTime {Chime xmllist} {
+    variable Options
+    upvar #0 $Chime chime
+    array set a [linsert [wrapper::getattrlist $xmllist] 0 id 0]
+    if {[jid equal $a(to) $Options(JID)] 
+        || [jid equal [jid !resource $a(to)] [jid !resource $chime(mainjid)]] 
+    } then {
+        set xep0082fmt "%Y-%m-%dT%H:%M:%SZ"
+        set time [clock format [clock seconds] -format $xep0082fmt -gmt 1]
+        set tzo [clock format [clock seconds] -format "%z" -gmt 0]
+        lappend parts [wrapper::createtag utc -chdata $time]
+        lappend parts [wrapper::createtag tzo -chdata $tzo]
+        lappend child [wrapper::createtag time -subtags $parts \
+                           -attrlist {xmlns urn:xmpp:time}]
+        set rx [wrapper::createtag iq -subtags $child \
+                    -attrlist [list xmlns jabber:client type result \
+                                   id $a(id) to $a(from) from $a(to)]]
+        $chime(component) route [wrapper::createxml $rx]
+        return -code break
     }
-    if {$status ne {}} {
-        lappend kids [list status {
-            xmlns:xml http://www.w3.org/XML/1998/namespace
-            xml:lang en-GB
-        } 0 $status {}]
+    return
+}
+
+# chime::OnIqDiscoInfo --
+#
+#	Service Discovery (XEP-0030)
+#	Note: we only respond for JIDs that refer to this bare domain
+#	or are specific to this chime instance.
+#
+proc ::chime::OnIqDiscoInfo {Chime xmllist} {
+    upvar #0 $Chime chime
+    variable Options
+    variable NS
+
+    array set a [linsert [wrapper::getattrlist $xmllist] 0 id 0]
+    if {[jid equal $a(to) $Options(JID)] 
+        || [jid equal [jid !resource $a(to)] [jid !resource $chime(mainjid)]]
+    } then {
+        lappend parts [wrapper::createtag identity \
+                           -attrlist [list name Chime type chime category service]]
+        lappend parts [wrapper::createtag feature -attrlist [list var iq]]
+        lappend parts [wrapper::createtag feature -attrlist [list var message]]
+        lappend parts [wrapper::createtag feature -attrlist [list var $NS(discoinfo)]]
+        #lappend parts [wrapper::createtag feature -attrlist [list var $NS(discoitems)]]
+        lappend parts [wrapper::createtag feature -attrlist [list var $NS(version)]]
+        lappend parts [wrapper::createtag feature -attrlist [list var jabber:iq:time]]
+        lappend parts [wrapper::createtag feature -attrlist [list var urn:xmpp:time]]
+        lappend child [wrapper::createtag query -subtags $parts \
+                           -attrlist [list xmlns $NS(discoinfo)]]
+        set rx [wrapper::createtag iq -subtags $child \
+                    -attrlist [list xmlns jabber:client type result id $a(id) \
+                                   to $a(from) from $a(to)]]
+        $chime(component) route [wrapper::createxml $rx]
+        return -code break
     }
-    set attr [list from $from to $to xmlns jabber:client]
-    if {$type ne {}} {lappend attr type $type}
-    
-    xmppd::jcp::route $Component \
-        [wrapper::createxml [list presence $attr 0 "" $kids]]
+    return
+}
+
+# chime::JoinMUC --
+#
+#	Join a MUC by sending a suitable presence to our desired nick jid.
+#
+proc ::chime::join_muc {Component from conference nick} {
+    variable NS
+
+    lappend hist [wrapper::createtag history -attrlist {maxchars 0 maxstanzas 0}]
+    lappend kids [wrapper::createtag x -attrlist [list xmlns $NS(muc)] -subtags $hist]
+    set attr [list from $from to $conference/$nick xmlns jabber:client]
+    $Component route [wrapper::createxml \
+                          [wrapper::createtag presence -subtags $kids -attrlist $attr]]
     return
 }
 
@@ -252,14 +384,14 @@ proc ::chime::LoadConfig {{conf {}}} {
 #
 #	Manage the scheduling of chimes on the hour.
 #
-proc ::chime::chimes {cmd} {
-    variable ChimeId
+proc ::chime::chimes {Chime cmd} {
+    upvar #0 $Chime chime
     switch -exact -- $cmd {
         start {
-            set ChimeId [after [nextchime] [namespace origin bong]]
+            set chime(afterid) [after [nextchime] [namespace code [list bong $Chime]]]
         }
         stop {
-            after cancel $ChimeId
+            after cancel $chime(afterid)
         }
         default {
             return -code error "invalid option \"$cmd\": rtfm"
@@ -286,24 +418,18 @@ proc ::chime::nextchime {} {
 #
 #	Issue a timestamp message to the connected chatroom.
 #
-proc ::chime::bong {} {
-    variable ChimeId
-    variable Options
-    variable Component
-
-    after cancel $ChimeId
+proc ::chime::bong {Chime} {
+    upvar #0 $Chime chime
+    after cancel $chime(afterid)
     set kids {}
     set ts [clock format [clock seconds] -format %Y%m%dT%H:%M:%S -gmt 1]
     puts "BONG at $ts"
     lappend kids [list body {} 0 \
                       [clock format [clock seconds] -gmt 1] {}]
-    set from "$Options(Name)@$Options(JID)/$Options(Resource)"
-    set attr [list from $from to $Options(Conference) \
+    set attr [list from $chime(mainjid) to $chime(conference) \
                   type groupchat xmlns "jabber:client"]
-    set xml [wrapper::createxml [list message $attr 0 "" $kids]]
-
-    xmppd::jcp::route $Component $xml
-    set ChimeId [after [nextchime] [namespace origin bong]]
+    $chime(component) route [wrapper::createxml [list message $attr 0 "" $kids]]
+    set chime(afterid) [after [nextchime] [namespace code [list bong $Chime]]]
 }
 
 proc ::chime::Main {} {