a not-quite-working (yet?) experiment: nnnotmuch

1 files changed, 276 insertions, 0 deletions

diff --git a/lib/net/nnnotmuch.el b/lib/net/nnnotmuch.el
new file mode 100644
index 0000000..7aa62eb
--- /dev/null
+++ b/lib/net/nnnotmuch.el
@@ -0,0 +1,276 @@
+;;; 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-retrieve-headers (sequence &optional group server fetch-old)
+  (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))
+	    (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-open-server (server &optional defs)
+  (nnoo-change-server 'nnnotmuch server defs)
+  (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-request-regenerate (server)
+  (nnnotmuch-set-group-context nil server)
+  t)
+
+(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)
+	 (path (if (stringp id)
+                   (nnnotmuch--find-message-file id)
+                 (nnnotmuch-article-to-file id))))
+    (cond
+     ((not path)
+      (nnheader-report 'nnnotmuch "No such article: %s" id))
+     ((not (file-exists-p path))
+      (nnheader-report 'nnnotmuch "No such file: %s" path))
+     ((file-directory-p path)
+      (nnheader-report 'nnnotmuch "File is a directory: %s" path))
+     ((not (save-excursion (nnmail-find-file path)))
+      (nnheader-report 'nnnotmuch "Couldn't read file: %s" path))
+     (t
+      (nnheader-report 'nnnotmuch "Article %s retrieved" id)
+      (cons group id)))))
+
+(deffoo nnnotmuch-request-group (group &optional server _dont-check info)
+  (cond
+   ((not (nnnotmuch-set-group-context group server))
+    (nnheader-report 'nnnotmuch "Invalid group"))
+   (t
+    (let* ((info (or info (gnus-get-info group)))
+           (num-headers (length nnnotmuch-article-files))
+           (status (format "211 %d %d %d %s" num-headers 1 num-headers group)))
+      (with-current-buffer nntp-server-buffer
+        (erase-buffer)
+        (nnheader-insert "%s\n" status)
+        ;; (when info
+        ;;   (gnus-info-set-marks
+        ;;    info
+        ;;    (append (assq-delete-all 'seen (gnus-info-marks info))
+        ;;            (list `(seen (1 . ,num-headers))))
+        ;;    t))
+        ))
+    t)))
+
+(deffoo nnnotmuch-request-group-scan (group &optional server info)
+  (setq nnnotmuch-article-files nil)
+  (nnnotmuch-set-group-context group server)
+  (gnus-get-unread-articles-in-group
+   (or info (gnus-get-info gnus-newsgroup-name))
+   (gnus-active (gnus-info-group info))))
+
+(deffoo nnnotmuch-request-scan (&optional group server)
+  (nnnotmuch-set-group-context group server))
+
+(deffoo nnnotmuch-close-group (_group &optional _server)
+  (setq nnnotmuch-article-files nil)
+  t)
+
+(deffoo nnnotmuch-request-create-group (group &optional server _args)
+  (nnnotmuch-set-group-context nil server)
+  (nnmail-activate 'nnnotmuch)
+  (error "Not implemented yet"))
+
+(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-files q))
+               (new (nnnotmuch--count-files q t))
+               (first (1+ (- total new))))
+          (insert (format "%s %d %d y\n" name total first))))))
+  t)
+
+(deffoo nnnotmuch-request-newgroups (_date &optional server)
+  (nnnotmuch-request-list server))
+
+(deffoo nnnotmuch-request-list-newsgroups (&optional _server)
+  nil)
+
+(deffoo nnnotmuch-request-expire-articles (articles group &optional server force)
+  (nnnotmuch-set-group-context group server)
+  (when (eq 'delete nnmail-expiry-target)
+    (error "Not implemented yet")))
+
+(deffoo nnnotmuch-request-move-article
+    (article group server accept-form &optional last _move-is-internal)
+  (error "Not implemented yet"))
+
+(deffoo nnnotmuch-request-accept-article (group &optional server last)
+  (error "Not implemented yet"))
+
+(deffoo nnnotmuch-request-post (&optional server)
+  (nnmail-do-request-post 'nnnotmuch-request-accept-article server))
+
+(deffoo nnnotmuch-request-update-info (group info &optional server)
+  (when-let (n (nnnotmuch--count-files (nnnotmuch--find-query group)))
+    (gnus-set-active (gnus-group-prefixed-name group `(nnnotmuch ,server))
+                     (cons 1 n))))
+
+(deffoo nnnotmuch-request-replace-article (article group buffer)
+  (error "Not implemented yet"))
+
+(deffoo nnnotmuch-request-delete-group (group &optional force server)
+  (error "Not implemented yet"))
+
+(deffoo nnnotmuch-request-rename-group (group new-name &optional server)
+  (error "Not implemented yet"))
+
+(deffoo nnnotmuch-set-status (article name value &optional group server)
+  (nnnotmuch-set-group-context group server)
+  (let ((file (nnnotmuch-article-to-file article)))
+    (cond
+     ((not (file-exists-p file))
+      (nnheader-report 'nnnotmuch "File %s does not exist" file))
+     (t
+      (message "Setting status %s to %s" name value)
+      ;; (with-temp-file file
+      ;;   (nnheader-insert-file-contents file)
+      ;;   (nnmail-replace-status name value))
+      t))))
+
+
+
+(defvar nnnotmuch-article-files nil)
+
+(defun nnnotmuch-article-to-file (article)
+  (when (numberp article)
+    (elt nnnotmuch-article-files (1- article))))
+
+(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-group-message-ids (group &optional search)
+  (when-let (q (or search (nnnotmuch--find-query group)))
+    (notmuch-query-get-message-ids q)))
+
+(defun nnnotmuch--find-message-file (id)
+  (let ((q (notmuch-id-to-query id)))
+    (string-trim
+     (shell-command-to-string
+      (format "notmuch search --output=files %s" q)))))
+
+(defun nnnotmuch--count-files (query &optional unread)
+  (let ((cmd (format "notmuch count --output=files -- %s%s"
+                     (shell-quote-argument (format "(%s)" query))
+                     (if unread " AND tag:unread" ""))))
+    (string-to-number (shell-command-to-string cmd))))
+
+(defun nnnotmuch--query-files (query)
+  (let ((cmd (format "notmuch search --sort=oldest-first --output=files -- %s"
+                     (shell-quote-argument query))))
+    (split-string (shell-command-to-string cmd))))
+
+(defun nnnotmuch--find-group-files (group)
+  (when-let (q (nnnotmuch--find-query group))
+    (nnnotmuch--query-files q)))
+
+(defun nnnotmuch-set-group-context (group &optional server)
+  (when (and server
+	     (not (nnnotmuch-server-opened server)))
+    (nnnotmuch-open-server server))
+  (setq nnnotmuch-current-group group
+	nnnotmuch-article-files (nnnotmuch--find-group-files group))
+  t)
+
+
+
+
+(provide 'nnnotmuch)
+;;; nnnotmuch.el ends here