git.chise.org Git - elisp/gnus.git-/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 'path-util)
  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 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 (exec-installed-p "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 (exec-installed-p "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-default t))))
 616
 617 (add-hook 'gnus-get-new-news-hook 'spam-setup-widening)
 618
 619 \f
 620 ;;;; Regex headers
 621
 622 (defun spam-check-regex-headers ()
 623   (let (ret found)
 624     (dolist (h-regex spam-regex-headers-ham)
 625       (unless found
 626         (goto-char (point-min))
 627         (when (re-search-forward h-regex nil t)
 628           (message "Ham regex header search positive.")
 629           (setq found t))))
 630     (dolist (s-regex spam-regex-headers-spam)
 631       (unless found
 632         (goto-char (point-min))
 633         (when (re-search-forward s-regex nil t)
 634           (message "Spam regex header search positive." (match-string 1))
 635           (setq found t)
 636           (setq ret spam-split-group))))
 637     ret))
 638
 639 \f
 640 ;;;; Blackholes.
 641
 642 (defun spam-check-blackholes ()
 643   "Check the Received headers for blackholed relays."
 644   (let ((headers (message-fetch-field "received"))
 645         ips matches)
 646     (when headers
 647       (with-temp-buffer
 648         (insert headers)
 649         (goto-char (point-min))
 650         (gnus-message 5 "Checking headers for relay addresses")
 651         (while (re-search-forward
 652                 "\\[\\([0-9]+.[0-9]+.[0-9]+.[0-9]+\\)\\]" nil t)
 653           (gnus-message 9 "Blackhole search found host IP %s." (match-string 1))
 654           (push (mapconcat 'identity
 655                            (nreverse (split-string (match-string 1) "\\."))
 656                            ".")
 657                 ips)))
 658       (dolist (server spam-blackhole-servers)
 659         (dolist (ip ips)
 660           (unless (and spam-blackhole-good-server-regex
 661                        (string-match spam-blackhole-good-server-regex ip))
 662             (let ((query-string (concat ip "." server)))
 663               (if spam-use-dig
 664                   (let ((query-result (query-dig query-string)))
 665                     (when query-result
 666                       (gnus-message 5 "(DIG): positive blackhole check '%s'"
 667                                     query-result)
 668                       (push (list ip server query-result)
 669                             matches)))
 670                 ;; else, if not using dig.el
 671                 (when (query-dns query-string)
 672                   (gnus-message 5 "positive blackhole check")
 673                   (push (list ip server (query-dns query-string 'TXT))
 674                         matches))))))))
 675     (when matches
 676       spam-split-group)))
 677 \f
 678 ;;;; Hashcash.
 679
 680 (condition-case nil
 681     (progn
 682       (require 'hashcash)
 683
 684       (defun spam-check-hashcash ()
 685         "Check the headers for hashcash payments."
 686         (mail-check-payment)))          ;mail-check-payment returns a boolean
 687
 688   (file-error (progn
 689                 (defalias 'mail-check-payment 'ignore)
 690                 (defalias 'spam-check-hashcash 'ignore))))
 691 \f
 692 ;;;; BBDB
 693
 694 ;;; original idea for spam-check-BBDB from Alexander Kotelnikov
 695 ;;; <sacha@giotto.sj.ru>
 696
 697 ;; all this is done inside a condition-case to trap errors
 698
 699 (condition-case nil
 700     (progn
 701       (require 'bbdb)
 702       (require 'bbdb-com)
 703
 704   (defun spam-enter-ham-BBDB (from)
 705     "Enter an address into the BBDB; implies ham (non-spam) sender"
 706     (when (stringp from)
 707       (let* ((parsed-address (gnus-extract-address-components from))
 708              (name (or (car parsed-address) "Ham Sender"))
 709              (net-address (car (cdr parsed-address))))
 710         (gnus-message 5 "Adding address %s to BBDB" from)
 711         (when (and net-address
 712                    (not (bbdb-search-simple nil net-address)))
 713           (bbdb-create-internal name nil net-address nil nil
 714                                 "ham sender added by spam.el")))))
 715
 716   (defun spam-BBDB-register-routine ()
 717     (spam-generic-register-routine
 718      ;; spam function
 719      nil
 720      ;; ham function
 721      (lambda (article)
 722        (spam-enter-ham-BBDB (spam-fetch-field-from-fast article)))))
 723
 724   (defun spam-check-BBDB ()
 725     "Mail from people in the BBDB is classified as ham or non-spam"
 726     (let ((who (message-fetch-field "from")))
 727       (when who
 728         (setq who (cadr (gnus-extract-address-components who)))
 729         (if (bbdb-search-simple nil who)
 730             t
 731           (if spam-use-BBDB-exclusive
 732               spam-split-group
 733             nil))))))
 734
 735   (file-error (progn
 736                 (defalias 'bbdb-search-simple 'ignore)
 737                 (defalias 'spam-check-BBDB 'ignore)
 738                 (defalias 'spam-BBDB-register-routine 'ignore)
 739                 (defalias 'spam-enter-ham-BBDB 'ignore)
 740                 (defalias 'bbdb-create-internal 'ignore)
 741                 (defalias 'bbdb-records 'ignore))))
 742
 743 \f
 744 ;;;; ifile
 745
 746 ;;; check the ifile backend; return nil if the mail was NOT classified
 747 ;;; as spam
 748
 749 (defun spam-get-ifile-database-parameter ()
 750   "Get the command-line parameter for ifile's database from spam-ifile-database-path."
 751   (if spam-ifile-database-path
 752       (format "--db-file=%s" spam-ifile-database-path)
 753     nil))
 754
 755 (defun spam-check-ifile ()
 756   "Check the ifile backend for the classification of this message"
 757   (let ((article-buffer-name (buffer-name))
 758         category return)
 759     (with-temp-buffer
 760       (let ((temp-buffer-name (buffer-name))
 761             (db-param (spam-get-ifile-database-parameter)))
 762         (save-excursion
 763           (set-buffer article-buffer-name)
 764           (if db-param
 765               (call-process-region (point-min) (point-max) spam-ifile-path
 766                                    nil temp-buffer-name nil "-q" "-c" db-param)
 767             (call-process-region (point-min) (point-max) spam-ifile-path
 768                                  nil temp-buffer-name nil "-q" "-c")))
 769         (goto-char (point-min))
 770         (if (not (eobp))
 771             (setq category (buffer-substring (point) (spam-point-at-eol))))
 772         (when (not (zerop (length category))) ; we need a category here
 773           (if spam-ifile-all-categories
 774               (setq return category)
 775             ;; else, if spam-ifile-all-categories is not set...
 776             (when (string-equal spam-ifile-spam-category category)
 777               (setq return spam-split-group))))))
 778     return))
 779
 780 (defun spam-ifile-register-with-ifile (article-string category)
 781   "Register an article, given as a string, with a category.
 782 Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
 783   (when (stringp article-string)
 784     (let ((category (or category gnus-newsgroup-name))
 785           (db-param (spam-get-ifile-database-parameter)))
 786       (with-temp-buffer
 787         (insert article-string)
 788         (if db-param
 789             (call-process-region (point-min) (point-max) spam-ifile-path
 790                                  nil nil nil
 791                                  "-h" "-i" category db-param)
 792           (call-process-region (point-min) (point-max) spam-ifile-path
 793                                nil nil nil
 794                                "-h" "-i" category))))))
 795
 796 (defun spam-ifile-register-spam-routine ()
 797   (spam-generic-register-routine
 798    (lambda (article)
 799      (spam-ifile-register-with-ifile
 800       (spam-get-article-as-string article) spam-ifile-spam-category))
 801    nil))
 802
 803 (defun spam-ifile-register-ham-routine ()
 804   (spam-generic-register-routine
 805    nil
 806    (lambda (article)
 807      (spam-ifile-register-with-ifile
 808       (spam-get-article-as-string article) spam-ifile-ham-category))))
 809
 810 \f
 811 ;;;; spam-stat
 812
 813 (condition-case nil
 814     (progn
 815       (let ((spam-stat-install-hooks nil))
 816         (require 'spam-stat))
 817
 818       (defun spam-check-stat ()
 819         "Check the spam-stat backend for the classification of this message"
 820         (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override
 821               (spam-stat-buffer (buffer-name)) ; stat the current buffer
 822               category return)
 823           (spam-stat-split-fancy)))
 824
 825       (defun spam-stat-register-spam-routine ()
 826         (spam-generic-register-routine
 827          (lambda (article)
 828            (let ((article-string (spam-get-article-as-string article)))
 829              (with-temp-buffer
 830                (insert article-string)
 831                (spam-stat-buffer-is-spam))))
 832          nil))
 833
 834       (defun spam-stat-register-ham-routine ()
 835         (spam-generic-register-routine
 836          nil
 837          (lambda (article)
 838            (let ((article-string (spam-get-article-as-string article)))
 839              (with-temp-buffer
 840                (insert article-string)
 841                (spam-stat-buffer-is-non-spam))))))
 842
 843       (defun spam-maybe-spam-stat-load ()
 844         (when spam-use-stat (spam-stat-load)))
 845
 846       (defun spam-maybe-spam-stat-save ()
 847         (when spam-use-stat (spam-stat-save)))
 848
 849       ;; Add hooks for loading and saving the spam stats
 850       (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
 851       (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
 852       (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load))
 853
 854   (file-error (progn
 855                 (defalias 'spam-stat-register-ham-routine 'ignore)
 856                 (defalias 'spam-stat-register-spam-routine 'ignore)
 857                 (defalias 'spam-stat-buffer-is-spam 'ignore)
 858                 (defalias 'spam-stat-buffer-is-non-spam 'ignore)
 859                 (defalias 'spam-stat-split-fancy 'ignore)
 860                 (defalias 'spam-stat-load 'ignore)
 861                 (defalias 'spam-stat-save 'ignore)
 862                 (defalias 'spam-check-stat 'ignore))))
 863
 864 \f
 865
 866 ;;;; Blacklists and whitelists.
 867
 868 (defvar spam-whitelist-cache nil)
 869 (defvar spam-blacklist-cache nil)
 870
 871 (defun spam-enter-whitelist (address)
 872   "Enter ADDRESS into the whitelist."
 873   (interactive "sAddress: ")
 874   (spam-enter-list address spam-whitelist)
 875   (setq spam-whitelist-cache nil))
 876
 877 (defun spam-enter-blacklist (address)
 878   "Enter ADDRESS into the blacklist."
 879   (interactive "sAddress: ")
 880   (spam-enter-list address spam-blacklist)
 881   (setq spam-blacklist-cache nil))
 882
 883 (defun spam-enter-list (address file)
 884   "Enter ADDRESS into the given FILE, either the whitelist or the blacklist."
 885   (unless (file-exists-p (file-name-directory file))
 886     (make-directory (file-name-directory file) t))
 887   (save-excursion
 888     (set-buffer
 889      (find-file-noselect file))
 890     (goto-char (point-max))
 891     (unless (bobp)
 892       (insert "\n"))
 893     (insert address "\n")
 894     (save-buffer)))
 895
 896 ;;; returns t if the sender is in the whitelist, nil or spam-split-group otherwise
 897 (defun spam-check-whitelist ()
 898   ;; FIXME!  Should it detect when file timestamps change?
 899   (unless spam-whitelist-cache
 900     (setq spam-whitelist-cache (spam-parse-list spam-whitelist)))
 901   (if (spam-from-listed-p spam-whitelist-cache)
 902       t
 903     (if spam-use-whitelist-exclusive
 904         spam-split-group
 905       nil)))
 906
 907 (defun spam-check-blacklist ()
 908   ;; FIXME!  Should it detect when file timestamps change?
 909   (unless spam-blacklist-cache
 910     (setq spam-blacklist-cache (spam-parse-list spam-blacklist)))
 911   (and (spam-from-listed-p spam-blacklist-cache) spam-split-group))
 912
 913 (defun spam-parse-list (file)
 914   (when (file-readable-p file)
 915     (let (contents address)
 916       (with-temp-buffer
 917         (insert-file-contents file)
 918         (while (not (eobp))
 919           (setq address (buffer-substring (point) (spam-point-at-eol)))
 920           (forward-line 1)
 921           (unless (zerop (length address))
 922             (setq address (regexp-quote address))
 923             (while (string-match "\\\\\\*" address)
 924               (setq address (replace-match ".*" t t address)))
 925             (push address contents))))
 926       (nreverse contents))))
 927
 928 (defun spam-from-listed-p (cache)
 929   (let ((from (message-fetch-field "from"))
 930         found)
 931     (while cache
 932       (when (string-match (pop cache) from)
 933         (setq found t
 934               cache nil)))
 935     found))
 936
 937 (defun spam-blacklist-register-routine ()
 938   (spam-generic-register-routine
 939    ;; the spam function
 940    (lambda (article)
 941      (let ((from (spam-fetch-field-from-fast article)))
 942        (when (stringp from)
 943            (spam-enter-blacklist from))))
 944    ;; the ham function
 945    nil))
 946
 947 (defun spam-whitelist-register-routine ()
 948   (spam-generic-register-routine
 949    ;; the spam function
 950    nil
 951    ;; the ham function
 952    (lambda (article)
 953      (let ((from (spam-fetch-field-from-fast article)))
 954        (when (stringp from)
 955            (spam-enter-whitelist from))))))
 956
 957 \f
 958 ;;;; Bogofilter
 959
 960 (defun spam-check-bogofilter-headers (&optional score)
 961   (let ((header (message-fetch-field spam-bogofilter-header)))
 962       (when (and header
 963                  (string-match spam-bogofilter-bogosity-positive-spam-header
 964                                header))
 965           (if score
 966               (when (string-match "spamicity=\\([0-9.]+\\)" header)
 967                 (match-string 1 header))
 968             spam-split-group))))
 969
 970 ;; return something sensible if the score can't be determined
 971 (defun spam-bogofilter-score ()
 972   "Get the Bogofilter spamicity score"
 973   (interactive)
 974   (save-window-excursion
 975     (gnus-summary-show-article t)
 976     (set-buffer gnus-article-buffer)
 977     (let ((score (spam-check-bogofilter t)))
 978       (message "Spamicity score %s" score)
 979       (or score "0"))))
 980
 981 (defun spam-check-bogofilter (&optional score)
 982   "Check the Bogofilter backend for the classification of this message"
 983   (let ((article-buffer-name (buffer-name))
 984         return)
 985     (with-temp-buffer
 986       (let ((temp-buffer-name (buffer-name)))
 987         (save-excursion
 988           (set-buffer article-buffer-name)
 989           (if spam-bogofilter-database-directory
 990               (call-process-region (point-min) (point-max)
 991                                    spam-bogofilter-path
 992                                    nil temp-buffer-name nil "-v"
 993                                    "-d" spam-bogofilter-database-directory)
 994             (call-process-region (point-min) (point-max) spam-bogofilter-path
 995                                  nil temp-buffer-name nil "-v")))
 996         (setq return (spam-check-bogofilter-headers score))))
 997     return))
 998
 999 (defun spam-bogofilter-register-with-bogofilter (article-string spam)
1000   "Register an article, given as a string, as spam or non-spam."
1001   (when (stringp article-string)
1002     (let ((switch (if spam spam-bogofilter-spam-switch
1003                     spam-bogofilter-ham-switch)))
1004       (with-temp-buffer
1005         (insert article-string)
1006         (if spam-bogofilter-database-directory
1007             (call-process-region (point-min) (point-max)
1008                                  spam-bogofilter-path
1009                                  nil nil nil "-v" switch
1010                                  "-d" spam-bogofilter-database-directory)
1011           (call-process-region (point-min) (point-max) spam-bogofilter-path
1012                                nil nil nil "-v" switch))))))
1013
1014 (defun spam-bogofilter-register-spam-routine ()
1015   (spam-generic-register-routine
1016    (lambda (article)
1017      (spam-bogofilter-register-with-bogofilter
1018       (spam-get-article-as-string article) t))
1019    nil))
1020
1021 (defun spam-bogofilter-register-ham-routine ()
1022   (spam-generic-register-routine
1023    nil
1024    (lambda (article)
1025      (spam-bogofilter-register-with-bogofilter
1026       (spam-get-article-as-string article) nil))))
1027
1028 (provide 'spam)
1029
1030 ;;; spam.el ends here.