+# s2s.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#
+#
+# -------------------------------------------------------------------------
+# 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 Tclresolver
namespace eval ::xmppd {}
namespace eval ::xmppd::s2s {
variable options
if {![info exists options]} {
array set options {
- jid {}
+ jid conference.patthoyts.tk
+ secret secret
address 0.0.0.0
port 5269
- loglevel warn
+ loglevel debug
}
set options(jid) [info hostname]
- variable log [logger::init s2s]
+ }
+
+ variable log
+ if {![info exists log]} {
+ set log [logger::init s2s]
${log}::setlevel $options(loglevel)
+ proc ${log}::stdoutcmd {level text} {
+ variable service
+ #puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\
+ # $service $level\] $text"
+ puts stderr $text
+ }
}
variable uid
proc ::xmppd::s2s::configure {args} {
variable options
+ variable log
if {[llength $args] < 1} {
set r {}
foreach opt [lsort [array names options]] {
set options(jid) [Pop args 1]
}
}
+ -secret {
+ if {$cget} {
+ return $options(secret)
+ } else {
+ set options(secret) [Pop args 1]
+ }
+ }
-addr* {
if {$cget} {
return $options(address)
return
}
-proc ::xmppd::route {args} {
+proc ::xmppd::s2s::route {args} {
array set opts {-from {} -to {} -id {}}
while {[string match -* [set option [lindex $args 0]]]} {
switch -exact -- $option {
return
}
+proc ::xmppd::s2s::stop {} {
+ variable listeners
+ set srv [Pop listeners]
+ if {[llength $srv] > 0} {
+ set info [fconfigure $srv -sockname]
+ close $srv
+ Log notice "XMPP s2s stopped listening on [lindex $info 0]:[lindex $info 2]"
+ }
+ return
+}
+
# -------------------------------------------------------------------------
proc ::xmppd::s2s::Log {level msg} {
proc ::xmppd::s2s::Queue {from to data} {
Log debug "Queue message -from $from -to $to"
+ set ip [lindex [resolve $to] 0]
+ set connid conn:$ip
+ variable $connid
+ if {![info exists $connid]} {
+ Open $connid $from $to
+ }
+ upvar #0 [namespace current]::$connid conn
+ lappend conn(queue) $data
+ set conn(after) [after 10 [list [namespace current]::Flush $connid]]
+ return
}
-proc ::xmppd::s2s::Accept {chan clientaddr clientport} {
- variable options
- Log notice "XMPP s2s accept connect from $clientaddr:$clientport"
- set parser [wrapper::new \
- [list OnOpenStream $chan] [list OnCloseStream $chan] \
- [list OnInput $chan] [list OnError $chan]]
- fconfigure $chan -translation binary -encoding utf-8 -buffering none -blocking 0
- fileevent $chan readable [list Read $chan $parser]
+# Open
+# Opens a new connection to a jabber server and creates our session state
+#
+# TODO: check for config details per remote site?
+# use DNS to look for the SRV resources.
+proc ::xmppd::s2s::Open {connid from to} {
+ variable $connid
+ upvar #0 [namespace current]::$connid conn
+ set conn(from) $from
+ set conn(to) $to
+ set conn(id) 0
+ set conn(state) init
+ set conn(parser) [wrapper::new \
+ [list [namespace current]::OnOpenOutStream $connid] \
+ [list [namespace current]::OnCloseStream $connid] \
+ [list [namespace current]::OnInput $connid] \
+ [list [namespace current]::OnError $connid]]
+ #set conn(out) [socket -async $to 5269]
+ set conn(out) [socket -async localhost 55269] ;# FIX ME
+ fconfigure $conn(out) -buffering none -blocking 0 \
+ -encoding utf-8 -translation lf
+ fileevent $conn(out) writable \
+ [list [namespace current]::OutHeader $connid]
+ fileevent $conn(out) readable \
+ [list [namespace current]::Read $conn(out) $connid]
+ return
}
-# -------------------------------------------------------------------------
-
-
-proc Write {chan} {
- 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='all.tclers.tk' version='1.0'>"
- writeto $chan $xml
+proc ::xmppd::s2s::OutHeader {connid} {
+ variable $connid
+ upvar #0 [namespace current]::$connid conn
+ fileevent $conn(out) 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'>"
+ WriteTo $conn(out) $xml
}
-proc Read {chan parser} {
+proc ::xmppd::s2s::Read {chan connid} {
+ variable $connid
+ upvar #0 [namespace current]::$connid conn
+
if {[eof $chan]} {
fileevent $chan readable {}
- OnCloseStream $chan
+ OnCloseStream $chanid
}
set xml [read $chan]
- puts stderr "< $chan $xml"
- wrapper::parse $parser $xml
+ Log debug "< $chan $xml"
+ wrapper::parse $conn(parser) $xml
}
-proc closestream {chan} {
- writeto $chan "</stream:stream>"
- close $chan
- set ::forever 1
+proc ::xmppd::s2s::Flush {connid} {
+ variable $connid
+ upvar #0 [namespace current]::$connid conn
+ after cancel $conn(after)
+ if {$conn(state) ne "init"} {
+ set data [lindex $conn(queue) 0]
+ if {![catch {WriteTo $conn(out) $data} err]} {
+ Pop conn(queue)
+ }
+ } else {
+ set conn(after) [after 1000 [list [namespace current]::Flush $connid]]
+ }
+ return
}
-proc init {} {
- variable state
- set state(localhost) conference.patthoyts.tk
- set state(localport) 5269
- set state(localid) [uuid::uuid generate]
- set state(localkey) [sha1::sha1 $state(localhost):$state(localid):[uuid::generate]]
- set state(remotehost) all.tclers.tk
- set state(remoteport) 5269
- set state(remoteid) {}
- set state(remotekey) {}
- set state(sout) [socket $state(remotehost) $state(remoteport)]
- set state(sin) [socket -server Accept $state(localport)]
- set parser [wrapper::new \
- [list OnOpenStream $state(sout)] [list OnCloseStream $state(sout)] \
- [list OnInput $state(sout)] [list OnError $state(sout)]]
- fconfigure $state(sout) -translation binary -encoding utf-8 -buffering none -blocking 0
- fileevent $state(sout) writable [list Write $state(sout)]
- fileevent $state(sout) readable [list Read $state(sout) $parser]
- return
+proc ::xmppd::s2s::WriteTo {chan data} {
+ Log debug "> $chan $data"
+ puts -nonewline $chan $data
}
-proc OnOpenStream {chan args} {
- variable state
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::xmppd::s2s::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+proc ::xmppd::s2s::Accept {chan clientaddr clientport} {
+ variable options
+ Log notice "XMPP s2s accept connect from $clientaddr:$clientport on $chan"
+ if {0} {
+ set 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]::Read2 $chan {}]
+}
+
+proc ::xmppd::s2s::Read2 {chan connid} {
+ if {[eof $chan]} {
+ fileevent $chan readable {}
+ #OnCloseStream $chanid
+ }
+ set xml [read $chan]
+ Log debug "< $chan $xml"
+ #wrapper::parse $conn(parser) $xml
+}
+
+
+# -------------------------------------------------------------------------
+
+proc ::xmppd::s2s::OnOpenOutStream {connid args} {
+ variable options
+ variable $connid
+ upvar #0 [namespace current]::$connid conn
array set attr $args
- puts stderr "OS [array get attr]"
+ Log debug "| OpenStream [array get attr]"
- if {$state(remoteid) eq {}} {
- set state(remoteid) $attr(id)
- set xml "<db:result xmlns:db='jabber:server:dialback' to='$state(remotehost)' from='$state(localhost)'>$state(localkey)</db:result>"
- } else {
- set xml "<?xml version='1.0' encoding='utf-8'?><stream:stream xmlns='jabber:server' xmlns:stream='http://etherx.jabber.org/streams' id='$state(localid)' to='$state(remotehost)' version='1.0'>"
+ switch -exact -- $conn(state) {
+ init {
+ # We have initiated a s2s connection. This is their reply
+ set conn(rid) $attr(id)
+ 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
+ }
+ default {
+ Log error "- unexpected state"
+ }
}
- writeto $chan $xml
-
+}
- #set xml "<presence from='ircuser@conference.patthoyts.tk/bridge' to='tcl@tach.tclers.tk/ircuser' type='available'><x xmlns='http://jabber.org/protocol/muc'/></presence>"
- #puts stderr "> $xml"
- #puts $chan $xml
+proc xmppd::s2s::OnOpenInStream {chan args} {
+ # Someone is dialling into us - they are the initiator, so we
+ # send the open response.
+ Log debug "- state us $conn(state)"
+ set conn(id) [string map {- {}} [uuid::uuid generate]]
+ set xml "<?xml version='1.0' encoding='utf-8'?><stream:stream xmlns='jabber:server' xmlns:stream='http://etherx.jabber.org/streams' id='$conn(id)' to='$conn(to)' version='1.0'>"
+ WriteTo $conn(in) $xml
}
-proc OnCloseStream {chan} {
- close $chan
- puts stderr "! $chan closed"
- set ::forever 1
+proc ::xmppd::s2s::OnCloseStream {connid} {
+ variable $connid
+ upvar #0 [namespace current]::$connid conn
+ catch {close $conn(in)}
+ Log notice "- $conn(in) closed"
}
-proc OnError {chan code args} {
- puts stderr "error $code"
- closestream $chan
+proc ::xmppd::s2s::OnError {connid code args} {
+ variable $connid
+ upvar #0 [namespace current]::$connid conn
+ puts stderr "- error $connid $code"
+ WriteTo $conn(out) "</stream:stream>"
+ catch {close $conn(out)}
+ Log notice "- $conn(out) closed"
}
-proc OnInput {chan xmllist} {
- variable state
+proc ::xmppd::s2s::OnInput {connid xmllist} {
+ variable $connid
+ upvar #0 [namespace current]::$connid conn
+
foreach {cmd attr close value children} $xmllist break
array set a $attr
switch -exact -- $cmd {
features {
+ Log debug "- features $xmllist"
}
result {
+ Log debug "- result $xmllist"
if {$a(xmlns) eq "jabber:server:dialback"} {
- set state(key,$a(from)) $value
- set xml "<db:verify xmlns:db='jabber:server:dialback' from='$state(localhost)' to='$state(remotehost)' id='$state(remoteid)'>$state(key,$a(from))</db:verify>"
- writeto $state(sout) $xml
+ #set state(key,$a(from)) $value
+ #set xml "<db:verify xmlns:db='jabber:server:dialback' from='$state(localhost)' to='$state(remotehost)' id='$state(remoteid)'>$state(key,$a(from))</db:verify>"
+ #writeto $state(sout) $xml
}
}
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
+ #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
} else {
- puts stderr "IN $xmllist"
+ Log debug "- verify $xmllist"
}
}
default {
- puts stderr "IN $xmllist"
+ Log debug "- event $xmllist"
}
}
}
-proc writeto {chan data} {
- puts stderr "> $chan $data"
- puts -nonewline $chan $data
-}
+# -------------------------------------------------------------------------
if {!$tcl_interactive} {
- init
- vwait ::forever
- catch {close $state(sin)}
- catch {close $state(sout)}
- exit 0
+
+} 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>}
+ namespace import -force xmppd::s2s::*
+
}
+
+# -------------------------------------------------------------------------
projects / tclxmppd.git / commitdiff