205f2be73fb18182b586bf3860cb61880bbc77af
[gnus] / lisp / spam.el
1 ;;; spam.el --- Identifying spam
2 ;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;; Keywords: network
6
7 ;; This file is part of GNU Emacs.
8
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;;; This module addresses a few aspects of spam control under Gnus.  Page
27 ;;; breaks are used for grouping declarations and documentation relating to
28 ;;; each particular aspect.
29
30 ;;; The integration with Gnus is not yet complete.  See various `FIXME'
31 ;;; comments, below, for supplementary explanations or discussions.
32
33 ;;; Several TODO items are marked as such
34
35 ;;; Code:
36
37 (eval-when-compile (require 'cl))
38
39 (require 'gnus-sum)
40
41 (require 'gnus-uu)                      ; because of key prefix issues
42 (require 'gnus) ; for the definitions of group content classification and spam processors
43 (require 'message)                      ;for the message-fetch-field functions
44
45 ;; for nnimap-split-download-body-default
46 (eval-when-compile (require 'nnimap))
47
48 ;; autoload executable-find
49 (eval-and-compile
50   ;; executable-find is not autoloaded in Emacs 20
51   (autoload 'executable-find "executable"))
52
53 ;; autoload query-dig
54 (eval-and-compile
55   (autoload 'query-dig "dig"))
56
57 ;; autoload spam-report
58 (eval-and-compile
59   (autoload 'spam-report-gmane "spam-report"))
60
61 ;; autoload query-dns
62 (eval-and-compile
63   (autoload 'query-dns "dns"))
64
65 ;;; Main parameters.
66
67 (defgroup spam nil
68   "Spam configuration.")
69
70 (defcustom spam-directory "~/News/spam/"
71   "Directory for spam whitelists and blacklists."
72   :type 'directory
73   :group 'spam)
74
75 (defcustom spam-move-spam-nonspam-groups-only t
76   "Whether spam should be moved in non-spam groups only.
77 When nil, only ham and unclassified groups will have their spam moved
78 to the spam-process-destination.  When t, spam will also be moved from
79 spam groups."
80   :type 'boolean
81   :group 'spam)
82
83 (defcustom spam-mark-only-unseen-as-spam t
84   "Whether only unseen articles should be marked as spam in spam
85 groups.  When nil, all unread articles in a spam group are marked as
86 spam.  Set this if you want to leave an article unread in a spam group
87 without losing it to the automatic spam-marking process."
88   :type 'boolean
89   :group 'spam)
90
91 (defcustom spam-mark-ham-unread-before-move-from-spam-group nil
92   "Whether ham should be marked unread before it's moved out of a spam
93 group according to ham-process-destination.  This variable is an
94 official entry in the international Longest Variable Name
95 Competition."
96   :type 'boolean
97   :group 'spam)
98
99 (defcustom spam-whitelist (expand-file-name "whitelist" spam-directory)
100   "The location of the whitelist.
101 The file format is one regular expression per line.
102 The regular expression is matched against the address."
103   :type 'file
104   :group 'spam)
105
106 (defcustom spam-blacklist (expand-file-name "blacklist" spam-directory)
107   "The location of the blacklist.
108 The file format is one regular expression per line.
109 The regular expression is matched against the address."
110   :type 'file
111   :group 'spam)
112
113 (defcustom spam-use-dig t
114   "Whether query-dig should be used instead of query-dns."
115   :type 'boolean
116   :group 'spam)
117
118 (defcustom spam-use-blacklist nil
119   "Whether the blacklist should be used by spam-split."
120   :type 'boolean
121   :group 'spam)
122
123 (defcustom spam-use-whitelist nil
124   "Whether the whitelist should be used by spam-split."
125   :type 'boolean
126   :group 'spam)
127
128 (defcustom spam-use-whitelist-exclusive nil
129   "Whether whitelist-exclusive should be used by spam-split.
130 Exclusive whitelisting means that all messages from senders not in the whitelist
131 are considered spam."
132   :type 'boolean
133   :group 'spam)
134
135 (defcustom spam-use-blackholes nil
136   "Whether blackholes should be used by spam-split."
137   :type 'boolean
138   :group 'spam)
139
140 (defcustom spam-use-hashcash nil
141   "Whether hashcash payments should be detected by spam-split."
142   :type 'boolean
143   :group 'spam)
144
145 (defcustom spam-use-regex-headers nil
146   "Whether a header regular expression match should be used by spam-split.
147 Also see the variables `spam-regex-headers-spam' and `spam-regex-headers-ham'."
148   :type 'boolean
149   :group 'spam)
150
151 (defcustom spam-use-bogofilter-headers nil
152   "Whether bogofilter headers should be used by spam-split.
153 Enable this if you pre-process messages with Bogofilter BEFORE Gnus sees them."
154   :type 'boolean
155   :group 'spam)
156
157 (defcustom spam-use-bogofilter nil
158   "Whether bogofilter should be invoked by spam-split.
159 Enable this if you want Gnus to invoke Bogofilter on new messages."
160   :type 'boolean
161   :group 'spam)
162
163 (defcustom spam-use-BBDB nil
164   "Whether BBDB should be used by spam-split."
165   :type 'boolean
166   :group 'spam)
167
168 (defcustom spam-use-BBDB-exclusive nil
169   "Whether BBDB-exclusive should be used by spam-split.
170 Exclusive BBDB means that all messages from senders not in the BBDB are 
171 considered spam."
172   :type 'boolean
173   :group 'spam)
174
175 (defcustom spam-use-ifile nil
176   "Whether ifile should be used by spam-split."
177   :type 'boolean
178   :group 'spam)
179
180 (defcustom spam-use-stat nil
181   "Whether spam-stat should be used by spam-split."
182   :type 'boolean
183   :group 'spam)
184
185 (defcustom spam-use-spamoracle nil
186   "Whether spamoracle should be used by spam-split."
187   :type 'boolean
188   :group 'spam)
189
190 (defcustom spam-install-hooks (or
191                                spam-use-dig
192                                spam-use-blacklist
193                                spam-use-whitelist 
194                                spam-use-whitelist-exclusive 
195                                spam-use-blackholes 
196                                spam-use-hashcash 
197                                spam-use-regex-headers 
198                                spam-use-bogofilter-headers 
199                                spam-use-bogofilter 
200                                spam-use-BBDB 
201                                spam-use-BBDB-exclusive 
202                                spam-use-ifile 
203                                spam-use-stat
204                                spam-use-spamoracle)
205   "Whether the spam hooks should be installed, default to t if one of
206 the spam-use-* variables is set."
207   :group 'gnus-registry
208   :type 'boolean)
209
210 (defcustom spam-split-group "spam"
211   "Group name where incoming spam should be put by spam-split."
212   :type 'string
213   :group 'spam)
214
215 (defcustom spam-junk-mailgroups (cons spam-split-group '("mail.junk" "poste.pourriel"))
216   "Mailgroups with spam contents.
217 All unmarked article in such group receive the spam mark on group entry."
218   :type '(repeat (string :tag "Group"))
219   :group 'spam)
220
221 (defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org" 
222                                     "dev.null.dk" "relays.visi.com")
223   "List of blackhole servers."
224   :type '(repeat (string :tag "Server"))
225   :group 'spam)
226
227 (defcustom spam-blackhole-good-server-regex nil
228   "String matching IP addresses that should not be checked in the blackholes"
229   :type 'regexp
230   :group 'spam)
231
232 (defcustom spam-face 'gnus-splash-face
233   "Face for spam-marked articles"
234   :type 'face
235   :group 'spam)
236
237 (defcustom spam-regex-headers-spam '("^X-Spam-Flag: YES")
238   "Regular expression for positive header spam matches"
239   :type '(repeat (regexp :tag "Regular expression to match spam header"))
240   :group 'spam)
241
242 (defcustom spam-regex-headers-ham '("^X-Spam-Flag: NO")
243   "Regular expression for positive header ham matches"
244   :type '(repeat (regexp :tag "Regular expression to match ham header"))
245   :group 'spam)
246
247 (defgroup spam-ifile nil
248   "Spam ifile configuration."
249   :group 'spam)
250
251 (defcustom spam-ifile-path (executable-find "ifile")
252   "File path of the ifile executable program."
253   :type '(choice (file :tag "Location of ifile")
254                  (const :tag "ifile is not installed"))
255   :group 'spam-ifile)
256
257 (defcustom spam-ifile-database-path nil
258   "File path of the ifile database."
259   :type '(choice (file :tag "Location of the ifile database")
260                  (const :tag "Use the default"))
261   :group 'spam-ifile)
262
263 (defcustom spam-ifile-spam-category "spam"
264   "Name of the spam ifile category."  
265   :type 'string
266   :group 'spam-ifile)
267
268 (defcustom spam-ifile-ham-category nil
269   "Name of the ham ifile category.  If nil, the current group name will
270 be used."
271   :type '(choice (string :tag "Use a fixed category")
272                 (const :tag "Use the current group name"))
273   :group 'spam-ifile)
274
275 (defcustom spam-ifile-all-categories nil
276   "Whether the ifile check will return all categories, or just spam.
277 Set this to t if you want to use the spam-split invocation of ifile as
278 your main source of newsgroup names."
279   :type 'boolean
280   :group 'spam-ifile)
281
282 (defgroup spam-bogofilter nil
283   "Spam bogofilter configuration."
284   :group 'spam)
285
286 (defcustom spam-bogofilter-path (executable-find "bogofilter")
287   "File path of the Bogofilter executable program."
288   :type '(choice (file :tag "Location of bogofilter")
289                  (const :tag "Bogofilter is not installed"))
290   :group 'spam-bogofilter)
291
292 (defcustom spam-bogofilter-header "X-Bogosity"
293   "The header that Bogofilter inserts in messages."
294   :type 'string
295   :group 'spam-bogofilter)
296
297 (defcustom spam-bogofilter-spam-switch "-s"
298   "The switch that Bogofilter uses to register spam messages."
299   :type 'string
300   :group 'spam-bogofilter)
301
302 (defcustom spam-bogofilter-ham-switch "-n"
303   "The switch that Bogofilter uses to register ham messages."
304   :type 'string
305   :group 'spam-bogofilter)
306
307 (defcustom spam-bogofilter-bogosity-positive-spam-header "^\\(Yes\\|Spam\\)"
308   "The regex on `spam-bogofilter-header' for positive spam identification."
309   :type 'regexp
310   :group 'spam-bogofilter)
311
312 (defcustom spam-bogofilter-database-directory nil
313   "Directory path of the Bogofilter databases."
314   :type '(choice (directory :tag "Location of the Bogofilter database directory")
315                  (const :tag "Use the default"))
316   :group 'spam-ifile)
317
318 (defgroup spam-spamoracle nil
319   "Spam ifile configuration."
320   :group 'spam)
321
322 (defcustom spam-spamoracle-database nil 
323   "Location of spamoracle database file. When nil, use the default
324 spamoracle database."
325   :type '(choice (directory :tag "Location of spamoracle database file.")
326                  (const :tag "Use the default"))
327   :group 'spam-spamoracle)
328
329 (defcustom spam-spamoracle-binary (executable-find "spamoracle")
330   "Location of the spamoracle binary."
331   :type '(choice (directory :tag "Location of the spamoracle binary")
332                  (const :tag "Use the default"))
333   :group 'spam-spamoracle)
334
335 ;;; Key bindings for spam control.
336
337 (gnus-define-keys gnus-summary-mode-map
338   "St" spam-bogofilter-score
339   "Sx" gnus-summary-mark-as-spam
340   "Mst" spam-bogofilter-score
341   "Msx" gnus-summary-mark-as-spam
342   "\M-d" gnus-summary-mark-as-spam)
343
344 ;;; How to highlight a spam summary line.
345
346 ;; TODO: How do we redo this every time spam-face is customized?
347
348 (push '((eq mark gnus-spam-mark) . spam-face)
349       gnus-summary-highlight)
350
351 ;; convenience functions
352 (defun spam-group-ham-mark-p (group mark &optional spam)
353   (when (stringp group)
354     (let* ((marks (spam-group-ham-marks group spam))
355            (marks (if (symbolp mark) 
356                       marks 
357                     (mapcar 'symbol-value marks))))
358       (memq mark marks))))
359
360 (defun spam-group-spam-mark-p (group mark)
361   (spam-group-ham-mark-p group mark t))
362
363 (defun spam-group-ham-marks (group &optional spam)
364   (when (stringp group)
365     (let* ((marks (if spam
366                      (gnus-parameter-spam-marks group)
367                    (gnus-parameter-ham-marks group)))
368            (marks (car marks))
369            (marks (if (listp (car marks)) (car marks) marks)))
370       marks)))
371
372 (defun spam-group-spam-marks (group)
373   (spam-group-ham-marks group t))
374
375 (defun spam-group-spam-contents-p (group)
376   (if (stringp group)
377       (or (member group spam-junk-mailgroups)
378           (memq 'gnus-group-spam-classification-spam 
379                 (gnus-parameter-spam-contents group)))
380     nil))
381   
382 (defun spam-group-ham-contents-p (group)
383   (if (stringp group)
384       (memq 'gnus-group-spam-classification-ham 
385             (gnus-parameter-spam-contents group))
386     nil))
387
388 (defun spam-group-processor-p (group processor)
389   (if (and (stringp group)
390            (symbolp processor))
391       (member processor (car (gnus-parameter-spam-process group)))
392     nil))
393
394 (defun spam-group-spam-processor-report-gmane-p (group)
395   (spam-group-processor-p group 'gnus-group-spam-exit-processor-report-gmane))
396
397 (defun spam-group-spam-processor-bogofilter-p (group)
398   (spam-group-processor-p group 'gnus-group-spam-exit-processor-bogofilter))
399
400 (defun spam-group-spam-processor-blacklist-p (group)
401   (spam-group-processor-p group 'gnus-group-spam-exit-processor-blacklist))
402
403 (defun spam-group-spam-processor-ifile-p (group)
404   (spam-group-processor-p group 'gnus-group-spam-exit-processor-ifile))
405
406 (defun spam-group-ham-processor-ifile-p (group)
407   (spam-group-processor-p group 'gnus-group-ham-exit-processor-ifile))
408
409 (defun spam-group-spam-processor-spamoracle-p (group)
410   (spam-group-processor-p group 'gnus-group-spam-exit-processor-spamoracle))
411
412 (defun spam-group-ham-processor-bogofilter-p (group)
413   (spam-group-processor-p group 'gnus-group-ham-exit-processor-bogofilter))
414
415 (defun spam-group-spam-processor-stat-p (group)
416   (spam-group-processor-p group 'gnus-group-spam-exit-processor-stat))
417
418 (defun spam-group-ham-processor-stat-p (group)
419   (spam-group-processor-p group 'gnus-group-ham-exit-processor-stat))
420
421 (defun spam-group-ham-processor-whitelist-p (group)
422   (spam-group-processor-p group 'gnus-group-ham-exit-processor-whitelist))
423
424 (defun spam-group-ham-processor-BBDB-p (group)
425   (spam-group-processor-p group 'gnus-group-ham-exit-processor-BBDB))
426
427 (defun spam-group-ham-processor-copy-p (group)
428   (spam-group-processor-p group 'gnus-group-ham-exit-processor-copy))
429
430 (defun spam-group-ham-processor-spamoracle-p (group)
431   (spam-group-processor-p group 'gnus-group-ham-exit-processor-spamoracle))
432
433 ;;; Summary entry and exit processing.
434
435 (defun spam-summary-prepare ()
436   (spam-mark-junk-as-spam-routine))
437
438 ;; The spam processors are invoked for any group, spam or ham or neither
439 (defun spam-summary-prepare-exit ()
440   (unless gnus-group-is-exiting-without-update-p
441     (gnus-message 6 "Exiting summary buffer and applying spam rules")
442     (when (and spam-bogofilter-path
443                (spam-group-spam-processor-bogofilter-p gnus-newsgroup-name))
444       (gnus-message 5 "Registering spam with bogofilter")
445       (spam-bogofilter-register-spam-routine))
446   
447     (when (and spam-ifile-path
448                (spam-group-spam-processor-ifile-p gnus-newsgroup-name))
449       (gnus-message 5 "Registering spam with ifile")
450       (spam-ifile-register-spam-routine))
451   
452     (when (spam-group-spam-processor-spamoracle-p gnus-newsgroup-name)
453       (gnus-message 5 "Registering spam with spamoracle")
454       (spam-spamoracle-learn-spam))
455
456     (when (spam-group-spam-processor-stat-p gnus-newsgroup-name)
457       (gnus-message 5 "Registering spam with spam-stat")
458       (spam-stat-register-spam-routine))
459
460     (when (spam-group-spam-processor-blacklist-p gnus-newsgroup-name)
461       (gnus-message 5 "Registering spam with the blacklist")
462       (spam-blacklist-register-routine))
463
464     (when (spam-group-spam-processor-report-gmane-p gnus-newsgroup-name)
465       (gnus-message 5 "Registering spam with the Gmane report")
466       (spam-report-gmane-register-routine))
467
468     (if spam-move-spam-nonspam-groups-only      
469         (when (not (spam-group-spam-contents-p gnus-newsgroup-name))
470           (spam-mark-spam-as-expired-and-move-routine
471            (gnus-parameter-spam-process-destination gnus-newsgroup-name)))
472       (gnus-message 5 "Marking spam as expired and moving it to %s" gnus-newsgroup-name)
473       (spam-mark-spam-as-expired-and-move-routine 
474        (gnus-parameter-spam-process-destination gnus-newsgroup-name)))
475
476     ;; now we redo spam-mark-spam-as-expired-and-move-routine to only
477     ;; expire spam, in case the above did not expire them
478     (gnus-message 5 "Marking spam as expired without moving it")
479     (spam-mark-spam-as-expired-and-move-routine nil)
480
481     (when (spam-group-ham-contents-p gnus-newsgroup-name)
482       (when (spam-group-ham-processor-whitelist-p gnus-newsgroup-name)
483         (gnus-message 5 "Registering ham with the whitelist")
484         (spam-whitelist-register-routine))
485       (when (spam-group-ham-processor-ifile-p gnus-newsgroup-name)
486         (gnus-message 5 "Registering ham with ifile")
487         (spam-ifile-register-ham-routine))
488       (when (spam-group-ham-processor-bogofilter-p gnus-newsgroup-name)
489         (gnus-message 5 "Registering ham with Bogofilter")
490         (spam-bogofilter-register-ham-routine))
491       (when (spam-group-ham-processor-stat-p gnus-newsgroup-name)
492         (gnus-message 5 "Registering ham with spam-stat")
493         (spam-stat-register-ham-routine))
494       (when (spam-group-ham-processor-BBDB-p gnus-newsgroup-name)
495         (gnus-message 5 "Registering ham with the BBDB")
496         (spam-BBDB-register-routine))
497       (when (spam-group-ham-processor-spamoracle-p gnus-newsgroup-name)
498         (gnus-message 5 "Registering ham with spamoracle")
499         (spam-spamoracle-learn-ham)))
500
501     (when (spam-group-ham-processor-copy-p gnus-newsgroup-name)
502       (gnus-message 5 "Copying ham")
503       (spam-ham-move-routine
504        (gnus-parameter-ham-process-destination gnus-newsgroup-name) t))
505
506     ;; now move all ham articles out of spam groups
507     (when (spam-group-spam-contents-p gnus-newsgroup-name)
508       (gnus-message 5 "Moving ham messages from spam group")
509       (spam-ham-move-routine
510        (gnus-parameter-ham-process-destination gnus-newsgroup-name)))))
511
512 (defun spam-mark-junk-as-spam-routine ()
513   ;; check the global list of group names spam-junk-mailgroups and the
514   ;; group parameters
515   (when (spam-group-spam-contents-p gnus-newsgroup-name)
516     (gnus-message 5 "Marking %s articles as spam"
517                   (if spam-mark-only-unseen-as-spam 
518                       "unseen"
519                     "unread"))
520     (let ((articles (if spam-mark-only-unseen-as-spam 
521                         gnus-newsgroup-unseen
522                       gnus-newsgroup-unreads)))
523       (dolist (article articles)
524         (gnus-summary-mark-article article gnus-spam-mark)))))
525
526 (defun spam-mark-spam-as-expired-and-move-routine (&optional group)
527   (gnus-summary-kill-process-mark)
528   (let ((articles gnus-newsgroup-articles)
529         article tomove)
530     (dolist (article articles)
531       (when (eq (gnus-summary-article-mark article) gnus-spam-mark)
532         (gnus-summary-mark-article article gnus-expirable-mark)
533         (push article tomove)))
534
535     ;; now do the actual move
536     (when (and tomove
537                (stringp group))
538       (dolist (article tomove)
539         (gnus-summary-set-process-mark article))
540       (when tomove (gnus-summary-move-article nil group))))
541   (gnus-summary-yank-process-mark))
542  
543 (defun spam-ham-move-routine (&optional group copy)
544   (gnus-summary-kill-process-mark)
545   (let ((articles gnus-newsgroup-articles)
546         article mark tomove)
547     (when (stringp group)               ; this routine will do nothing
548                                         ; without a valid group
549       (dolist (article articles)
550         (when (spam-group-ham-mark-p gnus-newsgroup-name
551                                      (gnus-summary-article-mark article))
552           (push article tomove)))
553
554       ;; now do the actual move
555       (when tomove
556         (dolist (article tomove)
557           (when spam-mark-ham-unread-before-move-from-spam-group
558             (gnus-summary-mark-article article gnus-unread-mark))           
559           (gnus-summary-set-process-mark article))
560         (if copy
561             (gnus-summary-copy-article nil group)
562           (gnus-summary-move-article nil group)))))
563   (gnus-summary-yank-process-mark))
564  
565 (defun spam-generic-register-routine (spam-func ham-func)
566   (let ((articles gnus-newsgroup-articles)
567         article mark ham-articles spam-articles)
568
569     (while articles
570       (setq article (pop articles)
571             mark (gnus-summary-article-mark article))
572       (cond ((spam-group-spam-mark-p gnus-newsgroup-name mark) 
573              (push article spam-articles))
574             ((memq article gnus-newsgroup-saved))
575             ((spam-group-ham-mark-p gnus-newsgroup-name mark)
576              (push article ham-articles))))
577
578     (when (and ham-articles ham-func)
579       (mapc ham-func ham-articles))     ; we use mapc because unlike
580                                         ; mapcar it discards the
581                                         ; return values
582     (when (and spam-articles spam-func)
583       (mapc spam-func spam-articles)))) ; we use mapc because unlike
584                                         ; mapcar it discards the
585                                         ; return values
586
587 (eval-and-compile
588   (defalias 'spam-point-at-eol (if (fboundp 'point-at-eol)
589                                    'point-at-eol
590                                  'line-end-position)))
591
592 (defun spam-get-article-as-string (article)
593   (let ((article-buffer (spam-get-article-as-buffer article))
594                         article-string)
595     (when article-buffer
596       (save-window-excursion
597         (set-buffer article-buffer)
598         (setq article-string (buffer-string))))
599   article-string))
600
601 (defun spam-get-article-as-buffer (article)
602   (let ((article-buffer))
603     (when (numberp article)
604       (save-window-excursion
605         (gnus-summary-goto-subject article)
606         (gnus-summary-show-article t)
607         (setq article-buffer (get-buffer gnus-article-buffer))))
608     article-buffer))
609
610 ;; disabled for now
611 ;; (defun spam-get-article-as-filename (article)
612 ;;   (let ((article-filename))
613 ;;     (when (numberp article)
614 ;;       (nnml-possibly-change-directory (gnus-group-real-name gnus-newsgroup-name))
615 ;;       (setq article-filename (expand-file-name (int-to-string article) nnml-current-directory)))
616 ;;     (if (file-exists-p article-filename)
617 ;;      article-filename
618 ;;       nil)))
619
620 (defun spam-fetch-field-from-fast (article)
621   "Fetch the `from' field quickly, using the internal gnus-data-list function"
622   (if (and (numberp article)
623            (assoc article (gnus-data-list nil)))
624       (mail-header-from (gnus-data-header (assoc article (gnus-data-list nil))))
625     nil))
626
627 (defun spam-fetch-field-subject-fast (article)
628   "Fetch the `subject' field quickly, using the internal gnus-data-list function"
629   (if (and (numberp article)
630            (assoc article (gnus-data-list nil)))
631       (mail-header-subject (gnus-data-header (assoc article (gnus-data-list nil))))
632     nil))
633
634 \f
635 ;;;; Spam determination.
636
637 (defvar spam-list-of-checks
638   '((spam-use-blacklist                 .       spam-check-blacklist)
639     (spam-use-regex-headers             .       spam-check-regex-headers)
640     (spam-use-whitelist                 .       spam-check-whitelist)
641     (spam-use-BBDB                      .       spam-check-BBDB)
642     (spam-use-ifile                     .       spam-check-ifile)
643     (spam-use-spamoracle                .       spam-check-spamoracle)
644     (spam-use-stat                      .       spam-check-stat)
645     (spam-use-blackholes                .       spam-check-blackholes)
646     (spam-use-hashcash                  .       spam-check-hashcash)
647     (spam-use-bogofilter-headers        .       spam-check-bogofilter-headers)
648     (spam-use-bogofilter                .       spam-check-bogofilter))
649 "The spam-list-of-checks list contains pairs associating a parameter
650 variable with a spam checking function.  If the parameter variable is
651 true, then the checking function is called, and its value decides what
652 happens.  Each individual check may return nil, t, or a mailgroup
653 name.  The value nil means that the check does not yield a decision,
654 and so, that further checks are needed.  The value t means that the
655 message is definitely not spam, and that further spam checks should be
656 inhibited.  Otherwise, a mailgroup name is returned where the mail
657 should go, and further checks are also inhibited.  The usual mailgroup
658 name is the value of `spam-split-group', meaning that the message is
659 definitely a spam.")
660
661 (defvar spam-list-of-statistical-checks
662   '(spam-use-ifile spam-use-stat spam-use-bogofilter spam-use-spamoracle)
663 "The spam-list-of-statistical-checks list contains all the mail
664 splitters that need to have the full message body available.")
665
666 (defun spam-split (&rest specific-checks)
667   "Split this message into the `spam' group if it is spam.
668 This function can be used as an entry in `nnmail-split-fancy', for
669 example like this: (: spam-split).  It can take checks as parameters.
670
671 See the Info node `(gnus)Fancy Mail Splitting' for more details."
672   (interactive)
673   (save-excursion
674     (save-restriction
675       (dolist (check spam-list-of-statistical-checks)
676         (when (symbol-value check)
677           (widen)
678           (gnus-message 8 "spam-split: widening the buffer (%s requires it)"
679                         (symbol-name check))
680           (return)))
681       ;;   (progn (widen) (debug (buffer-string)))
682       (let ((list-of-checks spam-list-of-checks)
683             decision)
684         (while (and list-of-checks (not decision))
685           (let ((pair (pop list-of-checks)))
686             (when (and (symbol-value (car pair))
687                        (or (null specific-checks)
688                            (memq (car pair) specific-checks)))
689               (gnus-message 5 "spam-split: calling the %s function" (symbol-name (cdr pair)))
690               (setq decision (funcall (cdr pair))))))
691         (if (eq decision t)
692             nil
693           decision)))))
694   
695 (defun spam-setup-widening ()
696   (dolist (check spam-list-of-statistical-checks)
697     (when (symbol-value check)
698       (setq nnimap-split-download-body-default t))))
699
700 \f
701 ;;;; Regex headers
702
703 (defun spam-check-regex-headers ()
704   (let (ret found)
705     (dolist (h-regex spam-regex-headers-ham)
706       (unless found
707         (goto-char (point-min))
708         (when (re-search-forward h-regex nil t)
709           (message "Ham regex header search positive.")
710           (setq found t))))
711     (dolist (s-regex spam-regex-headers-spam)
712       (unless found
713         (goto-char (point-min))
714         (when (re-search-forward s-regex nil t)
715           (message "Spam regex header search positive." (match-string 1))
716           (setq found t)
717           (setq ret spam-split-group))))
718     ret))
719
720 \f
721 ;;;; Blackholes.
722
723 (defun spam-check-blackholes ()
724   "Check the Received headers for blackholed relays."
725   (let ((headers (message-fetch-field "received"))
726         ips matches)
727     (when headers
728       (with-temp-buffer
729         (insert headers)
730         (goto-char (point-min))
731         (gnus-message 5 "Checking headers for relay addresses")
732         (while (re-search-forward
733                 "\\[\\([0-9]+.[0-9]+.[0-9]+.[0-9]+\\)\\]" nil t)
734           (gnus-message 9 "Blackhole search found host IP %s." (match-string 1))
735           (push (mapconcat 'identity
736                            (nreverse (split-string (match-string 1) "\\."))
737                            ".")
738                 ips)))
739       (dolist (server spam-blackhole-servers)
740         (dolist (ip ips)
741           (unless (and spam-blackhole-good-server-regex
742                        (string-match spam-blackhole-good-server-regex ip))
743             (let ((query-string (concat ip "." server)))
744               (if spam-use-dig
745                   (let ((query-result (query-dig query-string)))
746                     (when query-result
747                       (gnus-message 5 "(DIG): positive blackhole check '%s'" 
748                                     query-result)
749                       (push (list ip server query-result)
750                             matches)))
751                 ;; else, if not using dig.el
752                 (when (query-dns query-string)
753                   (gnus-message 5 "positive blackhole check")
754                   (push (list ip server (query-dns query-string 'TXT))
755                         matches))))))))
756     (when matches
757       spam-split-group)))
758 \f
759 ;;;; Hashcash.
760
761 (condition-case nil
762     (progn
763       (require 'hashcash)
764       
765       (defun spam-check-hashcash ()
766         "Check the headers for hashcash payments."
767         (mail-check-payment)))          ;mail-check-payment returns a boolean
768
769   (file-error (progn
770                 (defalias 'mail-check-payment 'ignore)
771                 (defalias 'spam-check-hashcash 'ignore))))
772 \f
773 ;;;; BBDB 
774
775 ;;; original idea for spam-check-BBDB from Alexander Kotelnikov
776 ;;; <sacha@giotto.sj.ru>
777
778 ;; all this is done inside a condition-case to trap errors
779
780 (condition-case nil
781     (progn
782       (require 'bbdb)
783       (require 'bbdb-com)
784       
785   (defun spam-enter-ham-BBDB (from)
786     "Enter an address into the BBDB; implies ham (non-spam) sender"
787     (when (stringp from)
788       (let* ((parsed-address (gnus-extract-address-components from))
789              (name (or (car parsed-address) "Ham Sender"))
790              (net-address (car (cdr parsed-address))))
791         (gnus-message 5 "Adding address %s to BBDB" from)
792         (when (and net-address
793                    (not (bbdb-search-simple nil net-address)))
794           (bbdb-create-internal name nil net-address nil nil 
795                                 "ham sender added by spam.el")))))
796
797   (defun spam-BBDB-register-routine ()
798     (spam-generic-register-routine 
799      ;; spam function
800      nil
801      ;; ham function
802      (lambda (article)
803        (spam-enter-ham-BBDB (spam-fetch-field-from-fast article)))))
804
805   (defun spam-check-BBDB ()
806     "Mail from people in the BBDB is classified as ham or non-spam"
807     (let ((who (message-fetch-field "from")))
808       (when who
809         (setq who (cadr (gnus-extract-address-components who)))
810         (if (bbdb-search-simple nil who)
811             t 
812           (if spam-use-BBDB-exclusive
813               spam-split-group
814             nil))))))
815
816   (file-error (progn
817                 (defalias 'bbdb-search-simple 'ignore)
818                 (defalias 'spam-check-BBDB 'ignore)
819                 (defalias 'spam-BBDB-register-routine 'ignore)
820                 (defalias 'spam-enter-ham-BBDB 'ignore)
821                 (defalias 'bbdb-create-internal 'ignore)
822                 (defalias 'bbdb-records 'ignore))))
823
824 \f
825 ;;;; ifile
826
827 ;;; check the ifile backend; return nil if the mail was NOT classified
828 ;;; as spam
829
830 (defun spam-get-ifile-database-parameter ()
831   "Get the command-line parameter for ifile's database from spam-ifile-database-path."
832   (if spam-ifile-database-path
833       (format "--db-file=%s" spam-ifile-database-path)
834     nil))
835     
836 (defun spam-check-ifile ()
837   "Check the ifile backend for the classification of this message"
838   (let ((article-buffer-name (buffer-name)) 
839         category return)
840     (with-temp-buffer
841       (let ((temp-buffer-name (buffer-name))
842             (db-param (spam-get-ifile-database-parameter)))
843         (save-excursion
844           (set-buffer article-buffer-name)
845           (if db-param
846               (call-process-region (point-min) (point-max) spam-ifile-path
847                                    nil temp-buffer-name nil "-q" "-c" db-param)
848             (call-process-region (point-min) (point-max) spam-ifile-path
849                                  nil temp-buffer-name nil "-q" "-c")))
850         (goto-char (point-min))
851         (if (not (eobp))
852             (setq category (buffer-substring (point) (spam-point-at-eol))))
853         (when (not (zerop (length category))) ; we need a category here
854           (if spam-ifile-all-categories
855               (setq return category)
856             ;; else, if spam-ifile-all-categories is not set...
857             (when (string-equal spam-ifile-spam-category category)
858               (setq return spam-split-group))))))
859     return))
860
861 (defun spam-ifile-register-with-ifile (article-string category)
862   "Register an article, given as a string, with a category.
863 Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
864   (when (stringp article-string)
865     (let ((category (or category gnus-newsgroup-name))
866           (db-param (spam-get-ifile-database-parameter)))
867       (with-temp-buffer
868         (insert article-string)
869         (if db-param
870             (call-process-region (point-min) (point-max) spam-ifile-path 
871                                  nil nil nil 
872                                  "-h" "-i" category db-param)
873           (call-process-region (point-min) (point-max) spam-ifile-path 
874                                nil nil nil 
875                                "-h" "-i" category))))))
876
877 (defun spam-ifile-register-spam-routine ()
878   (spam-generic-register-routine 
879    (lambda (article)
880      (spam-ifile-register-with-ifile 
881       (spam-get-article-as-string article) spam-ifile-spam-category))
882    nil))
883
884 (defun spam-ifile-register-ham-routine ()
885   (spam-generic-register-routine 
886    nil
887    (lambda (article)
888      (spam-ifile-register-with-ifile 
889       (spam-get-article-as-string article) spam-ifile-ham-category))))
890
891 \f
892 ;;;; spam-stat
893
894 (condition-case nil
895     (progn
896       (let ((spam-stat-install-hooks nil))
897         (require 'spam-stat))
898       
899       (defun spam-check-stat ()
900         "Check the spam-stat backend for the classification of this message"
901         (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override
902               (spam-stat-buffer (buffer-name)) ; stat the current buffer
903               category return)
904           (spam-stat-split-fancy)))
905
906       (defun spam-stat-register-spam-routine ()
907         (spam-generic-register-routine 
908          (lambda (article)
909            (let ((article-string (spam-get-article-as-string article)))
910              (with-temp-buffer
911                (insert article-string)
912                (spam-stat-buffer-is-spam))))
913          nil))
914
915       (defun spam-stat-register-ham-routine ()
916         (spam-generic-register-routine 
917          nil
918          (lambda (article)
919            (let ((article-string (spam-get-article-as-string article)))
920              (with-temp-buffer
921                (insert article-string)
922                (spam-stat-buffer-is-non-spam))))))
923
924       (defun spam-maybe-spam-stat-load ()
925         (when spam-use-stat (spam-stat-load)))
926       
927       (defun spam-maybe-spam-stat-save ()
928         (when spam-use-stat (spam-stat-save))))
929
930   (file-error (progn
931                 (defalias 'spam-maybe-spam-stat-load 'ignore)
932                 (defalias 'spam-maybe-spam-stat-save 'ignore)
933                 (defalias 'spam-stat-register-ham-routine 'ignore)
934                 (defalias 'spam-stat-register-spam-routine 'ignore)
935                 (defalias 'spam-stat-buffer-is-spam 'ignore)
936                 (defalias 'spam-stat-buffer-is-non-spam 'ignore)
937                 (defalias 'spam-stat-split-fancy 'ignore)
938                 (defalias 'spam-stat-load 'ignore)
939                 (defalias 'spam-stat-save 'ignore)
940                 (defalias 'spam-check-stat 'ignore))))
941
942 \f
943
944 ;;;; Blacklists and whitelists.
945
946 (defvar spam-whitelist-cache nil)
947 (defvar spam-blacklist-cache nil)
948
949 (defun spam-enter-whitelist (address)
950   "Enter ADDRESS into the whitelist."
951   (interactive "sAddress: ")
952   (spam-enter-list address spam-whitelist)
953   (setq spam-whitelist-cache nil))
954
955 (defun spam-enter-blacklist (address)
956   "Enter ADDRESS into the blacklist."
957   (interactive "sAddress: ")
958   (spam-enter-list address spam-blacklist)
959   (setq spam-blacklist-cache nil))
960
961 (defun spam-enter-list (address file)
962   "Enter ADDRESS into the given FILE, either the whitelist or the blacklist."
963   (unless (file-exists-p (file-name-directory file))
964     (make-directory (file-name-directory file) t))
965   (save-excursion
966     (set-buffer
967      (find-file-noselect file))
968     (unless (search-forward (regexp-quote address))
969       (goto-char (point-max))
970       (unless (bobp)
971         (insert "\n"))
972       (insert address "\n")
973       (save-buffer))))
974
975 ;;; returns t if the sender is in the whitelist, nil or spam-split-group otherwise
976 (defun spam-check-whitelist ()
977   ;; FIXME!  Should it detect when file timestamps change?
978   (unless spam-whitelist-cache
979     (setq spam-whitelist-cache (spam-parse-list spam-whitelist)))
980   (if (spam-from-listed-p spam-whitelist-cache) 
981       t
982     (if spam-use-whitelist-exclusive
983         spam-split-group
984       nil)))
985
986 (defun spam-check-blacklist ()
987   ;; FIXME!  Should it detect when file timestamps change?
988   (unless spam-blacklist-cache
989     (setq spam-blacklist-cache (spam-parse-list spam-blacklist)))
990   (and (spam-from-listed-p spam-blacklist-cache) spam-split-group))
991
992 (defun spam-parse-list (file)
993   (when (file-readable-p file)
994     (let (contents address)
995       (with-temp-buffer
996         (insert-file-contents file)
997         (while (not (eobp))
998           (setq address (buffer-substring (point) (spam-point-at-eol)))
999           (forward-line 1)
1000           (unless (zerop (length address))
1001             (setq address (regexp-quote address))
1002             (while (string-match "\\\\\\*" address)
1003               (setq address (replace-match ".*" t t address)))
1004             (push address contents))))
1005       (nreverse contents))))
1006
1007 (defun spam-from-listed-p (cache)
1008   (let ((from (message-fetch-field "from"))
1009         found)
1010     (while cache
1011       (when (string-match (pop cache) from)
1012         (setq found t
1013               cache nil)))
1014     found))
1015
1016 (defun spam-blacklist-register-routine ()
1017   (spam-generic-register-routine 
1018    ;; the spam function
1019    (lambda (article)
1020      (let ((from (spam-fetch-field-from-fast article)))
1021        (when (stringp from)
1022            (spam-enter-blacklist from))))
1023    ;; the ham function
1024    nil))
1025
1026 (defun spam-whitelist-register-routine ()
1027   (spam-generic-register-routine 
1028    ;; the spam function
1029    nil 
1030    ;; the ham function
1031    (lambda (article)
1032      (let ((from (spam-fetch-field-from-fast article)))
1033        (when (stringp from)
1034            (spam-enter-whitelist from))))))
1035
1036 \f
1037 ;;;; Spam-report glue
1038 (defun spam-report-gmane-register-routine ()
1039   (spam-generic-register-routine
1040    'spam-report-gmane
1041    nil))
1042
1043 \f
1044 ;;;; Bogofilter
1045 (defun spam-check-bogofilter-headers (&optional score)
1046   (let ((header (message-fetch-field spam-bogofilter-header)))
1047     (when header                        ; return nil when no header
1048       (if score                         ; scoring mode
1049           (if (string-match "spamicity=\\([0-9.]+\\)" header)
1050               (match-string 1 header)
1051             "0")
1052         ;; spam detection mode
1053         (when (string-match spam-bogofilter-bogosity-positive-spam-header
1054                             header)
1055           spam-split-group)))))
1056
1057 ;; return something sensible if the score can't be determined
1058 (defun spam-bogofilter-score ()
1059   "Get the Bogofilter spamicity score"
1060   (interactive)
1061   (save-window-excursion
1062     (gnus-summary-show-article t)
1063     (set-buffer gnus-article-buffer)
1064     (let ((score (or (spam-check-bogofilter-headers t)
1065                      (spam-check-bogofilter t))))
1066       (message "Spamicity score %s" score)
1067       (or score "0"))))
1068
1069 (defun spam-check-bogofilter (&optional score)
1070   "Check the Bogofilter backend for the classification of this message"
1071   (let ((article-buffer-name (buffer-name)) 
1072         return)
1073     (with-temp-buffer
1074       (let ((temp-buffer-name (buffer-name)))
1075         (save-excursion
1076           (set-buffer article-buffer-name)
1077           (if spam-bogofilter-database-directory
1078               (call-process-region (point-min) (point-max) 
1079                                    spam-bogofilter-path
1080                                    nil temp-buffer-name nil "-v"
1081                                    "-d" spam-bogofilter-database-directory)
1082             (call-process-region (point-min) (point-max) spam-bogofilter-path
1083                                  nil temp-buffer-name nil "-v")))
1084         (setq return (spam-check-bogofilter-headers score))))
1085     return))
1086
1087 (defun spam-bogofilter-register-with-bogofilter (article-string spam)
1088   "Register an article, given as a string, as spam or non-spam."
1089   (when (stringp article-string)
1090     (let ((switch (if spam spam-bogofilter-spam-switch 
1091                     spam-bogofilter-ham-switch)))
1092       (with-temp-buffer
1093         (insert article-string)
1094         (if spam-bogofilter-database-directory
1095             (call-process-region (point-min) (point-max) 
1096                                  spam-bogofilter-path
1097                                  nil nil nil "-v" switch
1098                                  "-d" spam-bogofilter-database-directory)
1099           (call-process-region (point-min) (point-max) spam-bogofilter-path
1100                                nil nil nil "-v" switch))))))
1101
1102 (defun spam-bogofilter-register-spam-routine ()
1103   (spam-generic-register-routine 
1104    (lambda (article)
1105      (spam-bogofilter-register-with-bogofilter
1106       (spam-get-article-as-string article) t))
1107    nil))
1108
1109 (defun spam-bogofilter-register-ham-routine ()
1110   (spam-generic-register-routine 
1111    nil
1112    (lambda (article)
1113      (spam-bogofilter-register-with-bogofilter
1114       (spam-get-article-as-string article) nil))))
1115
1116 \f
1117 ;;;; spamoracle
1118 (defun spam-check-spamoracle ()
1119   "Run spamoracle on an article to determine whether it's spam."
1120   (let ((article-buffer-name (buffer-name)))
1121     (with-temp-buffer
1122       (let ((temp-buffer-name (buffer-name)))
1123         (save-excursion
1124           (set-buffer article-buffer-name)
1125           (let ((status 
1126                  (apply 'call-process-region 
1127                         (point-min) (point-max)
1128                         spam-spamoracle-binary 
1129                         nil temp-buffer-name nil
1130                         (if spam-spamoracle-database
1131                             `("-f" ,spam-spamoracle-database "mark")
1132                           '("mark")))))
1133             (if (zerop status)
1134                 (progn
1135                   (set-buffer temp-buffer-name)
1136                   (goto-char (point-min))
1137                   (when (re-search-forward "^X-Spam: yes;" nil t)
1138                     spam-split-group))
1139               (error "Error running spamoracle" status))))))))
1140
1141 (defun spam-spamoracle-learn (article article-is-spam-p)
1142   "Run spamoracle in training mode."
1143   (with-temp-buffer
1144     (let ((temp-buffer-name (buffer-name)))
1145       (save-excursion
1146         (goto-char (point-min))
1147         (insert-string (spam-get-article-as-string article))
1148         (let* ((arg (if article-is-spam-p "-spam" "-good"))
1149                (status 
1150                 (apply 'call-process-region
1151                        (point-min) (point-max)
1152                        spam-spamoracle-binary
1153                        nil temp-buffer-name nil
1154                        (if spam-spamoracle-database
1155                            `("-f" ,spam-spamoracle-database 
1156                              "add" ,arg)
1157                          `("add" ,arg)))))
1158           (when (not (zerop status))
1159             (error "Error running spamoracle" status)))))))
1160   
1161 (defun spam-spamoracle-learn-ham ()
1162   (spam-generic-register-routine 
1163    nil
1164    (lambda (article)
1165      (spam-spamoracle-learn article nil))))
1166
1167 (defun spam-spamoracle-learn-spam ()
1168   (spam-generic-register-routine 
1169    (lambda (article)
1170      (spam-spamoracle-learn article t))
1171    nil))
1172 \f
1173 ;;;; Hooks
1174
1175 (defun spam-install-hooks-function ()
1176   "Install the spam.el hooks"
1177   (interactive)
1178   ;; Add hooks for loading and saving the spam stats
1179   (when spam-use-stat
1180     (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
1181     (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
1182     (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load))
1183   (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
1184   (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
1185   (add-hook 'gnus-get-new-news-hook 'spam-setup-widening))
1186
1187 (defun spam-unload-hook ()
1188   "Uninstall the spam.el hooks"
1189   (interactive)
1190   (remove-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
1191   (remove-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
1192   (remove-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load)
1193   (remove-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
1194   (remove-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
1195   (remove-hook 'gnus-get-new-news-hook 'spam-setup-widening))
1196
1197 (when spam-install-hooks
1198   (spam-install-hooks-function))
1199
1200 (provide 'spam)
1201
1202 ;;; spam.el ends here.