Refactor message processing to use an intermediate object

- Instead of taking a WhatsApp message and sending an XMPP one directly, we now
  generate an XMPP-MESSAGE object, and have functions to deliver said object
  and make said object from a WhatsApp message.
- This paves the way to storing said XMPP-MESSAGEs in a database, so we can
  actually do message history / MAM. Yay!

db.lisp

@@ -9,6 +9,14 @@
       (when (sqlite:step-statement get-user)
         (first (column-values get-user))))))
 
+(defun get-user-jid (id)
+  "Get the user JID for the ID, or NIL if none exists."
+  (with-prepared-statement
+      (get-user "SELECT jid FROM users WHERE id = ?")
+      (bind-parameters get-user id)
+    (when (sqlite:step-statement get-user)
+      (first (column-values get-user)))))
+
 (defun get-user-contact-localparts (uid)
   "Returns a list of all contact localparts for UID."
   (with-prepared-statements

default.nix

@@ -987,6 +987,7 @@ buildLisp.program {
     "sqlite.lisp"
     "db.lisp"
     "media.lisp"
+    "message.lisp"
     "stuff.lisp"
   ];
   main = "whatsxmpp::main";

message.lisp

@@ -0,0 +1,191 @@
+;; Message processing
+
+(in-package :whatsxmpp)
+
+(defclass xmpp-message ()
+  ((conversation
+    :initarg :conversation
+    :reader conversation
+    :documentation "The localpart of the conversation this message is in (either a user or a group)")
+   (uid
+    :initarg :uid
+    :reader uid
+    :documentation "The user ID this message is associated with.")
+   (from
+    :initarg :from
+    :reader from
+    :documentation "The sender of the message. In a 1-to-1, this is the same as CONVERSATION if the other party sent it (and not if not); in a group, this is the group nickname / resource of the sender.")
+   (timestamp
+    :initarg :timestamp
+    :reader timestamp
+    :documentation "A LOCAL-TIME timestamp of when the message was sent.")
+   (xmpp-id
+    :initarg :xmpp-id
+    :reader xmpp-id
+    :documentation "The XMPP-side ID of the message (given in the 'id' header, and as the MUC <stanza-id> element)")
+   (orig-id
+    :initarg :orig-id
+    :initform nil
+    :reader orig-id
+    :documentation "The WhatsApp-side ID of the message, if any.")
+   (body
+    :initarg :body
+    :reader body
+    :documentation "The message text.")
+   (oob-url
+    :initarg :oob-url
+    :initform nil
+    :reader oob-url
+    :documentation "The URL of uploaded media contained in this message, if any.")))
+
+(defun wa-message-key-to-conversation-and-from (comp jid key &optional conn)
+  "Takes KEY, a WHATSCL::MESSAGE-KEY for a message for bridge user JID, and returns (VALUES CONVERSATION FROM).
+If a CONN is provided, it's used to create a new chat if that's required; otherwise, an error is signaled.
+FIXME: the above behaviour is a bit meh."
+  (let* ((wx-localpart (wa-jid-to-whatsxmpp-localpart (whatscl::key-jid key)))
+         (uid (get-user-id jid)))
+    (typecase key
+      (whatscl::message-key-receiving
+       ;; Received in a 1-to-1: conversation same as from
+       (values wx-localpart wx-localpart))
+      (whatscl::message-key-sending
+       (if (uiop:string-prefix-p "g" wx-localpart)
+           (alexandria:if-let ((user-resource (get-user-chat-resource uid wx-localpart)))
+             (values wx-localpart user-resource)
+             ;; If we don't have a user chat resource, just use their localpart.
+             ;; This shouldn't really happen that frequently.
+             (progn
+               (values wx-localpart (first (split-sequence:split-sequence #\@ jid)))
+               (warn "Using fallback localpart for sent message in group ~A; that's rather interesting." wx-localpart)))
+           ;; Put the user's jid as "from". This is okay, since we pretty much only
+           ;; want to determine "was it us or them" in a 1-to-1 conversation, which
+           ;; is done by comparing from to conversation.
+           (values wx-localpart jid)))
+      (whatscl::message-key-group-receiving
+       (let* ((chat-id (or
+                        (get-user-chat-id uid wx-localpart)
+                        (when conn
+                          (add-wa-chat comp conn jid (whatscl::key-jid key))
+                          (get-user-chat-id uid wx-localpart))))
+              (participant-localpart (wa-jid-to-whatsxmpp-localpart (whatscl::key-participant key))))
+         (if chat-id
+             (let ((from-resource (or
+                                   (get-participant-resource chat-id participant-localpart)
+                                   ;; whee fallback go brrr
+                                   participant-localpart)))
+               (values wx-localpart from-resource))
+             (error "Couldn't find or create group chat for ~A" chat-id)))))))
+
+(defmacro with-new-xmpp-message-context ((comp jid msg &optional conn) &body body)
+  "Evaluate FORMS, binding NEW-XMPP-MESSAGE (lambda-list (BODY &KEY OOB-URL SYSTEM-GENERATED)) to a function that returns an instance of the XMPP-MESSAGE class, using information contained in the message MSG received for the bridge user JID."
+  (alexandria:with-gensyms (key wa-id wa-ts uid ts conversation from xmpp-id orig-id)
+    `(let* ((,key (whatscl::message-key ,msg))
+            (,wa-id (whatscl::message-id ,msg))
+            (,wa-ts (whatscl::message-ts ,msg))
+            (,uid (get-user-id ,jid))
+            (local-time:*default-timezone* local-time:+utc-zone+)
+            (,ts (local-time:unix-to-timestamp ,wa-ts)))
+       (multiple-value-bind (,conversation ,from)
+           (wa-message-key-to-conversation-and-from ,comp ,jid ,key ,conn)
+         (labels ((new-xmpp-message (body &key oob-url system-generated)
+                    (let ((,xmpp-id (if system-generated
+                                        (princ-to-string (uuid:make-v4-uuid))
+                                        (concatenate 'string "wa-" ,wa-id "-" (princ-to-string ,wa-ts))))
+                          (,orig-id (unless system-generated ,wa-id)))
+                      (make-instance 'xmpp-message
+                                     :conversation ,conversation
+                                     :from ,from
+                                     :uid ,uid
+                                     :timestamp ,ts
+                                     :oob-url oob-url
+                                     :xmpp-id ,xmpp-id
+                                     :orig-id ,orig-id
+                                     :body body
+                                     :oob-url oob-url))))
+           ,@body)))))
+
+(defun quote-content (content)
+  "Prepends '> ' to each line of CONTENT."
+  (let ((oss (make-string-output-stream)))
+    (loop
+      for item in (split-sequence:split-sequence #\Linefeed content)
+      do (format oss "> ~A~%" item))
+    (get-output-stream-string oss)))
+
+(defun deliver-xmpp-message (comp msg)
+  "Deliver MSG, an XMPP-MESSAGE, to the intended destinations on COMP."
+  (let* ((jid (get-user-jid (uid msg)))
+         (one-to-one-p (uiop:string-prefix-p "u" (conversation msg)))
+         (component-host (component-name comp))
+         (destinations (if one-to-one-p
+                           ;; We can't send a message the user sent in a 1:1.
+                           (when (string= (conversation msg) (from msg))
+                             (list jid))
+                           (get-user-chat-joined (uid msg) (conversation msg))))
+         (from (if one-to-one-p
+                   (concatenate 'string (from msg) "@" component-host "/whatsapp")
+                   (concatenate 'string (conversation msg) "@" component-host "/" (from msg)))))
+    (loop
+      for to in destinations
+      do (with-message (comp to
+                        :from from
+                        :id (xmpp-id msg)
+                        :type (if one-to-one-p "chat" "groupchat"))
+           (cxml:with-element "body"
+             (cxml:text (body msg)))
+           (when (oob-url msg)
+             (cxml:with-element "x"
+               (cxml:attribute "xmlns" +oob-ns+)
+               (cxml:with-element "url"
+                 (cxml:text (oob-url msg)))))
+           (cxml:with-element "delay"
+             (cxml:attribute "xmlns" +delivery-delay-ns+)
+             (cxml:attribute "stamp" (local-time:format-timestring nil (timestamp msg))))
+           (cxml:with-element "active"
+             (cxml:attribute "xmlns" +chat-states-ns+))
+           (unless one-to-one-p
+             (cxml:with-element "stanza-id"
+               (cxml:attribute "xmlns" +unique-stanzas-ns+)
+               (cxml:attribute "id" (xmpp-id msg)))
+             (when (orig-id msg)
+               (cxml:with-element "origin-id"
+                 (cxml:attribute "xmlns" +unique-stanzas-ns+)
+                 (cxml:attribute "id" (orig-id msg)))))
+           (when (orig-id msg)
+             ;; Messages without a WhatsApp ID aren't markable for hopefully
+             ;; obvious reasons.
+             (cxml:with-element "markable"
+               (cxml:attribute "xmlns" +chat-markers-ns+)))))))
+
+(defun make-xmpp-messages-for-wa-message (comp conn jid msg)
+  "Returns a promise that is resolved with a list of XMPP-MESSAGE objects generated from the WhatsApp message object MSG.
+If something like file uploading fails, the promise can also be rejected."
+  (promisify
+   (with-new-xmpp-message-context (comp jid msg conn)
+     (let ((contents (whatscl::message-contents msg))
+           (qc (alexandria:when-let
+                   ((summary (whatscl::message-quoted-contents-summary msg)))
+                 (quote-content summary))))
+       (typecase contents
+         (whatscl::message-contents-text
+          (let* ((contents-text (whatscl::contents-text contents))
+                 (text (format nil "~@[~A~]~A" qc contents-text)))
+            (list (new-xmpp-message text))))
+         (whatscl::message-contents-file
+          (let* ((file-info (whatscl::contents-file-info contents))
+                 (media-type (whatscl::get-contents-media-type contents))
+                 (filename (when (typep contents 'whatscl::message-contents-document)
+                             (whatscl::contents-filename contents)))
+                 (caption (whatscl::contents-caption contents))
+                 (upload-promise (upload-whatsapp-media-file comp file-info media-type filename)))
+            (attach upload-promise
+                    (lambda (get-url)
+                      (append
+                       (when (or caption qc)
+                         (let ((text (format nil "~@[~A~]~@[~A~]" qc caption)))
+                           (list (new-xmpp-message text
+                                                   :system-generated t))))
+                       (list (new-xmpp-message get-url
+                                               :oob-url get-url)))))))
+         ;; FIXME: handle location messages, stub messages, etc.
+         (t nil))))))

stuff.lisp

@@ -252,7 +252,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
                  (update-session-data jid "")))
               ((equal status-code 419)
                (progn
-                 (admin-msg comp jid "Error: WhatsApp Web have invalidated this connection for some reason. You'll need to scan the QR code again. (It's unclear why this happens.")
+                 (admin-msg comp jid "Error: WhatsApp Web have invalidated this connection for some reason. You'll need to scan the QR code again. (It's unclear why this happens.)")
                  (admin-presence comp jid "Connection invalidated" "xa")
                  (update-session-data jid "")))
               (t
@@ -272,132 +272,30 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
     (admin-presence comp jid "Programming error" "xa")
     (remhash jid (component-whatsapps comp))))
 
-(defun wa-message-key-to-stanza-headers (comp conn jid msg-id msg-ts key)
-  "Takes KEY, a WHATSCL::MESSAGE-KEY, and returns (VALUES FROM TOS ID TYPE GROUP-LOCALPART) [i.e. the values of the 'from', 'to', 'id' and 'type' stanza headers, where TOS is a list of recipients], or NIL if no action should be taken to deliver the message."
-  (let* ((xmpp-id (concatenate 'string
-                               "wa-" msg-id "-" (write-to-string msg-ts)))
-         (group-localpart (wa-jid-to-whatsxmpp-localpart (whatscl::key-jid key)))
-         (uid (get-user-id jid))
-         (previous-xmpp-id (lookup-wa-msgid uid msg-id)))
-    (unless previous-xmpp-id
-      (typecase key
-        (whatscl::message-key-receiving
-         (progn
-           (format *debug-io* "~&direct message ~A for ~A~%" msg-id jid)
-           (values (concatenate 'string
-                                group-localpart
-                                "@"
-                                (component-name comp)
-                                "/whatsapp")
-                   (list jid) xmpp-id "chat" nil)))
-        (whatscl::message-key-group-receiving
-         (let* ((chat-id (get-user-chat-id uid group-localpart))
-                (participant-localpart (wa-jid-to-whatsxmpp-localpart (whatscl::key-participant key))))
-           (format *debug-io* "~&group message ~A in ~A for ~A~%" msg-id group-localpart jid)
-           (if chat-id
-               (let ((from-resource (or (get-participant-resource chat-id participant-localpart)
-                                        participant-localpart))
-                     (recipients (get-user-chat-joined uid group-localpart)))
-                 (if recipients
-                     (values (concatenate 'string
-                                          group-localpart "@" (component-name comp)
-                                          "/" from-resource)
-                             recipients xmpp-id "groupchat" group-localpart)
-                     (warn "None of ~A's resources were joined to group ~A to receive message ~A!" jid group-localpart msg-id)))
-               (progn
-                 (warn "No chat in database for group ~A for ~A -- creating" group-localpart jid)
-                 (admin-msg comp jid (format nil "Received message in unknown new WhatsApp group chat ~A; you should receive an invitation soon..." (whatscl::key-jid key)))
-                 (add-wa-chat comp conn jid (whatscl::key-jid key))
-                 (return-from wa-message-key-to-stanza-headers)))))
-        (t nil)))))
-
 (defun wa-handle-message (comp conn jid msg delivery-type)
   (declare (ignore delivery-type))
   (with-wa-handler-context (comp conn jid)
-    (let* ((key (whatscl::message-key msg))
+    (let ((uid (get-user-id jid)))
-           (wa-id (whatscl::message-id msg))
+      (when (lookup-wa-msgid uid (whatscl::message-id msg))
-           (contents (whatscl::message-contents msg))
+        ;; Don't process the same WhatsApp message twice.
-           (wa-ts (whatscl::message-ts msg))
+        (return-from wa-handle-message))
-           (uid (get-user-id jid))
+      (catcher
-           (local-time:*default-timezone* local-time:+utc-zone+)
+       (attach (make-xmpp-messages-for-wa-message comp conn jid msg)
-           (ts (local-time:unix-to-timestamp wa-ts)))
+               (lambda (messages)
-      (multiple-value-bind
+                 (with-component-data-lock (comp)
-            (from recipients xmpp-id xmpp-type group-localpart)
+                   (loop
-          (wa-message-key-to-stanza-headers comp conn jid wa-id wa-ts key)
+                     for x-msg in messages
-        (when from
+                     do (progn
-          (macrolet
+                          (deliver-xmpp-message comp x-msg)
-              ((send-message ((&key suppress-insert) &body contents)
+                          (when (orig-id x-msg)
-                 (let ((to-sym (gensym)))
+                            (insert-user-message uid (xmpp-id x-msg) (orig-id x-msg))))))))
-                   `(progn
+       (error (e)
-                      ;; Referencing lexical variables in a MACROLET! How hacky.
+              (with-component-data-lock (comp)
-                      (unless ,suppress-insert
+                (format *error-output* "~&processing of message ~A for ~A failed! error: ~A~%" (whatscl::message-id msg) jid e)
-                        (insert-user-message uid xmpp-id wa-id))
+                (insert-user-message uid (concatenate 'string "error-" (whatscl::message-id msg)) (whatscl::message-id msg))
-                      (loop
+                (admin-msg comp jid
-                        for ,to-sym in recipients
+                           (format nil "Warning: The bridge missed a message (whatsapp id ~A). The error was:~%~A"
-                        do (with-message (comp ,to-sym
+                                   (whatscl::message-id msg) e))))))))
-                                               :from from
-                                               :id xmpp-id
-                                               :type xmpp-type)
-                             ,@contents
-                             (cxml:with-element "delay"
-                               (cxml:attribute "xmlns" +delivery-delay-ns+)
-                               (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))
-                               (cxml:with-element "stanza-id"
-                                 (cxml:attribute "xmlns" +unique-stanzas-ns+)
-                                 (cxml:attribute "id" xmpp-id)
-                                 (cxml:attribute "by" (concatenate 'string
-                                                                   group-localpart
-                                                                   "@"
-                                                                   (component-name comp))))
-                               (cxml:with-element "origin-id"
-                                 (cxml:attribute "xmlns" +unique-stanzas-ns+)
-                                 (cxml:attribute "id" wa-id)))
-                             (cxml:with-element "markable"
-                               (cxml:attribute "xmlns" +chat-markers-ns+))))))))
-            (let* ((qc (whatscl::message-quoted-contents-summary msg)))
-              (typecase contents
-                (whatscl::message-contents-text
-                 (let* ((contents-text (whatscl::contents-text contents))
-                        (text (format nil "~@[> ~A~%~]~A" qc contents-text)))
-                   (send-message ()
-                    (cxml:with-element "body"
-                      (cxml:text text)))))
-                (whatscl::message-contents-file
-                 (let* ((file-info (whatscl::contents-file-info contents))
-                        (media-type (whatscl::get-contents-media-type contents))
-                        (filename (when (typep contents 'whatscl::message-contents-document)
-                                    (whatscl::contents-filename contents)))
-                        (caption (whatscl::contents-caption contents))
-                        (upload-promise (upload-whatsapp-media-file comp file-info media-type filename)))
-                   (catcher
-                    (attach upload-promise
-                            (lambda (get-url)
-                              (with-component-data-lock (comp)
-                                (when (or caption qc)
-                                  (let ((text (format nil "~@[> ~A~%~]~@[~A~]" qc caption)))
-                                    (send-message (:suppress-insert t)
-                                     (cxml:with-element "body"
-                                       (cxml:text text)))))
-                                (send-message ()
-                                 (cxml:with-element "body"
-                                   (cxml:text get-url))
-                                 (cxml:with-element "x"
-                                   (cxml:attribute "xmlns" +oob-ns+)
-                                   (cxml:with-element "url"
-                                     (cxml:text get-url)))))))
-                    (error (e)
-                           (with-component-data-lock (comp)
-                             ;; Insert the thing into the database, so this message
-                             ;; doesn't repeat.
-                             (insert-user-message uid xmpp-id wa-id)
-                             (format *debug-io* "~&whatsapp media message ~A from ~A failed! error: ~A~%"
-                                     wa-id from e)
-                             (admin-msg comp jid
-                                        (format nil "Warning: Failed to process a media message sent to you by ~A:~%    ~A"
-                                                from e)))))))))))))))
 
 (defun get-avatar-data (avatar-url)
   "Fetches AVATAR-URL, using the database as a cache. Returns the SHA1 hash (lowercase) of the avatar data as first argument, and the actual octets as second."

whatsxmpp.asd

@@ -16,4 +16,5 @@
    (:file "sqlite")
    (:file "db")
    (:file "media")
+   (:file "message")
    (:file "stuff")))