From: Pat Thoyts <patthoyts@users.sourceforge.net>
Date: Sat, 17 Oct 2020 10:04:18 +0000 (+0100)
Subject: jabberd: handle ping and update the tls support
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Fmaster;p=tclxmppd.git

jabberd: handle ping and update the tls support
---

diff --git a/tests/jabberd.tcl b/tests/jabberd.tcl
index b38ccfb..059d626 100644
--- a/tests/jabberd.tcl
+++ b/tests/jabberd.tcl
@@ -16,13 +16,17 @@ package require xmppd::s2s
 package require xmppd::s2c
 package require xmppd::sm
 
-# handler gets called with the xmllist from wrapper.
+# Handle stanzas addressed to this server.
+# input is xmllist from wrapper for the stanza to process.
 proc Handler {xmllist} {
     array set a [list to [xmppd::cget -domain] from {} id {}]
     array set a [wrapper::getattrlist $xmllist]
 
     switch -exact -- [set type [wrapper::gettag $xmllist]] {
         iq {
+            set query [lindex [wrapper::getchildren $xmllist] 0]
+            Log info "JABBERD: iq: $query"
+
             # RFC3921 3: Session Establishment
             set sx [wrapper::getchildswithtagandxmlns $xmllist \
                         session [xmppd::xmlns session]]
@@ -40,7 +44,29 @@ proc Handler {xmllist} {
                                     [list [list internal-server-error [list xmlns [xmppd::xmlns stanzas]] 1 {} {}]]]
                     set r [list iq [list type error to $a(from) from $a(to) id $a(id)] 1 {} $rc]
                 }
-                    xmppd::route $a(to) $a(from) [wrapper::createxml $r]
+                xmppd::route $a(to) $a(from) [wrapper::createxml $r]
+                return
+            }
+            # XEP-0199: XMPP Ping
+            if {$a(to) eq [xmppd::cget -domain]} {
+                set ping [wrapper::getchildswithtagandxmlns $xmllist \
+                            ping [xmppd::xmlns ping]]
+                if {[llength $ping] > 0} {
+                    Log debug "PING [array get a]"
+                    set xml "<iq id='$a(id)' to='$a(from)' from='$a(to)' type='result'/>"
+                    xmppd::route $a(to) $a(from) $xml
+                    return
+                }
+            }
+
+            set priv [wrapper::getchildswithtagandxmlns $xmllist query [xmppd::xmlns privacy]]
+            if {[llength $priv] > 0} {
+                set rc {}
+                lappend rc [list error {type cancel code 404} 0 {} \
+                                [list [list item-not-found [list xmlns [xmppd::xmlns stanzas]] 1 {} {}]]]
+                lappend rc [lindex $priv 0]
+                set r [list iq [list type error to $a(from) from $a(to) id $a(id)] 0 {} $rc]
+                xmppd::route $a(to) $a(from) [wrapper::createxml $r]
                 return
             }
 
@@ -90,19 +116,23 @@ proc Log {level msg} { puts stderr "$level: $msg" }
 
 proc LoadConfig {} {
     # FIX ME: should load from a .conf file
-    set cert [file join [file dirname [info script]] jabberd.pem]
+    set key [file normalize [file join [file dirname [info script]] jabberd.key]]
+    set cert [file normalize [file join [file dirname [info script]] jabberd.crt]]
     set db [file join [file dirname [info script]] jabberd.db]
     xmppd::configure  \
         -domain patthoyts.tk   \
         -loglevel debug    \
         -logfile xmppd.log   \
         -certfile $cert \
-        -keyfile $cert  \
+        -keyfile $key  \
+        -cadir /etc/ssl/certs \
+        -cafile /etc/ssl/certs/ca-certificates.crt \
         -s2c:handler ::Handler \
         -s2c:authenticate ::xmppd::sm::authuser \
         -sm:db:type Sqlite \
         -sm:database $db
-    
+
+    # register stream features
     xmppd::register feature session [xmppd::xmlns session]
 }