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!
This commit is contained in:
eta
parent
378bac1fe6
commit
e7c84623e8
8
db.lisp
8
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
|
||||
|
|
|
|||
|
|
@ -987,6 +987,7 @@ buildLisp.program {
|
|||
"sqlite.lisp"
|
||||
"db.lisp"
|
||||
"media.lisp"
|
||||
"message.lisp"
|
||||
"stuff.lisp"
|
||||
];
|
||||
main = "whatsxmpp::main";
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
146
stuff.lisp
146
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))
|
||||
(wa-id (whatscl::message-id msg))
|
||||
(contents (whatscl::message-contents 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
|
||||
(from recipients xmpp-id xmpp-type group-localpart)
|
||||
(wa-message-key-to-stanza-headers comp conn jid wa-id wa-ts key)
|
||||
(when from
|
||||
(macrolet
|
||||
((send-message ((&key suppress-insert) &body contents)
|
||||
(let ((to-sym (gensym)))
|
||||
`(progn
|
||||
;; Referencing lexical variables in a MACROLET! How hacky.
|
||||
(unless ,suppress-insert
|
||||
(insert-user-message uid xmpp-id wa-id))
|
||||
(loop
|
||||
for ,to-sym in recipients
|
||||
do (with-message (comp ,to-sym
|
||||
: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)))))))))))))))
|
||||
(let ((uid (get-user-id jid)))
|
||||
(when (lookup-wa-msgid uid (whatscl::message-id msg))
|
||||
;; Don't process the same WhatsApp message twice.
|
||||
(return-from wa-handle-message))
|
||||
(catcher
|
||||
(attach (make-xmpp-messages-for-wa-message comp conn jid msg)
|
||||
(lambda (messages)
|
||||
(with-component-data-lock (comp)
|
||||
(loop
|
||||
for x-msg in messages
|
||||
do (progn
|
||||
(deliver-xmpp-message comp x-msg)
|
||||
(when (orig-id x-msg)
|
||||
(insert-user-message uid (xmpp-id x-msg) (orig-id x-msg))))))))
|
||||
(error (e)
|
||||
(with-component-data-lock (comp)
|
||||
(format *error-output* "~&processing of message ~A for ~A failed! error: ~A~%" (whatscl::message-id msg) jid e)
|
||||
(insert-user-message uid (concatenate 'string "error-" (whatscl::message-id msg)) (whatscl::message-id msg))
|
||||
(admin-msg comp jid
|
||||
(format nil "Warning: The bridge missed a message (whatsapp id ~A). The error was:~%~A"
|
||||
(whatscl::message-id msg) 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."
|
||||
|
|
|
|||
|
|
@ -16,4 +16,5 @@
|
|||
(:file "sqlite")
|
||||
(:file "db")
|
||||
(:file "media")
|
||||
(:file "message")
|
||||
(:file "stuff")))
|
||||
|
|
|
|||
Loading…
Reference in New Issue