Initial support for typing notifications / chat state (1-to-1 only)

This commit is contained in:
eta 2020-05-28 14:02:37 +01:00
parent f0612e6613
commit b8760ac948

View file

@ -19,6 +19,8 @@
(defparameter +muc-stable-id-ns+ "http://jabber.org/protocol/muc#stable_id") (defparameter +muc-stable-id-ns+ "http://jabber.org/protocol/muc#stable_id")
(defparameter +muc-user-ns+ "http://jabber.org/protocol/muc#user") (defparameter +muc-user-ns+ "http://jabber.org/protocol/muc#user")
(defparameter +unique-stanzas-ns+ "urn:xmpp:sid:0") (defparameter +unique-stanzas-ns+ "urn:xmpp:sid:0")
(defparameter +chat-states-ns+ "http://jabber.org/protocol/chatstates")
(defparameter +hints-ns+ "urn:xmpp:hints")
(defvar *xmpp-debug-io* (make-broadcast-stream)) (defvar *xmpp-debug-io* (make-broadcast-stream))
(defvar *xmpp-debug-out* (make-synonym-stream '*xmpp-debug-io*)) (defvar *xmpp-debug-out* (make-synonym-stream '*xmpp-debug-io*))
@ -559,7 +561,8 @@
(id (dom:get-attribute stanza "id")) (id (dom:get-attribute stanza "id"))
(children (dom:child-nodes stanza)) (children (dom:child-nodes stanza))
(body (get-node-named children "body")) (body (get-node-named children "body"))
(marker (get-node-with-xmlns children +chat-markers-ns+))) (marker (get-node-with-xmlns children +chat-markers-ns+))
(chat-state (get-node-with-xmlns children +chat-states-ns+)))
(cond (cond
(body (body
(let* ((child-nodes (dom:child-nodes body)) (let* ((child-nodes (dom:child-nodes body))
@ -571,6 +574,9 @@
(let ((marker-type (dom:tag-name marker)) (let ((marker-type (dom:tag-name marker))
(msgid (dom:get-attribute marker "id"))) (msgid (dom:get-attribute marker "id")))
(emit :message-marker comp :from from :to to :type marker-type :marker-id msgid :id id :stanza stanza))) (emit :message-marker comp :from from :to to :type marker-type :marker-id msgid :id id :stanza stanza)))
(chat-state
(let ((state-type (dom:tag-name chat-state)))
(emit :chat-state comp :from from :to to :type state-type :id id :stanza stanza)))
(t (t
(emit :message comp :from from :to to :id id :stanza stanza))))) (emit :message comp :from from :to to :id id :stanza stanza)))))
@ -707,7 +713,6 @@ Commands:
(cxml:with-element "status" (cxml:with-element "status"
(cxml:text status)))) (cxml:text status))))
(defun wa-resetup-users (comp) (defun wa-resetup-users (comp)
"Go through the list of WhatsApp users and reconnect those whose connections have dropped." "Go through the list of WhatsApp users and reconnect those whose connections have dropped."
(with-component-data-lock (comp) (with-component-data-lock (comp)
@ -900,6 +905,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
(update-session-data jid sessdata) (update-session-data jid sessdata)
(admin-msg comp jid status) (admin-msg comp jid status)
(admin-presence comp jid status) (admin-presence comp jid status)
(whatscl::send-presence conn :available)
(format *debug-io* "~&ws-connected: ~A (as ~A)~%" jid wa-jid)))) (format *debug-io* "~&ws-connected: ~A (as ~A)~%" jid wa-jid))))
(defun wa-handle-error-status-code (comp conn jid err) (defun wa-handle-error-status-code (comp conn jid err)
@ -1002,6 +1008,8 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
(cxml:with-element "delay" (cxml:with-element "delay"
(cxml:attribute "xmlns" +delivery-delay-ns+) (cxml:attribute "xmlns" +delivery-delay-ns+)
(cxml:attribute "stamp" (local-time:format-timestring nil ts))) (cxml:attribute "stamp" (local-time:format-timestring nil ts)))
(cxml:with-element "active"
(cxml:attribute "xmlns" +chat-states-ns+))
(when (and group-localpart (not ,suppress-insert)) (when (and group-localpart (not ,suppress-insert))
(cxml:with-element "stanza-id" (cxml:with-element "stanza-id"
(cxml:attribute "xmlns" +unique-stanzas-ns+) (cxml:attribute "xmlns" +unique-stanzas-ns+)
@ -1544,6 +1552,25 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
(sqlite:reset-statement insert-member-stmt))) (sqlite:reset-statement insert-member-stmt)))
(handle-wa-chat-invitation comp conn jid uid localpart :noretry t)))))) (handle-wa-chat-invitation comp conn jid uid localpart :noretry t))))))
(defun wa-handle-presence (comp conn jid &key for-jid type participant &allow-other-keys)
(with-wa-handler-context (comp conn jid)
(let* ((localpart (wa-jid-to-whatsxmpp-localpart for-jid))
(chat-state
(cond
((eql type :composing) "composing")
((eql type :paused) "paused")
((eql type :available) "active")
(t (return-from wa-handle-presence)))))
(unless participant ; Groups hard
(let ((from-jid (concatenate 'string
localpart
"@"
(component-name comp))))
(with-message (comp jid
:from from-jid)
(cxml:with-element chat-state
(cxml:attribute "xmlns" +chat-states-ns+))))))))
(defun bind-wa-handlers (comp conn jid) (defun bind-wa-handlers (comp conn jid)
(on :ws-open conn (lambda () (wa-handle-ws-open comp conn jid))) (on :ws-open conn (lambda () (wa-handle-ws-open comp conn jid)))
(on :ws-close conn (lambda (&rest args) (on :ws-close conn (lambda (&rest args)
@ -1566,6 +1593,10 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
(on :status-change conn (lambda (for-jid status) (on :status-change conn (lambda (for-jid status)
(wa-handle-status-change comp conn jid for-jid status))) (wa-handle-status-change comp conn jid for-jid status)))
(on :presence conn (lambda (&key of type participant &allow-other-keys)
(wa-handle-presence comp conn jid
:for-jid of :type type
:participant participant)))
(on :connected conn (lambda (waj) (wa-handle-ws-connected comp conn jid waj)))) (on :connected conn (lambda (waj) (wa-handle-ws-connected comp conn jid waj))))
(defun handle-setup-user (comp jid) (defun handle-setup-user (comp jid)
@ -1861,7 +1892,8 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
(when conn (when conn
(loop (loop
for localpart in (get-contact-localparts uid) for localpart in (get-contact-localparts uid)
do (handle-wa-contact-presence comp conn stripped localpart)))))) do (handle-wa-contact-presence comp conn stripped localpart))
(whatscl::send-presence conn :available)))))
(t nil)))))) (t nil))))))
(defun whatsxmpp-presence-probe-handler (comp &key from to id &allow-other-keys) (defun whatsxmpp-presence-probe-handler (comp &key from to id &allow-other-keys)
@ -1908,6 +1940,34 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
:text "That user's JID isn't in a recognizable format." :text "That user's JID isn't in a recognizable format."
:type "modify")))))) :type "modify"))))))
(defun whatsxmpp-chat-state-handler (comp &key from to type &allow-other-keys)
"Handles a chat state sent to the whatsxmpp bridge."
(with-component-data-lock (comp)
(multiple-value-bind (to-hostname to-localpart)
(parse-jid to)
(declare (ignore to-hostname))
(format *debug-io* "~&chat state: ~A is ~A to ~A~%" from type to)
(let* ((stripped (strip-resource from))
(uid (get-user-id stripped))
(conn (gethash stripped (component-whatsapps comp)))
(wa-jid (whatsxmpp-localpart-to-wa-jid to-localpart))
(presence-type
(cond
((string= type "composing") :composing)
((string= type "paused") :paused)
((string= type "active") :available)
(t (return-from whatsxmpp-chat-state-handler)))))
(unless uid
(warn "Got chat state for user that isn't registered")
(return-from whatsxmpp-chat-state-handler))
(unless wa-jid
(return-from whatsxmpp-chat-state-handler))
(unless conn
(warn "Can't send chat state, since user connection is offline"))
(whatscl::send-presence conn presence-type
(unless (eql presence-type :active)
wa-jid))))))
(defun whatsxmpp-marker-handler (comp &key from to type marker-id id &allow-other-keys) (defun whatsxmpp-marker-handler (comp &key from to type marker-id id &allow-other-keys)
"Handles a message marker sent to the whatsxmpp bridge." "Handles a message marker sent to the whatsxmpp bridge."
(with-component-data-lock (comp) (with-component-data-lock (comp)
@ -1994,6 +2054,7 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
:muc-resource user-resource :muc-resource user-resource
:result result))) :result result)))
(msgid (whatscl::send-simple-text-message conn wa-jid body callback))) (msgid (whatscl::send-simple-text-message conn wa-jid body callback)))
(whatscl::send-presence conn :available)
(insert-user-message uid id msgid))))))))) (insert-user-message uid id msgid)))))))))
(defun whatsxmpp-load-users (comp) (defun whatsxmpp-load-users (comp)
@ -2033,6 +2094,8 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
(apply #'whatsxmpp-presence-unavailable-handler ret args))) (apply #'whatsxmpp-presence-unavailable-handler ret args)))
(on :presence ret (lambda (&rest args) (on :presence ret (lambda (&rest args)
(apply #'whatsxmpp-presence-handler ret args))) (apply #'whatsxmpp-presence-handler ret args)))
(on :chat-state ret (lambda (&rest args)
(apply #'whatsxmpp-chat-state-handler ret args)))
(register-whatsxmpp-handlers ret) (register-whatsxmpp-handlers ret)
(whatsxmpp-load-users ret) (whatsxmpp-load-users ret)
(setf (component-reconnect-timer ret) (trivial-timers:make-timer (setf (component-reconnect-timer ret) (trivial-timers:make-timer