package require xmppd::wrapper; # tclxmppd
package require sha1; # tcllib
package require logger; # tcllib
+package require stringprep; # tcllib 1.10
namespace eval ::xmppd {}
namespace eval ::xmppd::jcp {
- variable version 1.1.0
- variable rcsid {$Id: jcp.tcl,v 1.2 2004/12/08 15:22:11 pat Exp $}
+ variable version 1.2.0
variable uid; if {![info exists uid]} { set uid 0 }
variable options
if {![info exists options]} {
loglevel debug
server xmppd.example.com
port 5347
- handler {}
- connectproc {}
- disconnectproc {}
- messageproc {}
- presenceproc {}
- iqproc {}
}
}
+ namespace export jid jidsplit
}
# Create a component.
fileevent $state(sock) readable [list [namespace current]::Read $Component]
}
+
+proc ::xmppd::jcp::GetSet {Component type {cmd {}} {priority 900}} {
+ if {$cmd eq {}} {
+ return [lindex [lindex [Hook $Component list $type] 0] 0]
+ } else {
+ set old [lindex [lindex [Hook $Component list $type] 0] 0]
+ Hook $Component remove $type $old
+ Hook $Component add $type $cmd $priority
+ }
+}
+
+proc ::xmppd::jcp::put {Component name value} {
+ upvar #0 $Component state
+ set state(v,$name) $value
+}
+proc ::xmppd::jcp::get {Component name} {
+ upvar #0 $Component state
+ set state(v,$name)
+}
+
proc ::xmppd::jcp::configure {Component args} {
upvar #0 $Component state
variable log
-component -
-secret -
-server -
- -port -
- -connectproc -
- -disconnectproc -
- -messageproc -
- -iqproc -
- -presenceproc {
+ -port {
set option [string trimleft $option -]
if {$cget} {
return $state($option)
set state($option) [Pop args 1]
}
}
+ -connectproc {
+ if {$cget} {
+ return [GetSet $Component connect]
+ } else {
+ return [GetSet $Component connect [Pop args 1]]
+ }
+ }
+ -disconnectproc {
+ if {$cget} {
+ return [GetSet $Component disconnect]
+ } else {
+ return [GetSet $Component disconnect [Pop args 1]]
+ }
+ }
+ -messageproc {
+ if {$cget} {
+ return [GetSet $Component message]
+ } else {
+ return [GetSet $Component message [Pop args 1]]
+ }
+ }
+ -presenceproc {
+ if {$cget} {
+ return [GetSet $Component presence]
+ } else {
+ return [GetSet $Component presence [Pop args 1]]
+ }
+ }
-loglevel {
if {$cget} {
return $state(loglevel)
proc ::xmppd::jcp::Hook {Component do type args} {
upvar #0 $Component state
- set valid {message presence iq}
+ set valid {connect disconnect message presence iq}
if {[lsearch -exact $valid $type] == -1} {
return -code error "unknown hook type \"$type\":\
must be one of [join $valid ,]"
}
proc ::xmppd::jcp::Log {level msg} { puts stderr $msg }
+proc ::xmppd::jcp::LogX {level msg} {
+ variable Options
+ set levels {debug info notice warn error critical}
+ set n [lsearch -exact $levels $level]
+ set lvl [lsearch -exact $levels $level]
+ if {$n >= $lvl} {
+ puts stderr "$level $text"
+ }
+}
proc ::xmppd::jcp::SetLogLevel {Component} {
upvar #0 $Component state
set log $state(log)
return $r
}
+# JID: node uses nodeprep, resource uses Resourceprep, domain
+# must conform to the IDN Nameprep
+
+# IDN Nameprep: http://www.ietf.org/rfc/rfc3491.txt + IDN restrictions
+# but not dealing with punycode (which we should deal with really).
+::stringprep::register nameprep \
+ -mapping {B.1 B.2} \
+ -normalization KC \
+ -prohibited {A.1 C.1.2 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \
+ -prohibitedList {0x20 0x21 0x22 0x23 0x24 0x25 0x26 0x27 0x28 0x29 0x2a 0x2b
+ 0x2c 0x2f 0x3a 0x3b 0x3c 0x3d 0x3e 0x3f 0x40 0x5b 0x5c 0x5d 0x5e
+ 0x5f 0x60 0x7b 0x7c 0x7d 0x7e } \
+ -prohibitedBidi 1
+
+# XMPP Nodeprep: http://www.ietf.org/rfc/rfc3920.txt
+::stringprep::register nodeprep \
+ -mapping {B.1 B.2} \
+ -normalization KC \
+ -prohibited {A.1 C.1.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \
+ -prohibitedList {0x22 0x26 0x27 0x2f 0x3a 0x3c 0x3e 0x40} \
+ -prohibitedBidi 1
+
+# XMPP Resourceprep: http://www.ietf.org/rfc3920.txt
+::stringprep::register resourceprep \
+ -mapping {B.1} \
+ -normalization KC \
+ -prohibited {A.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \
+ -prohibitedBidi 1
+
+proc ::xmppd::jcp::jidsplit {jid} {
+ set node {} ; set domain {} ; set resource {}
+ regexp {^(?:([^@]*)@)?([^/]+)(?:/(.+))?} $jid -> node domain resource
+ return [list $node $domain $resource]
+}
+proc ::xmppd::jcp::jid {what args} {
+ switch -exact -- $what {
+ equal {
+ set lhs [jid normalize [lindex $args 0]]
+ set rhs [jid normalize [lindex $args 1]]
+ return [string equal $lhs $rhs]
+ }
+ validate {
+ set code [catch {jid normalize [index $args 0]}]
+ return [expr {$code == 0}]
+ }
+ }
+ foreach {node domain resource} [jidsplit [lindex $args 0]] break
+ switch -exact -- $what {
+ node { return $node }
+ domain { return $domain }
+ resource { return $resource }
+ !resource { return ${node}@${domain} }
+ jid { return ${node}@${domain}/${resource} }
+ normalize {
+ set node [stringprep::stringprep nodeprep $node]
+ set domain [stringprep::stringprep nameprep $domain]
+ set resource [stringprep::stringprep resourceprep $resource]
+ set r {}
+ if {$node ne ""} { append r $node @ }
+ if {$domain ne ""} { append r $domain }
+ if {$resource ne ""} { append r / $resource }
+ return $r
+ }
+ }
+ return -code error "invalid option \"$what\": \
+ must be one of node, domain, resource, !resource, normalize or equal."
+}
+
proc ::xmppd::jcp::WriteTo {chan data} {
Log debug "> $chan $data"
puts -nonewline $chan $data
proc ::xmppd::jcp::OnCloseStream {Component} {
upvar #0 $Component state
+ if {[catch {Hook $Component run disconnect} err] == 1} {
+ Log error "! error handling disconnect: $err"
+ }
Log debug "CLOSE $Component"
catch {close $state(sock)}
wrapper::reset $state(parser)
array set a {xmlns {} from {} to {} id {}}
array set a [wrapper::getattrlist $xmllist]
- set handled 0
switch -exact -- [set tag [wrapper::gettag $xmllist]] {
features {
Log notice "? features $xmllist"
- set handled 1
}
result {
Log notice "? result $xmllist"
- set handled 1
}
verify {
Log notice "? verify $xmllist"
- set handled 1
}
handshake {
- if {[info exists state(connectproc)]
- && $state(connectproc) ne {}
- } then {
- if {[catch {$state(connectproc) $xmllist} err]} {
- Log error "! error handling connectproc: $err"
- }
+ set r [catch {Hook $Component run connect $xmllist} err]
+ if {$r == 1} {
+ Log error "! error handing \"$tag\" stanza: $err"
}
}
iq {
# error no reply, include get/set child + error child.
set child [lindex [wrapper::getchildren $xmllist] 0]
set ns [wrapper::getattr [wrapper::getattrlist $child] xmlns]
+ Log debug "JCP IQ $a(type) $ns $xmllist"
set r [catch {Hook $Component run iq $a(type) $ns $xmllist} err]
if {$r == 1} {
set tag [wrapper::gettag $child]
}
message -
presence {
- set cmd ${tag}proc
- if {[info exists state($cmd)] && $state($cmd) ne {}} {
- if {[catch {$state($cmd) $xmllist} err]} {
- Log error "! error handing \"$tag\" stanza: $err"
- }
+ set r [catch {Hook $Component run $tag $xmllist} err]
+ if {$r == 1} {
+ Log error "! error handing \"$tag\" stanza: $err"
}
}
default {
# not intend to handle.
# Returns an xmllist containing an iq error.
#
-#proc ::xmppd::jcp::RaiseIQ {query type id self requester {text {}}} {
proc ::xmppd::jcp::RaiseIQ {errortype xmllist text} {
array set a [linsert [wrapper::getattrlist $xmllist] 0 id {}]
set firstchild [lindex [wrapper::getchildren $xmllist] 0]
set rsp [list iq $ra 0 {} $qr]
}
+# ::xmppd::jcp::send_presence --
+#
+# Send a jabber presence message
+#
+proc ::xmppd::jcp::send_presence {Component from {to {}} {type {}} {show {}} {status {}}} {
+ set kids {}
+ if {$show ne {}} {
+ lappend kids [wrapper::createtag show -chdata $show]
+ }
+ if {$status ne {}} {
+ lappend kids [wrapper::createtag status -chdata $status -attrlist {xml:lang en}]
+ }
+ set attr [list xmlns jabber:client from [jid normalize $from]]
+ if {$to ne {}} { lappend attr to [jid normalize $to] }
+ if {$type ne {}} { lappend attr type $type }
+
+ set xml [wrapper::createxml \
+ [wrapper::createtag presence -subtags $kids -attrlist $attr]]
+ $Component route $xml
+ return
+}
+
# -------------------------------------------------------------------------
package provide xmppd::jcp $::xmppd::jcp::version
projects / tclxmppd.git / commitdiff