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

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"))

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)))))

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" ];

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

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)))

xep-0030.lisp

@@ -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

xep-0363.lisp

@@ -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")))))))