More work -- now have separate sessions for in and out channels.

diff --git a/s2s.tcl b/s2s.tcl
index fffb7bc03ede033925a0c54658b3c9e803a14269..e9c4845d802eb736679cf39a2d1637b4213085a5 100644 (file)
--- a/s2s.tcl
+++ b/s2s.tcl
@@ -12,7 +12,7 @@ package require wrapper
 package require uuid
 package require sha1
 package require logger
-package require Tclresolver
+#package require Tclresolver
 
 namespace eval ::xmppd {}
 namespace eval ::xmppd::s2s {
@@ -156,20 +156,22 @@ 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)"
+    foreach addr $options(address) port $options(port) {
+        set srv [socket -server [namespace current]::Accept -myaddr $addr $port]
+        lappend listeners $srv
+        Log notice "XMPP s2s listening on $options(address):$options(port)"
+    }
     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]"
+    foreach src $listeners {
+        catch {
+            set info [fconfigure $srv -sockname]
+            close $srv
+            Log notice "XMPP s2s stopped listening on [lindex $info 0]:[lindex $info 2]"
+        }
     }
     return
 }
@@ -181,17 +183,28 @@ proc ::xmppd::s2s::Log {level msg} {
     ${log}::${level} $msg
 }
 
+# Find a session for a given route
+proc ::xmppd::s2s::FindConnection {from to} {
+    foreach connid [info vars sock*] {
+        upvar #0 [namespace current]::$connid conn
+        if {$conn(from) eq $from && $conn(to) eq $to} {
+            return $connid
+        }
+    }
+    return {}
+}
+
 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
+    set connid [FindConnection $from $to]
+    if {$connid eq {}} {
+        set connid [Open $from $to]
     }
     upvar #0 [namespace current]::$connid conn
     lappend conn(queue) $data
-    set conn(after) [after 10 [list [namespace current]::Flush $connid]]
+    if {[llength $conn(queue)] == 1} {
+        set conn(after) [after 10 [list [namespace current]::Flush $connid]]
+    }
     return
 }
 
@@ -200,44 +213,47 @@ proc ::xmppd::s2s::Queue {from to data} {
 #
 # 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
+proc ::xmppd::s2s::Open {from to} {
+    set chan [socket -async localhost 55269] ;# FIX ME
+    variable $chan
+    upvar #0 [namespace current]::$chan conn
+    set conn(from)  $from
+    set conn(to)    $to
+    set conn(id)    0
     set conn(state) init
+    set conn(queue) {}
+    set conn(after) {}
+    set conn(key)   {}
     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
+                          [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
 }
 
-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 ::xmppd::s2s::Write {chan} {
+    variable $chan
+    upvar #0 [namespace current]::$chan conn
+    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='$conn(to)' version='1.0'>"
+    WriteTo $chan $xml
 }
 
-proc ::xmppd::s2s::Read {chan connid} {
-    variable $connid
-    upvar #0 [namespace current]::$connid conn
 
+proc ::xmppd::s2s::Read {chan} {
+    variable $chan
+    upvar #0 [namespace current]::$chan conn
     if {[eof $chan]} {
         fileevent $chan readable {}
-        OnCloseStream $chanid
+        # delete parser
+        # clean up session
+        # remove route
     }
     set xml [read $chan]
     Log debug "< $chan $xml"
@@ -253,7 +269,8 @@ proc ::xmppd::s2s::Flush {connid} {
         if {![catch {WriteTo $conn(out) $data} err]} {
             Pop conn(queue)
         }
-    } else {
+    }
+    if {[llength $conn(queue)] != 0} {
         set conn(after) [after 1000 [list [namespace current]::Flush $connid]]
     }
     return
@@ -276,83 +293,89 @@ proc ::xmppd::s2s::Pop {varname {nth 0}} {
 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]]
-    }
+    # 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]::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
+    fileevent $chan readable [list [namespace current]::Read $chan]
 }
 
-
 # -------------------------------------------------------------------------
 
-proc ::xmppd::s2s::OnOpenOutStream {connid args} {
+proc ::xmppd::s2s::OnOpenStream {chan args} {
     variable options
-    variable $connid
-    upvar #0 [namespace current]::$connid conn
+    variable $chan
+    upvar #0 [namespace current]::$chan conn
 
     array set attr $args
-    Log debug "| OpenStream [array get attr]"
-
-    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"
-        }
+    Log debug "O $chan [array get attr]"
+    if {$conn(state) ne "init"} {
+        Log error "- unexpected state \"$conn(state)\" in openstream"
     }
-}
 
-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
+    if {$conn(id) eq {}} {
+
+        # Outgoing stream. They provide the session id and we provide the key.
+        #
+        set conn(id) $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
+
+    } else {
+
+        # Incoming stream - at this point we don't know who they are. But we manage the 
+        # session id. So send it now.
+        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 $conn $xml
+
+    }
 }
 
-proc ::xmppd::s2s::OnCloseStream {connid} {
-    variable $connid
-    upvar #0 [namespace current]::$connid conn
-    catch {close $conn(in)}
-    Log notice "- $conn(in) closed"
+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 {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 ::xmppd::s2s::OnError {chan code args} {
+    variable $chan
+    upvar #0 [namespace current]::$chan conn
+    puts stderr "- $chan error $code"
+    WriteTo $chan "</stream:stream>"
+    catch {close $chan}
+    catch {unset conn} msg
+    Log notice "- $chan closed: msg"
 }
 
-proc ::xmppd::s2s::OnInput {connid xmllist} {
-    variable $connid
-    upvar #0 [namespace current]::$connid conn
+proc ::xmppd::s2s::OnInput {chan xmllist} {
+    variable $chan
+    upvar #0 [namespace current]::$chan conn
 
     foreach {cmd attr close value children} $xmllist break
+    array set a {xmlns {}}
     array set a $attr
     switch -exact -- $cmd {
         features {
@@ -361,9 +384,22 @@ proc ::xmppd::s2s::OnInput {connid 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
+                # This should be from an incoming stream
+                # result has the key and from
+                if {$conn(key) ne ""} {error "I GOT IT WRONG"}
+                set conn(key) $value
+                set conn(id) $a(id)
+                set conn(from) $a(id)
+                # Find the corresponding outgoing stream (if it exists)
+                set outid [FindConnection $conn(to) $conn(from)]
+                if {$outid ne {}} {
+                    variable $outid
+                    upvar #0 $outid 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
+                }
             }
         }
         verify {
@@ -397,6 +433,8 @@ if {!$tcl_interactive} {
     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::*
 
+    xmppd::s2s::route -from uknml2375.renishaw.com -to bugzilla.renishaw.com \
+        {<presence from='patthoyts@uknml2375.renishaw.com' type='available'/>}
 }
 
 # -------------------------------------------------------------------------