From c622974e1d7ac9e8d0821e9efc4d10e459b88de0 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Sat, 17 Oct 2020 10:52:28 +0100 Subject: [PATCH] demos: testbridge redone using jcp hooks. --- demos/testbridge.tcl | 147 ++++++++++++++++++++++--------------------- 1 file changed, 76 insertions(+), 71 deletions(-) diff --git a/demos/testbridge.tcl b/demos/testbridge.tcl index 3c1902d..5681a03 100644 --- a/demos/testbridge.tcl +++ b/demos/testbridge.tcl @@ -9,14 +9,20 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- -set auto_path [linsert $auto_path 0 [file dirname [file dirname [info script]]]] +set auto_path [linsert $auto_path 0 \ + [file dirname [file dirname [file normalize [info script]]]]] package require xmppd::jcp; # tclxmppd package require xmppd::wrapper; # tclxmppd -namespace eval ::component { - variable version 1.0.0 +namespace eval ::testbridge { + variable version 1.1.0 variable rcsid {$Id$} + 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 { @@ -34,72 +40,82 @@ namespace eval ::component { } } - 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" } + + namespace import ::xmppd::jcp::jid } -# component::start -- +# testbridge::start -- # # Start the component. We create the JCP link. A successful link # will result in a call to the -handler function from where we # can perform further setup over the valid link # -proc ::component::start {} { +proc ::testbridge::start {} { variable Options variable Component variable NS + + set Options(JID) [stringprep::stringprep nameprep $Options(JID)] set Component [xmppd::jcp::create \ -component $Options(JID) \ -secret $Options(Secret) \ -server $Options(JabberServer) \ -port $Options(JabberPort) \ - -loglevel $Options(LogLevel) \ - -connectproc [namespace origin OnConnect] \ - -messageproc [namespace origin OnMessage] \ - -presenceproc [namespace origin OnPresence] \ - -iqproc [namespace origin OnIq]] - $Component iq_register get jabber:iq:version \ - [namespace code [list OnIqVersion $Component]] + -loglevel $Options(LogLevel)] + + $Component configure -connectproc [namespace code [list OnConnect $Component]] + $Component configure -disconnectproc [namespace code [list OnDisconnect $Component]] + $Component configure -messageproc [namespace code [list OnMessage $Component]] + $Component configure -presenceproc [namespace code [list OnPresence $Component]] + $Component iq_register get $NS(discoinfo) \ [namespace code [list OnIqDiscoInfo $Component]] - # presence_register / message_register ? + $Component iq_register get jabber:iq:version \ + [namespace code [list OnIqVersion $Component]] + $Component iq_register get urn:xmpp:time \ + [namespace code [list OnIqTime $Component]] + + # Connect the component. $Component connect - component start + return $Component } -# component::stop -- +# testbridge::stop -- # # Halt the component. We disconnect from the configured chat # by sending a presence unavailable and then destroy the component. # -proc ::component::stop {} { +proc ::testbridge::stop {} { variable Options variable Component - component stop - set jid "$Options(Name)@$Options(JID)/$Options(Resource)" + + set jid [jid normalize "$Options(Name)@$Options(JID)/$Options(Resource)"] presence $jid {} unavailable xmppd::jcp::destroy $Component } -# component::OnConnect -- +# testbridge::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. # -proc ::component::OnConnect {xmllist} { +proc ::testbridge::OnConnect {xmllist} { variable Options # initial presence from the bridge client presence "$Options(Name)@$Options(JID)/$Options(Resource)" + return } -proc ::component::OnMessage {xmllist} { +proc ::testbridge::OnMessage {xmllist} { array set a [linsert [wrapper::getattrlist $xmllist] 0 type normal] switch -exact -- $a(type) { groupchat - @@ -117,7 +133,7 @@ proc ::component::OnMessage {xmllist} { return } -proc ::component::OnPresence {xmllist} { +proc ::testbridge::OnPresence {xmllist} { array set a [linsert [wrapper::getattrlist $xmllist] 0 type available] switch -exact -- $a(type) { available { @@ -129,6 +145,7 @@ proc ::component::OnPresence {xmllist} { subscribe { # always refuse subsription requests presence $a(to) $a(from) unsubscribed + return -code break } subscribed - unsubscribe - unsubscribed - probe - error { @@ -137,16 +154,8 @@ proc ::component::OnPresence {xmllist} { return } -# component::OnIq -- -# -# iq get stanza handling -# -proc ::component::OnIq {xmllist} { - return -} - # iq handler for jabber:iq:version (xep-0092) -proc ::component::OnIqVersion {Component xmllist} { +proc ::testbridge::OnIqVersion {Component xmllist} { variable version variable Options array set a [linsert [wrapper::getattrlist $xmllist] 0 id 0] @@ -163,7 +172,7 @@ proc ::component::OnIqVersion {Component xmllist} { } # iq handler for urn:xmpp:time (xep-0202) -proc ::component::OnIqTime {Component xmllist} { +proc ::testbridge::OnIqTime {Component xmllist} { variable version variable Options array set a [linsert [wrapper::getattrlist $xmllist] 0 id 0] @@ -182,7 +191,7 @@ proc ::component::OnIqTime {Component xmllist} { } # iq handler for service discovery -proc ::component::OnIqDiscoInfo {Component xmllist} { +proc ::testbridge::OnIqDiscoInfo {Component xmllist} { variable version variable Options variable NS @@ -207,11 +216,11 @@ proc ::component::OnIqDiscoInfo {Component xmllist} { return -code break } -# component::presence -- +# testbridge::presence -- # # Send a jabber presence message # -proc ::component::presence {from {to {}} {type {}} {show {}} {status {}}} { +proc ::testbridge::presence {from {to {}} {type {}} {show {}} {status {}}} { variable Component variable Options variable NS @@ -231,14 +240,14 @@ proc ::component::presence {from {to {}} {type {}} {show {}} {status {}}} { return } -# component::LoadConfig -- +# testbridge::LoadConfig -- # # This procedure reads a text file and updates the Options array # from the contents. Comments and blank lines are ignored. All # other lines must be a list of two elements, the first element # must be an item in the Options array. # -proc ::component::LoadConfig {{conf {}}} { +proc ::testbridge::LoadConfig {{conf {}}} { variable Options if {$conf eq {}} { set conf [file normalize [info script]] @@ -270,24 +279,6 @@ proc ::component::LoadConfig {{conf {}}} { return } -# component::component -- -# -# The implementation of this component. -# -proc ::component::component {cmd} { - switch -exact -- $cmd { - start { - - } - stop { - - } - default { - return -code error "invalid option \"$cmd\": rtfm" - } - } -} - # ------------------------------------------------------------------------- # wubchain is using: # irc_send msg @@ -306,13 +297,13 @@ proc ::component::component {cmd} { # When they leave, send a presence unavailable for this jid. # -# component::JoinMUC -- +# testbridge::JoinMUC -- # # Join a MUC by sending a suitable presence to our desired nick jid. # proc JoinMUC {from conference nick} { - variable ::component::Component - variable ::component::NS + variable ::testbridge::Component + variable ::testbridge::NS lappend hist [wrapper::createtag history -attrlist {maxchars 0 maxstanzas 0}] lappend kids [wrapper::createtag x -attrlist [list xmlns $NS(muc)] -subtags $hist] @@ -323,24 +314,38 @@ proc JoinMUC {from conference nick} { } proc /join {nick} { - variable ::component::Component - variable ::component::Options + variable ::testbridge::Component + variable ::testbridge::Options set userjid $nick@$Options(JID)/webchat set nickjid $Options(Conference)/$nick - ::component::presence $userjid - ::component::presence $userjid $nickjid + ::testbridge::presence $userjid + ::testbridge::presence $userjid $nickjid } proc /part {nick} { - variable ::component::Component - variable ::component::Options + variable ::testbridge::Component + variable ::testbridge::Options set userjid $nick@$Options(JID)/webchat set nickjid $Options(Conference)/$nick - ::component::presence $userjid $nickjid unavailable - ::component::presence $userjid {} unavailable + ::testbridge::presence $userjid $nickjid unavailable + ::testbridge::presence $userjid {} unavailable } +proc /whisper {nick tonick message} { + variable ::testbridge::Component + variable ::testbridge::Options + set userjid $nick@$Options(JID)/webchat + set nickjid $Options(Conference)/$nick + set tojid $Options(Conference)/$tonick + + lappend body [wrapper::createtag body -chdata $message] + set xmllist [wrapper::createtag message \ + -attrlist [list xmlns jabber:client type chat \ + to $tojid from $userjid]\ + -subtags $body] + $Component route [wrapper::createxml $xmllist] +} proc /post {nick message} { - variable ::component::Component - variable ::component::Options + variable ::testbridge::Component + variable ::testbridge::Options set userjid $nick@$Options(JID)/webchat set nickjid $Options(Conference)/$nick @@ -354,7 +359,7 @@ proc /post {nick message} { # ------------------------------------------------------------------------- -proc ::component::Main {} { +proc ::testbridge::Main {} { global tcl_platform tcl_interactive tcl_service tk_version variable Options LoadConfig @@ -395,7 +400,7 @@ proc ::component::Main {} { } if {!$tcl_interactive} { - set r [catch [linsert $argv 0 ::component::Main] err] + set r [catch [linsert $argv 0 ::testbridge::Main] err] if {$r} {puts $errorInfo} exit $r } -- 2.23.0