diff --git a/component.lisp b/component.lisp
index ed506d4..2a9ac39 100644
--- a/component.lisp
+++ b/component.lisp
@@ -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"))
diff --git a/db.lisp b/db.lisp
index fc5ea27..c8615f7 100644
--- a/db.lisp
+++ b/db.lisp
@@ -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)))))
diff --git a/nix/docker.nix b/nix/docker.nix
index 2dfe146..51a9139 100644
--- a/nix/docker.nix
+++ b/nix/docker.nix
@@ -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" ];
diff --git a/stuff.lisp b/stuff.lisp
index d487956..451024f 100644
--- a/stuff.lisp
+++ b/stuff.lisp
@@ -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
diff --git a/utils.lisp b/utils.lisp
index ff37b7a..5c695a8 100644
--- a/utils.lisp
+++ b/utils.lisp
@@ -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)))
diff --git a/xep-0030.lisp b/xep-0030.lisp
index ea99a6f..7076f0d 100644
--- a/xep-0030.lisp
+++ b/xep-0030.lisp
@@ -13,7 +13,7 @@
(unless query-node
(error "Malformed disco#info response: no "))
(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 "))
(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
diff --git a/xep-0363.lisp b/xep-0363.lisp
index ff1004d..6fb2fad 100644
--- a/xep-0363.lisp
+++ b/xep-0363.lisp
@@ -14,18 +14,18 @@
(let ((slot-node (get-node-named results "slot")))
(unless slot-node
(error "Malformed XEP-0363 response: no "))
- (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")))))))