path: root/lib/net/nnnotmuch.el

;;; 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