# -------------------------------------------------------------------------
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 {
}
}
- 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
}
#
# 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"
#
# 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 {} {
projects / tclxmppd.git / commitdiff