summaryrefslogtreecommitdiffhomepage
path: root/attic/net
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2021-08-19 01:49:40 +0100
committerjao <jao@gnu.org>2021-08-19 01:49:46 +0100
commit26f7ffb67c1740835e966fe3832a6ddf9bc0b9cf (patch)
treec91e423f1ea4fc0779ac57eb74eaacdb085b07ac /attic/net
parent62fdbb8a4e0925eed13c07a646f92cbaab49d5b2 (diff)
downloadelibs-26f7ffb67c1740835e966fe3832a6ddf9bc0b9cf.tar.gz
elibs-26f7ffb67c1740835e966fe3832a6ddf9bc0b9cf.tar.bz2
attic misc rename
Diffstat (limited to 'attic/net')
-rw-r--r--attic/net/jao-notmuch-tree-fold.el139
-rw-r--r--attic/net/nnnm.el265
2 files changed, 404 insertions, 0 deletions
diff --git a/attic/net/jao-notmuch-tree-fold.el b/attic/net/jao-notmuch-tree-fold.el
new file mode 100644
index 0000000..ef528df
--- /dev/null
+++ b/attic/net/jao-notmuch-tree-fold.el
@@ -0,0 +1,139 @@
+;;; jao-notmuch-tree-fold.el --- Show/hide (sub)tress in notmuch-tree -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 jao
+
+;; Author: jao <mail@jao.io>
+;; Keywords: mail
+
+;; 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/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'jao-notmuch)
+
+
+;; Show/hide threads
+
+(defun jao-notmuch--tree-top () (notmuch-tree-get-prop :first))
+
+(defun jao-notmuch--tree-bottom ()
+ (let ((line-move-ignore-invisible t))
+ (save-excursion
+ (when (zerop (forward-line 1))
+ (or (not (notmuch-tree-get-message-properties))
+ (jao-notmuch--tree-top))))))
+
+(defun jao-notmuch-tree-hide-thread ()
+ (interactive)
+ (notmuch-tree-thread-top)
+ (save-excursion
+ (forward-line 1)
+ (when (not (jao-notmuch--tree-top))
+ (let ((line-move-ignore-invisible nil)
+ (inhibit-read-only t)
+ (p (point)))
+ (unless (notmuch-tree-next-thread-in-tree)
+ (forward-line -1))
+ (add-text-properties p (point) '(invisible t))))))
+
+(defun jao-notmuch-tree-show-thread ()
+ (interactive)
+ (when (or (jao-notmuch--tree-top) (invisible-p (point)))
+ (let ((line-move-ignore-invisible nil))
+ (notmuch-tree-thread-top)
+ (let ((inhibit-read-only t)
+ (p (point)))
+ (notmuch-tree-next-thread-in-tree)
+ (remove-text-properties p (point) '(invisible nil))
+ (goto-char p)))))
+
+(defun jao-notmuch-tree-show-all ()
+ (interactive)
+ (let ((inhibit-read-only t))
+ (put-text-property (point-min) (point-max) 'invisible nil)))
+
+(defun jao-notmuch-tree-hide-all ()
+ (interactive)
+ (let ((inhibit-read-only t)
+ (line-move-ignore-invisible nil))
+ (goto-char (point-min))
+ (jao-notmuch-tree-hide-thread)
+ (while (notmuch-tree-next-thread-in-tree)
+ (jao-notmuch-tree-hide-thread)))
+ (goto-char (point-min)))
+
+(defun jao-notmuch-tree-toggle-thread ()
+ (interactive)
+ (let ((line-move-ignore-invisible nil))
+ (forward-line 1)
+ (when (jao-notmuch--tree-top)
+ (forward-line -1))
+ (if (invisible-p (point))
+ (jao-notmuch-tree-show-thread)
+ (jao-notmuch-tree-hide-thread))))
+
+(defvar notmuch-tree-thread-map
+ (let ((m (make-keymap "Thread operations")))
+ (define-key m (kbd "TAB") #'jao-notmuch-tree-toggle-thread)
+ (define-key m (kbd "t") #'jao-notmuch-tree-toggle-thread)
+ (define-key m (kbd "s") #'jao-notmuch-tree-show-thread)
+ (define-key m (kbd "S") #'jao-notmuch-tree-show-all)
+ (define-key m (kbd "h") #'jao-notmuch-tree-hide-thread)
+ (define-key m (kbd "H") #'jao-notmuch-tree-hide-all)
+ m))
+
+(defun jao-notmuch--tree-next (prev thread no-exit)
+ (let ((line-move-ignore-invisible t))
+ (cond ((looking-at-p "^End of search results")
+ (unless no-exit
+ (notmuch-tree-close-message-window)
+ (notmuch-tree-quit)))
+ ((jao-notmuch--looking-at-new-p)
+ (save-excursion (jao-notmuch-tree-show-thread))
+ (notmuch-tree-show-message nil))
+ (thread
+ (save-excursion (jao-notmuch-tree-hide-thread))
+ (when (notmuch-tree-next-thread prev)
+ (save-excursion (jao-notmuch-tree-show-thread)))
+ (unless (jao-notmuch--looking-at-new-p)
+ (notmuch-tree-matching-message prev (not no-exit))))
+ ((or (and (not prev) (jao-notmuch--tree-bottom))
+ (and prev (jao-notmuch--tree-top)))
+ (save-excursion (jao-notmuch-tree-hide-thread))
+ (forward-line (if prev -1 1))
+ (jao-notmuch--tree-next prev nil no-exit))
+ ((notmuch-tree-get-message-id)
+ (save-excursion (jao-notmuch-tree-show-thread))
+ (notmuch-tree-matching-message prev (not no-exit)))))
+ (when (notmuch-tree-get-message-id)
+ (notmuch-tree-show-message nil))
+ (jao-notmuch--tree-update-buffer-name))
+
+(defun jao-notmuch-tree-next (thread &optional no-exit)
+ "Next message or thread in forest, taking care of thread visibility."
+ (interactive "P")
+ (jao-notmuch--tree-next nil thread no-exit))
+
+(defun jao-notmuch-tree-previous (thread)
+ "Previous message or thread in forest, taking care of thread visibility.."
+ (interactive "P")
+ (jao-notmuch--tree-next t thread t))
+
+
+(provide 'jao-notmuch-tree-fold)
+;;; jao-notmuch-tree-fold.el ends here
diff --git a/attic/net/nnnm.el b/attic/net/nnnm.el
new file mode 100644
index 0000000..552e95c
--- /dev/null
+++ b/attic/net/nnnm.el
@@ -0,0 +1,265 @@
+;;; nnnm.el --- Gnus backend for notmuch -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 jao
+
+;; Author: jao <mail@jao.io>
+;; Keywords: mail
+
+;; 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/>.
+
+;;; Commentary:
+
+;; A Gnus mail backend using notmuch.
+
+;;; Code:
+
+(require 'gnus)
+(require 'nnheader)
+(require 'nnmail)
+(require 'nnoo)
+
+
+(nnoo-declare nnnm)
+
+(defvar nnnm-marks-to-tags '((tick . "flagged")))
+
+(defvar nnnm-saved-searches nil)
+
+(defvar nnnm-maildir nil)
+
+(defvar nnnm--group-data nil)
+
+(defun nnnm--group-data (group) (cdr (assoc group nnnm--group-data)))
+
+(defun nnnm--set-group-data (group data)
+ (setf (alist-get group nnnm--group-data nil t #'string=) data))
+
+
+(defun nnnm--find-query (name)
+ (when-let (s (seq-find (lambda (s) (string= (plist-get s :name) name))
+ nnnm-saved-searches))
+ (plist-get s :query)))
+
+(defun nnnm--find-message-file (id)
+ (car (split-string
+ (shell-command-to-string
+ (format "notmuch search --output=files %s"
+ (if (string-prefix-p "id:" id) id (concat "id:" id)))))))
+
+(defun nnnm--article-data (article group)
+ (cond ((stringp article) (list article))
+ ((numberp article)
+ (when-let (data (nnnm--group-data group))
+ (elt data (1- article))))))
+
+(defun nnnm-article-to-file (article group)
+ (when-let (d (nnnm--article-data article group))
+ (or (cadr d) (nnnm--find-message-file (car d)))))
+
+(defun nnnm--count (query &optional context)
+ (let ((cmd (format "notmuch count -- '(%s)%s'"
+ query
+ (if context (concat " AND " context) ""))))
+ (string-to-number (shell-command-to-string cmd))))
+
+(defun nnnm--search (query &optional context)
+ (let ((cmd (format "notmuch search --sort=oldest-first --output=messages -- %s%s"
+ (shell-quote-argument (format "(%s)" query))
+ (if context (concat " AND " context) ""))))
+ (split-string (shell-command-to-string cmd))))
+
+(defun nnnm--tag (query tags)
+ (let ((cmd (format "notmuch tag %s -- '(%s)'" tags query)))
+ (shell-command-to-string cmd)))
+
+(defun nnnm--ids-query (ids) (mapconcat #'identity ids " OR "))
+
+(defun nnnm--prefixed (group server)
+ (gnus-group-prefixed-name group `(nnnm ,server)))
+
+(defun nnnm--get-group-marks (group server)
+ (gnus-info-marks (gnus-get-info (nnnm--prefixed group server))))
+
+(defun nnnm--set-group-marks (marks group server)
+ (let* ((full-group (nnnm--prefixed group server))
+ (info (gnus-get-info full-group)))
+ (gnus-info-set-marks info marks)
+ (gnus-set-info full-group info)))
+
+(defun nnnm--subtract-from-ranges (ranges lst)
+ (let ((ranges (gnus-uncompress-sequence ranges)))
+ (dolist (n lst)
+ (let ((rs (seq-group-by (lambda (r) (> n r)) ranges)))
+ (setq ranges
+ (append (alist-get t rs) (mapcar #'1- (alist-get nil rs))))))
+ (gnus-compress-sequence ranges)))
+
+(defun nnnm--remove-articles-from-marks (ranges group server)
+ (let ((marks (nnnm--get-group-marks group server))
+ (lst (gnus-uncompress-sequence ranges))
+ (new-marks))
+ (dolist (m marks)
+ (push (cons (car m) (nnnm--subtract-from-ranges (cdr m))) lst))
+ (nnnm--set-group-marks marks group server)))
+
+(defun nnnm--set-active (n group server)
+ (gnus-set-active (nnnm--prefixed group server) (cons 1 n)))
+
+(defun nnnm--update-group-data (group &optional server)
+ (when-let (query (nnnm--find-query group))
+ (let* ((data (or (nnnm--group-data group)
+ (mapcar #'list (nnnm--search query "NOT tag:new"))))
+ (ids (nnnm--search query "tag:new"))
+ (nids (length ids))
+ (new-data (mapcar (lambda (id)
+ (list id (nnnm--find-message-file id)))
+ ids)))
+ (when (> nids 0)
+ (nnnm--tag (nnnm--ids-query ids) "-new")
+ (nnheader-report 'nnnm "%s: %d new messages retrieved" group nids))
+ (nnnm--set-group-data group (append data new-data))
+ (nnnm--set-active (+ nids (length data)) group server)
+ (length ids))))
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nnnm)
+
+(defun nnnm-request-type (_group &optional _article)
+ 'mail)
+
+(deffoo nnnm-open-server (server &optional defs)
+ (nnoo-change-server 'nnnm server defs)
+ (setq nnnm--group-data nil)
+ (nnheader-report 'nnnm "Opened server %s" server)
+ t)
+
+(deffoo nnnm-close-server (_server)
+ (setq nnnm--group-data nil))
+
+(deffoo nnnm-request-regenerate (_server)
+ (setq nnnm--group-data nil)
+ t)
+
+(deffoo nnnm-request-list (&optional _server)
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (dolist (s nnnm-saved-searches)
+ (when-let (query (plist-get s :query))
+ (let ((name (plist-get s :name))
+ (total (nnnm--count query)))
+ (insert (format "%s %d 1 y\n" name total))))))
+ t)
+
+(deffoo nnnm-retrieve-headers (sequence &optional group server _fetch-old)
+ (when (nnnm--update-group-data group server)
+ (with-current-buffer nntp-server-buffer
+ (delete-region (point-min) (point-max))
+ (let ((file-name-coding-system nnmail-pathname-coding-system)
+ (count -1))
+ (if (stringp (car sequence))
+ 'headers
+ (dolist (article sequence)
+ (when-let (file (nnnm-article-to-file article group))
+ (insert (format "221 %d Article retrieved.\n" article))
+ (save-excursion (nnheader-insert-head file))
+ (if (re-search-forward "\n\r?\n" nil t)
+ (forward-char -1)
+ (goto-char (point-max))
+ (insert "\n\n"))
+ (insert ".\n")
+ (delete-region (point) (point-max)))
+ (when (zerop (% (cl-incf count) 20))
+ (nnheader-message 6 "nnnm: Receiving headers... %d%%"
+ (floor (* count 100.0) (length sequence)))))
+ (nnheader-fold-continuation-lines)
+ 'headers)))))
+
+(deffoo nnnm-request-article (id &optional group _server buffer)
+ (let* ((nntp-server-buffer (or buffer nntp-server-buffer))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ (d (nnnm--article-data id group))
+ (id (car d))
+ (file (when id (or (cadr d) (nnnm--find-message-file id)))))
+ (cond
+ ((not file)
+ (nnheader-report 'nnnm "No such article: %s" id))
+ ((not (file-exists-p file))
+ (nnheader-report 'nnnm "No such file: %s" file))
+ ((not (save-excursion (nnmail-find-file file)))
+ (nnheader-report 'nnnm "Couldn't read file: %s" file))
+ (t
+ (nnnm--tag id "-unread")
+ (nnheader-report 'nnnm "Article %s retrieved and tagged" id)
+ (cons group id)))))
+
+(deffoo nnnm-request-expire-articles (articles group &optional _server _force)
+ (let* ((articles (gnus-uncompress-range articles))
+ (ids (mapcar (lambda (a) (car (nnnm--article-data a group))) articles)))
+ (when ids
+ (nnnm--tag (nnnm--ids-query ids) "+deleted")
+ (let ((data (nnnm--group-data group)))
+ (dolist (id ids)
+ (setq data
+ (cl-delete-if (lambda (d) (string= (car d) id)) data :count 1)))
+ (nnnm--set-group-data group data)
+ (nnnm--remove-articles-from-marks articles group server)
+ (nnnm--set-active (length data) group server)))
+ articles))
+
+(deffoo nnnm-request-set-mark (group actions &optional _server)
+ (message "set marks: %s: %S" group actions)
+ actions)
+
+;; (deffoo nnnm-request-move-article
+;; (article group server accept-form &optional last _move-is-internal)
+;; (error "Not implemented yet"))
+
+(deffoo nnnm-request-group (group &optional server _dont-check info)
+ (nnheader-message 7 "nnnm: Opening %s -- %s" info group)
+ (if (nnnm--update-group-data group server)
+ (let ((n (length (nnnm--group-data group))))
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (nnheader-insert "211 %d %d %d %s\n" n 1 n group)
+ n))
+ (nnheader-report 'nnnm "Invalid group")))
+
+(deffoo nnnm-request-newgroups (_date &optional server)
+ (nnnm-request-list server))
+
+(deffoo nnnm-request-group-scan (group &optional server _info)
+ (nnnm--set-group-data group nil)
+ (nnnm--update-group-data group server))
+
+(deffoo nnnm-request-scan (&optional group server)
+ (if group
+ (nnnm--update-group-data group server)
+ (setq nnnm--group-data nil)))
+
+(deffoo nnnm-request-create-group (group &optional _server _args)
+ (let ((query (read-string "Query: ")))
+ (add-to-list 'nnnm-saved-searches `(:name ,group :query ,query))))
+
+;; (deffoo nnnm-request-rename-group (group new-name &optional _server)
+;; (error "Not implemented yet"))
+
+(deffoo nnnm-close-group (_group &optional _server) t)
+
+
+
+(provide 'nnnm)
+;;; nnnm.el ends here