attic

1 files changed, 0 insertions, 265 deletions

diff --git a/lib/net/nnnm.el b/lib/net/nnnm.el
deleted file mode 100644
index 552e95c..0000000
--- a/lib/net/nnnm.el
+++ /dev/null
@@ -1,265 +0,0 @@
-;;; 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