diff options
| -rw-r--r-- | lib/net/nnnm.el | 275 |
1 files changed, 126 insertions, 149 deletions
diff --git a/lib/net/nnnm.el b/lib/net/nnnm.el index 173c975..3df1386 100644 --- a/lib/net/nnnm.el +++ b/lib/net/nnnm.el @@ -28,17 +28,96 @@ (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-saved-searches nil) -(defvoo nnnm-inhibit-expiry nil - "If non-nil, inhibit expiry.") +(defvar nnnm-maildir nil) -(defvoo nnnm-saved-searches 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--init-group-data (full-group query) + (nnnm--tag (concat query " AND NOT tag:new AND not tag:nnnm") "+new") + (let* ((ids (nnnm--search query "tag:nnnm")) + (nids (length ids)) + (info (gnus-get-info full-group)) + (read (when (> nids 0) (list (cons 1 nids)))) + (marks (list (cons 'seen read)))) + (message "*** group info before %s - %s" full-group (gnus-get-info full-group)) + (gnus-info-set-marks info marks) + (setf (gnus-info-read info) read) + (gnus-set-info full-group info) + (message "*** group info after %s" (gnus-get-info full-group)) + (mapcar #'list ids))) + +(defun nnnm--update-group-data (group &optional server) + ;; (when (and server (not (nnnm-server-opened server))) + ;; (nnnm-open-server server)) + (when-let (query (nnnm--find-query group)) + (let* ((full-group (gnus-group-prefixed-name group `(nnnm ,server))) + (data (or (nnnm--group-data group) + (nnnm--init-group-data full-group query))) + (ids (nnnm--search query "tag:new AND NOT tag:nnnm")) + (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)) + (gnus-set-active (gnus-group-prefixed-name group `(nnnm ,server)) + (cons 1 (+ nids (length data)))) + (length ids)))) @@ -48,24 +127,18 @@ (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) + (setq nnnm--group-data nil) + ;; (when (and nnnm-maildir (file-exists-p nnnm-maildir)) + ;; ) + (message "defs: %s" defs) + (nnheader-report 'nnnm "Opened server %s using maildir %s" server nnnm-maildir) + t) + +(deffoo nnnm-close-server (_server) + (setq nnnm--group-data nil)) + +(deffoo nnnm-request-regenerate (_server) + (setq nnnm--group-data nil) (nnnm--tag "*" "-nnnm") t) @@ -73,72 +146,52 @@ (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (s nnnm-saved-searches) - (when-let (q (plist-get s :query)) + (when-let (query (plist-get s :query)) (let ((name (plist-get s :name)) - (total (nnnm--count q))) + (total (nnnm--count query))) (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) + (when (nnnm--update-group-data 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) + (delete-region (point-min) (point-max)) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (count -1)) (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))) + (dolist (article sequence) + (when-let (file (nnnm-article-to-file article group)) (insert (format "221 %d Article retrieved.\n" article)) - (setq beg (point)) - (nnheader-insert-head file) - (goto-char beg) + (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))) - (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) + (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) - ;; (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)))) + (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)) - ((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) + (nnheader-report 'nnnm "Article %s retrieved and tagged" id) (cons group id))))) (deffoo nnnm-request-expire-articles (articles group &optional _server _force) @@ -148,120 +201,44 @@ (push id ids) (push a excluded))) (when ids - (nnnm--tag (mapconcat #'identity ids " OR ") "+deleted +nnnm")) + (nnnm--tag (nnnm--ids-query ids) "+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) +(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)) - (message "we didn't find anything!!") (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-context group server)) + (nnnm--set-group-data group nil) + (nnnm--update-group-data group server)) (deffoo nnnm-request-scan (&optional group server) - (nnnm-set-group-context group server)) - -(deffoo nnnm-close-group (_group &optional _server) - t) + (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-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)))) +(deffoo nnnm-close-group (_group &optional _server) t) -(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))))))) |