--- /dev/null
+package require tls
+package require wrapper
+package require uuid
+package require sha1
+package require logger
+
+namespace eval ::xmppd {}
+namespace eval ::xmppd::s2s {
+
+ variable version 1.0.0
+ variable rcsid {$Id$}
+
+ namespace export configure route
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ jid {}
+ address 0.0.0.0
+ port 5269
+ loglevel warn
+ }
+ set options(jid) [info hostname]
+ variable log [logger::init s2s]
+ ${log}::setlevel $options(loglevel)
+ }
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+proc ::xmppd::s2s::configure {args} {
+ variable options
+ if {[llength $args] < 1} {
+ set r {}
+ foreach opt [lsort [array names options]] {
+ lappend r -$opt $options($opt)
+ }
+ return $r
+ }
+
+ set cget [expr {[llength $args] == 1 ? 1 : 0}]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -jid {
+ if {$cget} {
+ return $options(jid)
+ } else {
+ set options(jid) [Pop args 1]
+ }
+ }
+ -addr* {
+ if {$cget} {
+ return $options(address)
+ } else {
+ set options(address) [Pop args 1]
+ }
+ }
+ -port {
+ if {$cget} {
+ return $options(port)
+ } else {
+ set options(port) [Pop args 1]
+ }
+ }
+ -log* {
+ if {$cget} {
+ return $options(loglevel)
+ } else {
+ set options(loglevel) [Pop args 1]
+ ${log}::setlevel $options(loglevel)
+ }
+ }
+ -- { Pop args ; break }
+ default {
+ set opts [join [lsort [array names options]] ", -"]
+ return -code error "bad option \"$option\":\
+ must be one of -$opts"
+ }
+ }
+ Pop args
+ }
+ return
+}
+
+proc ::xmppd::route {args} {
+ array set opts {-from {} -to {} -id {}}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -from {
+ set opts(-from) [Pop args 1]
+ set ndx [string last / $opts(-from)]
+ if {$ndx != -1} {
+ set opts(-from) [string range $opts(-from) 0 [incr ndx -1]]
+ }
+ }
+ -to {
+ set opts(-to) [Pop args 1]
+ set ndx [string last / $opts(-to)]
+ if {$ndx != -1} {
+ set opts(-to) [string range $opts(-to) 0 [incr ndx -1]]
+ }
+ }
+ -id {
+ set opts(-id) [Pop args 1]
+ }
+ }
+ Pop args
+ }
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args"
+ }
+ set data [lindex $args 0]
+ if {[string length $data] < 1} {
+ Log warning "[lindex [info level 0] 0] no data to send!"
+ return
+ }
+
+ Queue $opts(-from) $opts(-to) $data
+ return
+}
+
+proc ::xmppd::s2s::start {} {
+ variable options
+ variable listeners
+ if {![info exists listeners]} {set listeners {}}
+ set srv [socket -server [namespace current]::Accept \
+ -myaddr $options(address) $options(port)]
+ lappend listeners $srv
+ Log notice "XMPP s2s listening on $options(address):$options(port)"
+ return
+}
+
+# -------------------------------------------------------------------------
+
+proc ::xmppd::s2s::Log {level msg} {
+ variable log
+ ${log}::${level} $msg
+}
+
+proc ::xmppd::s2s::Queue {from to data} {
+ Log debug "Queue message -from $from -to $to"
+}
+
+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]
+}
+
+# -------------------------------------------------------------------------
+
+
+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 Read {chan parser} {
+ if {[eof $chan]} {
+ fileevent $chan readable {}
+ OnCloseStream $chan
+ }
+ set xml [read $chan]
+ puts stderr "< $chan $xml"
+ wrapper::parse $parser $xml
+}
+
+proc closestream {chan} {
+ writeto $chan "</stream:stream>"
+ close $chan
+ set ::forever 1
+}
+
+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 OnOpenStream {chan args} {
+ variable state
+
+ array set attr $args
+ puts stderr "OS [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'>"
+ }
+ 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 OnCloseStream {chan} {
+ close $chan
+ puts stderr "! $chan closed"
+ set ::forever 1
+}
+
+proc OnError {chan code args} {
+ puts stderr "error $code"
+ closestream $chan
+}
+
+proc OnInput {chan xmllist} {
+ variable state
+ foreach {cmd attr close value children} $xmllist break
+ array set a $attr
+ switch -exact -- $cmd {
+ features {
+ }
+ result {
+ 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
+ }
+ }
+ 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
+ } else {
+ puts stderr "IN $xmllist"
+ }
+ }
+ default {
+ puts stderr "IN $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
+}
projects / tclxmppd.git / commitdiff