# s2s.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# A Tcl implementation of the Jabber server-to-server protocol.
-# See http://www.jabber.org/
+# See http://www.jabber.org/
#
# RFC 3920 [http://www.ietf.org/rfc/rfc3921.txt]
# RFC 3921 [http://www.ietf.org/rfc/rfc3921.txt]
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
-package require xmppd::core; # tclxmppd
+package require xmppd::core; # tclxmppd
package require uuid; # tcllib
package require sha1; # tcllib
package require logger; # tcllib
namespace eval ::xmppd::s2s {
variable version 1.0.0
- variable rcsid {$Id: s2s.tcl,v 1.15 2006/04/17 10:14:47 pat Exp $}
namespace export start stop route
catch {
set info [fconfigure $srv -sockname]
close $srv
- Log notice "XMPP s2s stopped listening on [lindex $info 0]:[lindex $info 2]"
+ Log notice "XMPP s2s stopped listening on\
+ [lindex $info 0]:[lindex $info 2]"
} msg
puts stderr $msg
}
-from {
set jid [jid domain [Pop args 1]]
if {[string length $jid] > 0} {
- puts "$option jid: '$jid'"
+ #puts "$option jid: '$jid'"
set opts($option) $jid
}
}
}
Pop args
}
-
+
foreach opt {-from -to} {
if {[string length $opts($opt)] < 1} {
return -code error "invalid argument \"$opt\":\
foreach {from to} $args break
foreach Session [info vars [namespace current]::session*] {
upvar #0 $Session session
- if {[info exists session(from)] && $session(from) eq $from
+ if {[info exists session(from)] && $session(from) eq $from
&& [info exists session(to)] && $session(to) eq $to} {
lappend r $Session
Log debug " Found session $r: $from -> $to"
set Channel [lindex $args 0]
foreach Session [info vars [namespace current]::session*] {
upvar #0 $Session session
- if {[info exists session(channel)]
+ if {[info exists session(channel)]
&& $session(channel) eq $Channel} {
lappend r $Session
}
# First, resolve the hostname. If possible we can re-use a connection that
# already exists.
-
+
if {[llength [set addr [resolve $to]]] < 1} {
- return -code error "hostname invalid: \"$to\" failed to resolve ip address"
+ return -code error "hostname invalid: \"$to\" \
+ failed to resolve ip address"
}
-
+
set Channel [FindChannel out [lindex $addr 0]]
if {[llength $Channel] < 1} {
set Channel [CreateChannel]
[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]]
set sock [socket -async $channel(address) $channel(port)]
set channel(sock) $sock
[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]]
fconfigure $chan -translation binary -encoding utf-8 \
-buffering none -blocking 0
#
#
proc ::xmppd::s2s::Log {level msg} {
- ::xmppd::Log s2s $level $msg
+ ::xmppd::Log s2s $level $msg
}
# -------------------------------------------------------------------------
array set attr {version 0.0}
array set attr $args
- Log debug "OPENSTREAM $channel(sock) [array get attr]"
if {[info exists attr(id)]} {
+ Log info "OPENSTREAM out $channel(sock) [array get attr]"
# RFC3920 8.3(3): Remote server sends up a unique session id.
# The from and to elements are optional here.
# We must reject invalid namespace.
- #if {![info exists attr(xmlns)]
+ #if {![info exists attr(xmlns)]
# || $attr(xmlns) ne "http://etherx.jabber.org/streams"} {
# return [Raise $Channel invalid-namespace]
#}
set session(queue) [list $channel(queue)]
}
set channel(from) {}; # clean up temporary channel items
- set channel(to) {}; #
+ set channel(to) {}; #
set channel(queue) {}
-
- # RFC3920 8.3(4): The Originating Server (us) sends a dialback key
+ # RFC3920 8.3(4): The Originating Server (us) sends a dialback key
# to the Receiving Server (them)
#
# JID-0185: Dialback key generation and validation
set session(key) [sha1::sha1 $key]
set xml "<db:result xmlns:db='[xmlns dialback]'\
- to='$session(to)' from='$session(from)'>$session(key)</db:result>"
+ to='$session(to)'\
+ from='$session(from)'>$session(key)</db:result>"
set session(state) dialback
WriteTo $Channel $xml
} else {
+ Log debug "OPENSTREAM in $channel(sock) [array get attr]"
+
# RFC3920 8.3(6): The Receiving Server (them) sends the Authoritative
# Server (us) a stream header. From and to are
# optional. We MUST reject invalid namespaces.
# return [Raise $Channel invalid-namespace]
#}
- # RFC3920 8.3(7): The Authoritative Server (us) sends the Receiving
+ # RFC3920 8.3(7): The Authoritative Server (us) sends the Receiving
# Server (them) a stream header - with a session id
# We don't have enough info to create a session, so we store the
# id on the channel
Raise $Channel improper-addressing
}
- if {$a(xmlns:db) eq [xmlns dialback]} {
-
+ if {$a(xmlns) eq [xmlns dialback]} {
+
if {[info exists a(type)]} {
- # RFC3920 8.3(10): The Receiving Server (them) informs the
+ # RFC3920 8.3(10): The Receiving Server (them) informs the
# Originating Server (us)of the result.
set Session [FindSession name $a(from) $a(to)]
- if {$Session eq {}} {
+ if {$Session eq {}} {
return [Raise $Channel invalid-from]
}
upvar #0 $Session session
return
}
- # RFC3290 8.3(4): The Originating Server (them) sends a
+ # RFC3290 8.3(4): The Originating Server (them) sends a
# dialback key to the Receiving Server (us)
#
if {![info exists channel(id)]} {
}
set Session [CreateSession]
upvar #0 $Session session
- set session(id) $channel(id)
+ set session(id) $channel(id)
set session(state) dialback
set session(channel) $Channel
set session(from) $a(from)
set session(to) $a(to)
set session(key) $value
- # We need to send this key on the out channel with the
+ # We need to send this key on the out channel with the
# out session id, from and to.
set Out [FindSession name $a(to) $a(from)]
if {$Out ne {}} {
id='$session(id)'>$session(key)</db:verify>"
WriteTo $out(channel) $xml
} else {
- Log debug "- Creating new out channel to $a(from)"
+ Log info "- Creating new out channel to $a(from)"
Open $a(to) $a(from)
}
} else {
- Log error "unespected 'result' namespace'"
+ Log error "unexpected 'result' namespace'"
}
}
verify {
- Log debug "- verify $xmllist"
-
+ Log debug "- verify $xmllist"
+
# RFC3920 8.3: All stanzas MUST include both to and from
if {$a(from) eq "" || $a(to) eq ""} {
Raise $Channel improper-addressing
}
-
+
set Session [FindSession id $a(id)]
- if {$Session eq {}} {
+ if {$Session eq {}} {
# Raise invalid-id ??
Log error "Failed to find session for '$a(id)'"
return
}
if {![info exists a(type)]} {
-
- # RFC3920 8.3(8): The Receiving Server (them) sends the
- # Authoritative Server (us) a request for
+
+ # RFC3920 8.3(8): The Receiving Server (them) sends the
+ # Authoritative Server (us) a request for
# verification of a key. This is the id we
# recieved in step 3 and its key. So we are
# validating the out channel using data
WriteTo $Channel $xml
} else {
-
+
# RFC3920 8.3(9): The Authoritative Server (them) verifies the
# valididy of the key and posts a message to
# the Recieving Server (us).
# IMPOSSIBLE??
Log error "ARGH: 8.3(10) this isnt supposed to happen"
}
-
+
} else {
Close $Channel
}
}
}
-
+
iq -
message -
presence {
projects / tclxmppd.git / commitdiff