# 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/
#
+# RFC 3920 [http://www.ietf.org/rfc3921.txt] -- CHECK
+# RFC 3921 [http://www.ietf.org/rfc3921.txt]
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
-package require tls
-package require wrapper
-package require uuid
-package require sha1
-package require logger
+package require wrapper; # jabberlib
+package require uuid; # tcllib
+package require sha1; # tcllib
+package require logger; # tcllib
+#package require tls
#package require Tclresolver
namespace eval ::xmppd {}
port 5269
loglevel debug
}
- set options(jid) [info hostname]
+ #set options(jid) [info hostname]
}
variable log
if {![info exists log]} {
set log [logger::init s2s]
${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
- #puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\
- # $service $level\] $text"
+ variable logfile
+ set ts [clock format [clock seconds] -format {%H:%M:%S}]
+ puts $logfile "\[$ts\] $level $text"
puts stderr $text
}
}
}
set data [lindex $args 0]
if {[string length $data] < 1} {
- Log warning "[lindex [info level 0] 0] no data to send!"
+ Log warn "[lindex [info level 0] 0] no data to send!"
return
}
# Find a session for a given route
proc ::xmppd::s2s::FindConnection {from to} {
- foreach connid [info vars sock*] {
- upvar #0 [namespace current]::$connid conn
+ foreach connid [info vars [namespace current]::sock*] {
+ upvar #0 $connid conn
if {$conn(from) eq $from && $conn(to) eq $to} {
- return $connid
+ return [namespace tail $connid]
}
}
return {}
# TODO: check for config details per remote site?
# use DNS to look for the SRV resources.
proc ::xmppd::s2s::Open {from to} {
- set chan [socket -async localhost 55269] ;# FIX ME
+ set chan [socket -async $to 5269]
variable $chan
upvar #0 [namespace current]::$chan conn
+ set conn(chan) $chan
set conn(from) $from
set conn(to) $to
- set conn(id) 0
+ set conn(id) {}
set conn(state) init
set conn(queue) {}
set conn(after) {}
variable $chan
upvar #0 [namespace current]::$chan conn
fileevent $chan writable {}
- set xml "<?xml version='1.0' encoding='utf-8'?><stream:stream\
- xmlns='jabber:server' xmlns:stream='http://etherx.jabber.org/streams'
- to='$conn(to)' version='1.0'>"
+ set xml "<?xml version='1.0' encoding='utf-8'?>"
+ append xml "<stream:stream xmlns='jabber:server'"
+ append xml " xmlns:stream='http://etherx.jabber.org/streams'"
+ append xml " to='$conn(to)' version='1.0'>"
WriteTo $chan $xml
}
-
proc ::xmppd::s2s::Read {chan} {
variable $chan
upvar #0 [namespace current]::$chan conn
- if {[eof $chan]} {
+ if {[eof $conn(chan)]} {
fileevent $chan readable {}
+ Log warn "- EOF on $chan"
# delete parser
# clean up session
# remove route
}
- set xml [read $chan]
+ set xml [read $conn(chan)]
Log debug "< $chan $xml"
wrapper::parse $conn(parser) $xml
}
proc ::xmppd::s2s::Flush {connid} {
variable $connid
upvar #0 [namespace current]::$connid conn
- after cancel $conn(after)
+ catch {after cancel $conn(after)}
if {$conn(state) ne "init"} {
set data [lindex $conn(queue) 0]
- if {![catch {WriteTo $conn(out) $data} err]} {
+ if {![catch {WriteTo $conn(chan) $data} err]} {
Pop conn(queue)
}
}
fileevent $chan readable [list [namespace current]::Read $chan]
}
+
+# Raise --
+#
+# Raise a stream error and close the route.
+#
+proc ::xmppd::s2s::Raise {chan type args} {
+ set xml "<stream:error>"
+ append xml "<$type xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>"
+ WriteTo $chan $xml
+ Close $chan
+}
+
+# Close --
+#
+# Shut down a route. We close the channel and clear up our state.
+#
+# FIX ME: we need to clean up the parser state too -- we currently
+# leak the parsers resources.
+#
+proc ::xmppd::s2s::Close {chan} {
+ variable $chan
+ upvar #0 [namespace current]::$chan conn
+ WriteTo $chan "</stream:stream>"
+ close $chan
+ unset conn
+}
+
# -------------------------------------------------------------------------
proc ::xmppd::s2s::OnOpenStream {chan args} {
if {$conn(id) eq {}} {
# Outgoing stream. They provide the session id and we provide the key.
- #
+
+ # RFC3920 8.3.3: We must reject if invalid namespace.
+ if {![info exists attr(xmlns)]
+ || $attr(xmlns) ne "http://etherx.jabber.org/streams"} {
+ return [Raise $chan invalid-namespace]
+ }
set conn(id) $attr(id)
+
+ # RFC3920 8.3.4: send the dialback key
set conn(key) [sha1::sha1 [sha1::sha1 [sha1::sha1 $options(secret)]$conn(from)]$conn(id)]
set xml "<db:result xmlns:db='jabber:server:dialback'\
to='$conn(to)' from='$conn(from)'>$conn(key)</db:result>"
set conn(state) dialback
- WriteTo $conn(out) $xml
+ WriteTo $chan $xml
} else {
- # Incoming stream - at this point we don't know who they are. But we manage the
- # session id. So send it now.
+ # RFC3920 8.3.7: check namespace
+ if {![info exists attr(xmlns)]
+ || $attr(xmlns) ne "http://etherx.jabber.org/streams"} {
+ return [Raise $chan invalid-namespace]
+ }
+
+ # Incoming stream - at this point we may not know who they are.
+ # But we manage the session id. So send it now.
set xml "<?xml version='1.0' encoding='utf-8'?>"
append xml "<stream:stream xmlns='jabber:server'\
xmlns:stream='http://etherx.jabber.org/streams'\
id='$conn(id)' version='1.0'>"
set conn(state) dialback
- WriteTo $conn $xml
+ WriteTo $chan $xml
}
}
proc ::xmppd::s2s::OnError {chan code args} {
variable $chan
upvar #0 [namespace current]::$chan conn
- puts stderr "- $chan error $code"
+ Log error "- $chan error $code"
WriteTo $chan "</stream:stream>"
catch {close $chan}
catch {unset conn} msg
Log notice "- $chan closed: msg"
}
+proc ::xmppd::s2s::NewSession {chan} {
+ set token [namespace current]::sess[incr uid]
+ variable $token
+ upvar #0 $token session
+ array set session [list id {} key {} from {} to {} \
+ queue {} after {} state init \
+ chan $chan parser {}]
+ return $token
+}
+
+
proc ::xmppd::s2s::OnInput {chan xmllist} {
variable $chan
upvar #0 [namespace current]::$chan conn
foreach {cmd attr close value children} $xmllist break
- array set a {xmlns {}}
+ array set a {xmlns {} from {} to {}}
array set a $attr
+
switch -exact -- $cmd {
features {
Log debug "- features $xmllist"
}
result {
Log debug "- result $xmllist"
+
+ # RFC3920 8.3: All stanzas MUST include both to and from
+ if {$a(from) eq "" || $a(to) eq ""} {
+ Raise $chan improper-addressing
+ }
+
if {$a(xmlns) eq "jabber:server:dialback"} {
# This should be from an incoming stream
# result has the key and from
- if {$conn(key) ne ""} {error "I GOT IT WRONG"}
+ if {$conn(key) ne ""} {Log error "I GOT IT WRONG"}
set conn(key) $value
- set conn(id) $a(id)
- set conn(from) $a(id)
+ if {[info exists a(id)]} {set conn(id) $a(id)}
+ if {[info exists a(from)]} {set conn(from) $a(from)}
# Find the corresponding outgoing stream (if it exists)
set outid [FindConnection $conn(to) $conn(from)]
- if {$outid ne {}} {
+ if {[llength $outid] > 0} {
variable $outid
- upvar #0 $outid out
+ upvar #0 [namespace current]::$outid out
set xml "<db:verify xmlns:db='jabber:server:dialback'\
from='$out(from)' to='$out(to)'\
id='$conn(id)'>$conn(key)</db:verify>"
WriteTo $outid $xml
+ } else {
+ # We need to create an outbound connection to go with
+ # this.
+ Open $a(to) $a(from)
}
}
}
verify {
- if {![info exists a(-type)]} {
- #set xml "<db:verify xmlns:db='jabber:server:dialback' from='$state(localhost)' to='$state(remotehost)' id='$state(localid)' "
- #if {$value eq $state(localkey)} {
- # append xml "type='valid'"
- #} else {
- # append xml "type='invalid'"
- #}
- #append xml "/>"
- #writeto $chan $xml
+ Log debug "- verify $xmllist"
+
+ # RFC3920 8.3: All stanzas MUST include both to and from
+ if {$a(from) eq "" || $a(to) eq ""} {
+ Raise $chan improper-addressing
+ }
+
+ if {[info exists a(type)]} {
+ set sid [FindConnection $a(from) $a(to)]
+ if {[llength $sid] > 0} {
+ upvar #0 [namespace current]::$sid sess
+ set sess(state) $a(type)
+ }
} else {
- Log debug "- verify $xmllist"
+ # request to verify a key for a route - find the corresponding
+ # session and check the id/key pair.
+ set sid [FindConnection $a(to) $a(from)]
+ if {[llength $sid] > 0} {
+ upvar #0 [namespace current]::$sid sess
+ set type invalid
+ if {$sess(id) eq $a(id) && $sess(key) eq $value} {
+ set type valid
+ }
+ set xml "<db:verify xmlns:db='jabber:server:dialback'\
+ from='$sess(from)' to='$sess(to)' id='$sess(id)'\
+ type='$type'/>"
+ WriteTo $chan $xml
+ }
}
}
default {
} else {
- xmppd::s2s::start
- set presence {<presence from='patthoyts@conference.patthoyts.tk/test' to='test@tach.tclers.tk/testing' type='available'><x xmlns='http://jabber.org/protocol/muc'/></presence>}
- set unpresence {<presence from='patthoyts@conference.patthoyts.tk/test' to='test@tach.tclers.tk' type='unavailable'><x xmlns='http://jabber.org/protocol/muc'/></presence>}
+ catch {xmppd::s2s::start}
+
#set presence {<presence from='patthoyts@conference.patthoyts.tk/test' to='test@tach.tclers.tk/testing' type='available'><x xmlns='http://jabber.org/protocol/muc'/></presence>}
+
#set unpresence {<presence from='patthoyts@conference.patthoyts.tk/test' to='test@tach.tclers.tk' type='unavailable'><x xmlns='http://jabber.org/protocol/muc'/></presence>}
namespace import -force xmppd::s2s::*
- xmppd::s2s::route -from uknml2375.renishaw.com -to bugzilla.renishaw.com \
+ #xmppd::s2s::route -from uknml2375.renishaw.com -to bugzilla.renishaw.com \
{<presence from='patthoyts@uknml2375.renishaw.com' type='available'/>}
+ proc presence {type} {
+ xmppd::s2s::route -from conference.patthoyts.tk -to tach.tclers.tk \
+ "<presence from='patthoyts@conference.patthoyts.tk/test'\
+ to='test@tach.tclers.tk/s2s_test' type='$type'><x\
+ xmlns='http://jabber.org/protocols/muc'/></presence>"
+ }
+ proc say {msg} {
+ xmppd::s2s::route -from conference.patthoyts.tk -to tach.tclers.tk \
+ "<message from='patthoyts@conference.patthoyts.tk/test'\
+ to='test@tach.tclers.tk' type='groupchat'>\
+ <body>[wrapper::xmlcrypt $msg]</body></message>"
+ }
}
# -------------------------------------------------------------------------
projects / tclxmppd.git / commitdiff