diff options
Diffstat (limited to 'lisp/gnus/gnus-search.el')
| -rw-r--r-- | lisp/gnus/gnus-search.el | 2158 |
1 files changed, 2158 insertions, 0 deletions
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el new file mode 100644 index 00000000000..498da200dab --- /dev/null +++ b/lisp/gnus/gnus-search.el @@ -0,0 +1,2158 @@ +;;; gnus-search.el --- Search facilities for Gnus -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Eric Abrahamsen <eric@ericabrahamsen.net> + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file defines a generalized search language, and search engines +;; that interface with various search programs. It is responsible for +;; parsing the user's search input, sending that query to the search +;; engines, and collecting results. Results are in the form of a +;; vector of vectors, each vector representing a found article. The +;; nnselect backend interprets that value to create a group containing +;; the search results. + +;; This file was formerly known as nnir. Later, the backend parts of +;; nnir became nnselect, and only the search functionality was left +;; here. + +;; See the Gnus manual for details of the search language. Tests are +;; in tests/gnus-search-test.el. + +;; The search parsing routines are responsible for accepting the +;; user's search query as a string and parsing it into a sexp +;; structure. The function `gnus-search-parse-query' is the entry +;; point for that. Once the query is in sexp form, it is passed to +;; the search engines themselves, which are responsible for +;; transforming the query into a form that the external program can +;; understand, and then filtering the search results into a format +;; that nnselect can understand. + +;; The general flow is: + +;; 1. The user calls one of `gnus-group-make-search-group' or +;; `gnus-group-make-permanent-search-group' (or a few other entry +;; points). These functions prompt for a search query, and collect +;; the groups to search, then create an nnselect group, setting an +;; 'nnselect-specs group parameter where 'nnselect-function is +;; `gnus-search-run-query', and 'nnselect-args is the search query and +;; groups to search. + +;; 2. `gnus-search-run-query' is called with 'nnselect-args. It looks +;; at the groups to search, categorizes them by server, and for each +;; server finds the search engine to use. It calls each engine's +;; `gnus-search-run-search' method with the query and groups passed as +;; arguments, and the results are collected and handed off to the +;; nnselect group. + +;; For information on writing new search engines, see the Gnus manual. + +;; TODO: Rewrite the query parser using syntax tables and +;; `parse-partial-sexp'. + +;; TODO: Refactor IMAP search so we can move code that uses nnimap-* +;; functions out into nnimap.el. + +;; TODO: Is there anything we can do about sorting results? + +;; TODO: Provide for returning a result count. This would probably +;; need a completely separate top-level command, since we wouldn't be +;; creating a group at all. + +;;; Code: + +(require 'gnus-group) +(require 'gnus-sum) +(require 'message) +(require 'gnus-util) +(require 'eieio) +(eval-when-compile (require 'cl-lib)) +(autoload 'eieio-build-class-alist "eieio-opt") +(autoload 'nnmaildir-base-name-to-article-number "nnmaildir") + +(defvar gnus-inhibit-demon) +(defvar gnus-english-month-names) + +;;; Internal Variables: + +;; When Gnus servers are implemented as objects or structs, give them +;; a `search-engine' slot and get rid of this variable. +(defvar gnus-search-engine-instance-alist nil + "Mapping between servers and instantiated search engines.") + +(defvar gnus-search-history () + "Internal history of Gnus searches.") + +(defun gnus-search-shutdown () + (setq gnus-search-engine-instance-alist nil)) + +(gnus-add-shutdown #'gnus-search-shutdown 'gnus) + +(define-error 'gnus-search-parse-error "Gnus search parsing error") + +;;; User Customizable Variables: + +(defgroup gnus-search nil + "Search groups in Gnus with assorted search engines." + :group 'gnus) + +(defcustom gnus-search-use-parsed-queries nil + "When t, use Gnus' generalized search language. +The generalized search language is a search language that can be +used across all search engines that Gnus supports. See the Gnus +manual for details. + +If this option is set to nil, search queries will be passed +directly to the search engines without being parsed or +transformed." + :version "28.1" + :type 'boolean + :group 'gnus-search) + +(define-obsolete-variable-alias 'nnir-ignored-newsgroups + 'gnus-search-ignored-newsgroups "28.1") + +(defcustom gnus-search-ignored-newsgroups "" + "A regexp to match newsgroups in the active file that should + be skipped when searching." + :version "24.1" + :type 'regexp + :group 'gnus-search) + +(make-obsolete-variable + 'nnir-imap-default-search-key + "specify imap search keys, or use parsed queries." "28.1") + +;; Engine-specific configuration options. + +(defcustom gnus-search-swish++-config-file + (expand-file-name "~/Mail/swish++.conf") + "Location of Swish++ configuration file. +This variable can also be set per-server." + :type 'file + :group 'gnus-search) + +(defcustom gnus-search-swish++-program "search" + "Name of swish++ search executable. +This variable can also be set per-server." + :type 'string + :group 'gnus-search) + +(defcustom gnus-search-swish++-switches '() + "A list of strings, to be given as additional arguments to swish++. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-swish++-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-swish++-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :group 'gnus-search) + +(defcustom gnus-search-swish++-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by swish++ +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable can also be set per-server." + :type 'regexp + :group 'gnus-search) + +(defcustom gnus-search-swish++-raw-queries-p nil + "If t, all Swish++ engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-config-file + (expand-file-name "~/Mail/swish-e.conf") + "Configuration file for swish-e. +This variable can also be set per-server." + :type 'file + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-program "search" + "Name of swish-e search executable. +This variable can also be set per-server." + :type 'string + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-switches '() + "A list of strings, to be given as additional arguments to swish-e. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-swish-e-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-swish-e-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by swish-e +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable can also be set per-server." + :type 'regexp + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-index-files '() + "A list of index files to use with this Swish-e instance. +This variable can also be set per-server." + :type '(repeat file) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-raw-queries-p nil + "If t, all Swish-e engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +;; Namazu engine, see <URL:http://www.namazu.org/> + +(defcustom gnus-search-namazu-program "namazu" + "Name of Namazu search executable. +This variable can also be set per-server." + :type 'string + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-index-directory (expand-file-name "~/Mail/namazu/") + "Index directory for Namazu. +This variable can also be set per-server." + :type 'directory + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-switches '() + "A list of strings, to be given as additional arguments to namazu. +The switches `-q', `-a', and `-s' are always used, very few other switches +make any sense in this context. + +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-namazu-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-namazu-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by Namazu +in order to get a group name (albeit with / instead of .). + +For example, suppose that Namazu returns file names such as +\"/home/john/Mail/mail/misc/42\". For this example, use the following +setting: (setq gnus-search-namazu-remove-prefix \"/home/john/Mail/\") +Note the trailing slash. Removing this prefix gives \"mail/misc/42\". +Gnus knows to remove the \"/42\" and to replace \"/\" with \".\" to +arrive at the correct group name, \"mail.misc\". + +This variable can also be set per-server." + :type 'directory + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-raw-queries-p nil + "If t, all Namazu engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-program "notmuch" + "Name of notmuch search executable. +This variable can also be set per-server." + :type '(string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-config-file + (expand-file-name "~/.notmuch-config") + "Configuration file for notmuch. +This variable can also be set per-server." + :type 'file + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-switches '() + "A list of strings, to be given as additional arguments to notmuch. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-notmuch-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-notmuch-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by notmuch +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable can also be set per-server." + :type 'regexp + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-raw-queries-p nil + "If t, all Notmuch engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-imap-raw-queries-p nil + "If t, all IMAP engines will only accept raw search query + strings." + :version "28.1" + :type 'boolean + :group 'gnus-search) + +(defcustom gnus-search-mairix-program "mairix" + "Name of mairix search executable. +This variable can also be set per-server." + :version "28.1" + :type 'string + :group 'gnus-search) + +(defcustom gnus-search-mairix-config-file + (expand-file-name "~/.mairixrc") + "Configuration file for mairix. +This variable can also be set per-server." + :version "28.1" + :type 'file + :group 'gnus-search) + +(defcustom gnus-search-mairix-switches '() + "A list of strings, to be given as additional arguments to mairix. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-mairix-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnu-search-mairix-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :version "28.1" + :type '(repeat string) + :group 'gnus-search) + +(defcustom gnus-search-mairix-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by mairix +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable can also be set per-server." + :version "28.1" + :type 'regexp + :group 'gnus-search) + +(defcustom gnus-search-mairix-raw-queries-p nil + "If t, all Mairix engines will only accept raw search query + strings." + :version "28.1" + :type 'boolean + :group 'gnus-search) + +;; Options for search language parsing. + +(defcustom gnus-search-expandable-keys + '("from" "subject" "to" "cc" "bcc" "body" "recipient" "date" + "mark" "before" "after" "larger" "smaller" "attachment" "text" + "since" "thread" "sender" "address" "tag" "size" "grep" "limit" + "raw" "message-id" "id") + "A list of strings representing expandable search keys. +\"Expandable\" simply means the key can be abbreviated while +typing in search queries, ie \"subject\" could be entered as +\"subj\" or even \"su\", though \"s\" is ambigous between +\"subject\" and \"since\". + +Ambiguous abbreviations will raise an error." + :group 'gnus-search + :version "28.1" + :type '(repeat string)) + +(defcustom gnus-search-date-keys + '("date" "before" "after" "on" "senton" "sentbefore" "sentsince" "since") + "A list of keywords whose value should be parsed as a date. +See the docstring of `gnus-search-parse-query' for information on +date parsing." + :group 'gnus-search + :version "26.1" + :type '(repeat string)) + +(defcustom gnus-search-contact-tables '() + "A list of completion tables used to search for messages from contacts. +Each list element should be a table or collection suitable to be +returned by `completion-at-point-functions'. That usually means +a list of strings, a hash table, or an alist." + :group 'gnus-search + :version "28.1" + :type '(repeat sexp)) + +;;; Search language + +;; This "language" was generalized from the original IMAP search query +;; parsing routine. + +(defun gnus-search-parse-query (string) + "Turn STRING into an s-expression based query. +The resulting query structure is passed to the various search +backends, each of which adapts it as needed. + +The search \"language\" is essentially a series of key:value +expressions. Key is most often a mail header, but there are +other keys. Value is a string, quoted if it contains spaces. +Key and value are separated by a colon, no space. Expressions +are implictly ANDed; the \"or\" keyword can be used to +OR. \"not\" will negate the following expression, or keys can be +prefixed with a \"-\". The \"near\" operator will work for +engines that understand it; other engines will convert it to +\"or\". Parenthetical groups work as expected. + +A key that matches the name of a mail header will search that +header. + +Search keys can be expanded with TAB during entry, or left +abbreviated so long as they remain unambiguous, ie \"f\" will +search the \"from\" header. \"s\" will raise an error. + +Other keys: + +\"address\" will search all sender and recipient headers. + +\"recipient\" will search \"To\", \"Cc\", and \"Bcc\". + +\"before\" will search messages sent before the specified +date (date specifications to come later). Date is exclusive. + +\"after\" (or its synonym \"since\") will search messages sent +after the specified date. Date is inclusive. + +\"mark\" will search messages that have some sort of mark. +Likely values include \"flag\", \"seen\", \"read\", \"replied\". +It's also possible to use Gnus' internal marks, ie \"mark:R\" +will be interpreted as mark:read. + +\"tag\" will search tags -- right now that's translated to +\"keyword\" in IMAP, and left as \"tag\" for notmuch. At some +point this should also be used to search marks in the Gnus +registry. + +Other keys can be specified, provided that the search backends +know how to interpret them. + +External contact-management packages can push completion tables +onto the list variable `gnus-search-contact-tables', to provide +auto-completion of contact names and addresses for keys like +\"from\" and \"to\". + +Date values (any key in `gnus-search-date-keys') can be provided +in any format that `parse-time-string' can parse (note that this +can produce weird results). Dates with missing bits will be +interpreted as the most recent occurance thereof (ie \"march 03\" +is the most recent March 3rd). Lastly, relative specifications +such as 1d (one day ago) are understood. This also accepts w, m, +and y. m is assumed to be 30 days. + +This function will accept pretty much anything as input. Its +only job is to parse the query into a sexp, and pass that on -- +it is the job of the search backends to make sense of the +structured query. Malformed, unusable or invalid queries will +typically be silently ignored." + (with-temp-buffer + ;; Set up the parsing environment. + (insert string) + (goto-char (point-min)) + ;; Now, collect the output terms and return them. + (let (out) + (while (not (gnus-search-query-end-of-input)) + (push (gnus-search-query-next-expr) out)) + (reverse out)))) + +(defun gnus-search-query-next-expr (&optional count halt) + "Return the next expression from the current buffer." + (let ((term (gnus-search-query-next-term count)) + (next (gnus-search-query-peek-symbol))) + ;; Deal with top-level expressions. And, or, not, near... What + ;; else? Notmuch also provides xor and adj. It also provides a + ;; "nearness" parameter for near and adj. + (cond + ;; Handle 'expr or expr' + ((and (eq next 'or) + (null halt)) + (list 'or term (gnus-search-query-next-expr 2))) + ;; Handle 'near operator. + ((eq next 'near) + (let ((near-next (gnus-search-query-next-expr 2))) + (if (and (stringp term) + (stringp near-next)) + (list 'near term near-next) + (signal 'gnus-search-parse-error + (list "\"Near\" keyword must appear between two plain strings."))))) + ;; Anything else + (t term)))) + +(defun gnus-search-query-next-term (&optional count) + "Return the next TERM from the current buffer." + (let ((term (gnus-search-query-next-symbol count))) + ;; What sort of term is this? + (cond + ;; negated term + ((eq term 'not) (list 'not (gnus-search-query-next-expr nil 'halt))) + ;; generic term + (t term)))) + +(defun gnus-search-query-peek-symbol () + "Return the next symbol from the current buffer, but don't consume it." + (save-excursion + (gnus-search-query-next-symbol))) + +(defun gnus-search-query-next-symbol (&optional count) + "Return the next symbol from the current buffer, or nil if we are +at the end of the buffer. If supplied COUNT skips some symbols before +returning the one at the supplied position." + (when (and (numberp count) (> count 1)) + (gnus-search-query-next-symbol (1- count))) + (let ((case-fold-search t)) + ;; end of input stream? + (unless (gnus-search-query-end-of-input) + ;; No, return the next symbol from the stream. + (cond + ;; Negated expression -- return it and advance one char. + ((looking-at "-") (forward-char 1) 'not) + ;; List expression -- we parse the content and return this as a list. + ((looking-at "(") + (gnus-search-parse-query (gnus-search-query-return-string ")" t))) + ;; Keyword input -- return a symbol version. + ((looking-at "\\band\\b") (forward-char 3) 'and) + ((looking-at "\\bor\\b") (forward-char 2) 'or) + ((looking-at "\\bnot\\b") (forward-char 3) 'not) + ((looking-at "\\bnear\\b") (forward-char 4) 'near) + ;; Plain string, no keyword + ((looking-at "[\"/]?\\b[^:]+\\([[:blank:]]\\|\\'\\)") + (gnus-search-query-return-string + (when (looking-at-p "[\"/]") t))) + ;; Assume a K:V expression. + (t (let ((key (gnus-search-query-expand-key + (buffer-substring + (point) + (progn + (re-search-forward ":" (point-at-eol) t) + (1- (point)))))) + (value (gnus-search-query-return-string + (when (looking-at-p "[\"/]") t)))) + (gnus-search-query-parse-kv key value))))))) + +(defun gnus-search-query-parse-kv (key value) + "Handle KEY and VALUE, parsing and expanding as necessary. +This may result in (key value) being turned into a larger query +structure. + +In the simplest case, they are simply consed together. String +KEY is converted to a symbol." + (let (return) + (cond + ((member key gnus-search-date-keys) + (when (string= "after" key) + (setq key "since")) + (setq value (gnus-search-query-parse-date value))) + ((equal key "mark") + (setq value (gnus-search-query-parse-mark value))) + ((string= "message-id" key) + (setq key "id"))) + (or return + (cons (intern key) value)))) + +(defun gnus-search-query-parse-date (value &optional rel-date) + "Interpret VALUE as a date specification. +See the docstring of `gnus-search-parse-query' for details. + +The result is a list of (dd mm yyyy); individual elements can be +nil. + +If VALUE is a relative time, interpret it as relative to +REL-DATE, or (current-time) if REL-DATE is nil." + ;; Time parsing doesn't seem to work with slashes. + (let ((value (replace-regexp-in-string "/" "-" value)) + (now (append '(0 0 0) + (seq-subseq (decode-time (or rel-date + (current-time))) + 3)))) + ;; Check for relative time parsing. + (if (string-match "\\([[:digit:]]+\\)\\([dwmy]\\)" value) + (seq-subseq + (decode-time + (time-subtract + (apply #'encode-time now) + (days-to-time + (* (string-to-number (match-string 1 value)) + (cdr (assoc (match-string 2 value) + '(("d" . 1) + ("w" . 7) + ("m" . 30) + ("y" . 365)))))))) + 3 6) + ;; Otherwise check the value of `parse-time-string'. + + ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) + (let ((d-time (parse-time-string value))) + ;; Did parsing produce anything at all? + (if (seq-some #'integerp (seq-subseq d-time 3 7)) + (seq-subseq + ;; If DOW is given, handle that specially. + (if (and (seq-elt d-time 6) (null (seq-elt d-time 3))) + (decode-time + (time-subtract (apply #'encode-time now) + (days-to-time + (+ (if (> (seq-elt d-time 6) + (seq-elt now 6)) + 7 0) + (- (seq-elt now 6) (seq-elt d-time 6)))))) + d-time) + 3 6) + ;; `parse-time-string' failed to produce anything, just + ;; return the string. + value))))) + +(defun gnus-search-query-parse-mark (mark) + "Possibly transform MARK. +If MARK is a single character, assume it is one of the +gnus-*-mark marks, and return an appropriate string." + (if (= 1 (length mark)) + (let ((m (aref mark 0))) + ;; Neither pcase nor cl-case will work here. + (cond + ((eql m gnus-ticked-mark) "flag") + ((eql m gnus-read-mark) "read") + ((eql m gnus-replied-mark) "replied") + ((eql m gnus-recent-mark) "recent") + (t mark))) + mark)) + +(defun gnus-search-query-expand-key (key) + (cond ((test-completion key gnus-search-expandable-keys) + ;; We're done! + key) + ;; There is more than one possible completion. + ((consp (cdr (completion-all-completions + key gnus-search-expandable-keys #'stringp 0))) + (signal 'gnus-search-parse-error + (list (format "Ambiguous keyword: %s" key)))) + ;; Return KEY, either completed or untouched. + ((car-safe (completion-try-completion + key gnus-search-expandable-keys + #'stringp 0))))) + +(defun gnus-search-query-return-string (&optional delimited trim) + "Return a string from the current buffer. +If DELIMITED is non-nil, assume the next character is a delimiter +character, and return everything between point and the next +occurance of the delimiter, including the delimiters themselves. +If TRIM is non-nil, do not return the delimiters. Otherwise, +return one word." + ;; This function cannot handle nested delimiters, as it's not a + ;; proper parser. Ie, you cannot parse "to:bob or (from:bob or + ;; (cc:bob or bcc:bob))". + (let ((start (point)) + (delimiter (if (stringp delimited) + delimited + (when delimited + (char-to-string (char-after))))) + end) + (if delimiter + (progn + (when trim + ;; Skip past first delimiter if we're trimming. + (forward-char 1)) + (while (not end) + (unless (search-forward delimiter nil t (unless trim 2)) + (signal 'gnus-search-parse-error + (list (format "Unmatched delimited input with %s in query" delimiter)))) + (let ((here (point))) + (unless (equal (buffer-substring (- here 2) (- here 1)) "\\") + (setq end (if trim (1- (point)) (point)) + start (if trim (1+ start) start)))))) + (setq end (progn (re-search-forward "\\([[:blank:]]+\\|$\\)" (point-max) t) + (match-beginning 0)))) + (buffer-substring-no-properties start end))) + +(defun gnus-search-query-end-of-input () + "Are we at the end of input?" + (skip-chars-forward "[:blank:]") + (looking-at "$")) + +;;; Search engines + +;; Search engines are implemented as classes. This is good for two +;; things: encapsulating things like indexes and search prefixes, and +;; transforming search queries. + +(defclass gnus-search-engine () + ((raw-queries-p + :initarg :raw-queries-p + :initform nil + :type boolean + :custom boolean + :documentation + "When t, searches through this engine will never be parsed or + transformed, and must be entered \"raw\".")) + :abstract t + :documentation "Abstract base class for Gnus search engines.") + +(defclass gnus-search-grep () + ((grep-program + :initarg :grep-program + :initform "grep" + :type string + :documentation "Grep executable to use for second-pass grep + searches.") + (grep-options + :initarg :grep-options + :initform nil + :type list + :documentation "Additional options, in the form of a list, + passed to the second-pass grep search, when present.")) + :abstract t + :documentation "An abstract mixin class that can be added to + local-filesystem search engines, providing an additional grep: + search key. After the base engine returns a list of search + results (as local filenames), an external grep process is used + to further filter the results.") + +(cl-defgeneric gnus-search-grep-search (engine artlist criteria) + "Run a secondary grep search over a list of preliminary results. + +ARTLIST is a list of (filename score) pairs, produced by one of +the other search engines. CRITERIA is a grep-specific search +key. This method uses an external grep program to further filter +the files in ARTLIST by that search key.") + +(cl-defmethod gnus-search-grep-search ((engine gnus-search-grep) + artlist criteria) + (with-slots (grep-program grep-options) engine + (if (executable-find grep-program) + ;; Don't catch errors -- allow them to propagate. + (let ((matched-files + (apply + #'process-lines + grep-program + `("-l" ,@grep-options + "-e" ,(shell-quote-argument criteria) + ,@(mapcar #'car artlist))))) + (seq-filter (lambda (a) (member (car a) matched-files)) + artlist)) + (nnheader-report 'search "invalid grep program: %s" grep-program)))) + +(defclass gnus-search-process () + ((proc-buffer + :initarg :proc-buffer + :type buffer + :documentation "A temporary buffer this engine uses for its + search process, and for munging its search results.")) + :abstract t + :documentation + "A mixin class for engines that do their searching in a single + process launched for this purpose, which returns at the end of + the search. Subclass instances are safe to be run in + threads.") + +(cl-defmethod shared-initialize ((engine gnus-search-process) + slots) + (setq slots (plist-put slots :proc-buffer + (generate-new-buffer " *gnus-search-"))) + (cl-call-next-method engine slots)) + +(defclass gnus-search-imap (gnus-search-engine) + ((literal-plus + :initarg :literal-plus + :initform nil + :type boolean + :documentation + "Can this search engine handle literal+ searches? This slot + is set automatically by the imap server, and cannot be + set manually. Only the LITERAL+ capability is handled.") + (multisearch + :initarg :multisearch + :initform nil + :type boolean + :documentation + "Can this search engine handle the MULTISEARCH capability? + This slot is set automatically by the imap server, and cannot + be set manually. Currently unimplemented.") + (fuzzy + :initarg :fuzzy + :initform nil + :type boolean + :documentation + "Can this search engine handle the FUZZY search capability? + This slot is set automatically by the imap server, and cannot + be set manually. Currently only partially implemented.") + (raw-queries-p + :initform (symbol-value 'gnus-search-imap-raw-queries-p))) + :documentation + "The base IMAP search engine, using an IMAP server's search capabilites. +This backend may be subclassed to handle particular IMAP servers' +quirks.") + +(defclass gnus-search-find-grep (gnus-search-engine + gnus-search-process + gnus-search-grep) + nil) + +;;; The "indexed" search engine. + +;; These are engines that use an external program, with indexes kept +;; on disk, to search messages usually kept in some local directory. +;; They have several slots in common, for instance program name or +;; configuration file. Many of the subclasses also allow +;; distinguishing multiple databases or indexes. These slots can be +;; set using a global default, or on a per-server basis. + +(defclass gnus-search-indexed (gnus-search-engine + gnus-search-process + gnus-search-grep) + ((program + :initarg :program + :type string + :documentation + "The executable used for indexing and searching.") + (config-file + :init-arg :config-file + :type string + :custom file + :documentation "Location of the config file, if any.") + (remove-prefix + :initarg :remove-prefix + :initform (concat (getenv "HOME") "/Mail/") + :type string + :documentation + "The path to the directory where the indexed mails are + kept. This path is removed from the search results.") + (switches + :initarg :switches + :type list + :documentation + "Additional switches passed to the search engine command-line + program.")) + :abstract t + :allow-nil-initform t + :documentation "A base search engine class that assumes a local search index + accessed by a command line program.") + +(defclass gnus-search-swish-e (gnus-search-indexed) + ((index-files + :init-arg :index-files + :initform (symbol-value 'gnus-search-swish-e-index-files) + :type list) + (program + :initform (symbol-value 'gnus-search-swish-e-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-swish-e-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-swish-e-switches)) + (raw-queries-p + :initform (symbol-value 'gnus-search-swish-e-raw-queries-p)))) + +(defclass gnus-search-swish++ (gnus-search-indexed) + ((program + :initform (symbol-value 'gnus-search-swish++-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-swish++-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-swish++-switches)) + (config-file + :initform (symbol-value 'gnus-search-swish++-config-file)) + (raw-queries-p + :initform (symbol-value 'gnus-search-swish++-raw-queries-p)))) + +(defclass gnus-search-mairix (gnus-search-indexed) + ((program + :initform (symbol-value 'gnus-search-mairix-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-mairix-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-mairix-switches)) + (config-file + :initform (symbol-value 'gnus-search-mairix-config-file)) + (raw-queries-p + :initform (symbol-value 'gnus-search-mairix-raw-queries-p)))) + +(defclass gnus-search-namazu (gnus-search-indexed) + ((index-directory + :initarg :index-directory + :type string + :custom directory) + (program + :initform (symbol-value 'gnus-search-namazu-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-namazu-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-namazu-switches)) + (raw-queries-p + :initform (symbol-value 'gnus-search-namazu-raw-queries-p)))) + +(defclass gnus-search-notmuch (gnus-search-indexed) + ((program + :initform (symbol-value 'gnus-search-notmuch-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-notmuch-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-notmuch-switches)) + (config-file + :initform (symbol-value 'gnus-search-notmuch-config-file)) + (raw-queries-p + :initform (symbol-value 'gnus-search-notmuch-raw-queries-p)))) + +(define-obsolete-variable-alias 'nnir-method-default-engines + 'gnus-search-default-engines "28.1") + +(defcustom gnus-search-default-engines '((nnimap . gnus-search-imap)) + "Alist of default search engines keyed by server method." + :version "26.1" + :group 'gnus-search + :type `(repeat (cons (choice (const nnimap) (const nntp) (const nnspool) + (const nneething) (const nndir) (const nnmbox) + (const nnml) (const nnmh) (const nndraft) + (const nnfolder) (const nnmaildir)) + (choice + ,@(mapcar + (lambda (el) (list 'const (intern (car el)))) + (eieio-build-class-alist 'gnus-search-engine t)))))) + +;;; Transforming and running search queries. + +(cl-defgeneric gnus-search-run-search (engine server query groups) + "Run QUERY in GROUPS against SERVER, using search ENGINE. +Should return results as a vector of vectors.") + +(cl-defgeneric gnus-search-transform (engine expression) + "Transform sexp EXPRESSION into a string search query usable by ENGINE. +Responsible for handling and, or, and parenthetical expressions.") + +(cl-defgeneric gnus-search-transform-expression (engine expression) + "Transform a basic EXPRESSION into a string usable by ENGINE.") + +(cl-defgeneric gnus-search-make-query-string (engine query-spec) + "Extract the actual query string to use from QUERY-SPEC.") + +;; Methods that are likely to be the same for all engines. + +(cl-defmethod gnus-search-make-query-string ((engine gnus-search-engine) + query-spec) + (let ((parsed-query (alist-get 'parsed-query query-spec)) + (raw-query (alist-get 'query query-spec))) + (if (and gnus-search-use-parsed-queries + (null (alist-get 'raw query-spec)) + (null (slot-value engine 'raw-queries-p)) + parsed-query) + (gnus-search-transform engine parsed-query) + (if (listp raw-query) + ;; Some callers are sending this in as (query "query"), not + ;; as a cons cell? + (car raw-query) + raw-query)))) + +(defsubst gnus-search-single-p (query) + "Return t if QUERY is a search for a single message." + (let ((q (alist-get 'parsed-query query))) + (and (= (length q ) 1) + (consp (car-safe q)) + (eq (caar q) 'id)))) + +(cl-defmethod gnus-search-transform ((engine gnus-search-engine) + (query list)) + (let (clauses) + (mapc + (lambda (item) + (when-let ((expr (gnus-search-transform-expression engine item))) + (push expr clauses))) + query) + (mapconcat #'identity (reverse clauses) " "))) + +;; Most search engines just pass through plain strings. +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-engine) + (expr string)) + expr) + +;; Most search engines use implicit ANDs. +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-engine) + (_expr (eql and))) + nil) + +;; Most search engines use explicit infixed ORs. +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-engine) + (expr (head or))) + (let ((left (gnus-search-transform-expression engine (nth 1 expr))) + (right (gnus-search-transform-expression engine (nth 2 expr)))) + ;; Unhandled keywords return a nil; don't create an "or" expression + ;; unless both sub-expressions are non-nil. + (if (and left right) + (format "%s or %s" left right) + (or left right)))) + +;; Most search engines just use the string "not" +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-engine) + (expr (head not))) + (let ((next (gnus-search-transform-expression engine (cadr expr)))) + (when next + (format "not %s" next)))) + +;;; Search Engine Interfaces: + +(autoload 'nnimap-change-group "nnimap") +(declare-function nnimap-buffer "nnimap" ()) +(declare-function nnimap-command "nnimap" (&rest args)) + +;; imap interface +(cl-defmethod gnus-search-run-search ((engine gnus-search-imap) + srv query groups) + (save-excursion + (let ((server (cadr (gnus-server-to-method srv))) + (gnus-inhibit-demon t) + ;; We're using the message id to look for a single message. + (single-search (gnus-search-single-p query)) + (grouplist (or groups (gnus-search-get-active srv))) + q-string artlist group) + (message "Opening server %s" server) + ;; We should only be doing this once, in + ;; `nnimap-open-connection', but it's too frustrating to try to + ;; get to the server from the process buffer. + (with-current-buffer (nnimap-buffer) + (setf (slot-value engine 'literal-plus) + (when (nnimap-capability "LITERAL+") t)) + ;; MULTISEARCH not yet implemented. + (setf (slot-value engine 'multisearch) + (when (nnimap-capability "MULTISEARCH") t)) + ;; FUZZY only partially supported: the command is sent to the + ;; server (and presumably acted upon), but we don't yet + ;; request a RELEVANCY score as part of the response. + (setf (slot-value engine 'fuzzy) + (when (nnimap-capability "SEARCH=FUZZY") t))) + + (setq q-string + (gnus-search-make-query-string engine query)) + + ;; If it's a thread query, make sure that all message-id + ;; searches are also references searches. + (when (alist-get 'thread query) + (setq q-string + (replace-regexp-in-string + "HEADER Message-Id \\([^ )]+\\)" + "(OR HEADER Message-Id \\1 HEADER References \\1)" + q-string))) + + (while (and (setq group (pop grouplist)) + (or (null single-search) (null artlist))) + (when (nnimap-change-group + (gnus-group-short-name group) server) + (with-current-buffer (nnimap-buffer) + (message "Searching %s..." group) + (let ((result + (gnus-search-imap-search-command engine q-string))) + (when (car result) + (setq artlist + (vconcat + (mapcar + (lambda (artnum) + (let ((artn (string-to-number artnum))) + (when (> artn 0) + (vector group artn 100)))) + (cdr (assoc "SEARCH" (cdr result)))) + artlist)))) + (message "Searching %s...done" group)))) + (nreverse artlist)))) + +(cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap) + (query string)) + "Create the IMAP search command for QUERY. +Currenly takes into account support for the LITERAL+ capability. +Other capabilities could be tested here." + (with-slots (literal-plus) engine + (when literal-plus + (setq query (split-string query "\n"))) + (cond + ((consp query) + ;; We're not really streaming, just need to prevent + ;; `nnimap-send-command' from waiting for a response. + (let* ((nnimap-streaming t) + (call + (nnimap-send-command + "UID SEARCH CHARSET UTF-8 %s" + (pop query)))) + (dolist (l query) + (process-send-string (get-buffer-process (current-buffer)) l) + (process-send-string (get-buffer-process (current-buffer)) + (if (nnimap-newlinep nnimap-object) + "\n" + "\r\n"))) + (nnimap-get-response call))) + (t (nnimap-command "UID SEARCH %s" query))))) + +;; TODO: Don't exclude booleans and date keys, just check for them +;; before checking for general keywords. +(defvar gnus-search-imap-search-keys + '(body cc bcc from header keyword larger smaller subject text to uid x-gm-raw) + "Known IMAP search keys, excluding booleans and date keys.") + +(cl-defmethod gnus-search-transform ((_ gnus-search-imap) + (_query null)) + "ALL") + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr string)) + (unless (string-match-p "\\`/.+/\\'" expr) + ;; Also need to check for fuzzy here. Or better, do some + ;; refactoring of this stuff. + (format "TEXT %s" + (gnus-search-imap-handle-string engine expr)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr (head or))) + (let ((left (gnus-search-transform-expression engine (nth 1 expr))) + (right (gnus-search-transform-expression engine (nth 2 expr)))) + (if (and left right) + (format "(OR %s %s)" + left (format (if (eq 'or (car-safe (nth 2 expr))) + "(%s)" "%s") + right)) + (or left right)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr (head near))) + "Imap searches interpret \"near\" as \"or\"." + (setcar expr 'or) + (gnus-search-transform-expression engine expr)) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr (head not))) + "Transform IMAP NOT. +If the term to be negated is a flag, then use the appropriate UN* +boolean instead." + (if (eql (caadr expr) 'mark) + (if (string= (cdadr expr) "new") + "OLD" + (format "UN%s" (gnus-search-imap-handle-flag (cdadr expr)))) + (format "NOT %s" + (gnus-search-transform-expression engine (cadr expr))))) + +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-imap) + (expr (head mark))) + (gnus-search-imap-handle-flag (cdr expr))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr list)) + "Handle a search keyword for IMAP. +All IMAP search keywords that take a value are supported +directly. Keywords that are boolean are supported through other +means (usually the \"mark\" keyword)." + (let ((fuzzy-supported (slot-value engine 'fuzzy)) + (fuzzy "")) + (cl-case (car expr) + (date (setcar expr 'on)) + (tag (setcar expr 'keyword)) + (sender (setcar expr 'from)) + (attachment (setcar expr 'body))) + ;; Allow sizes specified as KB or MB. + (let ((case-fold-search t) + unit) + (when (and (memq (car expr) '(larger smaller)) + (string-match "\\(kb?\\|mb?\\)\\'" (cdr expr))) + (setq unit (match-string 1 (cdr expr))) + (setcdr expr + (number-to-string + (* (string-to-number + (string-replace unit "" (cdr expr))) + (if (string-prefix-p "k" unit) + 1024 + 1048576)))))) + (cond + ((consp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ((eq (car expr) 'recipient) + (gnus-search-transform + engine (gnus-search-parse-query + (format + "to:%s or cc:%s or bcc:%s" + (cdr expr) (cdr expr) (cdr expr))))) + ((eq (car expr) 'address) + (gnus-search-transform + engine (gnus-search-parse-query + (format + "from:%s or to:%s or cc:%s or bcc:%s" + (cdr expr) (cdr expr) (cdr expr) (cdr expr))))) + ((memq (car expr) '(before since on sentbefore senton sentsince)) + ;; Ignore dates given as strings. + (when (listp (cdr expr)) + (format "%s %s" + (upcase (symbol-name (car expr))) + (gnus-search-imap-handle-date engine (cdr expr))))) + ((stringp (cdr expr)) + ;; If the search term starts or ends with "*", remove the + ;; asterisk. If the engine supports FUZZY, then additionally make + ;; the search fuzzy. + (when (string-match "\\`\\*\\|\\*\\'" (cdr expr)) + (setcdr expr (replace-regexp-in-string + "\\`\\*\\|\\*\\'" "" (cdr expr))) + (when fuzzy-supported + (setq fuzzy "FUZZY "))) + ;; If the search term is a regexp, drop the expression altogether. + (unless (string-match-p "\\`/.+/\\'" (cdr expr)) + (cond + ((memq (car expr) gnus-search-imap-search-keys) + (format "%s%s %s" + fuzzy + (upcase (symbol-name (car expr))) + (gnus-search-imap-handle-string engine (cdr expr)))) + ((eq (car expr) 'id) + (format "HEADER Message-ID \"%s\"" (cdr expr))) + ;; Treat what can't be handled as a HEADER search. Probably a bad + ;; idea. + (t (format "%sHEADER %s %s" + fuzzy + (car expr) + (gnus-search-imap-handle-string engine (cdr expr)))))))))) + +(cl-defmethod gnus-search-imap-handle-date ((_engine gnus-search-imap) + (date list)) + "Turn DATE into a date string recognizable by IMAP. +While other search engines can interpret partially-qualified +dates such as a plain \"January\", IMAP requires an absolute +date. + +DATE is a list of (dd mm yyyy), any element of which could be +nil. Massage those numbers into the most recent past occurrence +of whichever date elements are present." + (let ((now (decode-time (current-time)))) + ;; Set nil values to 1, current-month, current-year, or else 1, 1, + ;; current-year, depending on what we think the user meant. + (unless (seq-elt date 1) + (setf (seq-elt date 1) + (if (seq-elt date 0) + (seq-elt now 4) + 1))) + (unless (seq-elt date 0) + (setf (seq-elt date 0) 1)) + (unless (seq-elt date 2) + (setf (seq-elt date 2) + (seq-elt now 5))) + ;; Fiddle with the date until it's in the past. There + ;; must be a way to combine all these steps. + (unless (< (seq-elt date 2) + (seq-elt now 5)) + (when (< (seq-elt now 3) + (seq-elt date 0)) + (cl-decf (seq-elt date 1))) + (cond ((zerop (seq-elt date 1)) + (setf (seq-elt date 1) 1) + (cl-decf (seq-elt date 2))) + ((< (seq-elt now 4) + (seq-elt date 1)) + (cl-decf (seq-elt date 2)))))) + (format-time-string "%e-%b-%Y" (apply #'encode-time + (append '(0 0 0) + date)))) + +(cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap) + (str string)) + (with-slots (literal-plus) engine + (if (multibyte-string-p str) + ;; If LITERAL+ is available, use it and encode string as + ;; UTF-8. + (if literal-plus + (format "{%d+}\n%s" + (string-bytes str) + (encode-coding-string str 'utf-8)) + ;; Otherwise, if the user hasn't already quoted the string, + ;; quote it for them. + (if (string-prefix-p "\"" str) + str + (format "\"%s\"" str))) + str))) + +(defun gnus-search-imap-handle-flag (flag) + "Make sure string FLAG is something IMAP will recognize." + ;; What else? What about the KEYWORD search key? + (setq flag + (pcase flag + ("flag" "flagged") + ("read" "seen") + (_ flag))) + (if (member flag '("seen" "answered" "deleted" "draft" "flagged")) + (upcase flag) + "")) + +;;; Methods for the indexed search engines. + +;; First, some common methods. + +(cl-defgeneric gnus-search-indexed-parse-output (engine server &optional groups) + "Parse the results of ENGINE's query against SERVER in GROUPS. +Locally-indexed search engines return results as a list of +filenames, sometimes with additional information. Returns a list +of viable results, in the form of a list of [group article score] +vectors.") + +(cl-defgeneric gnus-search-indexed-extract (engine) + "Extract a single article result from the current buffer. +Returns a list of two values: a file name, and a relevancy score. +Advances point to the beginning of the next result.") + +(cl-defmethod gnus-search-run-search ((engine gnus-search-indexed) + server query groups) + "Run QUERY against SERVER using ENGINE. +This method is common to all indexed search engines. + +Returns a list of [group article score] vectors." + + (save-excursion + (let* ((qstring (gnus-search-make-query-string engine query)) + (program (slot-value engine 'program)) + (buffer (slot-value engine 'proc-buffer)) + (cp-list (gnus-search-indexed-search-command + engine qstring query groups)) + proc exitstatus) + (set-buffer buffer) + (erase-buffer) + + (if groups + (message "Doing %s query on %s..." program groups) + (message "Doing %s query..." program)) + (setq proc (apply #'start-process (format "search-%s" server) + buffer program cp-list)) + (while (process-live-p proc) + (accept-process-output proc)) + (setq exitstatus (process-exit-status proc)) + (if (zerop exitstatus) + ;; The search results have been put into the current buffer; + ;; `parse-output' finds them there and returns the article + ;; list. + (gnus-search-indexed-parse-output engine server query groups) + (nnheader-report 'search "%s error: %s" program exitstatus) + ;; Failure reason is in this buffer, show it if the user + ;; wants it. + (when (> gnus-verbose 6) + (display-buffer buffer)) + nil)))) + +(cl-defmethod gnus-search-indexed-parse-output ((engine gnus-search-indexed) + server query &optional groups) + (let ((prefix (slot-value engine 'remove-prefix)) + (group-regexp (when groups + (regexp-opt + (mapcar + (lambda (x) (gnus-group-real-name x)) + groups)))) + artlist vectors article group) + (goto-char (point-min)) + (while (not (eobp)) + (pcase-let ((`(,f-name ,score) (gnus-search-indexed-extract engine))) + (when (and (file-readable-p f-name) + (null (file-directory-p f-name)) + (or (null groups) + (and (gnus-search-single-p query) + (alist-get 'thread query)) + (string-match-p group-regexp f-name))) + (push (list f-name score) artlist)))) + ;; Are we running an additional grep query? + (when-let ((grep-reg (alist-get 'grep query))) + (setq artlist (gnus-search-grep-search engine artlist grep-reg))) + ;; Turn (file-name score) into [group article score]. + (pcase-dolist (`(,f-name ,score) artlist) + (setq article (file-name-nondirectory f-name)) + ;; Remove prefix. + (when (and prefix + (file-name-absolute-p prefix) + (string-match (concat "^" + (file-name-as-directory prefix)) + f-name)) + (setq group (replace-match "" t t (file-name-directory f-name)))) + ;; Break the directory name down until it's something that + ;; (probably) can be used as a group name. + (setq group + (replace-regexp-in-string + "[/\\]" "." + (replace-regexp-in-string + "/?\\(cur\\|new\\|tmp\\)?/\\'" "" + (replace-regexp-in-string + "^[./\\]" "" + group nil t) + nil t) + nil t)) + + (push (vector (gnus-group-full-name group server) + (if (string-match-p "\\`[[:digit:]]+\\'" article) + (string-to-number article) + (nnmaildir-base-name-to-article-number + (substring article 0 (string-match ":" article)) + group nil)) + (if (numberp score) + score + (string-to-number score))) + vectors)) + vectors)) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-indexed)) + "Base implementation treats the whole line as a filename, and +fudges a relevancy score of 100." + (prog1 + (list (buffer-substring-no-properties (line-beginning-position) + (line-end-position)) + 100) + (forward-line 1))) + +;; Swish++ + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-swish++) + (expr (head near))) + (format "%s near %s" + (gnus-search-transform-expression engine (nth 1 expr)) + (gnus-search-transform-expression engine (nth 2 expr)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-swish++) + (expr list)) + (cond + ((listp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ;; Untested and likely wrong. + ((and (stringp (cdr expr)) + (string-prefix-p "(" (cdr expr))) + (format "%s = %s" (car expr) (gnus-search-transform + engine + (gnus-search-parse-query (cdr expr))))) + (t (format "%s = %s" (car expr) (cdr expr))))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-swish++) + (qstring string) + _query &optional _groups) + (with-slots (config-file switches) engine + `("--config-file" ,config-file + ,@switches + ,qstring + ))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-swish++)) + (when (re-search-forward + "\\(^[0-9]+\\) \\([^ ]+\\) [0-9]+ \\(.*\\)$" nil t) + (list (match-string 2) + (match-string 1)))) + +;; Swish-e + +;; I didn't do the query transformation for Swish-e, because the +;; program seems no longer to exist. + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-swish-e) + (qstring string) + _query &optional _groups) + (with-slots (index-files switches) engine + `("-f" ,@index-files + ,@switches + "-w" + ,qstring + ))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-swish-e)) + (when (re-search-forward + "\\(^[0-9]+\\) \\([^ ]+\\) \"\\([^\"]+\\)\" [0-9]+$" nil t) + (list (match-string 3) + (match-string 1)))) + +;; Namazu interface + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-namazu) + (expr list)) + (cond + ((listp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ((eql (car expr) 'body) + (cadr expr)) + ;; I have no idea which fields namazu can handle. Just do these + ;; for now. + ((memq (car expr) '(subject from to)) + (format "+%s:%s" (car expr) (cdr expr))) + ((eql (car expr) 'address) + (gnus-search-transform engine `((or (from . ,(cdr expr)) + (to . ,(cdr expr)))))) + ((eq (car expr) 'id) + (format "+message-id:%s" (cdr expr))) + (t (ignore-errors (cl-call-next-method))))) + +;; I can't tell if this is actually necessary. +(cl-defmethod gnus-search-run-search :around ((_e gnus-search-namazu) + _server _query _groups) + (let ((process-environment (copy-sequence process-environment))) + (setenv "LC_MESSAGES" "C") + (cl-call-next-method))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-namazu) + (qstring string) + query &optional _groups) + (let ((max (alist-get 'limit query))) + (with-slots (switches index-directory) engine + (append + (list "-q" ; don't be verbose + "-a" ; show all matches + "-s") ; use short format + (when max (list (format "--max=%d" max))) + switches + (list qstring index-directory))))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-namazu)) + "Extract a single message result for Namazu. +Namazu provides a little more information, for instance a score." + + (when (re-search-forward + "^\\([0-9,]+\\.\\).*\\((score: \\([0-9]+\\)\\))\n\\([^ ]+\\)" + nil t) + (list (match-string 4) + (match-string 3)))) + +;;; Notmuch interface + +(cl-defmethod gnus-search-transform ((_engine gnus-search-notmuch) + (_query null)) + "*") + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-notmuch) + (expr (head near))) + (format "%s near %s" + (gnus-search-transform-expression engine (nth 1 expr)) + (gnus-search-transform-expression engine (nth 2 expr)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-notmuch) + (expr list)) + ;; Swap keywords as necessary. + (cl-case (car expr) + (sender (setcar expr 'from)) + ;; Notmuch's "to" is already equivalent to our "recipient". + (recipient (setcar expr 'to)) + (mark (setcar expr 'tag))) + ;; Then actually format the results. + (cl-flet ((notmuch-date (date) + (if (stringp date) + date + (pcase date + (`(nil ,m nil) + (nth (1- m) gnus-english-month-names)) + (`(nil nil ,y) + (number-to-string y)) + (`(,d ,m nil) + (format "%02d-%02d" d m)) + (`(nil ,m ,y) + (format "%02d-%d" m y)) + (`(,d ,m ,y) + (format "%d/%d/%d" m d y)))))) + (cond + ((consp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ((eql (car expr) 'address) + (gnus-search-transform engine `((or (from . ,(cdr expr)) + (to . ,(cdr expr)))))) + ((eql (car expr) 'body) + (cdr expr)) + ((memq (car expr) '(from to subject attachment mimetype tag id + thread folder path lastmod query property)) + ;; Notmuch requires message-id with no angle brackets. + (when (eql (car expr) 'id) + (setcdr + expr (replace-regexp-in-string "\\`<\\|>\\'" "" (cdr expr)))) + (format "%s:%s" (car expr) + (if (string-match "\\`\\*" (cdr expr)) + ;; Notmuch can only handle trailing asterisk + ;; wildcards, so strip leading asterisks. + (replace-match "" nil nil (cdr expr)) + (cdr expr)))) + ((eq (car expr) 'date) + (format "date:%s" (notmuch-date (cdr expr)))) + ((eq (car expr) 'before) + (format "date:..%s" (notmuch-date (cdr expr)))) + ((eq (car expr) 'since) + (format "date:%s.." (notmuch-date (cdr expr)))) + (t (ignore-errors (cl-call-next-method)))))) + +(cl-defmethod gnus-search-run-search :around ((engine gnus-search-notmuch) + server query groups) + "Handle notmuch's thread-search routine." + ;; Notmuch allows for searching threads, but only using its own + ;; thread ids. That means a thread search is a \"double-bounce\": + ;; once to find the relevant thread ids, and again to find the + ;; actual messages. This method performs the first \"bounce\". + (if (alist-get 'thread query) + (with-slots (program proc-buffer) engine + (let* ((qstring + (gnus-search-make-query-string engine query)) + (cp-list (gnus-search-indexed-search-command + engine qstring query groups)) + thread-ids proc) + (set-buffer proc-buffer) + (erase-buffer) + (setq proc (apply #'start-process (format "search-%s" server) + proc-buffer program cp-list)) + (while (process-live-p proc) + (accept-process-output proc)) + (while (re-search-forward "^thread:\\([^ ]+\\)" (point-max) t) + (push (match-string 1) thread-ids)) + (cl-call-next-method + engine server + ;; Completely replace the query with our new thread-based one. + (mapconcat (lambda (thrd) (concat "thread:" thrd)) + thread-ids " or ") + nil))) + (cl-call-next-method engine server query groups))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-notmuch) + (qstring string) + query &optional _groups) + ;; Theoretically we could use the GROUPS parameter to pass a + ;; --folder switch to notmuch, but I'm not confident of getting the + ;; format right. + (let ((limit (alist-get 'limit query)) + (thread (alist-get 'thread query))) + (with-slots (switches config-file) engine + `(,(format "--config=%s" config-file) + "search" + ,(if thread + "--output=threads" + "--output=files") + "--duplicate=1" ; I have found this necessary, I don't know why. + ,@switches + ,(if limit (format "--limit=%d" limit) "") + ,qstring + )))) + +;;; Mairix interface + +;; See the Gnus manual for why mairix searching is a bit weird. + +(cl-defmethod gnus-search-transform ((engine gnus-search-mairix) + (query list)) + "Transform QUERY for a Mairix engine. +Because Mairix doesn't accept parenthesized expressions, nor +\"or\" statements between different keys, results may differ from +other engines. We unpeel parenthesized expressions, and just +cross our fingers for the rest of it." + (let (clauses) + (mapc + (lambda (item) + (when-let ((expr (if (consp (car-safe item)) + (gnus-search-transform engine item) + (gnus-search-transform-expression engine item)))) + (push expr clauses))) + query) + (mapconcat #'identity (reverse clauses) " "))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) + (expr (head not))) + "Transform Mairix \"not\". +Mairix negation requires a \"~\" preceding string search terms, +and \"-\" before marks." + (let ((next (gnus-search-transform-expression engine (cadr expr)))) + (replace-regexp-in-string + ":" + (if (eql (caadr expr) 'mark) + ":-" + ":~") + next))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) + (expr (head or))) + "Handle Mairix \"or\" statement. +Mairix only accepts \"or\" expressions on homogenous keys. We +cast \"or\" expressions on heterogenous keys as \"and\", which +isn't quite right, but it's the best we can do. For date keys, +only keep one of the terms." + (let ((term1 (caadr expr)) + (term2 (caaddr expr)) + (val1 (gnus-search-transform-expression engine (nth 1 expr))) + (val2 (gnus-search-transform-expression engine (nth 2 expr)))) + (cond + ((or (listp term1) (listp term2)) + (concat val1 " " val2)) + ((and (member (symbol-name term1) gnus-search-date-keys) + (member (symbol-name term2) gnus-search-date-keys)) + (or val1 val2)) + ((eql term1 term2) + (if (and val1 val2) + (format "%s/%s" + val1 + (nth 1 (split-string val2 ":"))) + (or val1 val2))) + (t (concat val1 " " val2))))) + + +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-mairix) + (expr (head mark))) + (gnus-search-mairix-handle-mark (cdr expr))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) + (expr list)) + (let ((key (cl-case (car expr) + (sender "f") + (from "f") + (to "t") + (cc "c") + (subject "s") + (id "m") + (body "b") + (address "a") + (recipient "tc") + (text "bs") + (attachment "n") + (t nil)))) + (cond + ((consp (car expr)) + (gnus-search-transform engine expr)) + ((member (symbol-name (car expr)) gnus-search-date-keys) + (gnus-search-mairix-handle-date expr)) + ((memq (car expr) '(size smaller larger)) + (gnus-search-mairix-handle-size expr)) + ;; Drop regular expressions. + ((string-match-p "\\`/" (cdr expr)) + nil) + ;; Turn parenthesized phrases into multiple word terms. Again, + ;; this isn't quite what the user is asking for, but better to + ;; return false positives. + ((and key (string-match-p "[[:blank:]]" (cdr expr))) + (mapconcat + (lambda (s) (format "%s:%s" key s)) + (split-string (gnus-search-mairix-treat-string + (cdr expr))) + " ")) + (key (format "%s:%s" key + (gnus-search-mairix-treat-string + (cdr expr)))) + (t nil)))) + +(defun gnus-search-mairix-treat-string (str) + "Treat string for wildcards. +Mairix accepts trailing wildcards, but not leading. Also remove +double quotes." + (replace-regexp-in-string + "\\`\\*\\|\"" "" + (replace-regexp-in-string "\\*\\'" "=" str))) + +(defun gnus-search-mairix-handle-size (expr) + "Format a mairix size search. +Assume \"size\" key is equal to \"larger\"." + (format + (if (eql (car expr) 'smaller) + "z:-%s" + "z:%s-") + (cdr expr))) + +(defun gnus-search-mairix-handle-mark (expr) + "Format a mairix mark search." + (let ((mark + (pcase (cdr expr) + ("flag" "f") + ("read" "s") + ("seen" "s") + ("replied" "r") + (_ nil)))) + (when mark + (format "F:%s" mark)))) + +(defun gnus-search-mairix-handle-date (expr) + (let ((str + (pcase (cdr expr) + (`(nil ,m nil) + (substring + (nth (1- m) gnus-english-month-names) + 0 3)) + (`(nil nil ,y) + (number-to-string y)) + (`(,d ,m nil) + (format "%s%02d" + (substring + (nth (1- m) gnus-english-month-names) + 0 3) + d)) + (`(nil ,m ,y) + (format "%d%s" + y (substring + (nth (1- m) gnus-english-month-names) + 0 3))) + (`(,d ,m ,y) + (format "%d%02d%02d" y m d))))) + (format + (pcase (car expr) + ('date "d:%s") + ('since "d:%s-") + ('after "d:%s-") + ('before "d:-%s")) + str))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-mairix) + (qstring string) + query &optional _groups) + (with-slots (switches config-file) engine + (append `("--rcfile" ,config-file "-r") + switches + (when (alist-get 'thread query) (list "-t")) + (list qstring)))) + +;;; Find-grep interface + +(cl-defmethod gnus-search-transform-expression ((_engine gnus-search-find-grep) + (_ list)) + ;; Drop everything that isn't a plain string. + nil) + +(cl-defmethod gnus-search-run-search ((engine gnus-search-find-grep) + server query + &optional groups) + "Run find and grep to obtain matching articles." + (let* ((method (gnus-server-to-method server)) + (sym (intern + (concat (symbol-name (car method)) "-directory"))) + (directory (cadr (assoc sym (cddr method)))) + (regexp (alist-get 'grep query)) + (grep-options (slot-value engine 'grep-options)) + (grouplist (or groups (gnus-search-get-active server))) + (buffer (slot-value engine 'proc-buffer))) + (unless directory + (error "No directory found in method specification of server %s" + server)) + (apply + 'vconcat + (mapcar (lambda (x) + (let ((group x) + artlist) + (message "Searching %s using find-grep..." + (or group server)) + (save-window-excursion + (set-buffer buffer) + (if (> gnus-verbose 6) + (pop-to-buffer (current-buffer))) + (cd directory) ; Using relative paths simplifies + ; postprocessing. + (let ((group + (if (not group) + "." + ;; Try accessing the group literally as + ;; well as interpreting dots as directory + ;; separators so the engine works with + ;; plain nnml as well as the Gnus Cache. + (let ((group (gnus-group-real-name group))) + ;; Replace cl-func find-if. + (if (file-directory-p group) + group + (if (file-directory-p + (setq group + (replace-regexp-in-string + "\\." "/" + group nil t))) + group)))))) + (unless group + (error "Cannot locate directory for group")) + (save-excursion + (apply + 'call-process "find" nil t + "find" group "-maxdepth" "1" "-type" "f" + "-name" "[0-9]*" "-exec" + (slot-value engine 'grep-program) + `("-l" ,@(and grep-options + (split-string grep-options "\\s-" t)) + "-e" ,regexp "{}" "+")))) + + ;; Translate relative paths to group names. + (while (not (eobp)) + (let* ((path (split-string + (buffer-substring + (point) + (line-end-position)) "/" t)) + (art (string-to-number (car (last path))))) + (while (string= "." (car path)) + (setq path (cdr path))) + (let ((group (mapconcat #'identity + (cl-subseq path 0 -1) + "."))) + (push + (vector (gnus-group-full-name group server) art 0) + artlist)) + (forward-line 1))) + (message "Searching %s using find-grep...done" + (or group server)) + artlist))) + grouplist)))) + +;;; Util Code: + +(defun gnus-search-run-query (specs) + "Invoke appropriate search engine function." + ;; For now, run the searches synchronously. At some point + ;; multiple-server searches can each be run in their own thread, + ;; allowing concurrent searches of multiple backends. At present + ;; this causes problems when searching more than one server that + ;; uses `nntp-server-buffer', as their return values are written + ;; interleaved into that buffer. Anyway, that's the reason for the + ;; `mapc'. + (let* ((results []) + (prepared-query (gnus-search-prepare-query + (alist-get 'search-query-spec specs))) + (limit (alist-get 'limit prepared-query))) + (mapc + (pcase-lambda (`(,server . ,groups)) + (let ((search-engine (gnus-search-server-to-engine server))) + (setq results + (vconcat + (gnus-search-run-search + search-engine server prepared-query groups) + results)))) + (alist-get 'search-group-spec specs)) + ;; Some search engines do their own limiting, but some don't, so + ;; do it again here. This is bad because, if the user is + ;; searching multiple groups, they would reasonably expect the + ;; limiting to apply to the search results *after sorting*. Doing + ;; it this way is liable to, for instance, eliminate all results + ;; from a later group entirely. + (if limit + (seq-subseq results 0 (min limit (length results))) + results))) + +(defun gnus-search-prepare-query (query-spec) + "Accept a search query in raw format, and prepare it. +QUERY-SPEC is an alist produced by functions such as +`gnus-group-make-search-group', and contains at least a 'query +key, and possibly some meta keys. This function extracts any +additional meta keys from the 'query string, and parses the +remaining string, then adds all that to the top-level spec." + (let ((query (alist-get 'query query-spec)) + val) + (when (stringp query) + ;; Look for these meta keys: + (while (string-match + "\\(thread\\|grep\\|limit\\|raw\\):\\([^ ]+\\)" + query) + (setq val (match-string 2 query)) + (setf (alist-get (intern (match-string 1 query)) query-spec) + ;; This is stupid. + (cond + ((equal val "t")) + ((null (zerop (string-to-number val))) + (string-to-number val)) + (t val))) + (setq query + (string-trim (replace-match "" t t query 0))) + (setf (alist-get 'query query-spec) query))) + (when (and gnus-search-use-parsed-queries + (null (alist-get 'raw query-spec))) + (setf (alist-get 'parsed-query query-spec) + (gnus-search-parse-query query))) + query-spec)) + +;; This should be done once at Gnus startup time, when the servers are +;; first opened, and the resulting engine instance attached to the +;; server. +(defun gnus-search-server-to-engine (srv) + (let* ((method (gnus-server-to-method srv)) + (engine-config (assoc 'gnus-search-engine (cddr method))) + (server (or (cdr-safe + (assoc-string srv gnus-search-engine-instance-alist t)) + (nth 1 engine-config) + (cdr-safe (assoc (car method) gnus-search-default-engines)) + (when-let ((old (assoc 'nnir-search-engine + (cddr method)))) + (nnheader-message + 8 "\"nnir-search-engine\" is no longer a valid parameter") + (nth 1 old)))) + inst) + (setq server + (pcase server + ('notmuch 'gnus-search-notmuch) + ('namazu 'gnus-search-namazu) + ('find-grep 'gnus-search-find-grep) + ('imap 'gnus-search-imap) + (_ server)) + inst + (cond + ((null server) nil) + ((eieio-object-p server) + server) + ((class-p server) + (make-instance server)) + (t nil))) + (if inst + (unless (assoc-string srv gnus-search-engine-instance-alist t) + (when (cddr engine-config) + ;; We're not being completely backward-compatible here, + ;; because we're not checking for nnir-specific config + ;; options in the server definition. + (pcase-dolist (`(,key ,value) (cddr engine-config)) + (condition-case nil + (setf (slot-value inst key) value) + ((invalid-slot-name invalid-slot-type) + (nnheader-message + 5 "Invalid search engine parameter: (%s %s)" + key value))))) + (push (cons srv inst) gnus-search-engine-instance-alist)) + (error "No search engine defined for %s" srv)) + inst)) + +(declare-function gnus-registry-get-id-key "gnus-registry" (id key)) + +(defun gnus-search-thread (header) + "Make an nnselect group based on the thread containing the article +header. The current server will be searched. If the registry is +installed, the server that the registry reports the current +article came from is also searched." + (let* ((ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) + (query + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) + (server + (list (list (gnus-method-to-server + (gnus-find-method-for-group gnus-newsgroup-name))))) + (registry-group (and + (bound-and-true-p gnus-registry-enabled) + (car (gnus-registry-get-id-key + (mail-header-id header) 'group)))) + (registry-server + (and registry-group + (gnus-method-to-server + (gnus-find-method-for-group registry-group))))) + (when registry-server + (cl-pushnew (list registry-server) server :test #'equal)) + (gnus-group-make-search-group nil (list + (cons 'search-query-spec query) + (cons 'search-group-spec server))) + (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) + +(defun gnus-search-get-active (srv) + (let ((method (gnus-server-to-method srv)) + groups) + (gnus-request-list method) + (with-current-buffer nntp-server-buffer + (let ((cur (current-buffer))) + (goto-char (point-min)) + (unless (or (null gnus-search-ignored-newsgroups) + (string= gnus-search-ignored-newsgroups "")) + (delete-matching-lines gnus-search-ignored-newsgroups)) + (if (eq (car method) 'nntp) + (while (not (eobp)) + (ignore-errors + (push (gnus-group-decoded-name + (gnus-group-full-name + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) + method)) + groups)) + (forward-line)) + (while (not (eobp)) + (ignore-errors + (push (gnus-group-decoded-name + (if (eq (char-after) ?\") + (gnus-group-full-name (read cur) method) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + (gnus-group-full-name name method)))) + groups)) + (forward-line))))) + groups)) + +(defvar gnus-search-minibuffer-map + (let ((km (make-sparse-keymap))) + (set-keymap-parent km minibuffer-local-map) + (define-key km (kbd "TAB") #'completion-at-point) + km)) + +(defun gnus-search--complete-key-data () + "Potentially return completion data for a search key or value." + (let* ((key-start (save-excursion + (or (re-search-backward " " (minibuffer-prompt-end) t) + (goto-char (minibuffer-prompt-end))) + (skip-chars-forward " -") + (point))) + (after-colon (save-excursion + (when (re-search-backward ":" key-start t) + (1+ (point))))) + in-string) + (if after-colon + ;; We're in the value part of a key:value pair, which we + ;; only handle in a contact-completion context. + (when (and gnus-search-contact-tables + (save-excursion + (re-search-backward "\\<-?\\(\\w+\\):" key-start t) + (member (match-string 1) + '("from" "to" "cc" + "bcc" "recipient" "address")))) + (setq in-string (nth 3 (syntax-ppss))) + (list (if in-string (1+ after-colon) after-colon) + (point) (apply #'completion-table-merge + gnus-search-contact-tables) + :exit-function + (lambda (str status) + ;; If the value contains spaces, make sure it's + ;; quoted. + (when (and (memql status '(exact finished)) + (or (string-match-p " " str) + in-string)) + (unless (looking-at-p "\\s\"") + (insert "\"")) + ;; Unless we already have an opening quote... + (unless in-string + (save-excursion + (goto-char after-colon) + (insert "\""))))))) + (list + key-start (point) gnus-search-expandable-keys + :exit-function (lambda (_s status) + (when (memql status '(exact finished)) + (insert ":"))))))) + +(defun gnus-search-make-spec (arg) + (list (cons 'query + (minibuffer-with-setup-hook + (lambda () + (add-hook 'completion-at-point-functions + #'gnus-search--complete-key-data + nil t)) + (read-from-minibuffer + "Query: " nil gnus-search-minibuffer-map + nil 'gnus-search-history))) + (cons 'raw arg))) + +(provide 'gnus-search) +;;; gnus-search.el ends here |