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