Added a testbridge component that can create pseudo-users and join a MUC. It handles basic service discovery.
--- /dev/null
+# Jabber component configuration file\r
+#\r
+# You MUST modify this to suit your environment.\r
+\r
+# Local server name\r
+# The JID is the jabber domain for your component. This needs to\r
+# be present in your DNS records as a SRV record such as\r
+# _xmpp-server._tcp.$JID 10 5269 primarydomain.name\r
+#\r
+JID COMPONENT.DOMAIN.NAME\r
+Resource Component\r
+\r
+JabberServer localhost\r
+JabberPort 5347\r
+Secret JCPPASSWORD\r
+\r
+# Details for the Jabber conference room to join to.\r
+#\r
+Conference MUC@CONFERENCE.DOMAIN.NAME\r
+\r
+# How noisy? One of:\r
+# debug info notice warn error critical\r
+LogLevel notice\r
--- /dev/null
+#!/usr/bin/env tclsh
+# Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# A demo Jabber component.
+#
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+set auto_path [linsert $auto_path 0 [file dirname [file dirname [info script]]]]
+package require xmppd::jcp; # tclxmppd
+package require xmppd::wrapper; # tclxmppd
+
+namespace eval ::component {
+ variable version 1.0.0
+ variable rcsid {$Id$}
+
+ variable Options
+ if {![info exists Options]} {
+ array set Options {
+ JID {}
+ Name TestBridge
+ Resource testbridge
+ Conference {}
+
+ JabberServer {}
+ JabberPort 5347
+ Secret {}
+
+ LogLevel notice
+ LogFile {}
+ }
+ }
+
+ variable Component
+ 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"
+ }
+}
+
+# component::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 {} {
+ variable Options
+ variable Component
+ variable NS
+ 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]]
+ $Component iq_register get $NS(discoinfo) \
+ [namespace code [list OnIqDiscoInfo $Component]]
+ # presence_register / message_register ?
+ $Component connect
+ component start
+ return $Component
+}
+
+# component::stop --
+#
+# Halt the component. We disconnect from the configured chat
+# by sending a presence unavailable and then destroy the component.
+#
+proc ::component::stop {} {
+ variable Options
+ variable Component
+ component stop
+ set jid "$Options(Name)@$Options(JID)/$Options(Resource)"
+ presence $jid {} unavailable
+ xmppd::jcp::destroy $Component
+}
+
+# component::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} {
+ variable Options
+
+ # initial presence from the bridge client
+ presence "$Options(Name)@$Options(JID)/$Options(Resource)"
+}
+
+proc ::component::OnMessage {xmllist} {
+ array set a [linsert [wrapper::getattrlist $xmllist] 0 type normal]
+ switch -exact -- $a(type) {
+ groupchat -
+ chat -
+ normal -
+ headline {
+ set body [wrapper::getfirstchildwithtag $xmllist body]
+ set text [wrapper::getcdata $body]
+ puts "<$a(from)> $text"
+ }
+ default {
+ puts stderr "unrecognised message type \"$a(type)\""
+ }
+ }
+ return
+}
+
+proc ::component::OnPresence {xmllist} {
+ array set a [linsert [wrapper::getattrlist $xmllist] 0 type available]
+ switch -exact -- $a(type) {
+ available {
+ puts "$a(from) entered"
+ }
+ unavailable {
+ puts "$a(from) left"
+ }
+ subscribe {
+ # always refuse subsription requests
+ presence $a(to) $a(from) unsubscribed
+ }
+ subscribed - unsubscribe - unsubscribed - probe - error {
+
+ }
+ }
+ 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} {
+ variable version
+ variable Options
+ array set a [linsert [wrapper::getattrlist $xmllist] 0 id 0]
+ lappend parts [wrapper::createtag name -chdata $Options(Name)]
+ 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)]]
+ $Component route [wrapper::createxml $rx]
+ return -code break
+}
+
+# iq handler for urn:xmpp:time (xep-0202)
+proc ::component::OnIqTime {Component xmllist} {
+ variable version
+ variable Options
+ array set a [linsert [wrapper::getattrlist $xmllist] 0 id 0]
+ 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)]]
+ $Component route [wrapper::createxml $rx]
+ return -code break
+}
+
+# iq handler for service discovery
+proc ::component::OnIqDiscoInfo {Component xmllist} {
+ variable version
+ variable Options
+ variable NS
+
+ array set a [linsert [wrapper::getattrlist $xmllist] 0 id 0]
+ lappend parts [wrapper::createtag identity \
+ -attrlist [list name $Options(Name) \
+ type testbridge \
+ 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 jabber:iq:version]]
+ 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)]]
+ $Component route [wrapper::createxml $rx]
+ return -code break
+}
+
+# component::presence --
+#
+# Send a jabber presence message
+#
+proc ::component::presence {from {to {}} {type {}} {show {}} {status {}}} {
+ variable Component
+ variable Options
+ variable NS
+ set kids {}
+ if {$show ne {}} {
+ lappend kids [wrapper::createtag show -chdata $show]
+ }
+ if {$status ne {}} {
+ lappend kids [wrapper::createtag status -chdata $status -attrlist {xml:lang en}]
+ }
+ set attr [list xmlns jabber:client from $from]
+ if {$to ne {}} { lappend attr to $to }
+ if {$type ne {}} { lappend attr type $type }
+
+ $Component route [wrapper::createxml [wrapper::createtag presence \
+ -subtags $kids -attrlist $attr]]
+ return
+}
+
+# component::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 {}}} {
+ variable Options
+ if {$conf eq {}} {
+ set conf [file normalize [info script]]
+ set base [file rootname [file tail $conf]].conf
+ set conf [file join [file dirname $conf] $base]
+ }
+ if {[file exists $conf]} {
+ set f [open $conf r]
+ set n 0
+ while {![eof $f]} {
+ gets $f line
+ string trim $line
+ if {[string match "#*" $line]} continue
+ if {[string length $line] < 1} continue
+ if {[llength $line] != 2} {
+ return -code error "invalid config line $n: \"$line\""
+ }
+ if {![info exists Options([lindex $line 0])]} {
+ return -code error "invalid config option\
+ \"[lindex $line 0]\" at line $n"
+ }
+ set Options([lindex $line 0]) [lindex $line 1]
+ incr n
+ }
+ close $f
+ } else {
+ return -code error "configuration file \"$conf\" could not be opened"
+ }
+ 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
+# irc_post nick msg : calls irc_send after /me handling
+# irc_recv : receives msg, add to history, input is gets $fd line
+#
+# On startup, hook up web interface and create component and join MUC
+# OnMessage: groupchat messages are to go into history
+# normal messages are memos to a specific user
+# chat messages are one-to-one chat messages
+# OnPresence: manage channel users arriving and departing
+# OnIq: queries - should be standard responses
+#
+# When a user logs in, send a presence online to the MUC for
+# username@component.tclers.tk/nick
+# When they leave, send a presence unavailable for this jid.
+#
+
+# component::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
+
+ 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
+}
+
+proc /join {nick} {
+ variable ::component::Component
+ variable ::component::Options
+ set userjid $nick@$Options(JID)/webchat
+ set nickjid $Options(Conference)/$nick
+ ::component::presence $userjid
+ ::component::presence $userjid $nickjid
+}
+proc /part {nick} {
+ variable ::component::Component
+ variable ::component::Options
+ set userjid $nick@$Options(JID)/webchat
+ set nickjid $Options(Conference)/$nick
+ ::component::presence $userjid $nickjid unavailable
+ ::component::presence $userjid {} unavailable
+}
+proc /post {nick message} {
+ variable ::component::Component
+ variable ::component::Options
+ set userjid $nick@$Options(JID)/webchat
+ set nickjid $Options(Conference)/$nick
+
+ lappend body [wrapper::createtag body -chdata $message]
+ set xmllist [wrapper::createtag message \
+ -attrlist [list xmlns jabber:client type groupchat \
+ to $Options(Conference) from $userjid]\
+ -subtags $body]
+ $Component route [wrapper::createxml $xmllist]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::component::Main {} {
+ global tcl_platform tcl_interactive tcl_service tk_version
+ variable Options
+ LoadConfig
+
+ # Setup control stream.
+ if {$tcl_platform(platform) eq "unix"} {
+ set cmdloop [file join [file dirname [info script]] cmdloop.tcl]
+ if {[file exists $cmdloop]} {
+ puts "Loading $cmdloop"
+ source $cmdloop
+ set cmdloop::welcome "$Options(Name) v[set [namespace current]::version]"
+ append cmdloop::welcome "\nReady for input from %client %port"
+ cmdloop::cmdloop
+ #set cmdloop::hosts_allow {127.0.0.1 ::1}
+ #cmdloop::listen 127.0.0.1 5442;# could do 0.0.0.0 5441
+ } else {
+ puts "Command loop not available."
+ }
+ set tcl_interactive 1; # fake it so we can re-source this file
+ }
+
+ # Begin the component
+ start
+
+ # Loop forever, dealing with wish, tclsh or tclsvc
+ if {[info exists tk_version]} {
+ if {[tk windowingsystem] eq "win32"} { console show }
+ wm withdraw .
+ tkwait variable ::forever
+ stop
+ } else {
+ # Permit running as a Windows service.
+ if {![info exists tcl_service]} {
+ vwait ::forever
+ stop
+ }
+ }
+}
+
+if {!$tcl_interactive} {
+ set r [catch [linsert $argv 0 ::component::Main] err]
+ if {$r} {puts $errorInfo}
+ exit $r
+}
namespace eval ::xmppd::jcp {
variable version 1.1.0
variable rcsid {$Id: jcp.tcl,v 1.2 2004/12/08 15:22:11 pat Exp $}
-
+ variable uid; if {![info exists uid]} { set uid 0 }
variable options
if {![info exists options]} {
array set options {
component component.example.com
secret secret
loglevel debug
+ server xmppd.example.com
+ port 5347
handler {}
+ connectproc {}
+ disconnectproc {}
+ messageproc {}
+ presenceproc {}
+ iqproc {}
}
}
+}
-
- variable log
- if {![info exists log]} {
- set log [logger::init jcp]
- ${log}::setlevel $options(loglevel)
- namespace eval $log {
- variable logfile ""
- #set logfile [open s2s.log a+]
- #fconfigure $logfile -buffering line
- #puts $logfile [string repeat - 72]
- }
- proc ${log}::stdoutcmd {level text} {
- variable service
- variable logfile
- set ts [clock format [clock seconds] -format {%H:%M:%S}]
- if {$logfile != {}} {
- puts $logfile "\[$ts\] $level $text"
- }
- puts stderr $text
- }
- proc Log {level msg} {variable log; ${log}::${level} $msg}
- }
+# Create a component.
+# We create a state array and matching command and call configure
+# to initialize the settings. Then connect the component which will
+# cause everything else to operate via the callbacks.
+proc ::xmppd::jcp::create {args} {
+ variable uid
+ variable options
+ set id [namespace current]::jcp[incr uid]
+ upvar #0 $id state
+ array set state [array get options]
+ set state(log) [logger::init jcp]
+ eval [linsert $args 0 configure $id]
+ proc $id {cmd args} "eval \[linsert \$args 0 \$cmd $id\]"
+ set state(parser) [wrapper::new \
+ [list [namespace current]::OnOpenStream $id] \
+ [list [namespace current]::OnCloseStream $id] \
+ [list [namespace current]::OnInput $id] \
+ [list [namespace current]::OnError $id]]
+ iq_register $id get default [namespace code [list OnIqDefault $id]] 1000
+ iq_register $id set default [namespace code [list OnIqDefault $id]] 1000
+ return $id
}
-proc ::xmppd::jcp::configure {args} {
- variable options
+proc ::xmppd::jcp::connect {Component} {
+ upvar #0 $Component state
+ set state(sock) [socket -async $state(server) $state(port)]
+ fconfigure $state(sock) -buffering none -blocking 0 \
+ -encoding utf-8 -translation lf
+ fileevent $state(sock) writable [list [namespace current]::Write $Component]
+ fileevent $state(sock) readable [list [namespace current]::Read $Component]
+}
+
+proc ::xmppd::jcp::configure {Component args} {
+ upvar #0 $Component state
variable log
if {[llength $args] < 1} {
set r {}
- foreach opt [lsort [array names options]] {
- lappend r -$opt $options($opt)
+ foreach opt [lsort [array names state]] {
+ lappend r -$opt $state($opt)
}
return $r
}
set cget [expr {[llength $args] == 1 ? 1 : 0}]
while {[string match -* [set option [lindex $args 0]]]} {
switch -glob -- $option {
- -component {
+ -component -
+ -secret -
+ -server -
+ -port -
+ -connectproc -
+ -disconnectproc -
+ -messageproc -
+ -iqproc -
+ -presenceproc {
+ set option [string trimleft $option -]
if {$cget} {
- return $options(component)
+ return $state($option)
} else {
- set options(component) [Pop args 1]
- }
- }
- -secret {
- if {$cget} {
- return $options(secret)
- } else {
- set options(secret) [Pop args 1]
+ set state($option) [Pop args 1]
}
}
-loglevel {
if {$cget} {
- return $options(loglevel)
+ return $state(loglevel)
} else {
- set options(loglevel) [Pop args 1]
- ${log}::setlevel $options(loglevel)
- }
- }
- -handler {
- if {$cget} {
- return $options(handler)
- } else {
- set options(handler) [Pop args 1]
+ set state(loglevel) [Pop args 1]
+ set log $state(log)
+ ${log}::setlevel $state(loglevel)
}
}
-- { Pop args ; break }
default {
+ variable options
set opts [join [lsort [array names options]] ", -"]
return -code error "bad option \"$option\":\
must be one of -$opts"
return
}
-#
-# component::join target as me
-proc ::xmppd::jcp::create {server {port 5347}} {
- variable options
- set sock [socket -async $server $port]
- set id [namespace current]::[string map {sock jcp} $sock]
- upvar #0 $id state
- set state(sock) $sock
- set state(server) $server
- set state(component) $options(component)
- set state(parser) [wrapper::new \
- [list [namespace current]::OnOpenStream $id] \
- [list [namespace current]::OnCloseStream $id] \
- [list [namespace current]::OnInput $id] \
- [list [namespace current]::OnError $id]]
- fconfigure $sock -buffering none -blocking 0 \
- -encoding utf-8 -translation lf
- fileevent $sock writable [list [namespace current]::Write $id]
- fileevent $sock readable [list [namespace current]::Read $id]
- return $id
-}
-
proc ::xmppd::jcp::destroy {Component} {
upvar #0 $Component state
WriteTo $state(sock) "</stream:stream>"
return
}
+proc ::xmppd::jcp::iq_register {Component type xmlns cmd {priority 50}} {
+ Hook $Component add iq $type $xmlns $cmd $priority
+}
+
proc ::xmppd::jcp::route {Component msg} {
upvar #0 $Component state
WriteTo $state(sock) $msg
}
+proc ::xmppd::jcp::Hook {Component do type args} {
+ upvar #0 $Component state
+ set valid {message presence iq}
+ if {[lsearch -exact $valid $type] == -1} {
+ return -code error "unknown hook type \"$type\":\
+ must be one of [join $valid ,]"
+ }
+ if {$type eq "iq"} {
+ set default iq,[lindex $args 0],default
+ set type iq,[join [lrange $args 0 1] ","]
+ set args [lrange $args 2 end]
+ } else {
+ set default $type,default
+ }
+ switch -exact -- $do {
+ add {
+ if {[llength $args] < 1 || [llength $args] > 2} {
+ return -code error "wrong # args: should be \"add hook cmd ?priority?\""
+ }
+ foreach {cmd pri} $args break
+ if {$pri eq {}} { set pri 50 }
+ lappend state(hook,$type) [list $cmd $pri]
+ set state(hook,$type) [lsort -real -index 1 [lsort -unique $state(hook,$type)]]
+ }
+ remove {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"remove hook cmd\""
+ }
+ if {![info exists state(hook,$type)]} { return }
+ for {set ndx 0} {$ndx < [llength $state(hook,$type)]} {incr ndx} {
+ set item [lindex $state(hook,$type) $ndx]
+ if {[lindex $item 0] eq [lindex $args 0]} {
+ set state(hook,$type) [lreplace $state(hook,$type) $ndx $ndx]
+ break
+ }
+ }
+ set state(hook,$type)
+ }
+ run {
+ set hooks {}
+ if {[info exists state(hook,$type)]} {
+ set hooks $state(hook,$type)
+ }
+ if {[info exists state(hook,$default)]} {
+ set hooks [concat $hooks $state(hook,$default)]
+ }
+ if {[llength $hooks] < 1} { return }
+ set res ""
+ foreach item $hooks {
+ foreach {cmd pri} $item break
+ set code [catch {eval $cmd $args} err]
+ if {$code == 0} { ;# ok
+ lappend res $err
+ } elseif {$code == 1 || $code == 3} { ;# error, break
+ set ::ERR $::errorInfo
+ return -code $code -errorcode $::errorCode -errorinfo $::errorInfo $err
+ }
+ }
+ return $res
+ }
+ list {
+ if {[info exists state(hook,$type)]} {
+ return $state(hook,$type)
+ }
+ }
+ default {
+ return -code error "unknown hook action \"$do\":\
+ must be add, remove, list or run"
+ }
+ }
+}
+
+proc ::xmppd::jcp::Log {level msg} { puts stderr $msg }
+proc ::xmppd::jcp::SetLogLevel {Component} {
+ upvar #0 $Component state
+ set log $state(log)
+ ${log}::setlevel $state(loglevel)
+ namespace eval $log {
+ variable logfile ""
+ #set logfile [open s2s.log a+]
+ #fconfigure $logfile -buffering line
+ #puts $logfile [string repeat - 72]
+ }
+ proc ${log}::stdoutcmd {level text} {
+ variable service
+ variable logfile
+ set ts [clock format [clock seconds] -format {%H:%M:%S}]
+ if {$logfile != {}} {
+ puts $logfile "\[$ts\] $level $text"
+ }
+ puts stderr $text
+ }
+ proc Log {level msg} {variable log; ${log}::${level} $msg}
+}
+
# Pop the nth element off a list. Used in options processing.
#
proc ::xmppd::jcp::Pop {varname {nth 0}} {
}
proc ::xmppd::jcp::OnOpenStream {Component args} {
- variable options
upvar #0 $Component state
Log debug "OPEN $Component $args"
array set a $args
# JEP0114 3 (2): Server replies with stream header plus stream id.
# We must reply with the handshake hash.
set state(streamid) $a(id)
- set reply [sha1::sha1 $state(streamid)$options(secret)]
+ set reply [sha1::sha1 $state(streamid)$state(secret)]
set xml "<handshake>$reply</handshake>"
WriteTo $state(sock) $xml
} else {
}
proc ::xmppd::jcp::OnInput {Component xmllist} {
- variable options
upvar #0 $Component state
#Log debug "INPUT $Component $xmllist"
- array set a {xmlns {} from {} to {}}
+ array set a {xmlns {} from {} to {} id {}}
array set a [wrapper::getattrlist $xmllist]
+ set handled 0
switch -exact -- [set tag [wrapper::gettag $xmllist]] {
features {
Log notice "? features $xmllist"
+ set handled 1
}
result {
Log notice "? result $xmllist"
+ set handled 1
}
verify {
Log notice "? verify $xmllist"
+ set handled 1
+ }
+ handshake {
+ if {[info exists state(connectproc)]
+ && $state(connectproc) ne {}
+ } then {
+ if {[catch {$state(connectproc) $xmllist} err]} {
+ Log error "! error handling connectproc: $err"
+ }
+ }
+ }
+ iq {
+ # RFC 3920 9.2.3: must have type attr. get,set,result,error
+ # get/set have 1 child, must reply
+ # result no reply, 0/1 childs
+ # error no reply, include get/set child + error child.
+ set child [lindex [wrapper::getchildren $xmllist] 0]
+ set ns [wrapper::getattr [wrapper::getattrlist $child] xmlns]
+ set r [catch {Hook $Component run iq $a(type) $ns $xmllist} err]
+ if {$r == 1} {
+ set tag [wrapper::gettag $child]
+ set rsp [RaiseIQ internal-server-error $xmllist $err]
+ route $Component [wrapper::createxml $rsp]
+ }
}
- handshake -
- iq -
message -
presence {
- if {$options(handler) ne {}} {
- if {[catch {$options(handler) $xmllist} err]} {
+ set cmd ${tag}proc
+ if {[info exists state($cmd)] && $state($cmd) ne {}} {
+ if {[catch {$state($cmd) $xmllist} err]} {
Log error "! error handing \"$tag\" stanza: $err"
}
- } else {
- Log error "! No handler defined for \"$tag\" stanzas"
}
}
default {
}
}
+# ::xmppd::jcp::OnIqDefault --
+#
+# Default iq get and iq set message handler.
+# Returns a not-implemented error.
+#
+proc ::xmppd::jcp::OnIqDefault {Component xmllist} {
+ array set a [linsert [wrapper::getattrlist $xmllist] 0 id {}]
+ set tag [wrapper::gettag [lindex [wrapper::getchildren $xmllist] 0]]
+ set rsp [RaiseIQ feature-not-implemented $xmllist "This feature is not available"]
+ route $Component [wrapper::createxml $rsp]
+ return -code break
+}
+
+# ::xmppd::jcp::RaiseIQ --
+#
+# Raise an error response for invalid queries or for queries we do
+# not intend to handle.
+# Returns an xmllist containing an iq error.
+#
+#proc ::xmppd::jcp::RaiseIQ {query type id self requester {text {}}} {
+proc ::xmppd::jcp::RaiseIQ {errortype xmllist text} {
+ array set a [linsert [wrapper::getattrlist $xmllist] 0 id {}]
+ set firstchild [lindex [wrapper::getchildren $xmllist] 0]
+ set tag [wrapper::gettag $firstchild]
+ set tagns [wrapper::getattribute $firstchild xmlns]
+
+ set ns urn:ietf:params:xml:ns:xmpp-stanzas
+ lappend p [wrapper::createtag $errortype -attrlist [list xmlns $ns]]
+ if {$text ne ""} {
+ lappend p [wrapper::createtag text -chdata $text \
+ -attrlist [list xmlns $ns xml:lang en]]
+ }
+ lappend qr [wrapper::createtag $tag -attrlist [list xmlns $tagns]]
+ lappend qr [list error {type cancel code 501} 0 {} $p]
+ set ra [list xmlns jabber:client type error id $a(id) to $a(from) from $a(to)]
+ set rsp [list iq $ra 0 {} $qr]
+}
+
# -------------------------------------------------------------------------
package provide xmppd::jcp $::xmppd::jcp::version
#
# $Id: pkgIndex.tcl,v 1.1 2004/11/28 10:20:34 pat Exp $
-package ifneeded xmppd::core 1.0.0 [list source [file join $dir core.tcl]]
+package ifneeded xmppd::core 0.1.0 [list source [file join $dir core.tcl]]
package ifneeded xmppd::s2s 1.0.0 [list source [file join $dir s2s.tcl]]
package ifneeded xmppd::s2c 1.0.0 [list source [file join $dir s2c.tcl]]
package ifneeded xmppd::sm 1.0.0 [list source [file join $dir sm.tcl]]
[list [namespace current]::OnOpenStream $Channel] \
[list [namespace current]::OnCloseStream $Channel] \
[list [namespace current]::OnInput $Channel] \
- [list [namespace current]::OnError $Channel] \
- -namespace 0]
+ [list [namespace current]::OnError $Channel]]
+ #-namespace 0
fconfigure $chan -translation binary -encoding utf-8 \
-buffering none -blocking 0
iq {
Log debug "- iq $xmllist { $channel(state) }"
if {$channel(state) eq "authorized"} {
- set bind [lindex [wrapper::getchildwithtaginnamespace \
+ set bind [lindex [wrapper::getchildswithtagandxmlns \
$xmllist bind [xmlns bind]] 0]
Log debug "[string repeat - 60]\n$bind\n[string repeat - 60]\n"
if {$bind ne {}} {
# $Id$
set auto_path [linsert $auto_path 0 \
- [file dirname [file dirname [info script]]]]
+ [file dirname [file dirname [file normalize [info script]]]]]
package require xmppd::core
package require xmppd::s2s
switch -exact -- [set type [wrapper::gettag $xmllist]] {
iq {
# RFC3921 3: Session Establishment
- set sx [wrapper::getchildwithtaginnamespace $xmllist \
+ set sx [wrapper::getchildswithtagandxmlns $xmllist \
session [xmppd::xmlns session]]
if {[llength $sx] > 0} {
# FIX ME: create a Jabberd session for this connected resource
if {[llength [package provide tdom]]} {
#set wrapper($id,parser) [xml::parser -namespace 1]
- set wrapper($id,parser) [expat -namespace 1]
+ set wrapper($id,parser) [expat -namespace 0]
set wrapper($id,class) "tdom"
$wrapper($id,parser) configure \
-final 0 \
set tagname [string range $tagname [incr ndx] end]
lappend attrlist xmlns $ns
}
+ # hack: un-expand xml:lang namespace attribute
+ set newattrs {}
+ foreach {an av} $attrlist {
+ if {[string match "http://www.w3.org/XML/1998/namespace:*" $an]} {
+ lappend newattrs xml[string range $an 36 end] $av
+ } else {
+ lappend newattrs $an $av
+ }
+ }
+ set attrlist $newattrs
}
if {$wrapper($id,level) == 0} {
projects / tclxmppd.git / commitdiff