324 lines
12 KiB
EmacsLisp
324 lines
12 KiB
EmacsLisp
;; jabber-history.el - recording message history
|
|
|
|
;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
|
|
;; Copyright (C) 2004 - Mathias Dahl
|
|
|
|
;; This file is a part of jabber.el.
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program; if not, write to the Free Software
|
|
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
;;; Log format:
|
|
;; Each message is on one separate line, represented as a vector with
|
|
;; five elements. The first element is time encoded according to
|
|
;; JEP-0082. The second element is direction, "in" or "out".
|
|
;; The third element is the sender, "me" or a JID. The fourth
|
|
;; element is the recipient. The fifth element is the text
|
|
;; of the message.
|
|
|
|
;; FIXME: when rotation is enabled, jabber-history-query won't look
|
|
;; for older history files if the current history file doesn't contain
|
|
;; enough backlog entries.
|
|
|
|
(require 'jabber-core)
|
|
(require 'jabber-util)
|
|
(require 'jabber-autoloads)
|
|
|
|
(defgroup jabber-history nil "Customization options for Emacs
|
|
Jabber history files."
|
|
:group 'jabber)
|
|
|
|
(defcustom jabber-history-enabled nil
|
|
"Non-nil means message logging is enabled."
|
|
:type 'boolean
|
|
:group 'jabber-history)
|
|
|
|
(defcustom jabber-history-muc-enabled nil
|
|
"Non-nil means MUC logging is enabled.
|
|
Default is nil, cause MUC logging may be i/o-intensive."
|
|
:type 'boolean
|
|
:group 'jabber-history)
|
|
|
|
(defcustom jabber-use-global-history t
|
|
"Indicate whether Emacs Jabber should use a global file for
|
|
store messages. If non-nil, jabber-global-history-filename is
|
|
used, otherwise, messages are stored in per-user files under
|
|
the jabber-history-dir directory."
|
|
:type 'boolean
|
|
:group 'jabber-history)
|
|
|
|
(defcustom jabber-history-dir "~/.emacs-jabber"
|
|
"Base directory where per-contact history files are stored.
|
|
Used only when jabber-use-global-history is not true."
|
|
:type 'directory
|
|
:group 'jabber-history)
|
|
|
|
(defcustom jabber-global-history-filename "~/.jabber_global_message_log"
|
|
"Global file where all messages are logged. Used when
|
|
jabber-use-global-history is non-nil."
|
|
:type 'file
|
|
:group 'jabber-history)
|
|
|
|
(defcustom jabber-history-enable-rotation nil
|
|
"Whether history files should be renamed when reach
|
|
jabber-history-size-limit kilobytes. If nil, history files
|
|
will grow indefinitely, otherwise they'll be renamed to
|
|
<history-file>-<number>, where <number> is 1 or the smallest
|
|
number after the last rotation."
|
|
:type 'boolean
|
|
:group 'jabber-history)
|
|
|
|
(defcustom jabber-history-size-limit 1024
|
|
"Maximum history file size in kilobytes. When history file
|
|
reaches this limit, it is renamed to <history-file>-<number>,
|
|
where <number> is 1 or the smallest number after the last
|
|
rotation."
|
|
:type 'integer
|
|
:group 'jabber-history)
|
|
|
|
|
|
(defun jabber-rotate-history-p (history-file)
|
|
"Return true if HISTORY-FILE should be rotated."
|
|
(when (and jabber-history-enable-rotation
|
|
(file-exists-p history-file))
|
|
(> (/ (nth 7 (file-attributes history-file)) 1024)
|
|
jabber-history-size-limit)))
|
|
|
|
(defun jabber-history-rotate (history-file &optional try)
|
|
"Rename HISTORY-FILE to HISTORY-FILE-TRY."
|
|
(let ((suffix (number-to-string (or try 1))))
|
|
(if (file-exists-p (concat history-file "-" suffix))
|
|
(jabber-history-rotate history-file (if try (1+ try) 1))
|
|
(rename-file history-file (concat history-file "-" suffix)))))
|
|
|
|
(add-to-list 'jabber-message-chain 'jabber-message-history)
|
|
(defun jabber-message-history (jc xml-data)
|
|
"Log message to log file."
|
|
(when (and (not jabber-use-global-history)
|
|
(not (file-directory-p jabber-history-dir)))
|
|
(make-directory jabber-history-dir))
|
|
(let ((is-muc (jabber-muc-message-p xml-data)))
|
|
(if (and jabber-history-enabled
|
|
(or
|
|
(not is-muc) ;chat message or private MUC message
|
|
(and jabber-history-muc-enabled is-muc))) ;muc message and muc logging active
|
|
(let ((from (jabber-xml-get-attribute xml-data 'from))
|
|
(text (car (jabber-xml-node-children
|
|
(car (jabber-xml-get-children xml-data 'body)))))
|
|
(timestamp (car (delq nil (mapcar 'jabber-x-delay (jabber-xml-get-children xml-data 'x))))))
|
|
(when (and from text)
|
|
(jabber-history-log-message "in" from nil text timestamp))))))
|
|
|
|
(add-hook 'jabber-chat-send-hooks 'jabber-history-send-hook)
|
|
|
|
(defun jabber-history-send-hook (body id)
|
|
"Log outgoing message to log file."
|
|
(when (and (not jabber-use-global-history)
|
|
(not (file-directory-p jabber-history-dir)))
|
|
(make-directory jabber-history-dir))
|
|
;; This function is called from a chat buffer, so jabber-chatting-with
|
|
;; contains the desired value.
|
|
(if jabber-history-enabled
|
|
(jabber-history-log-message "out" nil jabber-chatting-with body (current-time))))
|
|
|
|
(defun jabber-history-filename (contact)
|
|
"Return a history filename for CONTACT if the per-user file
|
|
loggin strategy is used or the global history filename."
|
|
(if jabber-use-global-history
|
|
jabber-global-history-filename
|
|
;; jabber-jid-symbol is the best canonicalization we have.
|
|
(concat jabber-history-dir
|
|
"/" (symbol-name (jabber-jid-symbol contact)))))
|
|
|
|
(defun jabber-history-log-message (direction from to body timestamp)
|
|
"Log a message"
|
|
(with-temp-buffer
|
|
;; Remove properties
|
|
(set-text-properties 0 (length body) nil body)
|
|
;; Encode text as Lisp string - get decoding for free
|
|
(setq body (prin1-to-string body))
|
|
;; Encode LF and CR
|
|
(while (string-match "\n" body)
|
|
(setq body (replace-match "\\n" nil t body nil)))
|
|
(while (string-match "\r" body)
|
|
(setq body (replace-match "\\r" nil t body nil)))
|
|
(insert (format "[\"%s\" \"%s\" %s %s %s]\n"
|
|
(jabber-encode-time (or timestamp (current-time)))
|
|
(or direction
|
|
"in")
|
|
(or (when from
|
|
(prin1-to-string from))
|
|
"\"me\"")
|
|
(or (when to
|
|
(prin1-to-string to))
|
|
"\"me\"")
|
|
body))
|
|
(let ((coding-system-for-write 'utf-8)
|
|
(history-file (jabber-history-filename (or from to))))
|
|
(when (and (not jabber-use-global-history)
|
|
(not (file-directory-p jabber-history-dir)))
|
|
(make-directory jabber-history-dir))
|
|
(when (jabber-rotate-history-p history-file)
|
|
(jabber-history-rotate history-file))
|
|
(condition-case e
|
|
(write-region (point-min) (point-max) history-file t 'quiet)
|
|
(error
|
|
(message "Unable to write history: %s" (error-message-string e)))))))
|
|
|
|
(defun jabber-history-query (start-time
|
|
end-time
|
|
number
|
|
direction
|
|
jid-regexp
|
|
history-file)
|
|
"Return a list of vectors, one for each message matching the criteria.
|
|
START-TIME and END-TIME are floats as obtained from `float-time'.
|
|
Either or both may be nil, meaning no restriction.
|
|
NUMBER is the maximum number of messages to return, or t for
|
|
unlimited.
|
|
DIRECTION is either \"in\" or \"out\", or t for no limit on direction.
|
|
JID-REGEXP is a regexp which must match the JID.
|
|
HISTORY-FILE is the file in which to search.
|
|
|
|
Currently jabber-history-query performs a linear search from the end
|
|
of the log file."
|
|
(when (file-readable-p history-file)
|
|
(with-temp-buffer
|
|
(let ((coding-system-for-read 'utf-8))
|
|
(if jabber-use-global-history
|
|
(insert-file-contents history-file)
|
|
(let* ((lines-collected nil)
|
|
(matched-files
|
|
(directory-files jabber-history-dir t
|
|
(concat "^"
|
|
(regexp-quote (file-name-nondirectory
|
|
history-file)))))
|
|
(matched-files
|
|
(cons (car matched-files)
|
|
(sort (cdr matched-files) 'string>-numerical))))
|
|
(while (not lines-collected)
|
|
(if (null matched-files)
|
|
(setq lines-collected t)
|
|
(let ((file (pop matched-files)))
|
|
(progn
|
|
(insert-file-contents file)
|
|
(when (numberp number)
|
|
(if (>= (count-lines (point-min) (point-max)) number)
|
|
(setq lines-collected t))))))))))
|
|
(let (collected current-line)
|
|
(goto-char (point-max))
|
|
(catch 'beginning-of-file
|
|
(while (progn
|
|
(backward-sexp)
|
|
(setq current-line (car (read-from-string
|
|
(buffer-substring
|
|
(point)
|
|
(save-excursion
|
|
(forward-sexp)
|
|
(point))))))
|
|
(and (or (null start-time)
|
|
(> (jabber-float-time (jabber-parse-time
|
|
(aref current-line 0)))
|
|
start-time))
|
|
(or (eq number t)
|
|
(< (length collected) number))))
|
|
(if (and (or (eq direction t)
|
|
(string= direction (aref current-line 1)))
|
|
(or (null end-time)
|
|
(> end-time (jabber-float-time (jabber-parse-time
|
|
(aref current-line 0)))))
|
|
(string-match
|
|
jid-regexp
|
|
(car
|
|
(remove "me"
|
|
(list (aref current-line 2)
|
|
(aref current-line 3))))))
|
|
(push current-line collected))
|
|
(when (bobp)
|
|
(throw 'beginning-of-file nil))))
|
|
collected))))
|
|
|
|
(defcustom jabber-backlog-days 3.0
|
|
"Age limit on messages in chat buffer backlog, in days"
|
|
:group 'jabber
|
|
:type '(choice (number :tag "Number of days")
|
|
(const :tag "No limit" nil)))
|
|
|
|
(defcustom jabber-backlog-number 10
|
|
"Maximum number of messages in chat buffer backlog"
|
|
:group 'jabber
|
|
:type 'integer)
|
|
|
|
(defun jabber-history-backlog (jid &optional before)
|
|
"Fetch context from previous chats with JID.
|
|
Return a list of history entries (vectors), limited by
|
|
`jabber-backlog-days' and `jabber-backlog-number'.
|
|
If BEFORE is non-nil, it should be a float-time after which
|
|
no entries will be fetched. `jabber-backlog-days' still
|
|
applies, though."
|
|
(jabber-history-query
|
|
(and jabber-backlog-days
|
|
(- (jabber-float-time) (* jabber-backlog-days 86400.0)))
|
|
before
|
|
jabber-backlog-number
|
|
t ; both incoming and outgoing
|
|
(concat "^" (regexp-quote (jabber-jid-user jid)) "\\(/.*\\)?$")
|
|
(jabber-history-filename jid)))
|
|
|
|
(defun jabber-history-move-to-per-user ()
|
|
"Migrate global history to per-user files."
|
|
(interactive)
|
|
(when (file-directory-p jabber-history-dir)
|
|
(error "Per-user history directory already exists"))
|
|
(make-directory jabber-history-dir)
|
|
(let ((jabber-use-global-history nil))
|
|
(with-temp-buffer
|
|
(let ((coding-system-for-read 'utf-8))
|
|
(insert-file-contents jabber-global-history-filename))
|
|
(let ((progress-reporter
|
|
(when (fboundp 'make-progress-reporter)
|
|
(make-progress-reporter "Migrating history..."
|
|
(point-min) (point-max))))
|
|
;;(file-table (make-hash-table :test 'equal))
|
|
;; Keep track of blocks of entries pertaining to the same JID.
|
|
current-jid jid-start)
|
|
(while (not (eobp))
|
|
(let* ((start (point))
|
|
(end (progn (forward-line) (point)))
|
|
(line (buffer-substring start end))
|
|
(parsed (car (read-from-string line)))
|
|
(jid (if (string= (aref parsed 2) "me")
|
|
(aref parsed 3)
|
|
(aref parsed 2))))
|
|
;; Whenever there is a change in JID...
|
|
(when (not (equal jid current-jid))
|
|
(when current-jid
|
|
;; ...save data for previous JID...
|
|
(let ((history-file (jabber-history-filename current-jid)))
|
|
(write-region jid-start start history-file t 'quiet)))
|
|
;; ...and switch to new JID.
|
|
(setq current-jid jid)
|
|
(setq jid-start start))
|
|
(when (fboundp 'progress-reporter-update)
|
|
(progress-reporter-update progress-reporter (point)))))
|
|
;; Finally, save the last block, if any.
|
|
(when current-jid
|
|
(let ((history-file (jabber-history-filename current-jid)))
|
|
(write-region jid-start (point-max) history-file t 'quiet))))))
|
|
(message "Done. Please change `jabber-use-global-history' now."))
|
|
|
|
(provide 'jabber-history)
|
|
|
|
;; arch-tag: 0AA0C235-3FC0-11D9-9FE7-000A95C2FCD0
|