# A Tcl implementation of the Jabber server-to-server protocol.
# See http://www.jabber.org/
#
-# RFC 3920 [http://www.ietf.org/rfc3921.txt] -- CHECK
-# RFC 3921 [http://www.ietf.org/rfc3921.txt]
+# RFC 3920 [http://www.ietf.org/rfc/rfc3921.txt]
+# RFC 3921 [http://www.ietf.org/rfc/rfc3921.txt]
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
package require sha1; # tcllib
package require logger; # tcllib
package require dns 1.2.1; # tcllib 1.8
-#package require tls
namespace eval ::xmppd {}
namespace eval ::xmppd::s2s {
variable version 1.0.0
variable rcsid {$Id$}
- namespace export configure route
+ namespace export configure route start stop
variable options
if {![info exists options]} {
array set options {
- jid conference.patthoyts.tk
+ jid {}
secret secret
address 0.0.0.0
port 5269
loglevel debug
handler {}
}
- #set options(jid) [info hostname]
+ set options(jid) [info hostname]
}
variable log
if {![info exists uid]} {
set uid 0
}
+
+ # Select the first nameserver available (if any)
+ foreach ns [dns::nameservers] {
+ dns::configure -nameserver $ns -protocol tcp
+ break
+ }
}
proc ::xmppd::s2s::configure {args} {
if {[eof $channel(sock)]} {
fileevent $channel(sock) readable {}
Log warn "- EOF on $Channel ($channel(sock))"
- # delete parser
- # clean up session
- # remove route
+ OnCloseStream $Channel
}
set xml [read $channel(sock)]
Log debug "< $channel(sock) $xml"
# to the Receiving Server (them)
set key [sha1::sha1 $options(secret)]
set key [sha1::sha1 ${key}$session(from)]
- set session(key) OUT[sha1::sha1 ${key}$session(id)]
+ set session(key) [sha1::sha1 ${key}$session(id)]
set xml "<db:result xmlns:db='jabber:server:dialback'\
to='$session(to)' from='$session(from)'>$session(key)</db:result>"
set session(state) dialback
proc ::xmppd::s2s::OnCloseStream {Channel} {
upvar #0 $Channel channel
+
+ foreach Session [FindSession channel $Channel] {
+ Log debug "closed session $Session"
+ unset $Session
+ }
+
catch {close $channel(sock)}
- # FIX ME - how to close the parser?
+ wrapper::reset $channel(parser)
catch {unset channel} msg
Log notice "- $Channel closed: $msg"
}
}
# -------------------------------------------------------------------------
-# Application level:
-# The s2s server routes incoming messages to the -handler configuration proc.
-# This is a demo.
-#
-proc Handler {type attributes close value children} {
-
- switch -exact -- $type {
- message {
- array set attr $attributes
- set msg [lindex [wrapper::gettag $children] 3]
- puts "$attr(from) -> $attr(to) \[$attr(type)\]\n $msg"
- }
- presence {
- array set attr {type {}}
- array set attr $attributes
- switch -exact -- $type {
- subscribe {
- # NB: servers should not do this.
- xmppd::s2s::route \
- -from $attr(to) -to $attr(from) \
- "<presence xmlns='jabber:client'\
- from='$attr(to)' to='attr(from)'\
- type='subscribed' />"
- }
- default {
- puts "$attr(from) -> $attr(to) \[$attr(type)\]"
- }
- }
- }
- default {
- xmppd::s2s::Log debug "$type $attributes $close $value $children"
- }
- }
-}
-
-#{from patthoyts@bugzilla.renishaw.com/tkabber xml:lang en-GB type chat to patthoyts@uknml2375.renishaw.com/test xmlns jabber:client} 0 {} {{body {} 0 hehe {}} {x {xmlns jabber:x:event} 0 {} {{offline {} 1 {} {}} {delivered {} 1 {} {}} {displayed {} 1 {} {}} {composing {} 1 {} {}}}}}
-
-
-#{from patthoyts@bugzilla.renishaw.com/tkabber id 37 xml:lang en-GB type get to patthoyts@uknml2375.renishaw.com/test xmlns jabber:client} 0 {} {{query {xmlns jabber:iq:version} 1 {} {}}}
-
-# -------------------------------------------------------------------------
-
-if {!$tcl_interactive} {
-
-} else {
-
- catch {xmppd::s2s::start}
-
- namespace import -force xmppd::s2s::*
-
- if {0} {
- #set client conference.patthoyts.tk
- #set server tach.tclers.tk
- #set who test
-
- proc presence {type} {
- global client server
- xmppd::s2s::route -from $client -to $server \
- "<presence from='patthoyts@${client}/test'\
- to='${who}@${server}/s2s_test' type='$type'><x\
- xmlns='http://jabber.org/protocols/muc'/></presence>"
- }
- proc say {msg {type groupchat}} {
- global client server
- xmppd::s2s::route -from $client -to $server \
- "<message from='patthoyts@${client}/test'\
- to='${who}@${server}' type='$type'>\
- <body>[wrapper::xmlcrypt $msg]</body></message>"
- }
- }
-
- set client uknml2375.renishaw.com
- set server bugzilla.renishaw.com
- set who patthoyts
-
- proc presence {type} {
- global client server who
- xmppd::s2s::route -from $client -to $server \
- "<presence from='patthoyts@${client}/test'\
- to='${who}@${server}' type='$type'/>"
- }
- proc say {msg {type chat}} {
- global client server who
- xmppd::s2s::route -from $client -to $server \
- "<message from='patthoyts@${client}/test'\
- to='${who}@${server}' type='$type'>\
- <body>[wrapper::xmlcrypt $msg]</body></message>"
- }
-
- xmppd::s2s::configure -jid $client -handler ::Handler
-
- set ns [dns::nameservers]
- if {[llength $ns] > 0} {
- dns::configure -nameserver [lindex $ns 0] -protocol tcp
- }
-}
+package provide xmppd::s2s $::xmppd::s2s::version
# -------------------------------------------------------------------------
--- /dev/null
+#
+#
+#
+
+set root [file dirname [info script]]
+source [file join $root s2s.tcl]
+package require xmppd::s2s
+namespace import -force xmppd::s2s::*
+
+# -------------------------------------------------------------------------
+# Application level:
+# The s2s server routes incoming messages to the -handler configuration proc.
+# This is a demo.
+#
+proc Handler {type attributes close value children} {
+
+ switch -exact -- $type {
+ message {
+ array set attr $attributes
+ set msg [lindex [wrapper::gettag $children] 3]
+ puts "$attr(from) -> $attr(to) \[$attr(type)\]\n $msg"
+ }
+ presence {
+ array set attr {type {}}
+ array set attr $attributes
+ switch -exact -- $type {
+ subscribe {
+ # NB: servers should not do this.
+ xmppd::s2s::route \
+ -from $attr(to) -to $attr(from) \
+ "<presence xmlns='jabber:client'\
+ from='$attr(to)' to='attr(from)'\
+ type='subscribed' />"
+ }
+ default {
+ set show "online"
+ set status ""
+ foreach xml $children {
+ switch -exact -- [wrapper::gettag $xml] {
+ show { set show [wrapper::getcdata $xml] }
+ status { set status [wrapper::getcdata $xml] }
+ }
+ }
+ if {$status ne {}} {append show " ($status)"}
+ puts "$attr(from) -> $attr(to) \[$show\]"
+ }
+ }
+ }
+ default {
+ xmppd::s2s::Log debug "$type $attributes $close $value $children"
+ }
+ }
+}
+
+#{from patthoyts@bugzilla.renishaw.com/tkabber xml:lang en-GB type chat to patthoyts@uknml2375.renishaw.com/test xmlns jabber:client} 0 {} {{body {} 0 hehe {}} {x {xmlns jabber:x:event} 0 {} {{offline {} 1 {} {}} {delivered {} 1 {} {}} {displayed {} 1 {} {}} {composing {} 1 {} {}}}}}
+
+
+#{from patthoyts@bugzilla.renishaw.com/tkabber id 37 xml:lang en-GB type get to patthoyts@uknml2375.renishaw.com/test xmlns jabber:client} 0 {} {{query {xmlns jabber:iq:version} 1 {} {}}}
+
+
+# -------------------------------------------------------------------------
+
+set client conference.patthoyts.tk
+set server tach.tclers.tk
+set who test
+
+proc presence2 {type {show {}} {status {}} {user {patthoyts}} {nick {}}} {
+ global client server who
+
+ set kids {}
+ lappend kids [list x {xmlns http://jabber.org/protocols/muc} 1 "" {}]
+ if {$show ne {}} {
+ lappend kids [list show {} 0 $show {}]
+ }
+ if {$status ne {}} {
+ lappend kids [list status {
+ xmlns:xml http://www.w3.org/XML/1998/namespace
+ xml:lang en-GB
+ } 0 $status {}]
+ }
+ if {$nick eq {}} {set nick $user}
+ set attr [list from "${user}@${client}/test" \
+ to "${who}@${server}/${nick}" type "$type"]
+
+ set xml [wrapper::createxml [list presence $attr 0 "" $kids]]
+ puts [wrapper::createxml [list presence $attr 0 "" $kids]]
+ xmppd::s2s::route -from $client -to $server $xml
+ return
+}
+
+proc say2 {msg {type groupchat} {user patthoyts}} {
+ global client server who
+ xmppd::s2s::route -from $client -to $server \
+ "<message from='$user@${client}/test'\
+ to='${who}@${server}' type='$type'>\
+ <body>[wrapper::xmlcrypt $msg]</body></message>"
+}
+
+proc presence {type {show {}}} {
+ global client server who
+ xmppd::s2s::route -from $client -to $server \
+ "<presence from='patthoyts@${client}/test'\
+ to='${who}@${server}/s2s_test' type='$type'><x\
+ xmlns='http://jabber.org/protocols/muc'/></presence>"
+}
+
+proc say {msg {type groupchat}} {
+ global client server who
+ xmppd::s2s::route -from $client -to $server \
+ "<message from='patthoyts@${client}/test'\
+ to='${who}@${server}' type='$type'>\
+ <body>[wrapper::xmlcrypt $msg]</body></message>"
+}
+
+
+if {0} {
+ set client uknml2375.renishaw.com
+ set server bugzilla.renishaw.com
+ set who patthoyts
+
+ proc presence {type} {
+ global client server who
+ xmppd::s2s::route -from $client -to $server \
+ "<presence from='patthoyts@${client}/test'\
+ to='${who}@${server}' type='$type'/>"
+ }
+ proc say {msg {type chat}} {
+ global client server who
+ xmppd::s2s::route -from $client -to $server \
+ "<message from='patthoyts@${client}/test'\
+ to='${who}@${server}' type='$type'>\
+ <body>[wrapper::xmlcrypt $msg]</body></message>"
+ }
+
+}
+
+# -------------------------------------------------------------------------
+
+xmppd::s2s::configure -jid $client -handler ::Handler
+catch {xmppd::s2s::start}
+
projects / tclxmppd.git / commitdiff