From 1b40b5848f62fbf48260a8be36bd08f20cda1277 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Fri, 19 Nov 2004 02:17:26 +0000 Subject: [PATCH] More work. Incomplete. --- ChangeLog | 4 + s2s.tcl | 302 ++++++++++++++++++++++++++++++++++++++---------------- 2 files changed, 216 insertions(+), 90 deletions(-) diff --git a/ChangeLog b/ChangeLog index 729dc27..d74e1b2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2004-11-19 Pat Thoyts + + * s2s.tcl: Still not complete. Reconfigured big time. + 2004-11-18 Pat Thoyts * s2s.tcl: NEW file: Jabber server to server daemon. diff --git a/s2s.tcl b/s2s.tcl index e319d5d..fffb7bc 100644 --- a/s2s.tcl +++ b/s2s.tcl @@ -1,8 +1,18 @@ +# s2s.tcl - Copyright (C) 2004 Pat Thoyts +# +# +# +# ------------------------------------------------------------------------- +# 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 { @@ -15,14 +25,25 @@ 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 @@ -33,6 +54,7 @@ namespace eval ::xmppd::s2s { proc ::xmppd::s2s::configure {args} { variable options + variable log if {[llength $args] < 1} { set r {} foreach opt [lsort [array names options]] { @@ -51,6 +73,13 @@ proc ::xmppd::s2s::configure {args} { 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) @@ -85,7 +114,7 @@ proc ::xmppd::s2s::configure {args} { 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 { @@ -134,6 +163,17 @@ proc ::xmppd::s2s::start {} { 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} { @@ -143,138 +183,220 @@ 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 "" - writeto $chan $xml +proc ::xmppd::s2s::OutHeader {connid} { + variable $connid + upvar #0 [namespace current]::$connid conn + fileevent $conn(out) writable {} + set xml "" + 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 "" - 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 "$state(localkey)" - } else { - set xml "" + 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 "$conn(key)" + set conn(state) dialback + WriteTo $conn(out) $xml + } + default { + Log error "- unexpected state" + } } - writeto $chan $xml - +} - #set xml "" - #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 "" + 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) "" + 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 "$state(key,$a(from))" - writeto $state(sout) $xml + #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 + #set 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 {} + set unpresence {} + namespace import -force xmppd::s2s::* + } + +# ------------------------------------------------------------------------- -- 2.23.0