Bridge read and delivery receipts as well, yay

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

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")))
+         (children (dom:child-nodes stanza))
-    (if body
+         (body (get-node-named children "body"))
-        (let* ((child-nodes (dom:child-nodes body))
+         (marker (get-node-with-xmlns children +chat-markers-ns+)))
-               (text (if (> (length child-nodes) 0)
+    (cond
-                         (dom:node-value (elt child-nodes 0))
+      (body
-                         "")))
+       (let* ((child-nodes (dom:child-nodes body))
-          (emit :text-message comp :from from :to to :body text :id id :stanza stanza))
+              (text (if (> (length child-nodes) 0)
-        (emit :message comp :from from :to to :id id :stanza stanza))))
+                        (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:text show)))
-      (cxml:with-element "status"
+    (cxml:with-element "status"
-        (cxml:text 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)~%"
+      (format *debug-io* "~&message ~A for ~A with key ~A (type ~A) - previous ID ~A~%"
-              wa-id jid key delivery-type)
+              wa-id jid key delivery-type previous-xmpp-id)
-      (when (eql delivery-type :relay) ; i.e. realtime
+      (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)