Browse Source

add MUC disco#items handler, fix children including text DOM nodes

master
η (eta) 6 months ago
parent
commit
5ce6d47266
7 changed files with 38 additions and 11 deletions
  1. +4
    -1
      component.lisp
  2. +9
    -0
      db.lisp
  3. +1
    -1
      nix/docker.nix
  4. +15
    -4
      stuff.lisp
  5. +4
    -0
      utils.lisp
  6. +2
    -2
      xep-0030.lisp
  7. +3
    -3
      xep-0363.lisp

+ 4
- 1
component.lisp View File

@@ -232,7 +232,10 @@

(defun handle-iq-get (comp id from stanza)
"Handles an IQ-get STANZA for component COMP."
(let* ((first-child (elt (dom:child-nodes stanza) 0))
(let* ((children (child-elements stanza))
(first-child (if (> (length children) 0)
(elt children 0)
(return-from handle-iq-get)))
(tag-name (dom:tag-name first-child))
(to (dom:get-attribute stanza "to"))
(xmlns (dom:get-attribute first-child "xmlns"))


+ 9
- 0
db.lisp View File

@@ -124,3 +124,12 @@
(loop
while (sqlite:step-statement get-stmt)
collect (with-bound-columns (localpart) get-stmt localpart))))

(defun get-user-groupchats (uid)
"Get a list of groupchat info (cons pairs of LOCALPART . SUBJECT) for the user with ID UID."
(with-prepared-statements
((get-stmt "SELECT wa_jid, subject FROM user_chats WHERE user_id = ?"))
(bind-parameters get-stmt uid)
(loop
while (sqlite:step-statement get-stmt)
collect (with-bound-columns (localpart subject) get-stmt (cons localpart subject)))))

+ 1
- 1
nix/docker.nix View File

@@ -4,7 +4,7 @@ let
in
pkgs.dockerTools.buildLayeredImage {
name = "eu.gcr.io/etainfra/whatsxmpp";
tag = "nix";
tag = "latest";
contents = [ whatsxmpp ];
config.Entrypoint = [ "${whatsxmpp}/bin/whatsxmpp" ];
config.Env = [ "SSL_CERT_FILE=${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt" ];


+ 15
- 4
stuff.lisp View File

@@ -40,6 +40,7 @@
(cond
((equal to (component-name comp))
`((disco-identity "whatsxmpp bridge" "xmpp" "gateway")
(disco-feature ,+disco-items-ns+)
(disco-feature ,+muc-ns+)))
((and user-name (not to-resource))
`((disco-identity ,user-name "registered" "account")))
@@ -56,12 +57,22 @@
(disco-feature "muc_nonanonymous")))
(t nil))))))))

(defun disco-items-handler (comp &key to &allow-other-keys)
(defun disco-items-handler (comp &key to from &allow-other-keys)
"Handles XEP-0030 disco#items requests."
(format *debug-io* "~&disco#items: ~A~%" to)
(format *debug-io* "~&disco#items: ~A from ~A~%" to from)
(with-component-data-lock (comp)
`((cxml:with-element "query"
(cxml:attribute "xmlns" ,+disco-info-ns+)))))
(cxml:attribute "xmlns" ,+disco-items-ns+)
,@(when (equal to (component-name comp))
(let ((uid (get-user-id (strip-resource from))))
(format *debug-io* "~&muc list disco#items for ~A~%" (strip-resource from))
(loop
for (localpart . subject) in (get-user-groupchats uid)
collect `(cxml:with-element "item"
(cxml:attribute "jid" ,(concatenate 'string
localpart "@"
(component-name comp)))
(cxml:attribute "name" ,subject)))))))))

(defun admin-jid (comp)
"Get the admin JID for COMP. You need the lock to be taken out for this one."
@@ -1115,7 +1126,7 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
(let* ((stripped (strip-resource from))
(conn (gethash stripped (component-whatsapps comp)))
(uid (get-user-id stripped))
(x-element (get-node-with-xmlns (dom:child-nodes stanza) +muc-ns+)))
(x-element (get-node-with-xmlns (child-elements stanza) +muc-ns+)))
(cond
(x-element
(handler-case


+ 4
- 0
utils.lisp View File

@@ -12,3 +12,7 @@
(defun sha1-hex (str)
"Returns the SHA1 of STR, a string, in lowercase hex."
(sha1-octets (babel:string-to-octets str)))

(defun child-elements (node)
"Returns the child elements (excluding text nodes) of the CXML DOM node NODE."
(remove-if-not #'dom:element-p (dom:child-nodes node)))

+ 2
- 2
xep-0030.lisp View File

@@ -13,7 +13,7 @@
(unless query-node
(error "Malformed disco#info response: no <query/>"))
(loop
for node across (dom:child-nodes query-node)
for node across (child-elements query-node)
do (let ((name (dom:tag-name node)))
(when (equal name "feature")
(setf features (cons (dom:get-attribute node "var") features)))))
@@ -31,7 +31,7 @@
(unless query-node
(error "Malformed disco#items response: no <query/>"))
(loop
for node across (dom:child-nodes query-node)
for node across (child-elements query-node)
do (let ((name (dom:tag-name node)))
(when (equal name "item")
(setf items (cons


+ 3
- 3
xep-0363.lisp View File

@@ -14,18 +14,18 @@
(let ((slot-node (get-node-named results "slot")))
(unless slot-node
(error "Malformed XEP-0363 response: no <slot/>"))
(let* ((children (dom:child-nodes slot-node))
(let* ((children (child-elements slot-node))
(put-node (get-node-named children "put"))
(get-node (get-node-named children "get"))
(headers '()))
(unless (and put-node get-node)
(error "Malformed XEP-0363 response: PUT or GET nodes missing"))
(loop
for node across (dom:child-nodes put-node)
for node across (child-elements put-node)
do (let ((name (dom:tag-name node)))
(when (equal name "header")
(setf headers (cons
(cons (dom:get-attribute node "name")
(dom:node-value (elt (dom:child-nodes node) 0)))
(dom:node-value (elt (child-elements node) 0)))
headers)))))
`((,(dom:get-attribute put-node "url") . ,headers) ,(dom:get-attribute get-node "url")))))))

Loading…
Cancel
Save