package require uuid; # tcllib
package require sha1; # tcllib
package require logger; # tcllib
+package require dns 1.2.1; # tcllib 1.8
#package require tls
-#package require Tclresolver
namespace eval ::xmppd {}
namespace eval ::xmppd::s2s {
return
}
+# look up the IP address for the server of a given JID.
+# This uses the DNS SRV records as described in RFC3920 and
+# falls back to DNS A record resolution if no SRV records.
+proc ::xmppd::s2s::resolve {jid} {
+ set front [string first @ $jid]
+ set back [string last / $jid]
+ if {$back == -1} {set back end} else {incr back -1}
+ set hostname [string range $jid [incr front] $back]
+
+ set result {}
+ set port 5269
+ foreach srvd {"_xmpp-server._tcp" "_jabber._tcp"} {
+ set tok [dns::resolve "${srvd}.${hostname}" -type SRV]
+ if {[dns::status $tok] eq "ok"} {
+ set answers {}
+ foreach rr [dns::result $tok] {
+ array set res $rr
+ if {[info exists res(type)] \
+ && $res(type) eq "SRV" \
+ && [llength $res(rdata)] > 0} {
+ lappend answers $res(rdata)
+ }
+ }
+ lsort -index 1 $answers
+ array set rrr [lindex $answers 0]
+ set port $rrr(port)
+ if {[ip::version $rrr(target)] == -1} {
+ set hostname $rrr(target)
+ } else {
+ set result [list $rrr(target) $port]
+ }
+ }
+ dns::cleanup $tok
+ if {[llength $result] > 0} {break}
+ }
+
+ if {[llength $result] == 0} {
+ set tok [dns::resolve $hostname -type A]
+ if {[dns::status $tok] eq "ok"} {
+ set result [list [dns::address $tok] $port]
+ }
+ dns::cleanup $tok
+ }
+
+ return $result
+}
+
# -------------------------------------------------------------------------
proc ::xmppd::s2s::Log {level msg} {
${log}::${level} $msg
}
+# Holds info about a socket stream.
+# The from and to items are temporary as routes are held on session objects.
+# Once the session is created, we erase the from and to items.
+proc ::xmppd::s2s::CreateChannel {} {
+ variable uid
+ set Channel [namespace current]::channel[incr uid]
+ variable $Channel
+ upvar #0 $Channel channel
+ array set channel {sock {} address {} port {} from {} to {} parser {}}
+ return $Channel
+}
+
# Find a session for a given route
-proc ::xmppd::s2s::FindConnection {from to} {
- foreach connid [info vars [namespace current]::sock*] {
- upvar #0 $connid conn
- if {$conn(from) eq $from && $conn(to) eq $to} {
- return [namespace tail $connid]
+proc ::xmppd::s2s::FindChannel {addr} {
+ foreach channel [info vars [namespace current]::channel*] {
+ upvar #0 $channel chan
+ if {$chan(address) eq $addr} {
+ return $channel
}
}
return {}
}
+proc ::xmppd::s2s::CreateSession {} {
+ variable uid
+ set Session [namespace current]::session[incr uid]
+ variable $Session
+ upvar #0 $Session session
+ array set session {
+ chan {} from {} to {} id {} state new
+ queue {} after {} key {} parser {}
+ }
+ return $Session
+}
+
+# Find a session for a given route
+proc ::xmppd::s2s::FindSession {op args} {
+ set r {}
+ switch -exact -- $op {
+ id {
+ set id [lindex $args 0]
+ foreach Session [info vars [namespace current]::session*] {
+ upvar #0 $Session session
+ if {[info exists session(id)] && $session(id) eq $id} {
+ lappend r $Session
+ break
+ }
+ }
+ }
+ name {
+ 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
+ && [info exists session(to)] && $session(to) eq $to} {
+ lappend r $Session
+ break
+ }
+ }
+ }
+ channel {
+ set Channel [lindex $args 0]
+ foreach Session [info vars [namespace current]::session*] {
+ upvar #0 $Session session
+ if {[info exists session(channel)]
+ && $session(channel) eq $Channel} {
+ lappend r $Session
+ }
+ }
+ }
+ default {
+ return -code error "invalid operation \"$op\":\
+ must be one of \"id\", \"name\" or \"channel\""
+ }
+ }
+ return $r
+}
+
proc ::xmppd::s2s::Queue {from to data} {
Log debug "Queue message -from $from -to $to"
- set connid [FindConnection $from $to]
- if {$connid eq {}} {
- set connid [Open $from $to]
+ # Either find an open session or open a new one.
+ set Session [FindSession name $from $to]
+ if {[llength $Session] < 1} {
+ set Session [Open $from $to]
}
- upvar #0 [namespace current]::$connid conn
- lappend conn(queue) $data
- if {[llength $conn(queue)] == 1} {
- set conn(after) [after 10 [list [namespace current]::Flush $connid]]
+ # Queue our message for transmission by this session.
+ upvar #0 $Session session
+ lappend session(queue) $data
+ if {[llength $session(queue)] == 1} {
+ set session(after) \
+ [after 10 [list [namespace current]::Flush $Session]]
}
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 $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) {}
- set conn(state) init
- set conn(queue) {}
- set conn(after) {}
- set conn(key) {}
- set conn(parser) [wrapper::new \
- [list [namespace current]::OnOpenStream $chan] \
- [list [namespace current]::OnCloseStream $chan] \
- [list [namespace current]::OnInput $chan] \
- [list [namespace current]::OnError $chan]]
- fconfigure $chan -buffering none -blocking 0 -encoding utf-8 -translation lf
- fileevent $chan writable [list [namespace current]::Write $chan]
- fileevent $chan readable [list [namespace current]::Read $chan]
- return $chan
+
+ # 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"
+ }
+
+ set Channel [FindChannel [lindex $addr 0]]
+ if {[llength $Channel] < 1} {
+ set Channel [CreateChannel]
+ upvar #0 $Channel channel
+ set channel(dir) out
+ set channel(address) [lindex $addr 0]
+ set channel(port) [lindex $addr 1]
+ set channel(from) $from
+ set channel(to) $to
+ set channel(parser) \
+ [wrapper::new \
+ [list [namespace current]::OnOpenStream $Channel] \
+ [list [namespace current]::OnCloseStream $Channel] \
+ [list [namespace current]::OnInput $Channel] \
+ [list [namespace current]::OnError $Channel]]
+
+ set sock [socket -async $channel(address) $channel(port)]
+ set channel(sock) $sock
+ fconfigure $sock -buffering none -blocking 0 \
+ -encoding utf-8 -translation lf
+ fileevent $sock writable [list [namespace current]::Write $Channel]
+ fileevent $sock readable [list [namespace current]::Read $Channel]
+ }
+
+ return $Channel
+}
+
+proc ::xmppd::s2s::Accept {chan clientaddr clientport} {
+ variable options
+ Log notice "XMPP s2s accept connect from $clientaddr:$clientport on $chan"
+ # RFC3920 8.3(5): The remote server opens a stream back here based upon
+ # the domain name we provided.
+ set Channel [CreateChannel]
+ upvar #0 $Channel channel
+ set channel(dir) in
+ set channel(address) $clientaddr
+ set channel(port) $clientport
+ set channel(sock) $chan
+ set channel(parser) \
+ [wrapper::new \
+ [list [namespace current]::OnOpenStream $Channel] \
+ [list [namespace current]::OnCloseStream $Channel] \
+ [list [namespace current]::OnInput $Channel] \
+ [list [namespace current]::OnError $Channel]]
+
+ fconfigure $chan -translation binary -encoding utf-8 \
+ -buffering none -blocking 0
+ fileevent $chan readable [list [namespace current]::Read $Channel]
}
-proc ::xmppd::s2s::Write {chan} {
- variable $chan
- upvar #0 [namespace current]::$chan conn
- fileevent $chan writable {}
+proc ::xmppd::s2s::Write {Channel} {
+ upvar #0 $Channel channel
+ fileevent $channel(sock) writable {}
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
+ append xml " version='1.0'>"
+ WriteTo $channel(sock) $xml
}
-proc ::xmppd::s2s::Read {chan} {
- variable $chan
- upvar #0 [namespace current]::$chan conn
- if {[eof $conn(chan)]} {
- fileevent $chan readable {}
- Log warn "- EOF on $chan"
+proc ::xmppd::s2s::Read {Channel} {
+ upvar #0 $Channel channel
+ if {[eof $channel(sock)]} {
+ fileevent $channel(sock) readable {}
+ Log warn "- EOF on $Channel ($channel(sock))"
# delete parser
# clean up session
# remove route
}
- set xml [read $conn(chan)]
- Log debug "< $chan $xml"
- wrapper::parse $conn(parser) $xml
+ set xml [read $channel(sock)]
+ Log debug "< $channel(sock) $xml"
+ wrapper::parse $channel(parser) $xml
}
-proc ::xmppd::s2s::Flush {connid} {
- variable $connid
- upvar #0 [namespace current]::$connid conn
- catch {after cancel $conn(after)}
- if {$conn(state) ne "init"} {
- set data [lindex $conn(queue) 0]
- if {![catch {WriteTo $conn(chan) $data} err]} {
- Pop conn(queue)
+proc ::xmppd::s2s::Flush {Session} {
+ upvar #0 $Session session
+ if {![info exists session]} {return}
+ if {[info exists session(channel)]} {
+ upvar #0 $session(channel) channel
+ catch {after cancel $session(after)}
+ if {$session(state) ne "init"} {
+ set data [lindex $session(queue) 0]
+ if {![catch {WriteTo $channel(sock) $data} err]} {
+ Pop session(queue)
+ }
}
}
- if {[llength $conn(queue)] != 0} {
- set conn(after) [after 1000 [list [namespace current]::Flush $connid]]
+ if {[llength $session(queue)] != 0} {
+ set session(after) \
+ [after 1000 [list [namespace current]::Flush $Session]]
}
return
}
return $r
}
-proc ::xmppd::s2s::Accept {chan clientaddr clientport} {
- variable options
- Log notice "XMPP s2s accept connect from $clientaddr:$clientport on $chan"
- # create a state array for this (channels are not variables!)
- variable $chan
- if {[info exists $chan]} {unset $chan}
- upvar #0 [namespace current]::$chan conn
- set conn(id) [string map {- {}} [uuid::uuid generate]]
- set conn(key) {}
- set conn(from) {}
- set conn(to) $options(jid)
- set conn(queue) {}
- set conn(after) {}
- set conn(state) init
- set conn(chan) $chan
- set conn(parser) [wrapper::new \
- [list [namespace current]::OnOpenStream $chan] \
- [list [namespace current]::OnCloseStream $chan] \
- [list [namespace current]::OnInput $chan] \
- [list [namespace current]::OnError $chan]]
- fconfigure $chan -translation binary -encoding utf-8 -buffering none -blocking 0
- fileevent $chan readable [list [namespace current]::Read $chan]
-}
-
-
# Raise --
#
# Raise a stream error and close the route.
#
-proc ::xmppd::s2s::Raise {chan type args} {
+proc ::xmppd::s2s::Raise {Channel type args} {
+ # FIX ME - close just the session!?
+ upvar #0 $Channel channel
set xml "<stream:error>"
append xml "<$type xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>"
- WriteTo $chan $xml
- Close $chan
+ WriteTo $channel(sock) $xml
+ Close $Channel
}
# Close --
# 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::Close {Channel} {
+ # FIX ME - this probably should just close a session.
+ upvar #0 $Channel channel
+ WriteTo $channel(sock) "</stream:stream>"
+ OnCloseStream $Channel
}
# -------------------------------------------------------------------------
-proc ::xmppd::s2s::OnOpenStream {chan args} {
+proc ::xmppd::s2s::OnOpenStream {Channel args} {
variable options
- variable $chan
- upvar #0 [namespace current]::$chan conn
+ variable $Channel
+ upvar #0 $Channel channel
array set attr $args
- Log debug "O $chan [array get attr]"
- if {$conn(state) ne "init"} {
- Log error "- unexpected state \"$conn(state)\" in openstream"
- }
+ Log debug "OPENSTREAM $channel(sock) [array get attr]"
- if {$conn(id) eq {}} {
+ if {[info exists attr(id)]} {
- # Outgoing stream. They provide the session id and we provide the key.
-
- # RFC3920 8.3.3: We must reject if invalid namespace.
+ # 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)]
|| $attr(xmlns) ne "http://etherx.jabber.org/streams"} {
- return [Raise $chan invalid-namespace]
+ return [Raise $Channel 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 Session [CreateSession]
+ upvar #0 $Session session
+ set session(channel) $Channel
+ set session(from) $channel(from)
+ set session(to) $channel(to)
+ set session(id) $attr(id)
+ set channel(from) {}; # clean up temporary channel items
+ set channel(to) {}; #
+
+ # RFC3920 8.3(4): The Originating Server (us) sends a dialback key
+ # 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 xml "<db:result xmlns:db='jabber:server:dialback'\
- to='$conn(to)' from='$conn(from)'>$conn(key)</db:result>"
- set conn(state) dialback
- WriteTo $chan $xml
+ to='$session(to)' from='$session(from)'>$session(key)</db:result>"
+ set session(state) dialback
+ WriteTo $channel(sock) $xml
} else {
- # RFC3920 8.3.7: check namespace
+ # 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.
if {![info exists attr(xmlns)]
|| $attr(xmlns) ne "http://etherx.jabber.org/streams"} {
- return [Raise $chan invalid-namespace]
+ return [Raise $Channel invalid-namespace]
}
- # Incoming stream - at this point we may not know who they are.
- # But we manage the session id. So send it now.
+ # 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
+ set channel(id) [string map {- {}} [uuid::uuid generate]]
+
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 $chan $xml
-
+ id='$channel(id)' version='1.0'>"
+ WriteTo $channel(sock) $xml
}
}
-proc ::xmppd::s2s::OnCloseStream {chan} {
- variable $chan
- upvar #0 [namespace current]::$chan conn
- catch {close $chan}
- catch {unset conn} msg
- Log notice "- $chan closed: $msg"
-}
-
-proc ::xmppd::s2s::OnError {chan code args} {
- variable $chan
- upvar #0 [namespace current]::$chan conn
- Log error "- $chan error $code"
- WriteTo $chan "</stream:stream>"
- catch {close $chan}
- catch {unset conn} msg
- Log notice "- $chan closed: msg"
+proc ::xmppd::s2s::OnCloseStream {Channel} {
+ upvar #0 $Channel channel
+ catch {close $channel(sock)}
+ # FIX ME - how to close the parser?
+ catch {unset channel} msg
+ Log notice "- $Channel 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::OnError {Channel code args} {
+ upvar #0 $Channel channel
+ Log error "- $Channel error $code"
+ WriteTo $channel(sock) "</stream:stream>"
+ OnCloseStream $Channel
}
-
-proc ::xmppd::s2s::OnInput {chan xmllist} {
- variable $chan
- upvar #0 [namespace current]::$chan conn
+proc ::xmppd::s2s::OnInput {Channel xmllist} {
+ upvar #0 $Channel channel
foreach {cmd attr close value children} $xmllist break
array set a {xmlns {} from {} to {}}
# RFC3920 8.3: All stanzas MUST include both to and from
if {$a(from) eq "" || $a(to) eq ""} {
- Raise $chan improper-addressing
+ Raise $Channel 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 ""} {Log error "I GOT IT WRONG"}
- set conn(key) $value
- 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 {[llength $outid] > 0} {
- variable $outid
- upvar #0 [namespace current]::$outid out
+
+ if {[info exists a(type)]} {
+ # 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 {}} {
+ return [Raise $Channel invalid-from]
+ }
+ upvar #0 $Session session
+ set session(state) $a(type)
+ return
+ }
+
+ # RFC3290 8.3(4): The Originating Server (them) sends a
+ # dialback key to the Receiving Server (us)
+ #
+ if {![info exists channel(id)]} {
+ Log error "Argh - no channel id!!"
+ return
+ }
+ set Session [CreateSession]
+ upvar #0 $Session session
+ 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
+ # out session id, from and to.
+ set Out [FindSession name $a(to) $a(from)]
+ if {$Out ne {}} {
+ upvar #0 $Out 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
+ from='$a(to)' to='$a(from)'\
+ id='$session(id)'>$session(key)</db:verify>"
+ upvar #0 $out(channel) ochannel
+ WriteTo $ochannel(sock) $xml
} else {
- # We need to create an outbound connection to go with
- # this.
- Open $a(to) $a(from)
+ # We need to create a new out-bound session attached
+ # to this channel
+ #set Out [CreateSession]
+ #upvar #0 $Out out
+ #set out(id)
+ #set out(state) dialback
+ #set out(channel) $Channel
+ Log error "FIXME need to open a outbound session"
}
+
+ } else {
+ Log error "unespected 'result' namespace'"
}
}
verify {
# RFC3920 8.3: All stanzas MUST include both to and from
if {$a(from) eq "" || $a(to) eq ""} {
- Raise $chan improper-addressing
+ Raise $Channel improper-addressing
+ }
+
+ set Session [FindSession id $a(id)]
+ if {$Session eq {}} {
+ # Raise invalid-id ??
+ Log error "Failed to find session for '$a(id)'"
+ return
+ }
+ upvar #0 $Session session
+ if {$session(from) eq {}} {
+ set session(from) $a(from)
+ set session(to) $a(to)
}
- 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)
+ if {![info exists a(type)]} {
+
+ # 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
+ # recieved on the in channel.
+ # Lets check the logic
+ if {$Channel eq $session(channel)} {
+ Log error "LOGIC FAILURE"
+ }
+ # RFC 3920 8.3(9): Check the key against the out session
+ set session(state) invalid
+ if {$session(key) eq $value} {
+ set session(state) valid
}
+ set xml "<db:verify xmlns:db='jabber:server:dialback'\
+ from='$session(from)' to='$session(to)'\
+ id='$session(id)' type='$session(state)'/>"
+ WriteTo $channel(sock) $xml
+
} else {
- # 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
+
+ # RFC3920 8.3(10): The Receiving Server (us) informs the
+ # Originating Server (them) of the result
+ set session(state) $a(type)
+ if {$session(state) eq "valid"} {
+ set Out [FindSession name $a(to) $a(from)]
+ if {$Out ne {}} {
+ Log debug "- $channel(sock) Found session $Out"
+ upvar #0 $Out out
+ upvar #0 $out(channel) ochannel
+ set xml "<db:verify xmlns:db='jabber:server:dialback'\
+ from='$session(to)' to='$session(from)'\
+ type='$session(state)'/>"
+ WriteTo $ochannel(sock) $xml
+ } else {
+ # We need to create an outbound connection to go with
+ # this.
+ #Open $a(to) $a(from)
+ Log error "FIXME need to open session (2)"
}
- set xml "<db:verify xmlns:db='jabber:server:dialback'\
- from='$sess(from)' to='$sess(to)' id='$sess(id)'\
- type='$type'/>"
- WriteTo $chan $xml
+ } else {
+ Close $Channel
}
}
}
to='test@tach.tclers.tk' type='groupchat'>\
<body>[wrapper::xmlcrypt $msg]</body></message>"
}
+
+
+ set ns [dns::nameservers]
+ if {[llength $ns] > 0} {
+ dns::configure -nameserver [lindex $ns 0] -protocol tcp
+ }
}
# -------------------------------------------------------------------------
projects / tclxmppd.git / commitdiff