djavu-asus/emacs/elpa/jabber-20230715.456/jabber-history.el

   1 ;; jabber-history.el - recording message history  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
   4 ;; Copyright (C) 2004 - Mathias Dahl
   5
   6 ;; This file is a part of jabber.el.
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, write to the Free Software
  20 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  21
  22 ;;; Log format:
  23 ;; Each message is on one separate line, represented as a vector with
  24 ;; five elements.  The first element is time encoded according to
  25 ;; XEP-0082.  The second element is direction, "in" or "out".
  26 ;; The third element is the sender, "me" or a JID.  The fourth
  27 ;; element is the recipient.  The fifth element is the text
  28 ;; of the message.
  29
  30 ;; FIXME: when rotation is enabled, jabber-history-query won't look
  31 ;; for older history files if the current history file doesn't contain
  32 ;; enough backlog entries.
  33
  34 (require 'jabber-core)
  35 (require 'jabber-util)
  36
  37 (defgroup jabber-history nil "Customization options for Emacs
  38 Jabber history files."
  39   :group 'jabber)
  40
  41 (defcustom jabber-history-enabled nil
  42   "Non-nil means message logging is enabled."
  43   :type 'boolean
  44   :group 'jabber-history)
  45
  46 (defcustom jabber-history-muc-enabled nil
  47   "Non-nil means MUC logging is enabled.
  48 Default is nil, cause MUC logging may be i/o-intensive."
  49   :type 'boolean
  50   :group 'jabber-history)
  51
  52 (defcustom jabber-history-dir
  53   (locate-user-emacs-file "jabber-history" ".emacs-jabber")
  54   "Base directory where per-contact history files are stored.
  55 Used only when `jabber-use-global-history' is nil."
  56   :type 'directory
  57   :group 'jabber-history)
  58
  59 (defcustom jabber-global-history-filename
  60   (locate-user-emacs-file "jabber-global-message-log" ".jabber_global_message_log")
  61   "Global file where all messages are logged.
  62 Used when `jabber-use-global-history' is non-nil."
  63   :type 'file
  64   :group 'jabber-history)
  65
  66 (defcustom jabber-use-global-history
  67   ;; Using a global history file by default was a bad idea.  Let's
  68   ;; default to per-user files unless the global history file already
  69   ;; exists, to avoid breaking existing installations.
  70   (file-exists-p jabber-global-history-filename)
  71   "Whether to use a global file for message history.
  72 If non-nil, `jabber-global-history-filename' is used, otherwise,
  73 messages are stored in per-user files under the
  74 `jabber-history-dir' directory."
  75   :type 'boolean
  76   :group 'jabber-history)
  77
  78 (defcustom jabber-history-enable-rotation nil
  79   "Whether to enable rotation of history files.
  80
  81 If nil, history files will grow indefinitely.
  82
  83 If non-nil, history files will be renamed to
  84 <history-file>-<number> (where <number> is 1 or the smallest
  85 number after the last rotation) when they reach
  86 `jabber-history-size-limit' kilobytes."
  87   :type 'boolean
  88   :group 'jabber-history)
  89
  90 (defcustom jabber-history-size-limit 1024
  91   "Maximum history file size in kilobytes.
  92 When history file reaches this limit, it is renamed to
  93 <history-file>-<number>, where <number> is 1 or the smallest
  94 number after the last rotation."
  95   :type 'integer
  96   :group 'jabber-history)
  97
  98 (defvar jabber-history-inhibit-received-message-functions nil
  99   "Functions determining whether to log an incoming message stanza.
 100 The functions in this list are called with two arguments,
 101 the connection and the full message stanza.
 102 If any of the functions returns non-nil, the stanza is not logged
 103 in the message history.")
 104
 105 (defun jabber-rotate-history-p (history-file)
 106   "Return non-nil if HISTORY-FILE should be rotated."
 107   (when (and jabber-history-enable-rotation
 108              (file-exists-p history-file))
 109     (> (/ (nth 7 (file-attributes history-file)) 1024)
 110        jabber-history-size-limit)))
 111
 112 (defun jabber-history-rotate (history-file &optional try)
 113   "Rename HISTORY-FILE to HISTORY-FILE-TRY."
 114   (let ((suffix (number-to-string (or try 1))))
 115     (if (file-exists-p (concat history-file "-"  suffix))
 116         (jabber-history-rotate history-file (if try (1+ try) 1))
 117       (rename-file history-file (concat history-file "-" suffix)))))
 118
 119 (add-to-list 'jabber-message-chain 'jabber-message-history)
 120 (defun jabber-message-history (jc xml-data)
 121   "Log message to log file.
 122
 123 JC is the Jabber connection.
 124 XML-DATA is the parsed tree data from the stream (stanzas)
 125 obtained from `xml-parse-region'."
 126   (when (and (not jabber-use-global-history)
 127              (not (file-directory-p jabber-history-dir)))
 128     (make-directory jabber-history-dir))
 129   (let ((is-muc (jabber-muc-message-p xml-data)))
 130     (when (and jabber-history-enabled
 131                (or
 132                 (not is-muc)                ;chat message or private MUC message
 133                 (and jabber-history-muc-enabled is-muc))) ;muc message and muc logging active
 134       (unless (run-hook-with-args-until-success
 135                'jabber-history-inhibit-received-message-functions
 136                jc xml-data)
 137         (let ((from (jabber-xml-get-attribute xml-data 'from))
 138               (text (car (jabber-xml-node-children
 139                           (car (jabber-xml-get-children xml-data 'body)))))
 140               (timestamp (jabber-message-timestamp xml-data)))
 141           (when (and from text)
 142             (jabber-history-log-message "in" from nil text timestamp)))))))
 143
 144 (add-hook 'jabber-chat-send-hooks 'jabber-history-send-hook)
 145
 146 (defun jabber-history-send-hook (body id)
 147   "Log outgoing message to log file."
 148   (when (and (not jabber-use-global-history)
 149              (not (file-directory-p jabber-history-dir)))
 150     (make-directory jabber-history-dir))
 151   ;; This function is called from a chat buffer, so jabber-chatting-with
 152   ;; contains the desired value.
 153   (if jabber-history-enabled
 154       (jabber-history-log-message "out" nil jabber-chatting-with body (current-time))))
 155
 156 (defun jabber-history-filename (contact)
 157   "Return a history filename for CONTACT.
 158 Return the global history filename, or (if the per-user file
 159 logging strategy is used) a history filename for CONTACT."
 160   (if jabber-use-global-history
 161       jabber-global-history-filename
 162     ;; jabber-jid-symbol is the best canonicalization we have.
 163     (concat jabber-history-dir
 164             "/" (symbol-name (jabber-jid-symbol contact)))))
 165
 166 (defun jabber-history-log-message (direction from to body timestamp)
 167   "Log a message."
 168   (with-temp-buffer
 169     ;; Remove properties
 170     (set-text-properties 0 (length body) nil body)
 171     ;; Encode text as Lisp string - get decoding for free
 172     (setq body (prin1-to-string body))
 173     ;; Encode LF and CR
 174     (while (string-match "\n" body)
 175       (setq body (replace-match "\\n" nil t body nil)))
 176     (while (string-match "\r" body)
 177       (setq body (replace-match "\\r" nil t body nil)))
 178     (insert (format "[\"%s\" \"%s\" %s %s %s]\n"
 179                     (jabber-encode-time (or timestamp (current-time)))
 180                     (or direction
 181                         "in")
 182                     (or (when from
 183                           (prin1-to-string from))
 184                         "\"me\"")
 185                     (or (when to
 186                           (prin1-to-string to))
 187                         "\"me\"")
 188                     body))
 189     (let ((coding-system-for-write 'utf-8)
 190           (history-file (jabber-history-filename (or from to))))
 191       (when (and (not jabber-use-global-history)
 192                  (not (file-directory-p jabber-history-dir)))
 193         (make-directory jabber-history-dir))
 194       (when (jabber-rotate-history-p history-file)
 195         (jabber-history-rotate history-file))
 196       (condition-case e
 197           (write-region (point-min) (point-max) history-file t 'quiet)
 198         (error
 199          (message "Unable to write history: %s" (error-message-string e)))))))
 200
 201 (defun jabber-history-query (start-time
 202                              end-time
 203                              number
 204                              direction
 205                              jid-regexp
 206                              history-file)
 207   "Return a list of vectors, one for each message matching the criteria.
 208 START-TIME and END-TIME are floats as obtained from `float-time'.
 209 Either or both may be nil, meaning no restriction.
 210 NUMBER is the maximum number of messages to return, or t for
 211 unlimited.
 212 DIRECTION is either \"in\" or \"out\", or t for no limit on direction.
 213 JID-REGEXP is a regexp which must match the JID.
 214 HISTORY-FILE is the file in which to search.
 215
 216 Currently jabber-history-query performs a linear search from the end
 217 of the log file."
 218   (when (file-readable-p history-file)
 219     (with-temp-buffer
 220       (let ((coding-system-for-read 'utf-8))
 221         (if jabber-use-global-history
 222             (insert-file-contents history-file)
 223           (let* ((lines-collected nil)
 224                 (matched-files
 225                  (directory-files jabber-history-dir t
 226                                   (concat "^"
 227                                           (regexp-quote (file-name-nondirectory
 228                                                          history-file)))))
 229                 (matched-files
 230                  (cons (car matched-files)
 231                        (sort (cdr matched-files) 'string>-numerical))))
 232             (while (not lines-collected)
 233               (if (null matched-files)
 234                   (setq lines-collected t)
 235                 (let ((file (pop matched-files)))
 236                   (progn
 237                     (insert-file-contents file)
 238                     (when (numberp number)
 239                       (if (>= (count-lines (point-min) (point-max)) number)
 240                         (setq lines-collected t))))))))))
 241       (let (collected current-line)
 242         (goto-char (point-max))
 243         (catch 'beginning-of-file
 244             (while (progn
 245                      (backward-sexp)
 246                      (setq current-line (car (read-from-string
 247                                               (buffer-substring
 248                                                (point)
 249                                                (save-excursion
 250                                                  (forward-sexp)
 251                                                  (point))))))
 252                      (and (or (null start-time)
 253                               (> (jabber-float-time (jabber-parse-time
 254                                                      (aref current-line 0)))
 255                                  start-time))
 256                           (or (eq number t)
 257                               (< (length collected) number))))
 258               (if (and (or (eq direction t)
 259                            (string= direction (aref current-line 1)))
 260                        (or (null end-time)
 261                            (> end-time (jabber-float-time (jabber-parse-time
 262                                                            (aref current-line 0)))))
 263                        (string-match
 264                         jid-regexp
 265                         (car
 266                          (remove "me"
 267                                  (list (aref current-line 2)
 268                                        (aref current-line 3))))))
 269                   (push current-line collected))
 270               (when (bobp)
 271                 (throw 'beginning-of-file nil))))
 272         collected))))
 273
 274 (defcustom jabber-backlog-days 3.0
 275   "Age limit on messages in chat buffer backlog, in days."
 276   :group 'jabber
 277   :type '(choice (number :tag "Number of days")
 278                  (const :tag "No limit" nil)))
 279
 280 (defcustom jabber-backlog-number 10
 281   "Maximum number of messages in chat buffer backlog."
 282   :group 'jabber
 283   :type 'integer)
 284
 285 (defun jabber-history-backlog (jid &optional before)
 286   "Fetch context from previous chats with JID.
 287 Return a list of history entries (vectors), limited by
 288 `jabber-backlog-days' and `jabber-backlog-number'.
 289 If BEFORE is non-nil, it should be a float-time after which
 290 no entries will be fetched.  `jabber-backlog-days' still
 291 applies, though."
 292   (jabber-history-query
 293    (and jabber-backlog-days
 294         (- (jabber-float-time) (* jabber-backlog-days 86400.0)))
 295    before
 296    jabber-backlog-number
 297    t                                    ; both incoming and outgoing
 298    (concat "^" (regexp-quote (jabber-jid-user jid)) "\\(/.*\\)?$")
 299    (jabber-history-filename jid)))
 300
 301 (defun jabber-history-move-to-per-user ()
 302   "Migrate global history to per-user files."
 303   (interactive)
 304   (when (file-directory-p jabber-history-dir)
 305     (error "Per-user history directory already exists"))
 306   (make-directory jabber-history-dir)
 307   (let ((jabber-use-global-history nil))
 308     (with-temp-buffer
 309       (let ((coding-system-for-read 'utf-8))
 310         (insert-file-contents jabber-global-history-filename))
 311       (let ((progress-reporter
 312              (when (fboundp 'make-progress-reporter)
 313                (make-progress-reporter "Migrating history..."
 314                                        (point-min) (point-max))))
 315             ;;(file-table (make-hash-table :test 'equal))
 316             ;; Keep track of blocks of entries pertaining to the same JID.
 317             current-jid jid-start)
 318         (while (not (eobp))
 319           (let* ((start (point))
 320                  (end (progn (forward-line) (point)))
 321                  (line (buffer-substring start end))
 322                  (parsed (car (read-from-string line)))
 323                  (jid (if (string= (aref parsed 2) "me")
 324                           (aref parsed 3)
 325                         (aref parsed 2))))
 326             ;; Whenever there is a change in JID...
 327             (when (not (equal jid current-jid))
 328               (when current-jid
 329                 ;; ...save data for previous JID...
 330                 (let ((history-file (jabber-history-filename current-jid)))
 331                   (write-region jid-start start history-file t 'quiet)))
 332               ;; ...and switch to new JID.
 333               (setq current-jid jid)
 334               (setq jid-start start))
 335             (when (fboundp 'progress-reporter-update)
 336               (progress-reporter-update progress-reporter (point)))))
 337         ;; Finally, save the last block, if any.
 338         (when current-jid
 339           (let ((history-file (jabber-history-filename current-jid)))
 340             (write-region jid-start (point-max) history-file t 'quiet))))))
 341   (message "Done.  Please change `jabber-use-global-history' now."))
 342
 343 (provide 'jabber-history)
 344
 345 ;; arch-tag: 0AA0C235-3FC0-11D9-9FE7-000A95C2FCD0