-
Notifications
You must be signed in to change notification settings - Fork 0
/
message.lisp
232 lines (224 loc) · 11.4 KB
/
message.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
;; 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" wx-localpart)))))))
(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-mam-history-message (comp msg to-jid &optional query-id)
"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."
(let* ((component-host (component-name comp))
(mam-from (concatenate 'string (conversation msg) "@" component-host))
(real-from (concatenate 'string mam-from "/" (from msg))))
(with-message (comp to-jid
:from mam-from
:type nil)
(cxml:with-element "result"
(cxml:attribute "xmlns" +mam-ns+)
(when query-id
(cxml:attribute "queryid" query-id))
(cxml:attribute "id" (xmpp-id msg))
(cxml:with-element "forwarded"
(cxml:attribute "xmlns" +forwarded-ns+)
(cxml:with-element "delay"
(cxml:attribute "xmlns" +delivery-delay-ns+)
(cxml:attribute "stamp" (local-time:format-timestring nil (timestamp msg))))
(cxml:with-element "message"
(cxml:attribute "from" real-from)
(cxml:attribute "xmlns" +client-ns+)
(cxml:attribute "type" "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)))))
(when (orig-id msg)
(cxml:with-element "origin-id"
(cxml:attribute "xmlns" +unique-stanzas-ns+)
(cxml:attribute "id" (orig-id msg))))))))))
(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)))))
(when (and (not one-to-one-p)
(eql (length destinations) 0))
(warn "User ~A not in groupchat ~A; inviting due to new message"
jid (conversation msg))
(handle-wa-chat-invitation comp nil jid (uid msg) (conversation msg)
:use-join-count t))
(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))
(cxml:attribute "by" (concatenate 'string (conversation msg) "@" component-host)))
(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))))))