From 70becb27d5561fac8aa6e11429ba0952f4a7371e Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Thu, 18 Nov 2004 02:42:33 +0000 Subject: [PATCH 1/1] * s2s: New file - Jabber server to server (partial) --- ChangeLog | 3 + s2s.tcl | 280 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 283 insertions(+) create mode 100644 ChangeLog create mode 100644 s2s.tcl diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..729dc27 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,3 @@ +2004-11-18 Pat Thoyts + + * s2s.tcl: NEW file: Jabber server to server daemon. diff --git a/s2s.tcl b/s2s.tcl new file mode 100644 index 0000000..e319d5d --- /dev/null +++ b/s2s.tcl @@ -0,0 +1,280 @@ +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 "" + 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 "" + 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 "$state(localkey)" + } else { + set xml "" + } + writeto $chan $xml + + + #set xml "" + #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 "$state(key,$a(from))" + writeto $state(sout) $xml + } + } + verify { + if {![info exists a(-type)]} { + set 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 +} -- 2.23.0