A WhatsApp (Web) transport for XMPP.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

227 lines
11KB

  1. ;; Message processing
  2. (in-package :whatsxmpp)
  3. (defclass xmpp-message ()
  4. ((conversation
  5. :initarg :conversation
  6. :reader conversation
  7. :documentation "The localpart of the conversation this message is in (either a user or a group)")
  8. (uid
  9. :initarg :uid
  10. :reader uid
  11. :documentation "The user ID this message is associated with.")
  12. (from
  13. :initarg :from
  14. :reader from
  15. :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.")
  16. (timestamp
  17. :initarg :timestamp
  18. :reader timestamp
  19. :documentation "A LOCAL-TIME timestamp of when the message was sent.")
  20. (xmpp-id
  21. :initarg :xmpp-id
  22. :reader xmpp-id
  23. :documentation "The XMPP-side ID of the message (given in the 'id' header, and as the MUC <stanza-id> element)")
  24. (orig-id
  25. :initarg :orig-id
  26. :initform nil
  27. :reader orig-id
  28. :documentation "The WhatsApp-side ID of the message, if any.")
  29. (body
  30. :initarg :body
  31. :reader body
  32. :documentation "The message text.")
  33. (oob-url
  34. :initarg :oob-url
  35. :initform nil
  36. :reader oob-url
  37. :documentation "The URL of uploaded media contained in this message, if any.")))
  38. (defun wa-message-key-to-conversation-and-from (comp jid key &optional conn)
  39. "Takes KEY, a WHATSCL::MESSAGE-KEY for a message for bridge user JID, and returns (VALUES CONVERSATION FROM).
  40. If a CONN is provided, it's used to create a new chat if that's required; otherwise, an error is signaled.
  41. FIXME: the above behaviour is a bit meh."
  42. (let* ((wx-localpart (wa-jid-to-whatsxmpp-localpart (whatscl::key-jid key)))
  43. (uid (get-user-id jid)))
  44. (typecase key
  45. (whatscl::message-key-receiving
  46. ;; Received in a 1-to-1: conversation same as from
  47. (values wx-localpart wx-localpart))
  48. (whatscl::message-key-sending
  49. (if (uiop:string-prefix-p "g" wx-localpart)
  50. (alexandria:if-let ((user-resource (get-user-chat-resource uid wx-localpart)))
  51. (values wx-localpart user-resource)
  52. ;; If we don't have a user chat resource, just use their localpart.
  53. ;; This shouldn't really happen that frequently.
  54. (progn
  55. (values wx-localpart (first (split-sequence:split-sequence #\@ jid)))
  56. (warn "Using fallback localpart for sent message in group ~A; that's rather interesting." wx-localpart)))
  57. ;; Put the user's jid as "from". This is okay, since we pretty much only
  58. ;; want to determine "was it us or them" in a 1-to-1 conversation, which
  59. ;; is done by comparing from to conversation.
  60. (values wx-localpart jid)))
  61. (whatscl::message-key-group-receiving
  62. (let* ((chat-id (or
  63. (get-user-chat-id uid wx-localpart)
  64. (when conn
  65. (add-wa-chat comp conn jid (whatscl::key-jid key))
  66. (get-user-chat-id uid wx-localpart))))
  67. (participant-localpart (wa-jid-to-whatsxmpp-localpart (whatscl::key-participant key))))
  68. (if chat-id
  69. (let ((from-resource (or
  70. (get-participant-resource chat-id participant-localpart)
  71. ;; whee fallback go brrr
  72. participant-localpart)))
  73. (values wx-localpart from-resource))
  74. (error "Couldn't find or create group chat for ~A" chat-id)))))))
  75. (defmacro with-new-xmpp-message-context ((comp jid msg &optional conn) &body body)
  76. "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."
  77. (alexandria:with-gensyms (key wa-id wa-ts uid ts conversation from xmpp-id orig-id)
  78. `(let* ((,key (whatscl::message-key ,msg))
  79. (,wa-id (whatscl::message-id ,msg))
  80. (,wa-ts (whatscl::message-ts ,msg))
  81. (,uid (get-user-id ,jid))
  82. (local-time:*default-timezone* local-time:+utc-zone+)
  83. (,ts (local-time:unix-to-timestamp ,wa-ts)))
  84. (multiple-value-bind (,conversation ,from)
  85. (wa-message-key-to-conversation-and-from ,comp ,jid ,key ,conn)
  86. (labels ((new-xmpp-message (body &key oob-url system-generated)
  87. (let ((,xmpp-id (if system-generated
  88. (princ-to-string (uuid:make-v4-uuid))
  89. (concatenate 'string "wa-" ,wa-id "-" (princ-to-string ,wa-ts))))
  90. (,orig-id (unless system-generated ,wa-id)))
  91. (make-instance 'xmpp-message
  92. :conversation ,conversation
  93. :from ,from
  94. :uid ,uid
  95. :timestamp ,ts
  96. :oob-url oob-url
  97. :xmpp-id ,xmpp-id
  98. :orig-id ,orig-id
  99. :body body
  100. :oob-url oob-url))))
  101. ,@body)))))
  102. (defun quote-content (content)
  103. "Prepends '> ' to each line of CONTENT."
  104. (let ((oss (make-string-output-stream)))
  105. (loop
  106. for item in (split-sequence:split-sequence #\Linefeed content)
  107. do (format oss "> ~A~%" item))
  108. (get-output-stream-string oss)))
  109. (defun deliver-mam-history-message (comp msg to-jid &optional query-id)
  110. "Deliver MSG, an XMPP-MESSAGE, to TO-JID as a piece of MAM history, as part of the response to a MAM query with QUERY-ID."
  111. (let* ((component-host (component-name comp))
  112. (mam-from (concatenate 'string (conversation msg) "@" component-host))
  113. (real-from (concatenate 'string mam-from "/" (from msg))))
  114. (with-message (comp to-jid
  115. :from mam-from
  116. :type nil)
  117. (cxml:with-element "result"
  118. (cxml:attribute "xmlns" +mam-ns+)
  119. (when query-id
  120. (cxml:attribute "queryid" query-id))
  121. (cxml:attribute "id" (xmpp-id msg))
  122. (cxml:with-element "forwarded"
  123. (cxml:attribute "xmlns" +forwarded-ns+)
  124. (cxml:with-element "delay"
  125. (cxml:attribute "xmlns" +delivery-delay-ns+)
  126. (cxml:attribute "stamp" (local-time:format-timestring nil (timestamp msg))))
  127. (cxml:with-element "message"
  128. (cxml:attribute "from" real-from)
  129. (cxml:attribute "xmlns" +client-ns+)
  130. (cxml:attribute "type" "groupchat")
  131. (cxml:with-element "body"
  132. (cxml:text (body msg)))
  133. (when (oob-url msg)
  134. (cxml:with-element "x"
  135. (cxml:attribute "xmlns" +oob-ns+)
  136. (cxml:with-element "url"
  137. (cxml:text (oob-url msg)))))
  138. (when (orig-id msg)
  139. (cxml:with-element "origin-id"
  140. (cxml:attribute "xmlns" +unique-stanzas-ns+)
  141. (cxml:attribute "id" (orig-id msg))))))))))
  142. (defun deliver-xmpp-message (comp msg)
  143. "Deliver MSG, an XMPP-MESSAGE, to the intended destinations on COMP."
  144. (let* ((jid (get-user-jid (uid msg)))
  145. (one-to-one-p (uiop:string-prefix-p "u" (conversation msg)))
  146. (component-host (component-name comp))
  147. (destinations (if one-to-one-p
  148. ;; We can't send a message the user sent in a 1:1.
  149. (when (string= (conversation msg) (from msg))
  150. (list jid))
  151. (get-user-chat-joined (uid msg) (conversation msg))))
  152. (from (if one-to-one-p
  153. (concatenate 'string (from msg) "@" component-host "/whatsapp")
  154. (concatenate 'string (conversation msg) "@" component-host "/" (from msg)))))
  155. (loop
  156. for to in destinations
  157. do (with-message (comp to
  158. :from from
  159. :id (xmpp-id msg)
  160. :type (if one-to-one-p "chat" "groupchat"))
  161. (cxml:with-element "body"
  162. (cxml:text (body msg)))
  163. (when (oob-url msg)
  164. (cxml:with-element "x"
  165. (cxml:attribute "xmlns" +oob-ns+)
  166. (cxml:with-element "url"
  167. (cxml:text (oob-url msg)))))
  168. (cxml:with-element "delay"
  169. (cxml:attribute "xmlns" +delivery-delay-ns+)
  170. (cxml:attribute "stamp" (local-time:format-timestring nil (timestamp msg))))
  171. (cxml:with-element "active"
  172. (cxml:attribute "xmlns" +chat-states-ns+))
  173. (unless one-to-one-p
  174. (cxml:with-element "stanza-id"
  175. (cxml:attribute "xmlns" +unique-stanzas-ns+)
  176. (cxml:attribute "id" (xmpp-id msg))
  177. (cxml:attribute "by" (concatenate 'string (conversation msg) "@" component-host)))
  178. (when (orig-id msg)
  179. (cxml:with-element "origin-id"
  180. (cxml:attribute "xmlns" +unique-stanzas-ns+)
  181. (cxml:attribute "id" (orig-id msg)))))
  182. (when (orig-id msg)
  183. ;; Messages without a WhatsApp ID aren't markable for hopefully
  184. ;; obvious reasons.
  185. (cxml:with-element "markable"
  186. (cxml:attribute "xmlns" +chat-markers-ns+)))))))
  187. (defun make-xmpp-messages-for-wa-message (comp conn jid msg)
  188. "Returns a promise that is resolved with a list of XMPP-MESSAGE objects generated from the WhatsApp message object MSG.
  189. If something like file uploading fails, the promise can also be rejected."
  190. (promisify
  191. (with-new-xmpp-message-context (comp jid msg conn)
  192. (let ((contents (whatscl::message-contents msg))
  193. (qc (alexandria:when-let
  194. ((summary (whatscl::message-quoted-contents-summary msg)))
  195. (quote-content summary))))
  196. (typecase contents
  197. (whatscl::message-contents-text
  198. (let* ((contents-text (whatscl::contents-text contents))
  199. (text (format nil "~@[~A~]~A" qc contents-text)))
  200. (list (new-xmpp-message text))))
  201. (whatscl::message-contents-file
  202. (let* ((file-info (whatscl::contents-file-info contents))
  203. (media-type (whatscl::get-contents-media-type contents))
  204. (filename (when (typep contents 'whatscl::message-contents-document)
  205. (whatscl::contents-filename contents)))
  206. (caption (whatscl::contents-caption contents))
  207. (upload-promise (upload-whatsapp-media-file comp file-info media-type filename)))
  208. (attach upload-promise
  209. (lambda (get-url)
  210. (append
  211. (when (or caption qc)
  212. (let ((text (format nil "~@[~A~]~@[~A~]" qc caption)))
  213. (list (new-xmpp-message text
  214. :system-generated t))))
  215. (list (new-xmpp-message get-url
  216. :oob-url get-url)))))))
  217. ;; FIXME: handle location messages, stub messages, etc.
  218. (t nil))))))