]>
Commit | Line | Data |
---|---|---|
53e6db90 DC |
1 | ;;; jabber-rtt.el --- XEP-0301: In-Band Real Time Text -*- lexical-binding: t; -*- |
2 | ||
3 | ;; Copyright (C) 2013 Magnus Henoch | |
4 | ||
5 | ;; Author: Magnus Henoch <magnus.henoch@gmail.com> | |
6 | ||
7 | ;; This program is free software; you can redistribute it and/or modify | |
8 | ;; it under the terms of the GNU General Public License as published by | |
9 | ;; the Free Software Foundation, either version 3 of the License, or | |
10 | ;; (at your option) any later version. | |
11 | ||
12 | ;; This program is distributed in the hope that it will be useful, | |
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;; GNU General Public License for more details. | |
16 | ||
17 | ;; You should have received a copy of the GNU General Public License | |
18 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | ;;; Commentary: | |
21 | ||
22 | ;; | |
23 | ||
24 | ;;; Code: | |
25 | ||
26 | (eval-when-compile (require 'cl-lib)) | |
27 | ||
28 | ;;;; Handling incoming events | |
29 | ||
30 | ;;;###autoload | |
31 | (eval-after-load "jabber-disco" | |
32 | '(jabber-disco-advertise-feature "urn:xmpp:rtt:0")) | |
33 | ||
34 | (defvar jabber-rtt-ewoc-node nil) | |
35 | (make-variable-buffer-local 'jabber-rtt-ewoc-node) | |
36 | ||
37 | (defvar jabber-rtt-last-seq nil) | |
38 | (make-variable-buffer-local 'jabber-rtt-last-seq) | |
39 | ||
40 | (defvar jabber-rtt-message nil) | |
41 | (make-variable-buffer-local 'jabber-rtt-message) | |
42 | ||
43 | (defvar jabber-rtt-pending-events nil) | |
44 | (make-variable-buffer-local 'jabber-rtt-pending-events) | |
45 | ||
46 | (defvar jabber-rtt-timer nil) | |
47 | (make-variable-buffer-local 'jabber-rtt-timer) | |
48 | ||
49 | ;; Add function last in chain, so a chat buffer is already created. | |
50 | ;;;###autoload | |
51 | (eval-after-load "jabber-core" | |
52 | '(add-to-list 'jabber-message-chain #'jabber-rtt-handle-message t)) | |
53 | ||
54 | ;;;###autoload | |
55 | (defun jabber-rtt-handle-message (jc xml-data) | |
56 | ;; We could support this for MUC as well, if useful. | |
57 | (when (and (not (jabber-muc-message-p xml-data)) | |
58 | (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)))) | |
59 | (with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)) | |
60 | (let* ((rtt (jabber-xml-path xml-data '(("urn:xmpp:rtt:0" . "rtt")))) | |
61 | (body (jabber-xml-path xml-data '(body))) | |
62 | (seq (when rtt (jabber-xml-get-attribute rtt 'seq))) | |
63 | (event (when rtt (or (jabber-xml-get-attribute rtt 'event) "edit"))) | |
64 | (actions (when rtt (jabber-xml-node-children rtt))) | |
65 | (inhibit-read-only t)) | |
66 | (cond | |
67 | ((or body (string= event "cancel")) | |
68 | ;; A <body/> element supersedes real time text. | |
69 | (jabber-rtt--reset)) | |
70 | ((member event '("new" "reset")) | |
71 | (jabber-rtt--reset) | |
72 | (setq jabber-rtt-ewoc-node | |
73 | (ewoc-enter-last jabber-chat-ewoc (list :notice "[typing...]")) | |
74 | jabber-rtt-last-seq (string-to-number seq) | |
75 | jabber-rtt-message "" | |
76 | jabber-rtt-pending-events nil) | |
77 | (jabber-rtt--enqueue-actions actions)) | |
78 | ((string= event "edit") | |
79 | ;; TODO: check whether this works properly in 32-bit Emacs | |
80 | (cond | |
81 | ((and jabber-rtt-last-seq | |
82 | (equal (1+ jabber-rtt-last-seq) | |
83 | (string-to-number seq))) | |
84 | ;; We are in sync. | |
85 | (setq jabber-rtt-last-seq (string-to-number seq)) | |
86 | (jabber-rtt--enqueue-actions actions)) | |
87 | (t | |
88 | ;; TODO: show warning when not in sync | |
89 | (message "out of sync! %s vs %s" | |
90 | seq jabber-rtt-last-seq)))) | |
91 | ;; TODO: handle event="init" | |
92 | ))))) | |
93 | ||
94 | (defun jabber-rtt--reset () | |
95 | (when jabber-rtt-ewoc-node | |
96 | (ewoc-delete jabber-chat-ewoc jabber-rtt-ewoc-node)) | |
97 | (when (timerp jabber-rtt-timer) | |
98 | (cancel-timer jabber-rtt-timer)) | |
99 | (setq jabber-rtt-ewoc-node nil | |
100 | jabber-rtt-last-seq nil | |
101 | jabber-rtt-message nil | |
102 | jabber-rtt-pending-events nil | |
103 | jabber-rtt-timer nil)) | |
104 | ||
105 | (defun jabber-rtt--enqueue-actions (new-actions) | |
106 | (setq jabber-rtt-pending-events | |
107 | ;; Ensure that the queue never contains more than 700 ms worth | |
108 | ;; of wait events. | |
109 | (jabber-rtt--fix-waits (append jabber-rtt-pending-events new-actions))) | |
110 | (unless jabber-rtt-timer | |
111 | (jabber-rtt--process-actions (current-buffer)))) | |
112 | ||
113 | (defun jabber-rtt--process-actions (buffer) | |
114 | (with-current-buffer buffer | |
115 | (setq jabber-rtt-timer nil) | |
116 | (catch 'wait | |
117 | (while jabber-rtt-pending-events | |
118 | (let ((action (pop jabber-rtt-pending-events))) | |
119 | (cl-case (jabber-xml-node-name action) | |
120 | ((t) | |
121 | ;; insert text | |
122 | (let* ((p (jabber-xml-get-attribute action 'p)) | |
123 | (position (if p (string-to-number p) (length jabber-rtt-message)))) | |
124 | (setq position (max position 0)) | |
125 | (setq position (min position (length jabber-rtt-message))) | |
126 | (setf (substring jabber-rtt-message position position) | |
127 | (car (jabber-xml-node-children action))) | |
128 | ||
129 | (ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message))) | |
130 | (let ((inhibit-read-only t)) | |
131 | (ewoc-invalidate jabber-chat-ewoc jabber-rtt-ewoc-node)))) | |
132 | ((e) | |
133 | ;; erase text | |
134 | (let* ((p (jabber-xml-get-attribute action 'p)) | |
135 | (position (if p (string-to-number p) (length jabber-rtt-message))) | |
136 | (n (jabber-xml-get-attribute action 'n)) | |
137 | (number (if n (string-to-number n) 1))) | |
138 | (setq position (max position 0)) | |
139 | (setq position (min position (length jabber-rtt-message))) | |
140 | (setq number (max number 0)) | |
141 | (setq number (min number position)) | |
142 | ;; Now erase the NUMBER characters before POSITION. | |
143 | (setf (substring jabber-rtt-message (- position number) position) | |
144 | "") | |
145 | ||
146 | (ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message))) | |
147 | (let ((inhibit-read-only t)) | |
148 | (ewoc-invalidate jabber-chat-ewoc jabber-rtt-ewoc-node)))) | |
149 | ((w) | |
150 | (setq jabber-rtt-timer | |
151 | (run-with-timer | |
152 | (/ (string-to-number (jabber-xml-get-attribute action 'n)) 1000.0) | |
153 | nil | |
154 | #'jabber-rtt--process-actions | |
155 | buffer)) | |
156 | (throw 'wait nil)))))))) | |
157 | ||
158 | (defun jabber-rtt--fix-waits (actions) | |
159 | ;; Ensure that the sum of all wait events is no more than 700 ms. | |
160 | (let ((sum 0)) | |
161 | (dolist (action actions) | |
162 | (when (eq (jabber-xml-node-name action) 'w) | |
163 | (let ((n (jabber-xml-get-attribute action 'n))) | |
164 | (setq n (string-to-number n)) | |
165 | (when (>= n 0) | |
166 | (setq sum (+ sum n)))))) | |
167 | ||
168 | (if (<= sum 700) | |
169 | actions | |
170 | (let ((scale (/ 700.0 sum))) | |
171 | (mapcar | |
172 | (lambda (action) | |
173 | (if (eq (jabber-xml-node-name action) 'w) | |
174 | (let ((n (jabber-xml-get-attribute action 'n))) | |
175 | (setq n (string-to-number n)) | |
176 | (setq n (max n 0)) | |
177 | `(w ((n . ,(number-to-string (* scale n)))) nil)) | |
178 | action)) | |
179 | actions))))) | |
180 | ||
181 | ;;;; Sending events | |
182 | ||
183 | (defvar jabber-rtt-send-timer nil) | |
184 | (make-variable-buffer-local 'jabber-rtt-send-timer) | |
185 | ||
186 | (defvar jabber-rtt-send-seq nil) | |
187 | (make-variable-buffer-local 'jabber-rtt-send-seq) | |
188 | ||
189 | (defvar jabber-rtt-outgoing-events nil) | |
190 | (make-variable-buffer-local 'jabber-rtt-outgoing-events) | |
191 | ||
192 | (defvar jabber-rtt-send-last-timestamp nil) | |
193 | (make-variable-buffer-local 'jabber-rtt-send-last-timestamp) | |
194 | ||
195 | ;;;###autoload | |
196 | (define-minor-mode jabber-rtt-send-mode | |
197 | "Show text to recipient as it is being typed. | |
198 | This lets the recipient see every change made to the message up | |
199 | until it's sent. The recipient's client needs to implement | |
200 | XEP-0301, In-Band Real Time Text." | |
201 | nil " Real-Time" nil | |
202 | (if (null jabber-rtt-send-mode) | |
203 | (progn | |
204 | (remove-hook 'after-change-functions #'jabber-rtt--queue-update t) | |
205 | (remove-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent t) | |
206 | (jabber-rtt--cancel-send)) | |
207 | (unless (derived-mode-p 'jabber-chat-mode) | |
208 | (error "Real Time Text only makes sense in chat buffers")) | |
209 | (when (timerp jabber-rtt-send-timer) | |
210 | (cancel-timer jabber-rtt-send-timer)) | |
211 | (setq jabber-rtt-send-timer nil | |
212 | jabber-rtt-send-seq nil | |
213 | jabber-rtt-outgoing-events nil | |
214 | jabber-rtt-send-last-timestamp nil) | |
215 | (jabber-rtt--send-current-text nil) | |
216 | (add-hook 'after-change-functions #'jabber-rtt--queue-update nil t) | |
217 | (add-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent nil t))) | |
218 | ||
219 | (defun jabber-rtt--cancel-send () | |
220 | (when (timerp jabber-rtt-send-timer) | |
221 | (cancel-timer jabber-rtt-send-timer)) | |
222 | (setq jabber-rtt-send-seq (1+ jabber-rtt-send-seq)) | |
223 | (jabber-send-sexp jabber-buffer-connection | |
224 | `(message ((to . ,jabber-chatting-with) | |
225 | (type . "chat")) | |
226 | (rtt ((xmlns . "urn:xmpp:rtt:0") | |
227 | (seq . ,(number-to-string jabber-rtt-send-seq)) | |
228 | (event . "cancel")) | |
229 | nil))) | |
230 | (setq jabber-rtt-send-timer nil | |
231 | jabber-rtt-send-seq nil | |
232 | jabber-rtt-outgoing-events nil | |
233 | jabber-rtt-send-last-timestamp nil)) | |
234 | ||
235 | (defun jabber-rtt--send-current-text (resetp) | |
236 | (let ((text (buffer-substring-no-properties jabber-point-insert (point-max)))) | |
237 | ;; This should give us enough room to avoid wrap-arounds, even | |
238 | ;; with just 28 bits... | |
239 | (setq jabber-rtt-send-seq (random 100000)) | |
240 | (jabber-send-sexp jabber-buffer-connection | |
241 | `(message ((to . ,jabber-chatting-with) | |
242 | (type . "chat")) | |
243 | (rtt ((xmlns . "urn:xmpp:rtt:0") | |
244 | (seq . ,(number-to-string jabber-rtt-send-seq)) | |
245 | (event . ,(if resetp "reset" "new"))) | |
246 | (t () ,text)))))) | |
247 | ||
248 | (defun jabber-rtt--queue-update (beg end pre-change-length) | |
249 | (unless (or (< beg jabber-point-insert) | |
250 | (< end jabber-point-insert)) | |
251 | (let ((timestamp (current-time))) | |
252 | (when jabber-rtt-send-last-timestamp | |
253 | (let* ((time-difference (time-subtract timestamp jabber-rtt-send-last-timestamp)) | |
254 | (interval (truncate (* 1000 (float-time time-difference))))) | |
255 | (when (and (> interval 0) | |
256 | ;; Don't send too long intervals - this should have | |
257 | ;; been sent by our timer already. | |
258 | (< interval 1000)) | |
259 | (push `(w ((n . ,(number-to-string interval))) nil) | |
260 | jabber-rtt-outgoing-events)))) | |
261 | (setq jabber-rtt-send-last-timestamp timestamp)) | |
262 | ||
263 | (when (> pre-change-length 0) | |
264 | ;; Some text was deleted. Let's check if we can use a shorter | |
265 | ;; tag: | |
266 | (let ((at-end (= end (point-max))) | |
267 | (erase-one (= pre-change-length 1))) | |
268 | (push `(e ( | |
269 | ,@(unless at-end | |
270 | `((p . ,(number-to-string | |
271 | (+ beg | |
272 | (- jabber-point-insert) | |
273 | pre-change-length))))) | |
274 | ,@(unless erase-one | |
275 | `((n . ,(number-to-string pre-change-length)))))) | |
276 | jabber-rtt-outgoing-events))) | |
277 | ||
278 | (when (/= beg end) | |
279 | ;; Some text was inserted. | |
280 | (let ((text (buffer-substring-no-properties beg end)) | |
281 | (at-end (= end (point-max)))) | |
282 | (push `(t ( | |
283 | ,@(unless at-end | |
284 | `((p . ,(number-to-string (- beg jabber-point-insert)))))) | |
285 | ,text) | |
286 | jabber-rtt-outgoing-events))) | |
287 | ||
288 | (when (null jabber-rtt-send-timer) | |
289 | (setq jabber-rtt-send-timer | |
290 | (run-with-timer 0.7 nil #'jabber-rtt--send-queued-events (current-buffer)))))) | |
291 | ||
292 | (defun jabber-rtt--send-queued-events (buffer) | |
293 | (with-current-buffer buffer | |
294 | (setq jabber-rtt-send-timer nil) | |
295 | (when jabber-rtt-outgoing-events | |
296 | (let ((event (if jabber-rtt-send-seq "edit" "new"))) | |
297 | (setq jabber-rtt-send-seq | |
298 | (if jabber-rtt-send-seq | |
299 | (1+ jabber-rtt-send-seq) | |
300 | (random 100000))) | |
301 | (jabber-send-sexp jabber-buffer-connection | |
302 | `(message ((to . ,jabber-chatting-with) | |
303 | (type . "chat")) | |
304 | (rtt ((xmlns . "urn:xmpp:rtt:0") | |
305 | (seq . ,(number-to-string jabber-rtt-send-seq)) | |
306 | (event . ,event)) | |
307 | ,@(nreverse jabber-rtt-outgoing-events)))) | |
308 | (setq jabber-rtt-outgoing-events nil))))) | |
309 | ||
310 | (defun jabber-rtt--message-sent (_text _id) | |
311 | ;; We're sending a <body/> element; reset our state | |
312 | (when (timerp jabber-rtt-send-timer) | |
313 | (cancel-timer jabber-rtt-send-timer)) | |
314 | (setq jabber-rtt-send-timer nil | |
315 | jabber-rtt-send-seq nil | |
316 | jabber-rtt-outgoing-events nil | |
317 | jabber-rtt-send-last-timestamp nil)) | |
318 | ||
319 | (provide 'jabber-rtt) | |
320 | ;;; jabber-rtt.el ends here |