| 1 | ;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment |
| 2 | ;; Copyright (C) 1995,96 Free Software Foundation, Inc. |
| 3 | |
| 4 | ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> |
| 5 | ;; Keywords: news |
| 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 | ;;; Code: |
| 27 | |
| 28 | (require 'gnus) |
| 29 | (require 'nnmail) |
| 30 | (eval-when-compile (require 'cl)) |
| 31 | |
| 32 | (defvar gnus-nocem-groups |
| 33 | '("alt.nocem.misc" "news.admin.net-abuse.announce") |
| 34 | "*List of groups that will be searched for NoCeM messages.") |
| 35 | |
| 36 | (defvar gnus-nocem-issuers |
| 37 | '("Automoose-1" ; The CancelMoose[tm] on autopilot. |
| 38 | "clewis@ferret.ocunix.on.ca;" ; Chris Lewis -- Canadian angel & despammer. |
| 39 | "jem@xpat.com;" ; John Milburn -- despammer in Korea. |
| 40 | "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; Spew/bincancel guy. |
| 41 | ) |
| 42 | "*List of NoCeM issuers to pay attention to.") |
| 43 | |
| 44 | (defvar gnus-nocem-directory |
| 45 | (concat (file-name-as-directory gnus-article-save-directory) "NoCeM/") |
| 46 | "*Directory where NoCeM files will be stored.") |
| 47 | |
| 48 | (defvar gnus-nocem-expiry-wait 15 |
| 49 | "*Number of days to keep NoCeM headers in the cache.") |
| 50 | |
| 51 | (defvar gnus-nocem-verifyer nil |
| 52 | "*Function called to verify that the NoCeM message is valid. |
| 53 | One likely value is `mc-verify'. If the function in this variable |
| 54 | isn't bound, the message will be used unconditionally.") |
| 55 | |
| 56 | ;;; Internal variables |
| 57 | |
| 58 | (defvar gnus-nocem-active nil) |
| 59 | (defvar gnus-nocem-alist nil) |
| 60 | (defvar gnus-nocem-touched-alist nil) |
| 61 | (defvar gnus-nocem-hashtb nil) |
| 62 | |
| 63 | ;;; Functions |
| 64 | |
| 65 | (defun gnus-nocem-active-file () |
| 66 | (concat (file-name-as-directory gnus-nocem-directory) "active")) |
| 67 | |
| 68 | (defun gnus-nocem-cache-file () |
| 69 | (concat (file-name-as-directory gnus-nocem-directory) "cache")) |
| 70 | |
| 71 | (defun gnus-nocem-scan-groups () |
| 72 | "Scan all NoCeM groups for new NoCeM messages." |
| 73 | (interactive) |
| 74 | (let ((groups gnus-nocem-groups) |
| 75 | group active gactive articles) |
| 76 | (or (file-exists-p gnus-nocem-directory) |
| 77 | (make-directory gnus-nocem-directory t)) |
| 78 | ;; Load any previous NoCeM headers. |
| 79 | (gnus-nocem-load-cache) |
| 80 | ;; Read the active file if it hasn't been read yet. |
| 81 | (and (file-exists-p (gnus-nocem-active-file)) |
| 82 | (not gnus-nocem-active) |
| 83 | (condition-case () |
| 84 | (load (gnus-nocem-active-file) t t t) |
| 85 | (error nil))) |
| 86 | ;; Go through all groups and see whether new articles have |
| 87 | ;; arrived. |
| 88 | (while (setq group (pop groups)) |
| 89 | (if (not (setq gactive (gnus-activate-group group))) |
| 90 | () ; This group doesn't exist. |
| 91 | (setq active (nth 1 (assoc group gnus-nocem-active))) |
| 92 | (when (and (not (< (cdr gactive) (car gactive))) ; Empty group. |
| 93 | (or (not active) |
| 94 | (< (cdr active) (cdr gactive)))) |
| 95 | ;; Ok, there are new articles in this group, se we fetch the |
| 96 | ;; headers. |
| 97 | (save-excursion |
| 98 | (let ((dependencies (make-vector 10 nil)) |
| 99 | (buffer (nnheader-set-temp-buffer " *Gnus NoCeM*")) |
| 100 | headers) |
| 101 | (setq headers |
| 102 | (if (eq 'nov |
| 103 | (gnus-retrieve-headers |
| 104 | (setq articles |
| 105 | (gnus-uncompress-range |
| 106 | (cons |
| 107 | (if active (1+ (cdr active)) |
| 108 | (car gactive)) |
| 109 | (cdr gactive)))) |
| 110 | group)) |
| 111 | (gnus-get-newsgroup-headers-xover |
| 112 | articles nil dependencies) |
| 113 | (gnus-get-newsgroup-headers dependencies))) |
| 114 | (while headers |
| 115 | ;; We take a closer look on all articles that have |
| 116 | ;; "@@NCM" in the subject. |
| 117 | (when (string-match "@@NCM" |
| 118 | (mail-header-subject (car headers))) |
| 119 | (gnus-nocem-check-article group (car headers))) |
| 120 | (setq headers (cdr headers))) |
| 121 | (kill-buffer (current-buffer))))) |
| 122 | (setq gnus-nocem-active |
| 123 | (cons (list group gactive) |
| 124 | (delq (assoc group gnus-nocem-active) |
| 125 | gnus-nocem-active))))) |
| 126 | ;; Save the results, if any. |
| 127 | (gnus-nocem-save-cache) |
| 128 | (gnus-nocem-save-active))) |
| 129 | |
| 130 | (defun gnus-nocem-check-article (group header) |
| 131 | "Check whether the current article is an NCM article and that we want it." |
| 132 | ;; Get the article. |
| 133 | (gnus-message 7 "Checking article %d in %s for NoCeM..." |
| 134 | (mail-header-number header) group) |
| 135 | (let ((date (mail-header-date header)) |
| 136 | issuer b e) |
| 137 | (when (or (not date) |
| 138 | (nnmail-time-less |
| 139 | (nnmail-time-since (nnmail-date-to-time date)) |
| 140 | (nnmail-days-to-time gnus-nocem-expiry-wait))) |
| 141 | (gnus-request-article-this-buffer (mail-header-number header) group) |
| 142 | (goto-char (point-min)) |
| 143 | ;; The article has to have proper NoCeM headers. |
| 144 | (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t)) |
| 145 | (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t))) |
| 146 | ;; We get the name of the issuer. |
| 147 | (narrow-to-region b e) |
| 148 | (setq issuer (mail-fetch-field "issuer")) |
| 149 | (and (member issuer gnus-nocem-issuers) ; We like her... |
| 150 | (gnus-nocem-verify-issuer issuer) ; She is who she says she is.. |
| 151 | (gnus-nocem-enter-article)))))) ; We gobble the message. |
| 152 | |
| 153 | (defun gnus-nocem-verify-issuer (person) |
| 154 | "Verify using PGP that the canceler is who she says she is." |
| 155 | (widen) |
| 156 | (if (fboundp gnus-nocem-verifyer) |
| 157 | (funcall gnus-nocem-verifyer) |
| 158 | ;; If we don't have MailCrypt, then we use the message anyway. |
| 159 | t)) |
| 160 | |
| 161 | (defun gnus-nocem-enter-article () |
| 162 | "Enter the current article into the NoCeM cache." |
| 163 | (goto-char (point-min)) |
| 164 | (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t)) |
| 165 | (e (search-forward "\n@@END NCM BODY\n" nil t)) |
| 166 | (buf (current-buffer)) |
| 167 | ncm id) |
| 168 | (when (and b e) |
| 169 | (narrow-to-region b (1+ (match-beginning 0))) |
| 170 | (goto-char (point-min)) |
| 171 | (while (search-forward "\t" nil t) |
| 172 | (when (condition-case nil |
| 173 | (boundp (let ((obarray gnus-active-hashtb)) (read buf))) |
| 174 | (error nil)) |
| 175 | (beginning-of-line) |
| 176 | (while (= (following-char) ?\t) |
| 177 | (forward-line -1)) |
| 178 | (setq id (buffer-substring (point) (1- (search-forward "\t")))) |
| 179 | (push id ncm) |
| 180 | (gnus-sethash id t gnus-nocem-hashtb) |
| 181 | (forward-line 1) |
| 182 | (while (= (following-char) ?\t) |
| 183 | (forward-line 1)))) |
| 184 | (when ncm |
| 185 | (setq gnus-nocem-touched-alist t) |
| 186 | (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time) |
| 187 | ncm) |
| 188 | gnus-nocem-alist))))) |
| 189 | |
| 190 | (defun gnus-nocem-load-cache () |
| 191 | "Load the NoCeM cache." |
| 192 | (unless gnus-nocem-alist |
| 193 | ;; The buffer doesn't exist, so we create it and load the NoCeM |
| 194 | ;; cache. |
| 195 | (when (file-exists-p (gnus-nocem-cache-file)) |
| 196 | (load (gnus-nocem-cache-file) t t t) |
| 197 | (gnus-nocem-alist-to-hashtb)))) |
| 198 | |
| 199 | (defun gnus-nocem-save-cache () |
| 200 | "Save the NoCeM cache." |
| 201 | (when (and gnus-nocem-alist |
| 202 | gnus-nocem-touched-alist) |
| 203 | (nnheader-temp-write (gnus-nocem-cache-file) |
| 204 | (prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist) (current-buffer))) |
| 205 | (setq gnus-nocem-touched-alist nil))) |
| 206 | |
| 207 | (defun gnus-nocem-save-active () |
| 208 | "Save the NoCeM active file." |
| 209 | (nnheader-temp-write (gnus-nocem-active-file) |
| 210 | (prin1 `(setq gnus-nocem-active ',gnus-nocem-active) (current-buffer)))) |
| 211 | |
| 212 | (defun gnus-nocem-alist-to-hashtb () |
| 213 | "Create a hashtable from the Message-IDs we have." |
| 214 | (let* ((alist gnus-nocem-alist) |
| 215 | (pprev (cons nil alist)) |
| 216 | (prev pprev) |
| 217 | (expiry (nnmail-days-to-time gnus-nocem-expiry-wait)) |
| 218 | entry) |
| 219 | (setq gnus-nocem-hashtb (gnus-make-hashtable (* (length alist) 51))) |
| 220 | (while (setq entry (car alist)) |
| 221 | (if (not (nnmail-time-less (nnmail-time-since (car entry)) expiry)) |
| 222 | ;; This entry has expired, so we remove it. |
| 223 | (setcdr prev (cdr alist)) |
| 224 | (setq prev alist) |
| 225 | ;; This is ok, so we enter it into the hashtable. |
| 226 | (setq entry (cdr entry)) |
| 227 | (while entry |
| 228 | (gnus-sethash (car entry) t gnus-nocem-hashtb) |
| 229 | (setq entry (cdr entry)))) |
| 230 | (setq alist (cdr alist))))) |
| 231 | |
| 232 | (gnus-add-shutdown 'gnus-nocem-close 'gnus) |
| 233 | |
| 234 | (defun gnus-nocem-close () |
| 235 | "Clear internal NoCeM variables." |
| 236 | (setq gnus-nocem-alist nil |
| 237 | gnus-nocem-hashtb nil |
| 238 | gnus-nocem-active nil |
| 239 | gnus-nocem-touched-alist nil)) |
| 240 | |
| 241 | (defun gnus-nocem-unwanted-article-p (id) |
| 242 | "Say whether article ID in the current group is wanted." |
| 243 | (gnus-gethash id gnus-nocem-hashtb)) |
| 244 | |
| 245 | (provide 'gnus-nocem) |
| 246 | |
| 247 | ;;; gnus-nocem.el ends here |