From 6df2c90c0ccae30246218446671a6f0ad8b65457 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Sat, 17 Oct 2020 10:45:13 +0100 Subject: [PATCH] jcp: reimplemented using hooks. JID stringprep handling This especially helps doing handlers for iq stanzas. JID handling requires the use of some stringprep profiles so added a jid command for matching jids. --- jcp.tcl | 193 ++++++++++++++++++++++++++++++++++++++++++--------- pkgIndex.tcl | 3 +- 2 files changed, 163 insertions(+), 33 deletions(-) diff --git a/jcp.tcl b/jcp.tcl index 91fd005..6f333e4 100644 --- a/jcp.tcl +++ b/jcp.tcl @@ -6,11 +6,11 @@ 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]} { @@ -20,14 +20,9 @@ namespace eval ::xmppd::jcp { loglevel debug server xmppd.example.com port 5347 - handler {} - connectproc {} - disconnectproc {} - messageproc {} - presenceproc {} - iqproc {} } } + namespace export jid jidsplit } # Create a component. @@ -63,6 +58,26 @@ proc ::xmppd::jcp::connect {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 @@ -80,12 +95,7 @@ proc ::xmppd::jcp::configure {Component args} { -component - -secret - -server - - -port - - -connectproc - - -disconnectproc - - -messageproc - - -iqproc - - -presenceproc { + -port { set option [string trimleft $option -] if {$cget} { return $state($option) @@ -93,6 +103,34 @@ proc ::xmppd::jcp::configure {Component args} { 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) @@ -133,7 +171,7 @@ proc ::xmppd::jcp::route {Component msg} { 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 ,]" @@ -204,6 +242,15 @@ proc ::xmppd::jcp::Hook {Component do type args} { } 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) @@ -235,6 +282,74 @@ proc ::xmppd::jcp::Pop {varname {nth 0}} { 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 @@ -281,6 +396,9 @@ proc ::xmppd::jcp::OnOpenStream {Component args} { 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) @@ -301,27 +419,20 @@ proc ::xmppd::jcp::OnInput {Component xmllist} { 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 { @@ -331,6 +442,7 @@ proc ::xmppd::jcp::OnInput {Component xmllist} { # 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] @@ -340,11 +452,9 @@ proc ::xmppd::jcp::OnInput {Component xmllist} { } 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 { @@ -372,7 +482,6 @@ proc ::xmppd::jcp::OnIqDefault {Component xmllist} { # 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] @@ -391,6 +500,28 @@ proc ::xmppd::jcp::RaiseIQ {errortype xmllist text} { 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 diff --git a/pkgIndex.tcl b/pkgIndex.tcl index bdeec8a..bd2defd 100644 --- a/pkgIndex.tcl +++ b/pkgIndex.tcl @@ -2,11 +2,10 @@ # # Declare tclxmppd packages. # -# $Id: pkgIndex.tcl,v 1.1 2004/11/28 10:20:34 pat Exp $ package ifneeded xmppd::core 0.1.0 [list source [file join $dir core.tcl]] package ifneeded xmppd::s2s 1.0.0 [list source [file join $dir s2s.tcl]] package ifneeded xmppd::s2c 1.0.0 [list source [file join $dir s2c.tcl]] package ifneeded xmppd::sm 1.0.0 [list source [file join $dir sm.tcl]] -package ifneeded xmppd::jcp 1.1.0 [list source [file join $dir jcp.tcl]] +package ifneeded xmppd::jcp 1.2.0 [list source [file join $dir jcp.tcl]] package ifneeded xmppd::wrapper 1.2 [list source [file join $dir wrapper.tcl]] -- 2.23.0