From 60b64605832aa9adca71c0e77b4a0264df96ce69 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Sat, 17 Oct 2020 10:46:59 +0100 Subject: [PATCH] demos: reworked the chime demo using the jcp hooks. --- demos/chime.tcl | 414 +++++++++++++++++++++++++++++++----------------- 1 file changed, 270 insertions(+), 144 deletions(-) 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 {} { -- 2.23.0