From 9d37b1c9fb77822cac311fc6af641db790ccf796 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Thu, 25 Nov 2004 00:57:12 +0000 Subject: [PATCH] * test-s2s.tcl: Test application code. * s2s.tcl: Working version. This correctly validates and xmits and recieves. Added a handler option that is called for all Jabber stanzas. Moved application code into separate file so s2s can be a package. Fixed recovery after a channel goes down. --- ChangeLog | 10 ++++ s2s.tcl | 128 ++++++++-------------------------------------- test-s2s.tcl | 141 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 172 insertions(+), 107 deletions(-) create mode 100644 test-s2s.tcl diff --git a/ChangeLog b/ChangeLog index dfa669a..1326ba5 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2004-11-25 Pat Thoyts + + * TAG: ====== tagged xmppd-1-0-0 ===== + + * test-s2s.tcl: Test application code. + * s2s.tcl: Working version. This correctly validates and xmits and + recieves. Added a handler option that is called for all Jabber + stanzas. Moved application code into separate file so s2s can be a + package. Fixed recovery after a channel goes down. + 2004-11-24 Pat Thoyts * s2s.tcl: Finally persuaded both sides to validate. Jabberd is diff --git a/s2s.tcl b/s2s.tcl index 8caf1fd..f762af9 100644 --- a/s2s.tcl +++ b/s2s.tcl @@ -3,8 +3,8 @@ # A Tcl implementation of the Jabber server-to-server protocol. # See http://www.jabber.org/ # -# RFC 3920 [http://www.ietf.org/rfc3921.txt] -- CHECK -# RFC 3921 [http://www.ietf.org/rfc3921.txt] +# RFC 3920 [http://www.ietf.org/rfc/rfc3921.txt] +# RFC 3921 [http://www.ietf.org/rfc/rfc3921.txt] # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution @@ -16,7 +16,6 @@ package require uuid; # tcllib package require sha1; # tcllib package require logger; # tcllib package require dns 1.2.1; # tcllib 1.8 -#package require tls namespace eval ::xmppd {} namespace eval ::xmppd::s2s { @@ -24,19 +23,19 @@ namespace eval ::xmppd::s2s { variable version 1.0.0 variable rcsid {$Id$} - namespace export configure route + namespace export configure route start stop variable options if {![info exists options]} { array set options { - jid conference.patthoyts.tk + jid {} secret secret address 0.0.0.0 port 5269 loglevel debug handler {} } - #set options(jid) [info hostname] + set options(jid) [info hostname] } variable log @@ -62,6 +61,12 @@ namespace eval ::xmppd::s2s { if {![info exists uid]} { set uid 0 } + + # Select the first nameserver available (if any) + foreach ns [dns::nameservers] { + dns::configure -nameserver $ns -protocol tcp + break + } } proc ::xmppd::s2s::configure {args} { @@ -428,9 +433,7 @@ proc ::xmppd::s2s::Read {Channel} { if {[eof $channel(sock)]} { fileevent $channel(sock) readable {} Log warn "- EOF on $Channel ($channel(sock))" - # delete parser - # clean up session - # remove route + OnCloseStream $Channel } set xml [read $channel(sock)] Log debug "< $channel(sock) $xml" @@ -530,7 +533,7 @@ proc ::xmppd::s2s::OnOpenStream {Channel args} { # to the Receiving Server (them) set key [sha1::sha1 $options(secret)] set key [sha1::sha1 ${key}$session(from)] - set session(key) OUT[sha1::sha1 ${key}$session(id)] + set session(key) [sha1::sha1 ${key}$session(id)] set xml "$session(key)" set session(state) dialback @@ -562,8 +565,14 @@ proc ::xmppd::s2s::OnOpenStream {Channel args} { proc ::xmppd::s2s::OnCloseStream {Channel} { upvar #0 $Channel channel + + foreach Session [FindSession channel $Channel] { + Log debug "closed session $Session" + unset $Session + } + catch {close $channel(sock)} - # FIX ME - how to close the parser? + wrapper::reset $channel(parser) catch {unset channel} msg Log notice "- $Channel closed: $msg" } @@ -738,102 +747,7 @@ proc ::xmppd::s2s::OnInput {Channel xmllist} { } # ------------------------------------------------------------------------- -# Application level: -# The s2s server routes incoming messages to the -handler configuration proc. -# This is a demo. -# -proc Handler {type attributes close value children} { - - switch -exact -- $type { - message { - array set attr $attributes - set msg [lindex [wrapper::gettag $children] 3] - puts "$attr(from) -> $attr(to) \[$attr(type)\]\n $msg" - } - presence { - array set attr {type {}} - array set attr $attributes - switch -exact -- $type { - subscribe { - # NB: servers should not do this. - xmppd::s2s::route \ - -from $attr(to) -to $attr(from) \ - "" - } - default { - puts "$attr(from) -> $attr(to) \[$attr(type)\]" - } - } - } - default { - xmppd::s2s::Log debug "$type $attributes $close $value $children" - } - } -} - -#{from patthoyts@bugzilla.renishaw.com/tkabber xml:lang en-GB type chat to patthoyts@uknml2375.renishaw.com/test xmlns jabber:client} 0 {} {{body {} 0 hehe {}} {x {xmlns jabber:x:event} 0 {} {{offline {} 1 {} {}} {delivered {} 1 {} {}} {displayed {} 1 {} {}} {composing {} 1 {} {}}}}} - - -#{from patthoyts@bugzilla.renishaw.com/tkabber id 37 xml:lang en-GB type get to patthoyts@uknml2375.renishaw.com/test xmlns jabber:client} 0 {} {{query {xmlns jabber:iq:version} 1 {} {}}} - -# ------------------------------------------------------------------------- - -if {!$tcl_interactive} { - -} else { - - catch {xmppd::s2s::start} - - namespace import -force xmppd::s2s::* - - if {0} { - #set client conference.patthoyts.tk - #set server tach.tclers.tk - #set who test - - proc presence {type} { - global client server - xmppd::s2s::route -from $client -to $server \ - "" - } - proc say {msg {type groupchat}} { - global client server - xmppd::s2s::route -from $client -to $server \ - "\ - [wrapper::xmlcrypt $msg]" - } - } - - set client uknml2375.renishaw.com - set server bugzilla.renishaw.com - set who patthoyts - - proc presence {type} { - global client server who - xmppd::s2s::route -from $client -to $server \ - "" - } - proc say {msg {type chat}} { - global client server who - xmppd::s2s::route -from $client -to $server \ - "\ - [wrapper::xmlcrypt $msg]" - } - - xmppd::s2s::configure -jid $client -handler ::Handler - - set ns [dns::nameservers] - if {[llength $ns] > 0} { - dns::configure -nameserver [lindex $ns 0] -protocol tcp - } -} +package provide xmppd::s2s $::xmppd::s2s::version # ------------------------------------------------------------------------- diff --git a/test-s2s.tcl b/test-s2s.tcl new file mode 100644 index 0000000..abc059d --- /dev/null +++ b/test-s2s.tcl @@ -0,0 +1,141 @@ +# +# +# + +set root [file dirname [info script]] +source [file join $root s2s.tcl] +package require xmppd::s2s +namespace import -force xmppd::s2s::* + +# ------------------------------------------------------------------------- +# Application level: +# The s2s server routes incoming messages to the -handler configuration proc. +# This is a demo. +# +proc Handler {type attributes close value children} { + + switch -exact -- $type { + message { + array set attr $attributes + set msg [lindex [wrapper::gettag $children] 3] + puts "$attr(from) -> $attr(to) \[$attr(type)\]\n $msg" + } + presence { + array set attr {type {}} + array set attr $attributes + switch -exact -- $type { + subscribe { + # NB: servers should not do this. + xmppd::s2s::route \ + -from $attr(to) -to $attr(from) \ + "" + } + default { + set show "online" + set status "" + foreach xml $children { + switch -exact -- [wrapper::gettag $xml] { + show { set show [wrapper::getcdata $xml] } + status { set status [wrapper::getcdata $xml] } + } + } + if {$status ne {}} {append show " ($status)"} + puts "$attr(from) -> $attr(to) \[$show\]" + } + } + } + default { + xmppd::s2s::Log debug "$type $attributes $close $value $children" + } + } +} + +#{from patthoyts@bugzilla.renishaw.com/tkabber xml:lang en-GB type chat to patthoyts@uknml2375.renishaw.com/test xmlns jabber:client} 0 {} {{body {} 0 hehe {}} {x {xmlns jabber:x:event} 0 {} {{offline {} 1 {} {}} {delivered {} 1 {} {}} {displayed {} 1 {} {}} {composing {} 1 {} {}}}}} + + +#{from patthoyts@bugzilla.renishaw.com/tkabber id 37 xml:lang en-GB type get to patthoyts@uknml2375.renishaw.com/test xmlns jabber:client} 0 {} {{query {xmlns jabber:iq:version} 1 {} {}}} + + +# ------------------------------------------------------------------------- + +set client conference.patthoyts.tk +set server tach.tclers.tk +set who test + +proc presence2 {type {show {}} {status {}} {user {patthoyts}} {nick {}}} { + global client server who + + set kids {} + lappend kids [list x {xmlns http://jabber.org/protocols/muc} 1 "" {}] + if {$show ne {}} { + lappend kids [list show {} 0 $show {}] + } + if {$status ne {}} { + lappend kids [list status { + xmlns:xml http://www.w3.org/XML/1998/namespace + xml:lang en-GB + } 0 $status {}] + } + if {$nick eq {}} {set nick $user} + set attr [list from "${user}@${client}/test" \ + to "${who}@${server}/${nick}" type "$type"] + + set xml [wrapper::createxml [list presence $attr 0 "" $kids]] + puts [wrapper::createxml [list presence $attr 0 "" $kids]] + xmppd::s2s::route -from $client -to $server $xml + return +} + +proc say2 {msg {type groupchat} {user patthoyts}} { + global client server who + xmppd::s2s::route -from $client -to $server \ + "\ + [wrapper::xmlcrypt $msg]" +} + +proc presence {type {show {}}} { + global client server who + xmppd::s2s::route -from $client -to $server \ + "" +} + +proc say {msg {type groupchat}} { + global client server who + xmppd::s2s::route -from $client -to $server \ + "\ + [wrapper::xmlcrypt $msg]" +} + + +if {0} { + set client uknml2375.renishaw.com + set server bugzilla.renishaw.com + set who patthoyts + + proc presence {type} { + global client server who + xmppd::s2s::route -from $client -to $server \ + "" + } + proc say {msg {type chat}} { + global client server who + xmppd::s2s::route -from $client -to $server \ + "\ + [wrapper::xmlcrypt $msg]" + } + +} + +# ------------------------------------------------------------------------- + +xmppd::s2s::configure -jid $client -handler ::Handler +catch {xmppd::s2s::start} + -- 2.23.0