aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKyle Meyer <kyle@kyleam.com>2021-06-05 17:13:50 -0400
committerKyle Meyer <kyle@kyleam.com>2021-06-07 00:12:06 -0400
commiteb40c78da8217b22681f5c42d74d9bc64eff1e77 (patch)
treedbe95133e36752fe87571c2a621dc9510e26d614
parent2a4f6fb5ac71e0805d145dec52a6e8e2ea6d9d76 (diff)
downloadpiem-eb40c78da8217b22681f5c42d74d9bc64eff1e77.tar.gz
lei: Add command for viewing a thread
piem-lei-query presents a message-based overview. In many cases the caller will want to use that search result as a seed for finding the associated thread. Add a command that construct thread for a given message. The threading algorithm is based on public-inbox's. Some details may have been lost in translation, but I haven't spotted any differences yet when doing side-by-side comparisons of output from piem-lei-query-thread and public-inbox's web interface. And testing with a few ~100-message threads, the performance seems to be okay. The appearance also follows public-inbox's, which I like. Message-Id: <20210605211402.20304-7-kyle@kyleam.com>
-rw-r--r--Makefile3
-rw-r--r--piem-lei.el147
-rw-r--r--tests/piem-lei-tests.el74
-rw-r--r--tests/piem-tests.el1
4 files changed, 224 insertions, 1 deletions
diff --git a/Makefile b/Makefile
index dac422b..b8d9fe6 100644
--- a/Makefile
+++ b/Makefile
@@ -6,7 +6,7 @@ BATCH = $(EMACS) --batch -Q -L . -L tests
EL = piem.el piem-b4.el piem-elfeed.el piem-eww.el piem-gnus.el \
piem-lei.el piem-maildir.el piem-notmuch.el piem-rmail.el \
- tests/piem-rmail-tests.el tests/piem-tests.el
+ tests/piem-lei-tests.el tests/piem-rmail-tests.el tests/piem-tests.el
ELC = $(EL:.el=.elc)
all: compile Documentation/piem.info piem-autoloads.el
@@ -40,6 +40,7 @@ piem-maildir.elc: piem-maildir.el
piem-notmuch.elc: piem-notmuch.el piem.elc
piem-rmail.elc: piem-rmail.el piem.elc
piem.elc: piem.el piem-maildir.elc
+tests/piem-lei-tests.elc: tests/piem-lei-tests.el piem-lei.elc
tests/piem-rmail-tests.elc: tests/piem-rmail-tests.el piem-rmail.elc
tests/piem-tests.elc: tests/piem-tests.el piem.elc
diff --git a/piem-lei.el b/piem-lei.el
index 12ccd87..1b74421 100644
--- a/piem-lei.el
+++ b/piem-lei.el
@@ -21,6 +21,8 @@
;;; Code:
+(require 'cl-lib)
+(require 'iso8601)
(require 'json)
(require 'message)
(require 'piem)
@@ -226,5 +228,150 @@ line."
(setq buffer-read-only t)
(setq-local line-move-visual t))
+
+;;;;; Threading
+
+;; The approach here tries to loosely follow what is in public-inbox's
+;; SearchThread.pm, which in turn is a modified version of the
+;; algorithm described at <https://www.jwz.org/doc/threading.html>.
+
+(cl-defstruct piem-lei-msg mid parent children time ghost)
+
+(defun piem-lei-query--add-child (parent child)
+ (let ((mid-parent (piem-lei-msg-mid parent))
+ (mid-child (piem-lei-msg-mid child)))
+ (when (equal mid-parent mid-child)
+ (error "Parent and child have same message ID: %s"
+ mid-parent))
+ (when-let ((parent-old (piem-lei-msg-parent child)))
+ (setf (piem-lei-msg-children parent-old)
+ (delq child (piem-lei-msg-children parent-old))))
+ (push child (piem-lei-msg-children parent))
+ (setf (piem-lei-msg-parent child) parent)))
+
+(defun piem-lei-query--has-descendant (msg1 msg2)
+ "Is MSG2 a descendant of MSG1?"
+ (let ((msg1-mid (piem-lei-msg-mid msg1))
+ seen)
+ (catch 'stop
+ (while msg2
+ (let ((msg2-mid (piem-lei-msg-mid msg2)))
+ (when (or (equal msg1-mid msg2-mid)
+ (member msg2 seen))
+ (throw 'stop t))
+ (push msg2-mid seen))
+ (setq msg2 (piem-lei-msg-parent msg2)))
+ nil)))
+
+(defun piem-lei-query--thread (records)
+ "Thread messages in RECORDS.
+
+RECORDS is a list of alists with information from `lei q'. This
+information is used to construct, link, and order `piem-lei-msg'
+objects.
+
+Return a list with a `piem-lei-msg' object for each root."
+ (let ((thread (make-hash-table :test #'equal)))
+ (dolist (record records)
+ (let ((mid (cdr (assq 'm record))))
+ (puthash mid
+ (make-piem-lei-msg
+ :mid mid :time (cdr (assq 'time record)))
+ thread)))
+ (dolist (record (sort (copy-sequence records)
+ (lambda (a b)
+ (time-less-p (cdr (assq 'time a))
+ (cdr (assq 'time b))))))
+ (let ((msg-prev nil)
+ (msg-cur (gethash (cdr (assq 'm record)) thread)))
+ (dolist (ref (cdr (assq 'refs record)))
+ (let ((msg (or (gethash ref thread)
+ (puthash ref
+ (make-piem-lei-msg :mid ref :ghost t)
+ thread))))
+ (when (and msg-prev
+ (not (piem-lei-msg-parent msg))
+ (not (piem-lei-query--has-descendant msg msg-prev)))
+ (piem-lei-query--add-child msg-prev msg))
+ (setq msg-prev msg)))
+ (when (and msg-prev
+ (not (piem-lei-query--has-descendant msg-cur msg-prev)))
+ (piem-lei-query--add-child msg-prev msg-cur))))
+ (let (roots)
+ (maphash
+ (lambda (_ v)
+ (setf (piem-lei-msg-children v)
+ (sort (piem-lei-msg-children v)
+ (lambda (a b)
+ (time-less-p (piem-lei-msg-time a)
+ (piem-lei-msg-time b)))))
+ (unless (piem-lei-msg-parent v)
+ (push v roots)))
+ thread)
+ (nreverse roots))))
+
+(defun piem-lei-query--format-thread-marker (level)
+ (if (= level 0)
+ ""
+ (concat (make-string (* 2 (1- level)) ?\s)
+ "` ")))
+
+(defun piem-lei-query--slurp (args)
+ (with-temp-buffer
+ (apply #'call-process "lei" nil '(t nil) nil
+ "q" "--format=ldjson" args)
+ (goto-char (point-min))
+ (let (items)
+ (while (not (eobp))
+ (let ((item (piem-lei-query--read-json-item)))
+ (push (cons 'time (encode-time
+ (iso8601-parse (cdr (assq 'dt item)))))
+ item)
+ (push (cons (cdr (assq 'm item)) item) items))
+ (forward-line))
+ (nreverse items))))
+
+(defun piem-lei-query-thread (mid)
+ "Show thread containing message MID."
+ (interactive
+ (list (or (piem-lei-query-get-mid)
+ (read-string "Message ID: " nil nil (piem-mid)))))
+ (let* ((records (piem-lei-query--slurp
+ (list "--threads" (concat "m:" mid))))
+ (msgs (piem-lei-query--thread records))
+ depths)
+ (with-current-buffer (get-buffer-create "*lei-thread*")
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (while msgs
+ (let* ((msg (pop msgs))
+ (mid-msg (piem-lei-msg-mid msg))
+ (children (piem-lei-msg-children msg))
+ (depth (1+ (or (cdr (assoc (piem-lei-msg-parent msg) depths))
+ -1))))
+ (when children
+ (setq msgs (append children msgs)))
+ (push (cons msg depth) depths)
+ (if (not (piem-lei-msg-ghost msg))
+ (let ((data (cdr (assoc mid-msg records))))
+ (insert
+ (piem-lei-query--format-date data) " "
+ (piem-lei-query--format-thread-marker depth)
+ (let ((from (car (cdr (assq 'f data)))))
+ (or (car from) (cadr from)))
+ (concat " "
+ (cdr (assq 's data))))
+ (add-text-properties (line-beginning-position)
+ (line-end-position)
+ (list 'piem-lei-query-result data)))
+ (insert (make-string 17 ?\s) ; Date alignment.
+ (piem-lei-query--format-thread-marker depth)
+ (concat " <" mid-msg ">")))
+ (insert ?\n)))
+ (insert "End of lei-q results"))
+ (goto-char (point-min))
+ (piem-lei-query-mode)
+ (pop-to-buffer-same-window (current-buffer)))))
+
;;; piem-lei.el ends here
(provide 'piem-lei)
diff --git a/tests/piem-lei-tests.el b/tests/piem-lei-tests.el
new file mode 100644
index 0000000..e20c62f
--- /dev/null
+++ b/tests/piem-lei-tests.el
@@ -0,0 +1,74 @@
+;;; piem-lei-tests.el --- tests for piem-lei -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 all contributors <piem@inbox.kyleam.com>
+
+;; Author: Kyle Meyer <kyle@kyleam.com>
+
+;; 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 3 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, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'piem-lei)
+
+(ert-deftest piem-lei-query--add-child ()
+ (should-error
+ (piem-lei-query--add-child
+ (make-piem-lei-msg :mid "m1")
+ (make-piem-lei-msg :mid "m1")))
+ (let ((m1 (make-piem-lei-msg :mid "m1"))
+ (m2 (make-piem-lei-msg :mid "m2")))
+ (piem-lei-query--add-child m1 m2)
+ (should (equal (piem-lei-msg-parent m2) m1))
+ (should (equal (piem-lei-msg-children m1) (list m2))))
+ (let ((m1 (make-piem-lei-msg :mid "m1"))
+ (m2 (make-piem-lei-msg :mid "m2"))
+ (m3 (make-piem-lei-msg :mid "m3"))
+ (m4 (make-piem-lei-msg :mid "m4")))
+ (piem-lei-query--add-child m1 m2)
+ (piem-lei-query--add-child m1 m4)
+ (piem-lei-query--add-child m3 m2)
+ (should (equal (piem-lei-msg-parent m2) m3))
+ (should (equal (piem-lei-msg-children m1) (list m4)))
+ (should (equal (piem-lei-msg-children m3) (list m2)))))
+
+(ert-deftest piem-lei-query--has-descendant ()
+ (let ((m1 (make-piem-lei-msg :mid "m1"))
+ (m2 (make-piem-lei-msg :mid "m2")))
+ (should-not
+ (piem-lei-query--has-descendant m1 m2))
+ (should-not
+ (piem-lei-query--has-descendant m2 m1)))
+ (let ((m1 (make-piem-lei-msg :mid "m1")))
+ (should (piem-lei-query--has-descendant m1 m1)))
+ (let ((m1 (make-piem-lei-msg :mid "m1"))
+ (m2 (make-piem-lei-msg :mid "m2")))
+ (piem-lei-query--add-child m1 m2)
+ (should (piem-lei-query--has-descendant m1 m2))
+ (should-not
+ (piem-lei-query--has-descendant m2 m1)))
+ (let ((m1 (make-piem-lei-msg :mid "m1"))
+ (m2 (make-piem-lei-msg :mid "m2"))
+ (m3 (make-piem-lei-msg :mid "m3")))
+ (piem-lei-query--add-child m1 m2)
+ (piem-lei-query--add-child m2 m3)
+ (should (piem-lei-query--has-descendant m1 m2))
+ (should (piem-lei-query--has-descendant m1 m3))
+ (should (piem-lei-query--has-descendant m2 m3))
+ (should-not (piem-lei-query--has-descendant m2 m1))
+ (should-not (piem-lei-query--has-descendant m3 m2))
+ (should-not (piem-lei-query--has-descendant m3 m1))))
+
+(provide 'piem-lei-tests)
+;;; piem-lei-tests.el ends here
diff --git a/tests/piem-tests.el b/tests/piem-tests.el
index 5f01a5e..91beb9a 100644
--- a/tests/piem-tests.el
+++ b/tests/piem-tests.el
@@ -21,6 +21,7 @@
(require 'ert)
(require 'piem)
+(require 'piem-lei-tests)
(require 'piem-rmail-tests)
(ert-deftest piem-message-link-re ()