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, 2010 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 (if (locate-library "epg")
 105                                    'gnus-nocem-epg-verify
 106                                  'pgg-verify)
 107   "*Function called to verify that the NoCeM message is valid.
 108 If the function in this variable isn't bound, the message will be used
 109 unconditionally."
 110   :group 'gnus-nocem
 111   :version "23.1"
 112   :type '(radio (function-item gnus-nocem-epg-verify)
 113                 (function-item pgg-verify)
 114                 (function-item mc-verify)
 115                 (function :tag "other"))
 116   :set (lambda (symbol value)
 117          (custom-set-default symbol
 118                              (if (and (eq value 'gnus-nocem-epg-verify)
 119                                       (not (locate-library "epg")))
 120                                  'pgg-verify
 121                                value))))
 122
 123 (defcustom gnus-nocem-liberal-fetch nil
 124   "*If t try to fetch all messages which have @@NCM in the subject.
 125 Otherwise don't fetch messages which have references or whose message-id
 126 matches a previously scanned and verified nocem message."
 127   :group 'gnus-nocem
 128   :type 'boolean)
 129
 130 (defcustom gnus-nocem-check-article-limit 500
 131   "*If non-nil, the maximum number of articles to check in any NoCeM group."
 132   :group 'gnus-nocem
 133   :version "21.1"
 134   :type '(choice (const :tag "unlimited" nil)
 135                  (integer 1000)))
 136
 137 (defcustom gnus-nocem-check-from t
 138   "Non-nil means check for valid issuers in message bodies.
 139 Otherwise don't bother fetching articles unless their author matches a
 140 valid issuer, which is much faster if you are selective about the issuers."
 141   :group 'gnus-nocem
 142   :version "21.1"
 143   :type 'boolean)
 144
 145 ;;; Internal variables
 146
 147 (defvar gnus-nocem-active nil)
 148 (defvar gnus-nocem-alist nil)
 149 (defvar gnus-nocem-touched-alist nil)
 150 (defvar gnus-nocem-hashtb nil)
 151 (defvar gnus-nocem-seen-message-ids nil)
 152
 153 ;;; Functions
 154
 155 (defun gnus-nocem-active-file ()
 156   (concat (file-name-as-directory gnus-nocem-directory) "active"))
 157
 158 (defun gnus-nocem-cache-file ()
 159   (concat (file-name-as-directory gnus-nocem-directory) "cache"))
 160
 161 ;;
 162 ;; faster lookups for group names:
 163 ;;
 164
 165 (defvar gnus-nocem-real-group-hashtb nil
 166   "Real-name mappings of subscribed groups.")
 167
 168 (defun gnus-fill-real-hashtb ()
 169   "Fill up a hash table with the real-name mappings from the user's active file."
 170   (if (hash-table-p gnus-nocem-real-group-hashtb)
 171       (clrhash gnus-nocem-real-group-hashtb)
 172     (setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal)))
 173   (mapcar (lambda (group)
 174             (setq group (gnus-group-real-name (car group)))
 175             (puthash group t gnus-nocem-real-group-hashtb))
 176           gnus-newsrc-alist))
 177
 178 ;;;###autoload
 179 (defun gnus-nocem-scan-groups ()
 180   "Scan all NoCeM groups for new NoCeM messages."
 181   (interactive)
 182   (let ((groups gnus-nocem-groups)
 183         (gnus-inhibit-demon t)
 184         group active gactive articles check-headers)
 185     (gnus-make-directory gnus-nocem-directory)
 186     ;; Load any previous NoCeM headers.
 187     (gnus-nocem-load-cache)
 188     ;; Get the group name mappings:
 189     (gnus-fill-real-hashtb)
 190     ;; Read the active file if it hasn't been read yet.
 191     (and (file-exists-p (gnus-nocem-active-file))
 192          (not gnus-nocem-active)
 193          (ignore-errors
 194            (load (gnus-nocem-active-file) t t t)))
 195     ;; Go through all groups and see whether new articles have
 196     ;; arrived.
 197     (while (setq group (pop groups))
 198       (if (not (setq gactive (gnus-activate-group group)))
 199           ()                            ; This group doesn't exist.
 200         (setq active (nth 1 (assoc group gnus-nocem-active)))
 201         (when (and (not (< (cdr gactive) (car gactive))) ; Empty group.
 202                    (or (not active)
 203                        (< (cdr active) (cdr gactive))))
 204           ;; Ok, there are new articles in this group, se we fetch the
 205           ;; headers.
 206           (save-excursion
 207             (let ((dependencies (make-vector 10 nil))
 208                   headers header)
 209               (with-temp-buffer
 210                 (setq headers
 211                       (if (eq 'nov
 212                               (gnus-retrieve-headers
 213                                (setq articles
 214                                      (gnus-uncompress-range
 215                                       (cons
 216                                        (if active (1+ (cdr active))
 217                                          (car gactive))
 218                                        (cdr gactive))))
 219                                group))
 220                           (gnus-get-newsgroup-headers-xover
 221                            articles nil dependencies)
 222                         (gnus-get-newsgroup-headers dependencies)))
 223                 (while (setq header (pop headers))
 224                   ;; We take a closer look on all articles that have
 225                   ;; "@@NCM" in the subject.  Unless we already read
 226                   ;; this cross posted message.  Nocem messages
 227                   ;; are not allowed to have references, so we can
 228                   ;; ignore scanning followups.
 229                   (and (string-match "@@NCM" (mail-header-subject header))
 230                        (and gnus-nocem-check-from
 231                             (let ((case-fold-search t))
 232                               (catch 'ok
 233                                 (mapc
 234                                  (lambda (author)
 235                                    (if (consp author)
 236                                        (setq author (car author)))
 237                                    (if (string-match
 238                                         author (mail-header-from header))
 239                                        (throw 'ok t)))
 240                                  gnus-nocem-issuers)
 241                                 nil)))
 242                        (or gnus-nocem-liberal-fetch
 243                            (and (or (string= "" (mail-header-references
 244                                                  header))
 245                                     (null (mail-header-references header)))
 246                                 (not (member (mail-header-message-id header)
 247                                              gnus-nocem-seen-message-ids))))
 248                        (push header check-headers)))
 249                 (setq check-headers (last (nreverse check-headers)
 250                                           gnus-nocem-check-article-limit))
 251                 (let ((i 0)
 252                       (len (length check-headers)))
 253                   (dolist (h check-headers)
 254                     (gnus-message
 255                      7 "Checking article %d in %s for NoCeM (%d of %d)..."
 256                      (mail-header-number h) group (incf i) len)
 257                     (gnus-nocem-check-article group h)))))))
 258         (setq gnus-nocem-active
 259               (cons (list group gactive)
 260                     (delq (assoc group gnus-nocem-active)
 261                           gnus-nocem-active)))))
 262     ;; Save the results, if any.
 263     (gnus-nocem-save-cache)
 264     (gnus-nocem-save-active)))
 265
 266 (defun gnus-nocem-check-article (group header)
 267   "Check whether the current article is an NCM article and that we want it."
 268   ;; Get the article.
 269   (let ((date (mail-header-date header))
 270         (gnus-newsgroup-name group)
 271         issuer b e type)
 272     (when (or (not date)
 273               (time-less-p
 274                (time-since (date-to-time date))
 275                (days-to-time gnus-nocem-expiry-wait)))
 276       (gnus-request-article-this-buffer (mail-header-number header) group)
 277       (goto-char (point-min))
 278       (when (re-search-forward
 279              "-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----"
 280              nil t)
 281         (delete-region (point-min) (match-beginning 0)))
 282       (when (re-search-forward
 283              "-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?"
 284              nil t)
 285         (delete-region (match-end 0) (point-max)))
 286       (goto-char (point-min))
 287       ;; The article has to have proper NoCeM headers.
 288       (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t))
 289                  (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t)))
 290         ;; We get the name of the issuer.
 291         (narrow-to-region b e)
 292         (setq issuer (mail-fetch-field "issuer")
 293               type (mail-fetch-field "type"))
 294         (widen)
 295         (if (not (gnus-nocem-message-wanted-p issuer type))
 296             (message "invalid NoCeM issuer: %s" issuer)
 297           (and (gnus-nocem-verify-issuer issuer) ; She is who she says she is.
 298                (gnus-nocem-enter-article) ; We gobble the message.
 299                (push (mail-header-message-id header) ; But don't come back for
 300                      gnus-nocem-seen-message-ids))))))) ; second helpings.
 301
 302 (defun gnus-nocem-message-wanted-p (issuer type)
 303   (let ((issuers gnus-nocem-issuers)
 304         wanted conditions condition)
 305     (cond
 306      ;; Do the quick check first.
 307      ((member issuer issuers)
 308       t)
 309      ((setq conditions (cdr (assoc issuer issuers)))
 310       ;; Check whether we want this type.
 311       (while (setq condition (pop conditions))
 312         (cond
 313          ((stringp condition)
 314           (when (string-match condition type)
 315             (setq wanted t)))
 316          ((and (consp condition)
 317                (eq (car condition) 'not)
 318                (stringp (cadr condition)))
 319           (when (string-match (cadr condition) type)
 320             (setq wanted nil)))
 321          (t
 322           (error "Invalid NoCeM condition: %S" condition))))
 323       wanted))))
 324
 325 (defun gnus-nocem-verify-issuer (person)
 326   "Verify using PGP that the canceler is who she says she is."
 327   (if (functionp gnus-nocem-verifyer)
 328       (ignore-errors
 329         (funcall gnus-nocem-verifyer))
 330     ;; If we don't have Mailcrypt, then we use the message anyway.
 331     t))
 332
 333 (defun gnus-nocem-enter-article ()
 334   "Enter the current article into the NoCeM cache."
 335   (goto-char (point-min))
 336   (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t))
 337         (e (search-forward "\n@@END NCM BODY\n" nil t))
 338         (buf (current-buffer))
 339         ncm id group)
 340     (when (and b e)
 341       (narrow-to-region b (1+ (match-beginning 0)))
 342       (goto-char (point-min))
 343       (while (search-forward "\t" nil t)
 344         (cond
 345          ((not (ignore-errors
 346                  (setq group (gnus-group-real-name (symbol-name (read buf))))
 347                  (gethash group gnus-nocem-real-group-hashtb)))
 348           ;; An error.
 349           )
 350          (t
 351           ;; Valid group.
 352           (beginning-of-line)
 353           (while (eq (char-after) ?\t)
 354             (forward-line -1))
 355           (setq id (buffer-substring (point) (1- (search-forward "\t"))))
 356           (unless (if (hash-table-p gnus-nocem-hashtb)
 357                       (gethash id gnus-nocem-hashtb)
 358                     (setq gnus-nocem-hashtb (make-hash-table :test 'equal))
 359                     nil)
 360             ;; only store if not already present
 361             (puthash id t gnus-nocem-hashtb)
 362             (push id ncm))
 363           (forward-line 1)
 364           (while (eq (char-after) ?\t)
 365             (forward-line 1)))))
 366       (when ncm
 367         (setq gnus-nocem-touched-alist t)
 368         (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
 369                     ncm)
 370               gnus-nocem-alist))
 371       t)))
 372
 373 ;;;###autoload
 374 (defun gnus-nocem-load-cache ()
 375   "Load the NoCeM cache."
 376   (interactive)
 377   (unless gnus-nocem-alist
 378     ;; The buffer doesn't exist, so we create it and load the NoCeM
 379     ;; cache.
 380     (when (file-exists-p (gnus-nocem-cache-file))
 381       (load (gnus-nocem-cache-file) t t t)
 382       (gnus-nocem-alist-to-hashtb))))
 383
 384 (defun gnus-nocem-save-cache ()
 385   "Save the NoCeM cache."
 386   (when (and gnus-nocem-alist
 387              gnus-nocem-touched-alist)
 388     (with-temp-file (gnus-nocem-cache-file)
 389       (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist)))
 390     (setq gnus-nocem-touched-alist nil)))
 391
 392 (defun gnus-nocem-save-active ()
 393   "Save the NoCeM active file."
 394   (with-temp-file (gnus-nocem-active-file)
 395     (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active))))
 396
 397 (defun gnus-nocem-alist-to-hashtb ()
 398   "Create a hashtable from the Message-IDs we have."
 399   (let* ((alist gnus-nocem-alist)
 400          (pprev (cons nil alist))
 401          (prev pprev)
 402          (expiry (days-to-time gnus-nocem-expiry-wait))
 403          entry)
 404     (if (hash-table-p gnus-nocem-hashtb)
 405         (clrhash gnus-nocem-hashtb)
 406       (setq gnus-nocem-hashtb (make-hash-table :test 'equal)))
 407     (while (setq entry (car alist))
 408       (if (not (time-less-p (time-since (car entry)) expiry))
 409           ;; This entry has expired, so we remove it.
 410           (setcdr prev (cdr alist))
 411         (setq prev alist)
 412         ;; This is ok, so we enter it into the hashtable.
 413         (setq entry (cdr entry))
 414         (while entry
 415           (puthash (car entry) t gnus-nocem-hashtb)
 416           (setq entry (cdr entry))))
 417       (setq alist (cdr alist)))))
 418
 419 (gnus-add-shutdown 'gnus-nocem-close 'gnus)
 420
 421 (defun gnus-nocem-close ()
 422   "Clear internal NoCeM variables."
 423   (setq gnus-nocem-alist nil
 424         gnus-nocem-hashtb nil
 425         gnus-nocem-active nil
 426         gnus-nocem-touched-alist nil
 427         gnus-nocem-seen-message-ids nil
 428         gnus-nocem-real-group-hashtb nil))
 429
 430 (defun gnus-nocem-unwanted-article-p (id)
 431   "Say whether article ID in the current group is wanted."
 432   (and gnus-nocem-hashtb
 433        (gethash id gnus-nocem-hashtb)))
 434
 435 (autoload 'epg-make-context "epg")
 436 (eval-when-compile
 437   (autoload 'epg-verify-string "epg")
 438   (autoload 'epg-context-result-for "epg")
 439   (autoload 'epg-signature-status "epg"))
 440
 441 (defun gnus-nocem-epg-verify ()
 442   "Return t if EasyPG verifies a signed message in the current buffer."
 443   (let ((context (epg-make-context 'OpenPGP))
 444         result)
 445     (epg-verify-string context (buffer-string))
 446     (and (setq result (epg-context-result-for context 'verify))
 447          (not (cdr result))
 448          (eq (epg-signature-status (car result)) 'good))))
 449
 450 (provide 'gnus-nocem)
 451
 452 ;;; gnus-nocem.el ends here