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