cgit.sxemacs.org Git - gnus/blob - lisp/gnus-nocem.el

   1 ;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
   2
   3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'gnus)
  31 (require 'nnmail)
  32 (require 'gnus-art)
  33 (require 'gnus-sum)
  34 (require 'gnus-range)
  35
  36 (defgroup gnus-nocem nil
  37   "NoCeM pseudo-cancellation treatment."
  38   :group 'gnus-score)
  39
  40 (defcustom gnus-nocem-groups
  41   '("news.lists.filters" "alt.nocem.misc")
  42   "*List of groups that will be searched for NoCeM messages."
  43   :group 'gnus-nocem
  44   :version "23.1"
  45   :type '(repeat (string :tag "Group")))
  46
  47 (defcustom gnus-nocem-issuers
  48   '("Adri Verhoef"
  49     "alba-nocem@albasani.net"
  50     "bleachbot@httrack.com"
  51     "news@arcor-online.net"
  52     "news@uni-berlin.de"
  53     "nocem@arcor.de"
  54     "pgpmoose@killfile.org"
  55     "xjsppl@gmx.de")
  56   "*List of NoCeM issuers to pay attention to.
  57
  58 This can also be a list of `(ISSUER CONDITION ...)' elements.
  59
  60 See <URL:http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html> for an
  61 issuer registry."
  62   :group 'gnus-nocem
  63   :link '(url-link "http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html")
  64   :version "23.1"
  65   :type '(repeat (cons :format "%v" (string :tag "Issuer")
  66                        (repeat :tag "Condition"
  67                                (group (checklist :inline t (const not))
  68                                       (regexp :tag "Type" :value ".*")))))
  69   :get (lambda (symbol)
  70          (mapcar (lambda (elem)
  71                    (if (consp elem)
  72                        (cons (car elem)
  73                              (mapcar (lambda (elt)
  74                                        (if (consp elt) elt (list elt)))
  75                                      (cdr elem)))
  76                      (list elem)))
  77                  (default-value symbol)))
  78   :set (lambda (symbol value)
  79          (custom-set-default
  80           symbol
  81           (mapcar (lambda (elem)
  82                     (if (consp elem)
  83                         (if (cdr elem)
  84                             (mapcar (lambda (elt)
  85                                       (if (consp elt)
  86                                           (if (cdr elt) elt (car elt))
  87                                         elt))
  88                                     elem)
  89                           (car elem))
  90                       elem))
  91                   value))))
  92
  93 (defcustom gnus-nocem-directory
  94   (nnheader-concat gnus-article-save-directory "NoCeM/")
  95   "*Directory where NoCeM files will be stored."
  96   :group 'gnus-nocem
  97   :type 'directory)
  98
  99 (defcustom gnus-nocem-expiry-wait 15
 100   "*Number of days to keep NoCeM headers in the cache."
 101   :group 'gnus-nocem
 102   :type 'integer)
 103
 104 (defcustom gnus-nocem-verifyer 'gnus-nocem-epg-verify
 105   "*Function called to verify that the NoCeM message is valid.
 106 One likely value is `gnus-nocem-epg-verify'.  If the function in this
 107 variable isn't bound, the message will be used unconditionally."
 108   :group 'gnus-nocem
 109   :version "23.1"
 110   :type '(radio (function-item gnus-nocem-epg-verify)
 111                 (function-item pgg-verify)
 112                 (function-item mc-verify)
 113                 (function :tag "other")))
 114
 115 (defcustom gnus-nocem-liberal-fetch nil
 116   "*If t try to fetch all messages which have @@NCM in the subject.
 117 Otherwise don't fetch messages which have references or whose message-id
 118 matches a previously scanned and verified nocem message."
 119   :group 'gnus-nocem
 120   :type 'boolean)
 121
 122 (defcustom gnus-nocem-check-article-limit 500
 123   "*If non-nil, the maximum number of articles to check in any NoCeM group."
 124   :group 'gnus-nocem
 125   :version "21.1"
 126   :type '(choice (const :tag "unlimited" nil)
 127                  (integer 1000)))
 128
 129 (defcustom gnus-nocem-check-from t
 130   "Non-nil means check for valid issuers in message bodies.
 131 Otherwise don't bother fetching articles unless their author matches a
 132 valid issuer, which is much faster if you are selective about the issuers."
 133   :group 'gnus-nocem
 134   :version "21.1"
 135   :type 'boolean)
 136
 137 ;;; Internal variables
 138
 139 (defvar gnus-nocem-active nil)
 140 (defvar gnus-nocem-alist nil)
 141 (defvar gnus-nocem-touched-alist nil)
 142 (defvar gnus-nocem-hashtb nil)
 143 (defvar gnus-nocem-seen-message-ids nil)
 144
 145 ;;; Functions
 146
 147 (defun gnus-nocem-active-file ()
 148   (concat (file-name-as-directory gnus-nocem-directory) "active"))
 149
 150 (defun gnus-nocem-cache-file ()
 151   (concat (file-name-as-directory gnus-nocem-directory) "cache"))
 152
 153 ;;
 154 ;; faster lookups for group names:
 155 ;;
 156
 157 (defvar gnus-nocem-real-group-hashtb nil
 158   "Real-name mappings of subscribed groups.")
 159
 160 (defun gnus-fill-real-hashtb ()
 161   "Fill up a hash table with the real-name mappings from the user's active file."
 162   (if (hash-table-p gnus-nocem-real-group-hashtb)
 163       (clrhash gnus-nocem-real-group-hashtb)
 164     (setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal)))
 165   (mapcar (lambda (group)
 166             (setq group (gnus-group-real-name (car group)))
 167             (puthash group t gnus-nocem-real-group-hashtb))
 168           gnus-newsrc-alist))
 169
 170 ;;;###autoload
 171 (defun gnus-nocem-scan-groups ()
 172   "Scan all NoCeM groups for new NoCeM messages."
 173   (interactive)
 174   (let ((groups gnus-nocem-groups)
 175         (gnus-inhibit-demon t)
 176         group active gactive articles check-headers)
 177     (gnus-make-directory gnus-nocem-directory)
 178     ;; Load any previous NoCeM headers.
 179     (gnus-nocem-load-cache)
 180     ;; Get the group name mappings:
 181     (gnus-fill-real-hashtb)
 182     ;; Read the active file if it hasn't been read yet.
 183     (and (file-exists-p (gnus-nocem-active-file))
 184          (not gnus-nocem-active)
 185          (ignore-errors
 186            (load (gnus-nocem-active-file) t t t)))
 187     ;; Go through all groups and see whether new articles have
 188     ;; arrived.
 189     (while (setq group (pop groups))
 190       (if (not (setq gactive (gnus-activate-group group)))
 191           ()                            ; This group doesn't exist.
 192         (setq active (nth 1 (assoc group gnus-nocem-active)))
 193         (when (and (not (< (cdr gactive) (car gactive))) ; Empty group.
 194                    (or (not active)
 195                        (< (cdr active) (cdr gactive))))
 196           ;; Ok, there are new articles in this group, se we fetch the
 197           ;; headers.
 198           (save-excursion
 199             (let ((dependencies (make-vector 10 nil))
 200                   headers header)
 201               (with-temp-buffer
 202                 (setq headers
 203                       (if (eq 'nov
 204                               (gnus-retrieve-headers
 205                                (setq articles
 206                                      (gnus-uncompress-range
 207                                       (cons
 208                                        (if active (1+ (cdr active))
 209                                          (car gactive))
 210                                        (cdr gactive))))
 211                                group))
 212                           (gnus-get-newsgroup-headers-xover
 213                            articles nil dependencies)
 214                         (gnus-get-newsgroup-headers dependencies)))
 215                 (while (setq header (pop headers))
 216                   ;; We take a closer look on all articles that have
 217                   ;; "@@NCM" in the subject.  Unless we already read
 218                   ;; this cross posted message.  Nocem messages
 219                   ;; are not allowed to have references, so we can
 220                   ;; ignore scanning followups.
 221                   (and (string-match "@@NCM" (mail-header-subject header))
 222                        (and gnus-nocem-check-from
 223                             (let ((case-fold-search t))
 224                               (catch 'ok
 225                                 (mapc
 226                                  (lambda (author)
 227                                    (if (consp author)
 228                                        (setq author (car author)))
 229                                    (if (string-match
 230                                         author (mail-header-from header))
 231                                        (throw 'ok t)))
 232                                  gnus-nocem-issuers)
 233                                 nil)))
 234                        (or gnus-nocem-liberal-fetch
 235                            (and (or (string= "" (mail-header-references
 236                                                  header))
 237                                     (null (mail-header-references header)))
 238                                 (not (member (mail-header-message-id header)
 239                                              gnus-nocem-seen-message-ids))))
 240                        (push header check-headers)))
 241                 (setq check-headers (last (nreverse check-headers)
 242                                           gnus-nocem-check-article-limit))
 243                 (let ((i 0)
 244                       (len (length check-headers)))
 245                   (dolist (h check-headers)
 246                     (gnus-message
 247                      7 "Checking article %d in %s for NoCeM (%d of %d)..."
 248                      (mail-header-number h) group (incf i) len)
 249                     (gnus-nocem-check-article group h)))))))
 250         (setq gnus-nocem-active
 251               (cons (list group gactive)
 252                     (delq (assoc group gnus-nocem-active)
 253                           gnus-nocem-active)))))
 254     ;; Save the results, if any.
 255     (gnus-nocem-save-cache)
 256     (gnus-nocem-save-active)))
 257
 258 (defun gnus-nocem-check-article (group header)
 259   "Check whether the current article is an NCM article and that we want it."
 260   ;; Get the article.
 261   (let ((date (mail-header-date header))
 262         (gnus-newsgroup-name group)
 263         issuer b e type)
 264     (when (or (not date)
 265               (time-less-p
 266                (time-since (date-to-time date))
 267                (days-to-time gnus-nocem-expiry-wait)))
 268       (gnus-request-article-this-buffer (mail-header-number header) group)
 269       (goto-char (point-min))
 270       (when (re-search-forward
 271              "-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----"
 272              nil t)
 273         (delete-region (point-min) (match-beginning 0)))
 274       (when (re-search-forward
 275              "-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?"
 276              nil t)
 277         (delete-region (match-end 0) (point-max)))
 278       (goto-char (point-min))
 279       ;; The article has to have proper NoCeM headers.
 280       (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t))
 281                  (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t)))
 282         ;; We get the name of the issuer.
 283         (narrow-to-region b e)
 284         (setq issuer (mail-fetch-field "issuer")
 285               type (mail-fetch-field "type"))
 286         (widen)
 287         (if (not (gnus-nocem-message-wanted-p issuer type))
 288             (message "invalid NoCeM issuer: %s" issuer)
 289           (and (gnus-nocem-verify-issuer issuer) ; She is who she says she is.
 290                (gnus-nocem-enter-article) ; We gobble the message.
 291                (push (mail-header-message-id header) ; But don't come back for
 292                      gnus-nocem-seen-message-ids))))))) ; second helpings.
 293
 294 (defun gnus-nocem-message-wanted-p (issuer type)
 295   (let ((issuers gnus-nocem-issuers)
 296         wanted conditions condition)
 297     (cond
 298      ;; Do the quick check first.
 299      ((member issuer issuers)
 300       t)
 301      ((setq conditions (cdr (assoc issuer issuers)))
 302       ;; Check whether we want this type.
 303       (while (setq condition (pop conditions))
 304         (cond
 305          ((stringp condition)
 306           (when (string-match condition type)
 307             (setq wanted t)))
 308          ((and (consp condition)
 309                (eq (car condition) 'not)
 310                (stringp (cadr condition)))
 311           (when (string-match (cadr condition) type)
 312             (setq wanted nil)))
 313          (t
 314           (error "Invalid NoCeM condition: %S" condition))))
 315       wanted))))
 316
 317 (defun gnus-nocem-verify-issuer (person)
 318   "Verify using PGP that the canceler is who she says she is."
 319   (if (functionp gnus-nocem-verifyer)
 320       (ignore-errors
 321         (funcall gnus-nocem-verifyer))
 322     ;; If we don't have Mailcrypt, then we use the message anyway.
 323     t))
 324
 325 (defun gnus-nocem-enter-article ()
 326   "Enter the current article into the NoCeM cache."
 327   (goto-char (point-min))
 328   (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t))
 329         (e (search-forward "\n@@END NCM BODY\n" nil t))
 330         (buf (current-buffer))
 331         ncm id group)
 332     (when (and b e)
 333       (narrow-to-region b (1+ (match-beginning 0)))
 334       (goto-char (point-min))
 335       (while (search-forward "\t" nil t)
 336         (cond
 337          ((not (ignore-errors
 338                  (setq group (gnus-group-real-name (symbol-name (read buf))))
 339                  (gethash group gnus-nocem-real-group-hashtb)))
 340           ;; An error.
 341           )
 342          (t
 343           ;; Valid group.
 344           (beginning-of-line)
 345           (while (eq (char-after) ?\t)
 346             (forward-line -1))
 347           (setq id (buffer-substring (point) (1- (search-forward "\t"))))
 348           (unless (if (hash-table-p gnus-nocem-hashtb)
 349                       (gethash id gnus-nocem-hashtb)
 350                     (setq gnus-nocem-hashtb (make-hash-table :test 'equal))
 351                     nil)
 352             ;; only store if not already present
 353             (puthash id t gnus-nocem-hashtb)
 354             (push id ncm))
 355           (forward-line 1)
 356           (while (eq (char-after) ?\t)
 357             (forward-line 1)))))
 358       (when ncm
 359         (setq gnus-nocem-touched-alist t)
 360         (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
 361                     ncm)
 362               gnus-nocem-alist))
 363       t)))
 364
 365 ;;;###autoload
 366 (defun gnus-nocem-load-cache ()
 367   "Load the NoCeM cache."
 368   (interactive)
 369   (unless gnus-nocem-alist
 370     ;; The buffer doesn't exist, so we create it and load the NoCeM
 371     ;; cache.
 372     (when (file-exists-p (gnus-nocem-cache-file))
 373       (load (gnus-nocem-cache-file) t t t)
 374       (gnus-nocem-alist-to-hashtb))))
 375
 376 (defun gnus-nocem-save-cache ()
 377   "Save the NoCeM cache."
 378   (when (and gnus-nocem-alist
 379              gnus-nocem-touched-alist)
 380     (with-temp-file (gnus-nocem-cache-file)
 381       (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist)))
 382     (setq gnus-nocem-touched-alist nil)))
 383
 384 (defun gnus-nocem-save-active ()
 385   "Save the NoCeM active file."
 386   (with-temp-file (gnus-nocem-active-file)
 387     (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active))))
 388
 389 (defun gnus-nocem-alist-to-hashtb ()
 390   "Create a hashtable from the Message-IDs we have."
 391   (let* ((alist gnus-nocem-alist)
 392          (pprev (cons nil alist))
 393          (prev pprev)
 394          (expiry (days-to-time gnus-nocem-expiry-wait))
 395          entry)
 396     (if (hash-table-p gnus-nocem-hashtb)
 397         (clrhash gnus-nocem-hashtb)
 398       (setq gnus-nocem-hashtb (make-hash-table :test 'equal)))
 399     (while (setq entry (car alist))
 400       (if (not (time-less-p (time-since (car entry)) expiry))
 401           ;; This entry has expired, so we remove it.
 402           (setcdr prev (cdr alist))
 403         (setq prev alist)
 404         ;; This is ok, so we enter it into the hashtable.
 405         (setq entry (cdr entry))
 406         (while entry
 407           (puthash (car entry) t gnus-nocem-hashtb)
 408           (setq entry (cdr entry))))
 409       (setq alist (cdr alist)))))
 410
 411 (gnus-add-shutdown 'gnus-nocem-close 'gnus)
 412
 413 (defun gnus-nocem-close ()
 414   "Clear internal NoCeM variables."
 415   (setq gnus-nocem-alist nil
 416         gnus-nocem-hashtb nil
 417         gnus-nocem-active nil
 418         gnus-nocem-touched-alist nil
 419         gnus-nocem-seen-message-ids nil
 420         gnus-nocem-real-group-hashtb nil))
 421
 422 (defun gnus-nocem-unwanted-article-p (id)
 423   "Say whether article ID in the current group is wanted."
 424   (and gnus-nocem-hashtb
 425        (gethash id gnus-nocem-hashtb)))
 426
 427 (autoload 'epg-make-context "epg")
 428 (eval-when-compile
 429   (autoload 'epg-verify-string "epg")
 430   (autoload 'epg-context-result-for "epg")
 431   (autoload 'epg-signature-status "epg"))
 432
 433 (defun gnus-nocem-epg-verify ()
 434   "Return t if EasyPG verifies a signed message in the current buffer."
 435   (let ((context (epg-make-context 'OpenPGP))
 436         result)
 437     (epg-verify-string context (buffer-string))
 438     (and (setq result (epg-context-result-for context 'verify))
 439          (not (cdr result))
 440          (eq (epg-signature-status (car result)) 'good))))
 441
 442 (provide 'gnus-nocem)
 443
 444 ;; arch-tag: 0e0c74ea-2f8e-4f3e-8fff-09f767c1adef
 445 ;;; gnus-nocem.el ends here