djavu-asus/elpa/jabber-20230715.456/jabber-rtt.el

   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