summaryrefslogtreecommitdiffhomepage
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/net/nnnm.el269
-rw-r--r--lib/net/nnnotmuch.el269
2 files changed, 269 insertions, 269 deletions
diff --git a/lib/net/nnnm.el b/lib/net/nnnm.el
new file mode 100644
index 0000000..173c975
--- /dev/null
+++ b/lib/net/nnnm.el
@@ -0,0 +1,269 @@
+;;; 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)
+(require 'notmuch)
+
+(nnoo-declare nnnm)
+
+(defvoo nnnm-directory message-directory
+ "Spool directory for the nnnm mail backend.")
+
+(defvoo nnnm-inhibit-expiry nil
+ "If non-nil, inhibit expiry.")
+
+(defvoo nnnm-saved-searches nil)
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nnnm)
+
+(deffoo nnnm-open-server (server &optional defs)
+ (nnoo-change-server 'nnnm server defs)
+ (setq nnnm-article-files nil)
+ (cond
+ ((not (file-exists-p nnnm-directory))
+ (nnnm-close-server)
+ (nnheader-report 'nnnm "Directory doesn't exist: %s" nnnm-directory))
+ ((not (file-directory-p (file-truename nnnm-directory)))
+ (nnnm-close-server)
+ (nnheader-report 'nnnm "Not a directory: %s" nnnm-directory))
+ (t
+ (nnheader-report 'nnnm "Opened server %s using directory %s"
+ server nnnm-directory)
+ t)))
+
+(deffoo nnnm-close-server (server)
+ (setq nnnm-article-files nil))
+
+(deffoo nnnm-request-regenerate (server)
+ (setq nnnm-article-files nil)
+ (nnnm--tag "*" "-nnnm")
+ t)
+
+(deffoo nnnm-request-list (&optional _server)
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (dolist (s nnnm-saved-searches)
+ (when-let (q (plist-get s :query))
+ (let ((name (plist-get s :name))
+ (total (nnnm--count q)))
+ (insert (format "%s %d 1 y\n" name total))))))
+ t)
+
+(deffoo nnnm-retrieve-headers (sequence &optional group server _fetch-old)
+ (message "retrieving headers for sequence %s" sequence)
+ (when (nnnm-set-group-context group server)
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (let* ((file nil)
+ (number (length sequence))
+ (count 0)
+ (file-name-coding-system nnmail-pathname-coding-system)
+ beg article)
+ (if (stringp (car sequence))
+ 'headers
+ (while sequence
+ (setq article (car sequence))
+ (setq file (nnnm-article-to-file article group))
+ (when (and file
+ (file-exists-p file)
+ (not (file-directory-p file)))
+ (insert (format "221 %d Article retrieved.\n" article))
+ (setq beg (point))
+ (nnheader-insert-head file)
+ (goto-char beg)
+ (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)))
+ (setq sequence (cdr sequence))
+ (setq count (1+ count))
+ (and (numberp nnmail-large-newsgroup)
+ (> number nnmail-large-newsgroup)
+ (zerop (% count 20))
+ (nnheader-message 6 "nnnm: Receiving headers... %d%%"
+ (floor (* count 100.0) number))))
+ (and (numberp nnmail-large-newsgroup)
+ (> number nnmail-large-newsgroup)
+ (nnheader-message 6 "nnml: Receiving headers...done"))
+ (nnheader-fold-continuation-lines)
+ 'headers)))))
+
+(deffoo nnnm-request-article (id &optional group _server buffer)
+ ;; (nnnm-set-group-context group server)
+ (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 (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))
+ ((file-directory-p file)
+ (nnheader-report 'nnnm "File is a directory: %s" file))
+ ((not (save-excursion (nnmail-find-file file)))
+ (nnheader-report 'nnnm "Couldn't read file: %s" file))
+ (t
+ (nnnm--tag id "+nnnm")
+ (nnheader-report 'nnnm "Article %s retrieved" id)
+ (cons group id)))))
+
+(deffoo nnnm-request-expire-articles (articles group &optional _server _force)
+ (let ((excluded) (ids))
+ (dolist (a articles)
+ (if-let (id (car (nnnm--article-data a group)))
+ (push id ids)
+ (push a excluded)))
+ (when ids
+ (nnnm--tag (mapconcat #'identity ids " OR ") "+deleted +nnnm"))
+ excluded))
+
+;; (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)
+ (message "opening %s" group)
+ (if (nnnm-set-group-context group server)
+ (let ((n (length (cdr (assoc group nnnm-article-files)))))
+ (message "we found here %s articles" n)
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (nnheader-insert "211 %d %d %d %s\n" n 1 n group)
+ n))
+ (message "we didn't find anything!!")
+ (nnheader-report 'nnnm "Invalid group")))
+
+(deffoo nnnm-request-group-scan (group &optional server _info)
+ (nnnm-set-group-context group server))
+
+(deffoo nnnm-request-scan (&optional group server)
+ (nnnm-set-group-context group server))
+
+(deffoo nnnm-close-group (_group &optional _server)
+ t)
+
+(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-newgroups (_date &optional server)
+ (nnnm-request-list server))
+
+;; (deffoo nnnm-request-rename-group (group new-name &optional _server)
+;; (error "Not implemented yet"))
+
+
+
+(defvar nnnm-article-files nil)
+
+(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 (cdr (assoc group nnnm-article-files)))
+ (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--init-data (full-group query)
+ (nnnm--tag (concat query " AND NOT tag:new AND not tag:nnnm")
+ "+nnnm")
+ (let* ((ids (nnnm--search query "tag:nnnm"))
+ (info (gnus-get-info full-group))
+ (read (when (> (length ids) 0) (list (cons 1 (length ids)))))
+ (marks (list (cons 'seen read))))
+ (gnus-info-set-marks info marks)
+ (setf (gnus-info-read info) read)
+ (gnus-set-info full-group info)
+ (message "group %s - %s" full-group (gnus-get-info full-group))
+ (mapcar #'list ids)))
+
+(defun nnnm--set-group-data (group data)
+ (setf (alist-get group nnnm-article-files nil t #'string=) data))
+
+(defun nnnm-set-group-context (group &optional server)
+ (when (and server (not (nnnm-server-opened server)))
+ (nnnm-open-server server))
+ (when-let (query (nnnm--find-query group))
+ (setq nnnm-current-group group)
+ (let* ((full-group (gnus-group-prefixed-name group `(nnnm ,server)))
+ (data (or (cdr (assoc group nnnm-article-files))
+ (nnnm--init-data full-group query)))
+ (ids (nnnm--search query "tag:new AND NOT tag:nnnm"))
+ (new-data (mapcar (lambda (id)
+ (list id (nnnm--find-message-file id)))
+ ids)))
+ (when (> (length ids) 0)
+ (nnnm--tag (nnnm--ids-query ids) "-new"))
+ (nnnm--set-group-data group (append data new-data))
+ (gnus-set-active (gnus-group-prefixed-name group `(nnnm ,server))
+ (cons 1 (+ (length new-data) (length data)))))))
+
+
+
+(provide 'nnnm)
+;;; nnnm.el ends here
diff --git a/lib/net/nnnotmuch.el b/lib/net/nnnotmuch.el
deleted file mode 100644
index a5fe09d..0000000
--- a/lib/net/nnnotmuch.el
+++ /dev/null
@@ -1,269 +0,0 @@
-;;; nnnotmuch.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)
-(require 'notmuch)
-
-(nnoo-declare nnnotmuch)
-
-(defvoo nnnotmuch-directory message-directory
- "Spool directory for the nnnotmuch mail backend.")
-
-(defvoo nnnotmuch-inhibit-expiry nil
- "If non-nil, inhibit expiry.")
-
-(defvoo nnnotmuch-saved-searches nil)
-
-
-
-;;; Interface functions.
-
-(nnoo-define-basics nnnotmuch)
-
-(deffoo nnnotmuch-open-server (server &optional defs)
- (nnoo-change-server 'nnnotmuch server defs)
- (setq nnnotmuch-article-files nil)
- (cond
- ((not (file-exists-p nnnotmuch-directory))
- (nnnotmuch-close-server)
- (nnheader-report 'nnnotmuch "Directory doesn't exist: %s" nnnotmuch-directory))
- ((not (file-directory-p (file-truename nnnotmuch-directory)))
- (nnnotmuch-close-server)
- (nnheader-report 'nnnotmuch "Not a directory: %s" nnnotmuch-directory))
- (t
- (nnheader-report 'nnnotmuch "Opened server %s using directory %s"
- server nnnotmuch-directory)
- t)))
-
-(deffoo nnnotmuch-close-server (server)
- (setq nnnotmuch-article-files nil))
-
-(deffoo nnnotmuch-request-regenerate (server)
- (setq nnnotmuch-article-files nil)
- (nnnotmuch--tag "*" "-nnnotmuch")
- t)
-
-(deffoo nnnotmuch-request-list (&optional _server)
- (with-current-buffer nntp-server-buffer
- (erase-buffer)
- (dolist (s nnnotmuch-saved-searches)
- (when-let (q (plist-get s :query))
- (let ((name (plist-get s :name))
- (total (nnnotmuch--count q)))
- (insert (format "%s %d 1 y\n" name total))))))
- t)
-
-(deffoo nnnotmuch-retrieve-headers (sequence &optional group server _fetch-old)
- (message "retrieving headers for sequence %s" sequence)
- (when (nnnotmuch-set-group-context group server)
- (with-current-buffer nntp-server-buffer
- (erase-buffer)
- (let* ((file nil)
- (number (length sequence))
- (count 0)
- (file-name-coding-system nnmail-pathname-coding-system)
- beg article)
- (if (stringp (car sequence))
- 'headers
- (while sequence
- (setq article (car sequence))
- (setq file (nnnotmuch-article-to-file article group))
- (when (and file
- (file-exists-p file)
- (not (file-directory-p file)))
- (insert (format "221 %d Article retrieved.\n" article))
- (setq beg (point))
- (nnheader-insert-head file)
- (goto-char beg)
- (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)))
- (setq sequence (cdr sequence))
- (setq count (1+ count))
- (and (numberp nnmail-large-newsgroup)
- (> number nnmail-large-newsgroup)
- (zerop (% count 20))
- (nnheader-message 6 "nnnotmuch: Receiving headers... %d%%"
- (floor (* count 100.0) number))))
- (and (numberp nnmail-large-newsgroup)
- (> number nnmail-large-newsgroup)
- (nnheader-message 6 "nnml: Receiving headers...done"))
- (nnheader-fold-continuation-lines)
- 'headers)))))
-
-(deffoo nnnotmuch-request-article (id &optional group _server buffer)
- ;; (nnnotmuch-set-group-context group server)
- (let* ((nntp-server-buffer (or buffer nntp-server-buffer))
- (file-name-coding-system nnmail-pathname-coding-system)
- (d (nnnotmuch--article-data id group))
- (id (car d))
- (file (or (cadr d) (nnnotmuch--find-message-file id))))
- (cond
- ((not file)
- (nnheader-report 'nnnotmuch "No such article: %s" id))
- ((not (file-exists-p file))
- (nnheader-report 'nnnotmuch "No such file: %s" file))
- ((file-directory-p file)
- (nnheader-report 'nnnotmuch "File is a directory: %s" file))
- ((not (save-excursion (nnmail-find-file file)))
- (nnheader-report 'nnnotmuch "Couldn't read file: %s" file))
- (t
- (nnnotmuch--tag id "+nnnotmuch")
- (nnheader-report 'nnnotmuch "Article %s retrieved" id)
- (cons group id)))))
-
-(deffoo nnnotmuch-request-expire-articles (articles group &optional _server _force)
- (let ((excluded) (ids))
- (dolist (a articles)
- (if-let (id (car (nnnotmuch--article-data a group)))
- (push id ids)
- (push a excluded)))
- (when ids
- (nnnotmuch--tag (mapconcat #'identity ids " OR ") "+deleted +nnnotmuch"))
- excluded))
-
-;; (deffoo nnnotmuch-request-move-article
-;; (article group server accept-form &optional last _move-is-internal)
-;; (error "Not implemented yet"))
-
-(deffoo nnnotmuch-request-group (group &optional server _dont-check _info)
- (message "opening %s" group)
- (if (nnnotmuch-set-group-context group server)
- (let ((n (length (cdr (assoc group nnnotmuch-article-files)))))
- (message "we found here %s articles" n)
- (with-current-buffer nntp-server-buffer
- (erase-buffer)
- (nnheader-insert "211 %d %d %d %s\n" n 1 n group)
- n))
- (message "we didn't find anything!!")
- (nnheader-report 'nnnotmuch "Invalid group")))
-
-(deffoo nnnotmuch-request-group-scan (group &optional server _info)
- (nnnotmuch-set-group-context group server))
-
-(deffoo nnnotmuch-request-scan (&optional group server)
- (nnnotmuch-set-group-context group server))
-
-(deffoo nnnotmuch-close-group (_group &optional _server)
- t)
-
-(deffoo nnnotmuch-request-create-group (group &optional _server _args)
- (let ((query (read-string "Query: ")))
- (add-to-list 'nnnotmuch-saved-searches `(:name ,group :query ,query))))
-
-(deffoo nnnotmuch-request-newgroups (_date &optional server)
- (nnnotmuch-request-list server))
-
-;; (deffoo nnnotmuch-request-rename-group (group new-name &optional _server)
-;; (error "Not implemented yet"))
-
-
-
-(defvar nnnotmuch-article-files nil)
-
-(defun nnnotmuch--find-query (name)
- (when-let (s (seq-find (lambda (s) (string= (plist-get s :name) name))
- nnnotmuch-saved-searches))
- (plist-get s :query)))
-
-(defun nnnotmuch--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 nnnotmuch--article-data (article group)
- (cond ((stringp article) (list article))
- ((numberp article)
- (when-let (data (cdr (assoc group nnnotmuch-article-files)))
- (elt data (1- article))))))
-
-(defun nnnotmuch-article-to-file (article group)
- (when-let (d (nnnotmuch--article-data article group))
- (or (cadr d) (nnnotmuch--find-message-file (car d)))))
-
-(defun nnnotmuch--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 nnnotmuch--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 nnnotmuch--tag (query tags)
- (let ((cmd (format "notmuch tag %s -- '(%s)'" tags query)))
- (shell-command-to-string cmd)))
-
-(defun nnnotmuch--ids-query (ids) (mapconcat #'identity ids " OR "))
-
-(defun nnnotmuch--init-data (full-group query)
- (nnnotmuch--tag (concat query " AND NOT tag:new AND not tag:nnnotmuch")
- "+nnnotmuch")
- (let* ((ids (nnnotmuch--search query "tag:nnnotmuch"))
- (info (gnus-get-info full-group))
- (read (when (> (length ids) 0) (list (cons 1 (length ids)))))
- (marks (list (cons 'seen read))))
- (gnus-info-set-marks info marks)
- (setf (gnus-info-read info) read)
- (gnus-set-info full-group info)
- (message "group %s - %s" full-group (gnus-get-info full-group))
- (mapcar #'list ids)))
-
-(defun nnnotmuch--set-group-data (group data)
- (setf (alist-get group nnnotmuch-article-files nil t #'string=) data))
-
-(defun nnnotmuch-set-group-context (group &optional server)
- (when (and server (not (nnnotmuch-server-opened server)))
- (nnnotmuch-open-server server))
- (when-let (query (nnnotmuch--find-query group))
- (setq nnnotmuch-current-group group)
- (let* ((full-group (gnus-group-prefixed-name group `(nnnotmuch ,server)))
- (data (or (cdr (assoc group nnnotmuch-article-files))
- (nnnotmuch--init-data full-group query)))
- (ids (nnnotmuch--search query "tag:new AND NOT tag:nnnotmuch"))
- (new-data (mapcar (lambda (id)
- (list id (nnnotmuch--find-message-file id)))
- ids)))
- (when (> (length ids) 0)
- (nnnotmuch--tag (nnnotmuch--ids-query ids) "-new"))
- (nnnotmuch--set-group-data group (append data new-data))
- (gnus-set-active (gnus-group-prefixed-name group `(nnnotmuch ,server))
- (cons 1 (+ (length new-data) (length data)))))))
-
-
-
-(provide 'nnnotmuch)
-;;; nnnotmuch.el ends here