diff --git a/schema.sql b/schema.sql index d971ad2..737ae04 100644 --- a/schema.sql +++ b/schema.sql @@ -22,3 +22,11 @@ CREATE TABLE user_contacts ( name VARCHAR, notify VARCHAR ); + +CREATE TABLE user_messages ( + id INTEGER PRIMARY KEY, + user_id INT NOT NULL REFERENCES users, + xmpp_id VARCHAR NOT NULL, + wa_id VARCHAR NOT NULL, + UNIQUE(user_id, wa_id) +); diff --git a/stuff.lisp b/stuff.lisp index fe7b5bf..85eacaf 100644 --- a/stuff.lisp +++ b/stuff.lisp @@ -14,6 +14,7 @@ (defparameter +vcard-temp-ns+ "vcard-temp") (defparameter +nick-ns+ "http://jabber.org/protocol/nick") (defparameter +roster-exchange-ns+ "http://jabber.org/protocol/rosterx") +(defparameter +delivery-receipts-ns+ "urn:xmpp:receipts") (defclass xmpp-component (event-emitter) ((socket @@ -272,6 +273,11 @@ (flet ((is-the-node (node) (equal (dom:tag-name node) name))) (find-if #'is-the-node nodes))) +(defun get-node-with-xmlns (nodes xmlns) + "Finds the node with XML namespace XMLNS in NODES, returning NIL if none was found." + (flet ((is-the-node (node) (equal (dom:get-attribute node "xmlns") xmlns))) + (find-if #'is-the-node nodes))) + (defun get-disco-info (comp to &optional from) "Send an XEP-0030 disco#info request. Returns a promise that resolves with a list of supported features." (attach @@ -536,14 +542,22 @@ (let* ((from (dom:get-attribute stanza "from")) (to (dom:get-attribute stanza "to")) (id (dom:get-attribute stanza "id")) - (body (get-node-named (dom:child-nodes stanza) "body"))) - (if body - (let* ((child-nodes (dom:child-nodes body)) - (text (if (> (length child-nodes) 0) - (dom:node-value (elt child-nodes 0)) - ""))) - (emit :text-message comp :from from :to to :body text :id id :stanza stanza)) - (emit :message comp :from from :to to :id id :stanza stanza)))) + (children (dom:child-nodes stanza)) + (body (get-node-named children "body")) + (marker (get-node-with-xmlns children +chat-markers-ns+))) + (cond + (body + (let* ((child-nodes (dom:child-nodes body)) + (text (if (> (length child-nodes) 0) + (dom:node-value (elt child-nodes 0)) + ""))) + (emit :text-message comp :from from :to to :body text :id id :stanza stanza))) + (marker + (let ((marker-type (dom:tag-name marker)) + (msgid (dom:get-attribute marker "id"))) + (emit :message-marker comp :from from :to to :type marker-type :marker-id msgid :id id :stanza stanza))) + (t + (emit :message comp :from from :to to :id id :stanza stanza))))) (defun component-stanza (comp stanza) "Handles a STANZA received by component COMP." @@ -654,9 +668,9 @@ Commands: :from (admin-jid comp)) (when show (cxml:with-element "show" - (cxml:text show)) - (cxml:with-element "status" - (cxml:text status))))) + (cxml:text show))) + (cxml:with-element "status" + (cxml:text status)))) (defun wa-resetup-users (comp) @@ -841,11 +855,13 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (wa-ts (whatscl::message-ts msg)) (xmpp-id (concatenate 'string "wa-" wa-id "-" (write-to-string wa-ts))) + (uid (get-user-id jid)) + (previous-xmpp-id (lookup-wa-msgid uid wa-id)) (local-time:*default-timezone* local-time:+utc-zone+) (ts (local-time:unix-to-timestamp wa-ts))) - (format *debug-io* "~&message ~A for ~A with key ~A (type ~A)~%" - wa-id jid key delivery-type) - (when (eql delivery-type :relay) ; i.e. realtime + (format *debug-io* "~&message ~A for ~A with key ~A (type ~A) - previous ID ~A~%" + wa-id jid key delivery-type previous-xmpp-id) + (when (not previous-xmpp-id) ; don't process messages twice (when (typep key 'whatscl::message-key-receiving) ; ignore group and self messages (when (typep contents 'whatscl::message-contents-text) (let ((text (whatscl::contents-text contents)) @@ -854,6 +870,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." "@" (component-name comp) "/whatsapp"))) + (insert-user-message uid xmpp-id wa-id) (with-message (comp jid :from from :id xmpp-id) (cxml:with-element "body" (cxml:text text)) @@ -863,11 +880,6 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (cxml:with-element "markable" (cxml:attribute "xmlns" +chat-markers-ns+)))))))))) -(defun wa-handle-message-ack (comp conn jid &key id ack from to ts) - (with-wa-handler-context (comp conn jid) - - )) - (defun get-user-id (jid) "Get the user ID of JID, or NIL if none exists." (with-prepared-statement @@ -913,6 +925,31 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (bind-parameters update-stmt "asked" ctid) (sqlite:step-statement update-stmt))))))) +(defun insert-user-message (uid xmpp-id wa-id) + "Inserts a mapping between the message IDs XMPP-ID and WA-ID for the user UID." + (with-prepared-statements + ((insert-stmt "INSERT INTO user_messages (user_id, xmpp_id, wa_id) VALUES (?, ?, ?)")) + (bind-parameters insert-stmt uid xmpp-id wa-id) + (sqlite:step-statement insert-stmt))) + +(defun lookup-wa-msgid (uid wa-msgid) + "Look up the XMPP ID for the WhatsApp message ID WA-MSGID, when received for the user UID." + (with-prepared-statements + ((get-stmt "SELECT xmpp_id FROM user_messages WHERE user_id = ? AND wa_id = ?")) + (bind-parameters get-stmt uid wa-msgid) + (when (sqlite:step-statement get-stmt) + (with-bound-columns (xid) get-stmt + xid)))) + +(defun lookup-xmpp-msgid (uid xmpp-msgid) + "Look up the WhatsApp message ID for the XMPP message ID XMPP-MSGID, when received for the user UID." + (with-prepared-statements + ((get-stmt "SELECT wa_id FROM user_messages WHERE user_id = ? AND xmpp_id = ?")) + (bind-parameters get-stmt uid xmpp-msgid) + (when (sqlite:step-statement get-stmt) + (with-bound-columns (wid) get-stmt + wid)))) + (defun add-wa-contact (comp jid contact) "Adds the WHATSCL:CONTACT to the list of JID's contacts, or updates it if it already exists." (with-accessors ((ct-jid whatscl::contact-jid) @@ -945,6 +982,57 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." for contact in contacts do (add-wa-contact comp jid contact)))) +(defun wa-handle-contact (comp conn jid contact) + (with-wa-handler-context (comp conn jid) + (format *debug-io* "~&got contact ~A for ~A~%" contact jid) + (add-wa-contact comp jid contact))) + +(defun wa-handle-message-ack (comp conn jid &key id ack from to &allow-other-keys) + (with-wa-handler-context (comp conn jid) + (format *debug-io* "~&message ack: ~A is ~A (from ~A, to ~A)~%" id ack from to) + (when (equal (whatscl::jid-to-string from) (whatscl::wac-jid conn)) + ;; (someone else acked this message) + (let ((xmpp-id (lookup-wa-msgid (get-user-id jid) id))) + (if xmpp-id + (let ((marker-name + (cond + ((eql ack :received) "received") + ((eql ack :read) "displayed") + ((eql ack :played) "displayed") + (t (return-from wa-handle-message-ack)))) + (from-jid (concatenate 'string + (wa-jid-to-whatsxmpp-localpart to) + "@" + (component-name comp)))) + (with-message (comp jid + :from from-jid) + (cxml:with-element marker-name + (cxml:attribute "xmlns" +chat-markers-ns+) + (cxml:attribute "id" xmpp-id)))) + (warn "Got ack for unknown message id ~A" id)))))) + +(defun wa-handle-message-send-result (comp conn jid &key orig-from orig-to orig-id result) + (with-wa-handler-context (comp conn jid) + (format *debug-io* "~&message send result for ~A from ~A: ~A~%" orig-id orig-from result) + (handler-case + (let ((status (cdr (assoc :status result)))) + (unless status + (error "No status response provided by WhatsApp")) + (unless (eql status 200) + (error "Message sending failed with code ~A" status)) + (with-message (comp orig-from :from orig-to) + (cxml:with-element "received" + (cxml:attribute "xmlns" +delivery-receipts-ns+) + (cxml:attribute "id" orig-id)))) + (error (e) + (send-stanza-error comp + :id orig-id :to orig-from :from orig-to + :stanza-type "message" + :e (make-condition 'stanza-error + :defined-condition "recipient-unavailable" + :type "modify" + :text (write-to-string e))))))) + (defun bind-wa-handlers (comp conn jid) (on :ws-open conn (lambda () (wa-handle-ws-open comp conn jid))) (on :ws-close conn (lambda (&rest args) @@ -956,6 +1044,10 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (on :qrcode conn (lambda (text) (wa-handle-ws-qrcode comp conn jid text))) (on :message conn (lambda (msg dt) (wa-handle-message comp conn jid msg dt))) (on :contacts conn (lambda (contacts) (wa-handle-contacts comp conn jid contacts))) + (on :contact conn (lambda (contact) (wa-handle-contact comp conn jid contact))) + (on :message-ack conn (lambda (&key id ack from to &allow-other-keys) + (wa-handle-message-ack comp conn jid + :id id :ack ack :from from :to to))) (on :connected conn (lambda (waj) (wa-handle-ws-connected comp conn jid waj)))) (defun handle-setup-user (comp jid) @@ -973,6 +1065,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (whatscl::deserialize-persistent-session sessdata))) (conn (whatscl::make-connection sess))) (admin-msg comp jid "Connecting to WhatsApp...") + (admin-presence comp jid "Connection in progress..." "away") (symbol-macrolet ((stored-conn (gethash jid (component-whatsapps comp)))) (let ((old-conn)) @@ -1088,6 +1181,41 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." :text "That user's JID isn't in a recognizable format." :type "modify")))))) +(defun whatsxmpp-marker-handler (comp &key from to type marker-id id &allow-other-keys) + "Handles a message marker sent to the whatsxmpp bridge." + (with-component-data-lock (comp) + (multiple-value-bind (to-hostname to-localpart) + (parse-jid to) + (unless (equal to-hostname (component-name comp)) + (warn "Got message addressed to ~A!" to) + (return-from whatsxmpp-marker-handler)) + (format *debug-io* "~&marker: ~A on ~A from ~A~%" type marker-id from) + (unless (equal type "displayed") + (return-from whatsxmpp-marker-handler)) + (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))) + (unless uid + (warn "Got marker for user that isn't registered") + (return-from whatsxmpp-marker-handler)) + (unless conn + (warn "Can't send marker, since user connection is offline") + (send-stanza-error comp + :id id :from to :to from + :stanza-type "message" + :e (make-condition 'stanza-error + :defined-condition "recipient-unavailable" + :text "Can't process chat marker: you're currently not connected to WhatsApp." + :type "wait")) + (return-from whatsxmpp-marker-handler)) + (let ((wa-msgid (lookup-xmpp-msgid uid marker-id))) + (if wa-msgid + (progn + (format *debug-io* "~&marking read for ~A: ~A from ~A~%" stripped wa-msgid wa-jid) + (whatscl::send-message-read conn wa-jid wa-msgid)) + (warn "Got marker for unknown XMPP message ID ~A" marker-id))))))) + (defun whatsxmpp-message-handler (comp &key from to body id &allow-other-keys) "Handles a message sent to the whatsxmpp bridge." (with-component-data-lock (comp) @@ -1126,7 +1254,14 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." :text "You're currently not connected to WhatsApp." :type "wait"))) (t - (whatscl::send-simple-text-message conn wa-jid body)))))))) + (let* ((callback (lambda (conn result) + (wa-handle-message-send-result comp conn stripped + :orig-from from + :orig-to to + :orig-id id + :result result))) + (msgid (whatscl::send-simple-text-message conn wa-jid body callback))) + (insert-user-message uid id msgid))))))))) (defun whatsxmpp-load-users (comp) (with-component-data-lock (comp) @@ -1155,6 +1290,8 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." :upload-component-name upload-name))) (on :text-message ret (lambda (&rest args) (apply #'whatsxmpp-message-handler ret args))) + (on :message-marker ret (lambda (&rest args) + (apply #'whatsxmpp-marker-handler ret args))) (on :presence-subscribe ret (lambda (&rest args) (apply #'whatsxmpp-presence-subscribe-handler ret args))) (register-whatsxmpp-handlers ret)