From 5a0d3c30cdba159d0ea7d320a2181edb289b8556 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Tue, 5 Aug 2008 09:01:43 +0000 Subject: [PATCH] Modified jcp to handle iq stanzas internally and use a hook registration to permit components to handle specific messages. Added a testbridge component that can create pseudo-users and join a MUC. It handles basic service discovery. --- demos/testbridge.conf.sample | 23 ++ demos/testbridge.tcl | 401 +++++++++++++++++++++++++++++++++++ jcp.tcl | 308 ++++++++++++++++++++------- pkgIndex.tcl | 2 +- s2c.tcl | 6 +- tests/jabberd.tcl | 4 +- wrapper.tcl | 12 +- 7 files changed, 670 insertions(+), 86 deletions(-) create mode 100644 demos/testbridge.conf.sample create mode 100644 demos/testbridge.tcl diff --git a/demos/testbridge.conf.sample b/demos/testbridge.conf.sample new file mode 100644 index 0000000..9f020b4 --- /dev/null +++ b/demos/testbridge.conf.sample @@ -0,0 +1,23 @@ +# Jabber component configuration file +# +# You MUST modify this to suit your environment. + +# Local server name +# The JID is the jabber domain for your component. This needs to +# be present in your DNS records as a SRV record such as +# _xmpp-server._tcp.$JID 10 5269 primarydomain.name +# +JID COMPONENT.DOMAIN.NAME +Resource Component + +JabberServer localhost +JabberPort 5347 +Secret JCPPASSWORD + +# Details for the Jabber conference room to join to. +# +Conference MUC@CONFERENCE.DOMAIN.NAME + +# How noisy? One of: +# debug info notice warn error critical +LogLevel notice diff --git a/demos/testbridge.tcl b/demos/testbridge.tcl new file mode 100644 index 0000000..3c1902d --- /dev/null +++ b/demos/testbridge.tcl @@ -0,0 +1,401 @@ +#!/usr/bin/env tclsh +# Copyright (C) 2005 Pat Thoyts +# +# 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 +} diff --git a/jcp.tcl b/jcp.tcl index 5698cdb..91fd005 100644 --- a/jcp.tcl +++ b/jcp.tcl @@ -11,49 +11,65 @@ namespace eval ::xmppd {} 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 } @@ -61,37 +77,34 @@ proc ::xmppd::jcp::configure {args} { 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" @@ -102,28 +115,6 @@ proc ::xmppd::jcp::configure {args} { 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) "" @@ -131,11 +122,110 @@ proc ::xmppd::jcp::destroy {Component} { 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}} { @@ -174,7 +264,6 @@ proc ::xmppd::jcp::Read {Component} { } proc ::xmppd::jcp::OnOpenStream {Component args} { - variable options upvar #0 $Component state Log debug "OPEN $Component $args" array set a $args @@ -182,7 +271,7 @@ proc ::xmppd::jcp::OnOpenStream {Component 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 "$reply" WriteTo $state(sock) $xml } else { @@ -206,33 +295,56 @@ proc ::xmppd::jcp::OnErrorStream {Component code args} { } 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 { @@ -241,6 +353,44 @@ proc ::xmppd::jcp::OnInput {Component xmllist} { } } +# ::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 diff --git a/pkgIndex.tcl b/pkgIndex.tcl index 51e3a8d..bdeec8a 100644 --- a/pkgIndex.tcl +++ b/pkgIndex.tcl @@ -4,7 +4,7 @@ # # $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]] diff --git a/s2c.tcl b/s2c.tcl index 16dc116..fbe8436 100644 --- a/s2c.tcl +++ b/s2c.tcl @@ -162,8 +162,8 @@ proc ::xmppd::s2c::Accept {chan clientaddr clientport} { [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 @@ -494,7 +494,7 @@ proc ::xmppd::s2c::OnInput {Channel xmllist} { 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 {}} { diff --git a/tests/jabberd.tcl b/tests/jabberd.tcl index 3f8055e..b38ccfb 100644 --- a/tests/jabberd.tcl +++ b/tests/jabberd.tcl @@ -9,7 +9,7 @@ # $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 @@ -24,7 +24,7 @@ proc Handler {xmllist} { 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 diff --git a/wrapper.tcl b/wrapper.tcl index 4c454c5..155f7cc 100644 --- a/wrapper.tcl +++ b/wrapper.tcl @@ -122,7 +122,7 @@ proc wrapper::new {streamstartcmd streamendcmd parsecmd errorcmd} { 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 \ @@ -281,6 +281,16 @@ proc wrapper::elementstart {id tagname attrlist args} { 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} { -- 2.23.0