;;; ebdb-gnus.el --- Gnus interface to EBDB -*- lexical-binding: t; -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. ;; Author: Eric Abrahamsen ;; 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 . ;;; Commentary: ;; Code for interaction with Gnus. ;;; Code: (require 'ebdb-com) (require 'ebdb-mua) (require 'gnus-sum) (require 'gnus-msg) (autoload 'message-make-domain "message") (defgroup ebdb-mua-gnus nil "Gnus-specific EBDB customizations." :group 'ebdb-mua) (put 'ebdb-mua-gnus 'custom-loads '(ebdb-gnus)) (defcustom ebdb-gnus-auto-update-p ebdb-mua-reader-update-p "Gnus-specific value of `ebdb-mua-auto-update-p'." :type '(choice (const :tag "do nothing" nil) (const :tag "search for existing records" existing) (const :tag "update existing records" update) (const :tag "query for update or record creation" query) (const :tag "update or create automatically" create) (function :tag "User-defined function"))) (defcustom ebdb-gnus-window-size ebdb-default-window-size "Size of the EBDB buffer when popping up in Gnus. Size should be specified as a float between 0 and 1. Defaults to the value of `ebdb-default-window-size'." :type 'float) (defcustom ebdb-gnus-window-configuration nil "Symbol that names EBDB's Gnus window config. This option is nil by default, meaning Gnus will pop up the *EBDB-Gnus* window next to the *Article* buffer, with a width/height of `ebdb-gnus-window-size'. If more control is required, set this to a symbol name. This symbol will be entered into the `gnus-window-to-buffer' alist, and can be used as an entry in more complex Gnus buffer/window configurations. Note that this should be a different symbol from that used in Message-mode article composition window config." :type '(choice (const :tag nil) (symbol :tag "Window config name"))) (defcustom ebdb-gnus-post-style-function (lambda (_rec _mail) nil) "Callable used to determine Gnus group posting styles. The callable should accept a single record as a first argument, and a mail field instance as a second. Either return a Gnus group name as a string, which will be used to configure posting styles when composing a message to that record/mail, or return nil to use Gnus defaults. See `ebdb-record-field' or `ebdb-record-current-fields' for likely ways to extract information about the record." :type 'function) (defgroup ebdb-mua-gnus-scoring nil "Gnus-specific scoring EBDB customizations" :group 'ebdb-mua-gnus) (put 'ebdb-mua-gnus-scoring 'custom-loads '(ebdb-gnus)) (defgroup ebdb-mua-gnus-splitting nil "Gnus-specific splitting EBDB customizations" :group 'ebdb-mua-gnus) (put 'ebdb-mua-gnus-splitting 'custom-loads '(ebdb-gnus)) ;;; Gnus-specific field types. All should subclass ;;; `ebdb-field-user'. ;;;###autoload (defclass ebdb-gnus-score-field (ebdb-field-user) ((score :type (or null number) :initarg :score :initval nil)) :human-readable "gnus score") (cl-defmethod ebdb-read ((field (subclass ebdb-gnus-score-field)) &optional slots obj) (let ((score (string-to-number (ebdb-read-string "Score" (when obj (slot-value obj 'score)))))) (cl-call-next-method field (plist-put slots :score score) obj))) (cl-defmethod ebdb-string ((field ebdb-gnus-score-field)) (slot-value field 'score)) ;; Scoring (defcustom ebdb/gnus-score-default nil "If this is set, then every mail address in the EBDB that does not have an associated score field will be assigned this score. A value of nil implies a default score of zero." :group 'ebdb-mua-gnus-scoring :type '(choice (const :tag "Do not assign default score" nil) (integer :tag "Assign this default score" 0))) (defvar ebdb/gnus-score-default-internal nil "Internal variable for detecting changes to `ebdb/gnus-score-default'. You should not set this variable directly - set `ebdb/gnus-score-default' instead.") (defvar ebdb/gnus-score-alist nil "The text version of the scoring structure returned by ebdb/gnus-score. This is built automatically from the EBDB.") (defvar ebdb/gnus-score-rebuild-alist t "Set to t to rebuild ebdb/gnus-score-alist on the next call to ebdb/gnus-score. This will be set automatically if you change a EBDB record which contains a gnus-score field.") (defun ebdb/gnus-score-invalidate-alist (record) "This function is called through `ebdb-after-change-hook', and sets `ebdb/gnus-score-rebuild-alist' to t if the changed record contains a gnus-score field." (if (ebdb-record-user-field record 'ebdb-gnus-score-field) (setq ebdb/gnus-score-rebuild-alist t))) ;;;###autoload (defun ebdb/gnus-score (group) "Return a score alist for Gnus. A score pair will be made for every member of the mail field in records which also have a `gnus-score' field. This allows the EBDB to serve as a supplemental global score file, with the advantage that it can keep up with multiple and changing addresses better than the traditionally static global scorefile." (list (list (condition-case nil (read (ebdb/gnus-score-as-text group)) (error (setq ebdb/gnus-score-rebuild-alist t) (message "Problem building EBDB score table.") (ding) (sit-for 2) nil))))) (defun ebdb/gnus-score-as-text (_group) "Returns a SCORE file format string built from the EBDB." (cond ((or (cond ((/= (or ebdb/gnus-score-default 0) (or ebdb/gnus-score-default-internal 0)) (setq ebdb/gnus-score-default-internal ebdb/gnus-score-default) t)) (not ebdb/gnus-score-alist) ebdb/gnus-score-rebuild-alist) (setq ebdb/gnus-score-rebuild-alist nil) (setq ebdb/gnus-score-alist (concat "((touched nil) (\"from\"\n" (mapconcat (lambda (record) (let ((score (or (ebdb-record-user-field record 'ebdb-gnus-score-field) ebdb/gnus-score-default)) (mail (ebdb-record-mail record))) (when (and score mail) (mapconcat (lambda (address) (format "(\"%s\" %s)\n" (ebdb-string address) score)) mail "")))) ebdb-record-tracker "") "))")))) ebdb/gnus-score-alist) ;;; Gnus splitting support ;; First, catch and upgrade instances of `ebdb-gnus-private-field' and ;; `ebdb-gnus-imap-field'. These upgrade routines were put in place ;; September 3, 2017. Give it... a year? Two? Then delete them. ;;;###autoload (defclass ebdb-gnus-private-field (ebdb-field-user) ((group :initarg :group))) ;;;###autoload (defclass ebdb-gnus-imap-field (ebdb-field-user) ((group :initarg :group))) (cl-defmethod make-instance ((_cls (subclass ebdb-gnus-private-field)) &rest slots) (apply #'make-instance 'ebdb-field-mail-folder (list :folder (plist-get slots :group)))) (cl-defmethod make-instance ((_cls (subclass ebdb-gnus-imap-field)) &rest slots) (apply #'make-instance 'ebdb-field-mail-folder (list :folder (plist-get slots :group)))) (defun ebdb/gnus-split-folders-list () "Return a list of (\"From\" mail-regexp imap-folder-name) tuples based on the contents of the EBDB. Mail address elements are already `regexp-quote'-ed, so we just concat them. Please note: in order that this will work with the `nnimap-split-fancy' or `nnmail-split-fancy' methods you have to use a backquote template, that is your setting will look like: \(setq nnimap-split-rule 'nnimap-split-fancy nnimap-split-inbox \"INBOX\" nnimap-split-fancy `(| ,@(ebdb/gnus-split-folders-list) ... )) Note that `( is the backquote, NOT the quote '(." (mapcar (lambda (elt) (list "From" (mapconcat #'identity (cdr elt) "\\|") (car elt))) ebdb-mail-folder-list)) ;; ;; Insinuation ;; (defun ebdb-gnus-auto-update () (ebdb-mua-auto-update ebdb-gnus-auto-update-p)) (add-hook 'gnus-article-prepare-hook #'ebdb-gnus-auto-update) (add-hook 'gnus-startup-hook #'ebdb-insinuate-gnus) (defsubst ebdb-gnus-buffer-name () (format "*%s-Gnus*" ebdb-buffer-name)) (cl-defmethod ebdb-make-buffer-name (&context (major-mode gnus-summary-mode)) "Produce a EBDB buffer name associated with Gnus." (ebdb-gnus-buffer-name)) (cl-defmethod ebdb-make-buffer-name (&context (major-mode gnus-article-mode)) "Produce a EBDB buffer name associated with Gnus." (ebdb-gnus-buffer-name)) (cl-defmethod ebdb-popup-window (&context (major-mode gnus-summary-mode)) (let ((win (progn (unless (gnus-buffer-live-p gnus-article-buffer) (gnus-summary-show-article)) (get-buffer-window gnus-article-buffer)))) (list win ebdb-gnus-window-size))) (cl-defmethod ebdb-popup-window (&context (major-mode gnus-article-mode)) (list (get-buffer-window) ebdb-gnus-window-size)) ;; It seems that `gnus-fetch-field' fetches decoded content of ;; `gnus-visible-headers', ignoring `gnus-ignored-headers'. ;; Here we use instead `gnus-fetch-original-field' that fetches ;; the encoded content of `gnus-original-article-buffer'. ;; Decoding makes this possibly a bit slower, but something like ;; `ebdb-select-message' does not get fooled by an apparent ;; absence of some headers. ;; See http://permalink.gmane.org/gmane.emacs.gnus.general/78741 (cl-defmethod ebdb-mua-message-header ((header string) &context (major-mode gnus-summary-mode)) "Return value of HEADER for current Gnus message." (set-buffer gnus-article-buffer) (gnus-fetch-original-field header)) ;; This is all a little goofy. (cl-defmethod ebdb-mua-message-header ((header string) &context (major-mode gnus-article-mode)) (set-buffer gnus-article-buffer) (gnus-fetch-original-field header)) (cl-defmethod ebdb-mua-message-header ((header string) &context (major-mode gnus-tree-mode)) (set-buffer gnus-article-buffer) (gnus-fetch-original-field header)) (cl-defmethod ebdb-mua-prepare-article (&context (major-mode gnus-summary-mode)) (gnus-summary-select-article)) (cl-defmethod ebdb-mua-prepare-article (&context (major-mode gnus-article-mode)) (gnus-summary-select-article)) (cl-defmethod ebdb-mua-article-body (&context (major-mode gnus-summary-mode)) "Return the current article body as a string. Must not include article headers, though can include headers in quoted replies." (gnus-with-article-buffer ;; This pretends that there's no such thing as mime parts, and ;; will probably fail horribly. (article-goto-body) (buffer-substring-no-properties (point) (point-max)))) (cl-defmethod ebdb-mua-article-body (&context (major-mode gnus-article-mode)) (gnus-with-article-buffer (article-goto-body) (buffer-substring-no-properties (point) (point-max)))) (cl-defmethod ebdb-mua-article-signature (&context (major-mode gnus-summary-mode)) (gnus-with-article-buffer (gnus-article-search-signature) (forward-line) (buffer-substring-no-properties (point) ;; Assume a blank line concludes a signature. (or (re-search-forward "\n\n" nil t) (point-max))))) (cl-defmethod ebdb-field-mail-compose ((record ebdb-record-entity) (mail ebdb-field-mail) &context (read-mail-command (eql gnus)) &rest args) "Compose a Gnus mail to RECORD's address MAIL. Gives the user a chance to set posting styles for a message composed to a certain record." (let ((group (funcall ebdb-gnus-post-style-function record mail))) (if group (let ((gnus-newsgroup-name group)) (gnus-setup-message 'message (apply #'message-mail (ebdb-dwim-mail record mail) args))) (cl-call-next-method)))) (defun ebdb-insinuate-gnus () "Hook EBDB into Gnus." ;; `ebdb-mua-display-sender' fails in *Article* buffers, where ;; `gnus-article-read-summary-keys' provides an additional wrapper ;; that restores the window configuration. (define-key gnus-summary-mode-map ";" ebdb-mua-keymap) (define-key gnus-article-mode-map ";" ebdb-mua-keymap) ;; If the user has set this to a symbol, it needs to be added to ;; Gnus' `gnus-window-to-buffer' list. (when ebdb-gnus-window-configuration (add-to-list 'gnus-window-to-buffer (cons ebdb-gnus-window-configuration (ebdb-gnus-buffer-name)))) ;; Versions of Gnus with the gnus-search.el library allow us to ;; perform contact auto-completion within search queries. (when (boundp 'gnus-search-contact-tables) (add-hook 'ebdb-after-load-hook (lambda () (push ebdb-hashtable gnus-search-contact-tables)))) ;; Set up user field for use in `gnus-summary-line-format' ;; (1) Big solution: use whole name (if ebdb-mua-summary-unify-format-letter (fset (intern (concat "gnus-user-format-function-" ebdb-mua-summary-unify-format-letter)) (lambda (header) (let ((from (mail-header-from header))) (or (and gnus-ignored-from-addresses (cond ((functionp gnus-ignored-from-addresses) (funcall gnus-ignored-from-addresses (mail-strip-quoted-names from))) (t (string-match (gnus-ignored-from-addresses) from))) (let ((extra-headers (mail-header-extra header)) to newsgroups) (cond ((setq to (cdr (assq 'To extra-headers))) (concat gnus-summary-to-prefix (ebdb-mua-summary-unify to))) ((setq newsgroups (or (cdr (assq 'Newsgroups extra-headers)) (and (memq 'Newsgroups gnus-extra-headers) (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nntp) (gnus-group-real-name gnus-newsgroup-name)))) (concat gnus-summary-newsgroup-prefix newsgroups))))) (ebdb-mua-summary-unify (mail-header-from header))))))) ;; (2) Small solution: a mark for messages whos sender is in EBDB. (if ebdb-mua-summary-mark-format-letter (fset (intern (concat "gnus-user-format-function-" ebdb-mua-summary-mark-format-letter)) (lambda (header) (ebdb-mua-summary-mark (mail-header-from header)))))) (provide 'ebdb-gnus) ;;; ebdb-gnus.el ends here ;;;