diff --git a/db.lisp b/db.lisp index d8a9f1f..9920a39 100644 --- a/db.lisp +++ b/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 diff --git a/default.nix b/default.nix index 8845dfc..68ad67c 100644 --- a/default.nix +++ b/default.nix @@ -987,6 +987,7 @@ buildLisp.program { "sqlite.lisp" "db.lisp" "media.lisp" + "message.lisp" "stuff.lisp" ]; main = "whatsxmpp::main"; diff --git a/message.lisp b/message.lisp new file mode 100644 index 0000000..a9a6e26 --- /dev/null +++ b/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 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)))))) diff --git a/stuff.lisp b/stuff.lisp index 94e1e35..e1aed8e 100644 --- a/stuff.lisp +++ b/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." diff --git a/whatsxmpp.asd b/whatsxmpp.asd index 5d14756..38a7e8a 100644 --- a/whatsxmpp.asd +++ b/whatsxmpp.asd @@ -16,4 +16,5 @@ (:file "sqlite") (:file "db") (:file "media") + (:file "message") (:file "stuff")))