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