Mercurial > hg > xemacs-beta
comparison lisp/mailcrypt/mc-remail.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;; mc-remail.el --- Remailer support for Mailcrypt | |
| 2 | |
| 3 ;; Copyright (C) 1995 Patrick LoPresti <patl@lcs.mit.edu> | |
| 4 | |
| 5 ;;{{{ Licensing | |
| 6 | |
| 7 ;; This file is intended to be used with GNU Emacs. | |
| 8 | |
| 9 ;; This program 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 ;; This program 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 | |
| 21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 22 | |
| 23 ;;}}} | |
| 24 ;;{{{ Load required packages | |
| 25 | |
| 26 (require 'mail-utils) | |
| 27 (require 'sendmail) | |
| 28 (require 'mailcrypt) | |
| 29 | |
| 30 (eval-and-compile | |
| 31 (if (not mc-xemacs-p) | |
| 32 (progn | |
| 33 (autoload 'mc-cleanup-recipient-headers "mc-toplev") | |
| 34 (autoload 'mc-encrypt-message "mc-toplev")))) | |
| 35 | |
| 36 (eval-and-compile | |
| 37 (condition-case nil (require 'mailalias) (error nil))) | |
| 38 | |
| 39 ;;}}} | |
| 40 ;;{{{ Functions dealing with remailer structures | |
| 41 | |
| 42 (defsubst mc-remailer-create (addr id props pre-encr post-encr) | |
| 43 "Create a remailer structure. | |
| 44 | |
| 45 ADDR is the remailer's Email address, a string. | |
| 46 | |
| 47 ID is the remailer's public key ID (a string) or nil if the same as | |
| 48 ADDR. | |
| 49 | |
| 50 PROPS is a list of properties, as strings. | |
| 51 | |
| 52 PRE-ENCR is a list of pre-encryption functions. Its elements will be | |
| 53 called with the remailer structure itself as argument. | |
| 54 | |
| 55 POST-ENCR is similar, but for post-encryption functions." | |
| 56 (list 'remailer addr id props pre-encr post-encr)) | |
| 57 | |
| 58 (defsubst mc-remailerp (remailer) | |
| 59 "Test whether REMAILER is a valid remailer struct." | |
| 60 (and (listp remailer) (eq 'remailer (car-safe remailer)))) | |
| 61 | |
| 62 (defsubst mc-remailer-address (remailer) | |
| 63 "Return the Email address of REMAILER." | |
| 64 (nth 1 remailer)) | |
| 65 | |
| 66 (defsubst mc-remailer-userid (remailer) | |
| 67 "Return the userid with which to look up the public key for REMAILER." | |
| 68 (or (nth 2 remailer) | |
| 69 (mc-strip-address (mc-remailer-address remailer)))) | |
| 70 | |
| 71 (defsubst mc-remailer-properties (remailer) | |
| 72 "Return the property list for REMAILER" | |
| 73 (nth 3 remailer)) | |
| 74 | |
| 75 (defsubst mc-remailer-pre-encrypt-hooks (remailer) | |
| 76 "Return the list of pre-encryption hooks for REMAILER." | |
| 77 (nth 4 remailer)) | |
| 78 | |
| 79 (defsubst mc-remailer-post-encrypt-hooks (remailer) | |
| 80 "Return the list of post-encryption hooks for REMAILER." | |
| 81 (nth 5 remailer)) | |
| 82 | |
| 83 (defun mc-remailer-remove-property (remailer prop) | |
| 84 (let ((props (append (mc-remailer-properties remailer) nil))) | |
| 85 (setq props (delete prop props)) | |
| 86 (mc-remailer-create | |
| 87 (mc-remailer-address remailer) | |
| 88 (mc-remailer-userid remailer) | |
| 89 props | |
| 90 (mc-remailer-pre-encrypt-hooks remailer) | |
| 91 (mc-remailer-post-encrypt-hooks remailer)))) | |
| 92 | |
| 93 ;;}}} | |
| 94 ;;{{{ User variables | |
| 95 | |
| 96 (defvar mc-response-block-included-headers | |
| 97 '("From" "To" "Newsgroups") | |
| 98 "List of header fields to include in response blocks. | |
| 99 | |
| 100 These will be copied into the deepest layer of the response block to | |
| 101 help you identify it when it is used to Email you.") | |
| 102 | |
| 103 | |
| 104 (defvar mc-remailer-tag "(*REMAILER*)" | |
| 105 "A string which marks an Email address as belonging to a remailer.") | |
| 106 | |
| 107 (defvar mc-levien-file-name "~/.remailers" | |
| 108 "The file containing a Levien format list of remailers. | |
| 109 | |
| 110 The file is read by `mc-read-levien-file' and `mc-reread-levien-file'. | |
| 111 | |
| 112 The file should include lines of the following form (other lines | |
| 113 are ignored): | |
| 114 | |
| 115 $remailer{\"NAME\"} = \"<EMAIL ADDRESS> PROPERTIES\"; | |
| 116 | |
| 117 PROPERTIES is a space-separated set of strings. | |
| 118 | |
| 119 This format is named after Raphael Levien, who maintains a list of | |
| 120 active remailers. Do \"finger remailer-list@kiwi.cs.berkeley.edu\" | |
| 121 for the latest copy of his list.") | |
| 122 | |
| 123 (defvar mc-remailer-user-chains nil | |
| 124 "An alist of remailer chains defined by the user. | |
| 125 | |
| 126 Format is | |
| 127 | |
| 128 ((NAME . REMAILER-LIST) | |
| 129 (NAME . REMAILER-LIST) | |
| 130 ...) | |
| 131 | |
| 132 NAME must be a string. | |
| 133 | |
| 134 REMAILER-LIST may be an arbitrary sequence, not just a list. Its | |
| 135 elements may be any of the following: | |
| 136 | |
| 137 1) A remailer structure created by `mc-remailer-create'. This is | |
| 138 the base case. | |
| 139 | |
| 140 2) A string naming another remailer chain to be spliced in | |
| 141 at this point. | |
| 142 | |
| 143 3) A positive integer N representing a chain to be spliced in at this | |
| 144 point and consisting of a random permutation of the top N remailers | |
| 145 as ordered in the file `mc-levien-file-name'. | |
| 146 | |
| 147 4) An arbitrary Lisp form to be evaluated, which should | |
| 148 return another REMAILER-LIST to be recursively processed and | |
| 149 spliced in at this point. | |
| 150 | |
| 151 The complete alist of chains is given by the union of the two lists | |
| 152 `mc-remailer-internal-chains' and `mc-remailer-user-chains'.") | |
| 153 | |
| 154 (defvar mc-remailer-internal-chains nil | |
| 155 "List of \"internal\" remailer chains. | |
| 156 | |
| 157 This variable is normally generated automatically from a human-readable | |
| 158 list of remailers; see, for example, the function `mc-reread-levien-file'. | |
| 159 | |
| 160 To define your own chains, you probably want to use the variable | |
| 161 `mc-remailer-user-chains'. See that variable's documentation for | |
| 162 format information.") | |
| 163 | |
| 164 (defvar mc-remailer-internal-ranking nil | |
| 165 "Ordered list of remailers, most reliable first. | |
| 166 | |
| 167 This variable is normally generated automatically from a human-readable | |
| 168 list of remailers; see, for example, the function `mc-reread-levien-file'.") | |
| 169 | |
| 170 (defvar mc-remailer-user-response-block | |
| 171 (function | |
| 172 (lambda (addr lines block) | |
| 173 (concat | |
| 174 ";;;\n" | |
| 175 (format | |
| 176 "To reply to this message, take the following %d-line block, remove\n" | |
| 177 lines) | |
| 178 "leading \"- \" constructs (if any), and place it at the top of a\n" | |
| 179 (format "message to %s :\n" addr) | |
| 180 block))) | |
| 181 "A function called to generate response block text. | |
| 182 | |
| 183 Value should be a function taking three arguments (ADDR LINES BLOCK). | |
| 184 ADDR is the address to which the response should be sent. | |
| 185 LINES is the number of lines in the encrypted response block. | |
| 186 BLOCK is the response block itself. | |
| 187 Function should return a string to be inserted into the buffer | |
| 188 by mc-remailer-insert-response-block.") | |
| 189 | |
| 190 (defvar mc-remailer-pseudonyms nil | |
| 191 "*A list of your pseudonyms. | |
| 192 | |
| 193 This is a list of strings. Completion against it will be available | |
| 194 when you are prompted for your pseudonym.") | |
| 195 | |
| 196 (defvar mc-remailer-preserved-headers | |
| 197 '("References" "Followup-to" "In-reply-to") | |
| 198 "*Header fields which are preserved as hashmark headers when rewriting. | |
| 199 | |
| 200 This is a list of strings naming the preserved headers. Note that | |
| 201 \"Subject\", \"Newsgroups\", and \"To\" are handled specially and | |
| 202 should not be included in this list.") | |
| 203 | |
| 204 ;;}}} | |
| 205 ;;{{{ Handling Levien format remailer lists | |
| 206 | |
| 207 (defun mc-parse-levien-buffer () | |
| 208 ;; Parse a buffer in Levien format. | |
| 209 (goto-char (point-min)) | |
| 210 (let (chains remailer remailer-name ranking) | |
| 211 (while | |
| 212 (re-search-forward | |
| 213 "^\\$remailer{\"\\(.+\\)\"}[ \t]*=[ \t]*\"\\(.*\\)\";" | |
| 214 nil t) | |
| 215 (let ((name (buffer-substring-no-properties | |
| 216 (match-beginning 1) (match-end 1))) | |
| 217 property-list address | |
| 218 (value-start (match-beginning 2)) | |
| 219 (value-end (match-end 2))) | |
| 220 (goto-char value-start) | |
| 221 (while (re-search-forward "[^ \t]+" value-end 'no-error) | |
| 222 (setq property-list | |
| 223 (append | |
| 224 property-list | |
| 225 (list (buffer-substring-no-properties | |
| 226 (match-beginning 0) (match-end 0)))))) | |
| 227 (setq address (car property-list) | |
| 228 property-list (cdr property-list) | |
| 229 remailer-name name) | |
| 230 (if (not | |
| 231 (or (member "mix" property-list) | |
| 232 (and (or (member "pgp" property-list) | |
| 233 (member "pgp." property-list)) | |
| 234 (or (member "cpunk" property-list) | |
| 235 (member "eric" property-list))))) | |
| 236 (setq remailer nil) | |
| 237 (setq remailer | |
| 238 (mc-remailer-create | |
| 239 address ; Address | |
| 240 (if (member "pgp." property-list) | |
| 241 name) ; User ID | |
| 242 property-list | |
| 243 '(mc-generic-pre-encrypt-function) ; Pre-encrypt hooks | |
| 244 '(mc-generic-post-encrypt-function) ; Post-encrypt hooks | |
| 245 )))) | |
| 246 (if (not (null remailer)) | |
| 247 (setq chains (cons (list remailer-name remailer) chains)))) | |
| 248 (goto-char (point-min)) | |
| 249 (if (re-search-forward "----------" nil t) | |
| 250 (while (re-search-forward "^\\([a-zA-Z0-9\\-]+\\) " nil t) | |
| 251 (setq remailer-name (buffer-substring-no-properties | |
| 252 (match-beginning 1) (match-end 1))) | |
| 253 (if (assoc remailer-name chains) | |
| 254 (setq ranking (append ranking (list remailer-name)))))) | |
| 255 (cons chains ranking))) | |
| 256 | |
| 257 (defun mc-read-levien-file () | |
| 258 "Read the Levien format file specified in `mc-levien-file-name'. | |
| 259 Return an alist of length-1 chains, one for each remailer, named | |
| 260 after the remailer. Only include remailers supporting PGP | |
| 261 encryption." | |
| 262 (save-excursion | |
| 263 (if (file-readable-p mc-levien-file-name) | |
| 264 (prog2 | |
| 265 (find-file-read-only mc-levien-file-name) | |
| 266 (mc-parse-levien-buffer) | |
| 267 (bury-buffer))))) | |
| 268 | |
| 269 (defun mc-reread-levien-file () | |
| 270 "Read the Levien format file specified in `mc-levien-file-name'. | |
| 271 | |
| 272 Place result in `mc-remailer-internal-chains' and `mc-remailer-internal-ranking'. | |
| 273 | |
| 274 See the documentation for the variable `mc-levien-file-name' for | |
| 275 a description of Levien file format." | |
| 276 (interactive) | |
| 277 (let ((parsed-levien-file (mc-read-levien-file))) | |
| 278 (setq mc-remailer-internal-chains (car parsed-levien-file) | |
| 279 mc-remailer-internal-ranking (cdr parsed-levien-file)))) | |
| 280 | |
| 281 ;;}}} | |
| 282 ;;{{{ Arbitrary chain choice | |
| 283 | |
| 284 (defun mc-remailer-choose-first (n &optional l) | |
| 285 (cond | |
| 286 ((= n 0) nil) | |
| 287 ((null l) (mc-remailer-choose-first n mc-remailer-internal-ranking)) | |
| 288 (t (cons (car l) (mc-remailer-choose-first (1- n) (cdr l)))))) | |
| 289 | |
| 290 (defun mc-remailer-choose-chain (n) | |
| 291 (if (null mc-remailer-internal-ranking) | |
| 292 (error "No ranking information, cannot choose the %d best remailer%s" | |
| 293 n (if (> n 1) "s" ""))) | |
| 294 (append (shuffle-vector (vconcat (mc-remailer-choose-first n))) | |
| 295 nil)) | |
| 296 | |
| 297 ;;}}} | |
| 298 ;;{{{ Canonicalization function | |
| 299 | |
| 300 (defun mc-remailer-canonicalize-elmt (elmt chains-alist) | |
| 301 (cond | |
| 302 ((mc-remailerp elmt) (list elmt)) | |
| 303 ((stringp elmt) | |
| 304 (mc-remailer-canonicalize-chain (cdr (assoc elmt chains-alist)) | |
| 305 chains-alist)) | |
| 306 ((integerp elmt) | |
| 307 (mc-remailer-canonicalize-chain (mc-remailer-choose-chain elmt) | |
| 308 chains-alist)) | |
| 309 (t (mc-remailer-canonicalize-chain (eval elmt) chains-alist)))) | |
| 310 | |
| 311 (defun mc-remailer-canonicalize-chain (chain &optional chains-alist) | |
| 312 ;; Canonicalize a remailer chain with respect to CHAINS-ALIST. | |
| 313 ;; That is, use CHAINS-ALIST to resolve strings. | |
| 314 ;; Here is where we implement the functionality described in | |
| 315 ;; the documentation for the variable `mc-remailer-user-chains'. | |
| 316 (if (null chains-alist) | |
| 317 (setq chains-alist (mc-remailer-make-chains-alist))) | |
| 318 (cond | |
| 319 ((null chain) nil) | |
| 320 ;; Handle case where chain is actually a string or a single | |
| 321 ;; remailer. | |
| 322 ((or (stringp chain) (mc-remailerp chain) (integerp chain)) | |
| 323 (mc-remailer-canonicalize-elmt chain chains-alist)) | |
| 324 (t | |
| 325 (let ((first (elt chain 0)) | |
| 326 (rest (cdr (append chain nil)))) | |
| 327 (append | |
| 328 (mc-remailer-canonicalize-elmt first chains-alist) | |
| 329 (mc-remailer-canonicalize-chain rest chains-alist)))))) | |
| 330 | |
| 331 ;;}}} | |
| 332 ;;{{{ Auxiliaries for mail header munging | |
| 333 | |
| 334 (defsubst mc-nuke-field (field &optional bounds) | |
| 335 ;; Delete all fields exactly matching regexp FIELD from header, | |
| 336 ;; bounded by BOUNDS. Default is entire visible region of buffer. | |
| 337 (mc-get-fields field bounds t)) | |
| 338 | |
| 339 (defun mc-replace-field (field-name replacement header) | |
| 340 (save-excursion | |
| 341 (save-restriction | |
| 342 (if (not (string-match "^[ \t]" replacement)) | |
| 343 (setq replacement (concat " " replacement))) | |
| 344 (if (not (string-match "\n$" replacement)) | |
| 345 (setq replacement (concat replacement "\n"))) | |
| 346 (let ((case-fold-search t) | |
| 347 (field-regexp (regexp-quote field-name))) | |
| 348 (narrow-to-region (car header) (cdr header)) | |
| 349 (goto-char (point-min)) | |
| 350 (re-search-forward | |
| 351 (concat "^" field-regexp ":" mc-field-body-regexp) | |
| 352 nil t) | |
| 353 (mc-nuke-field field-regexp header) | |
| 354 (insert field-name ":" replacement))))) | |
| 355 | |
| 356 (defun mc-find-main-header (&optional ignored) | |
| 357 ;; Find the main header of the mail message; return as a pair of | |
| 358 ;; markers (START . END). | |
| 359 (save-excursion | |
| 360 (goto-char (point-min)) | |
| 361 (re-search-forward | |
| 362 (concat "^" (regexp-quote mail-header-separator) "\n")) | |
| 363 (forward-line -1) | |
| 364 (cons (copy-marker (point-min)) (copy-marker (point))))) | |
| 365 | |
| 366 (defun mc-find-colon-header (&optional insert) | |
| 367 ;; Find the header with a "::" immediately after the | |
| 368 ;; mail-header-separator. Return region enclosing header. Optional | |
| 369 ;; arg INSERT means insert the header if it does not exist already. | |
| 370 (save-excursion | |
| 371 (goto-char (point-min)) | |
| 372 (re-search-forward | |
| 373 (concat "^" (regexp-quote mail-header-separator) "\n")) | |
| 374 (if (or (and (looking-at "::\n") (forward-line 1)) | |
| 375 (and insert | |
| 376 (progn | |
| 377 (insert-before-markers "::\n\n") | |
| 378 (forward-line -1)))) | |
| 379 (let ((start (point))) | |
| 380 (re-search-forward "^$" nil 'move) | |
| 381 (cons (copy-marker start) (copy-marker (point))))))) | |
| 382 | |
| 383 (defun mc-find-hash-header (&optional insert) | |
| 384 (save-excursion | |
| 385 (goto-char (point-min)) | |
| 386 (re-search-forward | |
| 387 (concat "^" (regexp-quote mail-header-separator) "\n")) | |
| 388 (if (or (and (looking-at "##\n") (forward-line 1)) | |
| 389 (and (looking-at "::\n") | |
| 390 (re-search-forward "^\n" nil 'move) | |
| 391 (looking-at "##\n") | |
| 392 (forward-line 1)) | |
| 393 (and insert | |
| 394 (progn | |
| 395 (insert-before-markers "##\n\n") | |
| 396 (forward-line -1)))) | |
| 397 (let ((start (point))) | |
| 398 (re-search-forward "^$" nil 'move) | |
| 399 (cons (copy-marker start) (copy-marker (point))))))) | |
| 400 | |
| 401 | |
| 402 (defsubst mc-replace-main-field (field replacement) | |
| 403 (mc-replace-field field replacement (mc-find-main-header t))) | |
| 404 | |
| 405 (defsubst mc-replace-hash-field (field replacement) | |
| 406 (mc-replace-field field replacement (mc-find-hash-header t))) | |
| 407 | |
| 408 (defsubst mc-replace-colon-field (field replacement) | |
| 409 (mc-replace-field field replacement (mc-find-colon-header t))) | |
| 410 | |
| 411 (defun mc-recipient-is-remailerp () | |
| 412 (let ((to (mc-get-fields "To" (mc-find-main-header)))) | |
| 413 (and to | |
| 414 (string-match (regexp-quote mc-remailer-tag) (cdr (car to)))))) | |
| 415 | |
| 416 ;;}}} | |
| 417 ;;{{{ Pre-encryption and post-encryption hook defaults | |
| 418 | |
| 419 (defun mc-generic-post-encrypt-function (remailer) | |
| 420 (let ((main-header (mc-find-main-header)) | |
| 421 (colon-header (mc-find-colon-header t))) | |
| 422 (mc-replace-field "Encrypted" "PGP" colon-header) | |
| 423 (mc-replace-field | |
| 424 "To" | |
| 425 (concat (mc-remailer-address remailer) " " mc-remailer-tag) | |
| 426 main-header))) | |
| 427 | |
| 428 (defun mc-generic-pre-encrypt-function (remailer) | |
| 429 (let ((addr (mc-remailer-address remailer)) | |
| 430 (props (mc-remailer-properties remailer)) | |
| 431 (main-header (mc-find-main-header)) | |
| 432 (colon-header (mc-find-colon-header t)) | |
| 433 to to-field preserved-regexp preserved) | |
| 434 | |
| 435 (setq preserved-regexp | |
| 436 (mc-disjunction-regexp mc-remailer-preserved-headers)) | |
| 437 (setq preserved (mc-get-fields preserved-regexp main-header t)) | |
| 438 (if preserved (goto-char (cdr (mc-find-hash-header t)))) | |
| 439 (mapcar (function | |
| 440 (lambda (c) | |
| 441 (insert (car c) ":" | |
| 442 (mc-eliminate-continuation-lines (cdr c))))) | |
| 443 preserved) | |
| 444 | |
| 445 (if (and (mc-find-hash-header) (not (member "hash" props))) | |
| 446 (error "Remailer %s does not support hashmarks" addr)) | |
| 447 | |
| 448 (if (mc-get-fields "Newsgroups" main-header) | |
| 449 (cond ((not (member "post" props)) | |
| 450 (error "Remailer %s does not support posting" addr)) | |
| 451 ((not (member "hash" props)) | |
| 452 (error "Remailer %s does not support hashmarks" addr)) | |
| 453 (t (mc-rewrite-news-to-mail remailer))) | |
| 454 (and (featurep 'mailalias) | |
| 455 (not (featurep 'mail-abbrevs)) | |
| 456 mail-aliases | |
| 457 (expand-mail-aliases (car main-header) (cdr main-header))) | |
| 458 (setq to (mc-strip-addresses | |
| 459 (mapcar 'cdr (mc-get-fields "To" main-header)))) | |
| 460 (if (string-match "," to) | |
| 461 (error "Remailer %s does not support multiple recipients." addr)) | |
| 462 (setq to-field | |
| 463 (if (mc-get-fields "From" colon-header) | |
| 464 "Send-To" | |
| 465 (cond | |
| 466 ((member "eric" props) "Anon-Send-To") | |
| 467 ((member "cpunk" props) "Request-Remailing-To") | |
| 468 (t (error "Remailer %s is not type-1" addr))))) | |
| 469 (mc-replace-field to-field to colon-header) | |
| 470 (mc-nuke-field "Reply-to" main-header)))) | |
| 471 | |
| 472 ;;}}} | |
| 473 ;;{{{ Misc. random | |
| 474 | |
| 475 (defun mc-disjunction-regexp (regexps) | |
| 476 ;; Take a list of regular expressions and return a single | |
| 477 ;; regular expression which matches anything that any of the | |
| 478 ;; original regexps match. | |
| 479 (concat "\\(" | |
| 480 (mapconcat 'identity regexps "\\)\\|\\(") | |
| 481 "\\)")) | |
| 482 | |
| 483 (defun mc-user-mail-address () | |
| 484 "Figure out the user's Email address as best we can." | |
| 485 (mc-strip-address | |
| 486 (cond ((and (boundp 'gnus-user-from-line) | |
| 487 (stringp gnus-user-from-line)) | |
| 488 gnus-user-from-line) | |
| 489 ((stringp mail-default-reply-to) mail-default-reply-to) | |
| 490 ((boundp 'user-mail-address) user-mail-address) | |
| 491 (t (concat (user-login-name) "@" (system-name)))))) | |
| 492 | |
| 493 (defun mc-eliminate-continuation-lines (string) | |
| 494 (while (string-match "\n[\t ]+" string) | |
| 495 (setq string (replace-match " " t nil string))) | |
| 496 string) | |
| 497 | |
| 498 (defun mc-remailer-make-chains-alist () | |
| 499 (if (null mc-remailer-internal-chains) | |
| 500 (mc-reread-levien-file)) | |
| 501 (append mc-remailer-internal-chains mc-remailer-user-chains)) | |
| 502 | |
| 503 ;;;###autoload | |
| 504 (defun mc-remailer-insert-pseudonym () | |
| 505 "Insert pseudonym as a From field in the hash-mark header. | |
| 506 | |
| 507 See the documentation for the variable `mc-remailer-pseudonyms' for | |
| 508 more information." | |
| 509 (interactive) | |
| 510 (let ((completion-ignore-case t) | |
| 511 pseudonym) | |
| 512 (setq pseudonym | |
| 513 (cond ((null mc-remailer-pseudonyms) | |
| 514 (read-from-minibuffer "Pseudonym: ")) | |
| 515 (t | |
| 516 (completing-read "Pseudonym: " | |
| 517 (mapcar 'list mc-remailer-pseudonyms))))) | |
| 518 (if (not (string-match "\\S +@\\S +" pseudonym)) | |
| 519 (setq pseudonym (concat pseudonym " <x@x.x>"))) | |
| 520 (mc-replace-colon-field "From" pseudonym))) | |
| 521 | |
| 522 ;;}}} | |
| 523 ;;{{{ Mixmaster support | |
| 524 (defvar mc-mixmaster-path nil | |
| 525 "*Path to the Mixmaster binary. If defined, Mixmaster chains will | |
| 526 be passed to this program for rewriting.") | |
| 527 | |
| 528 (defvar mc-mixmaster-list-path nil | |
| 529 "*Path to the Mixmaster type2.list file.") | |
| 530 | |
| 531 (defun mc-demix (&rest chain) | |
| 532 "Use arguments as a remailer-list and return a new list with the | |
| 533 \"mix\" property removed from all the elements." | |
| 534 (mapcar (function (lambda (r) (mc-remailer-remove-property r "mix"))) | |
| 535 (mc-remailer-canonicalize-chain chain))) | |
| 536 | |
| 537 (defun mc-mixmaster-process (beg end recipients preserved mix-chain) | |
| 538 ;; Run a region through Mixmaster. | |
| 539 (let (ret) | |
| 540 (if (not (markerp end)) | |
| 541 (setq end (copy-marker end))) | |
| 542 (goto-char beg) | |
| 543 (mapcar (function (lambda (x) (insert x ?\n))) recipients) | |
| 544 (insert ?\n) | |
| 545 (mapcar (function (lambda (x) (insert x))) preserved) | |
| 546 (insert ?\n) | |
| 547 (setq mix-chain (mapcar (function (lambda (x) (format "%d" x))) mix-chain)) | |
| 548 ;; Handle case of empty message | |
| 549 (if (< end (point)) (setq end (point))) | |
| 550 (setq ret | |
| 551 (apply 'call-process-region beg end mc-mixmaster-path t t nil | |
| 552 "-f" "-o" "stdout" "-l" mix-chain)) | |
| 553 (if (not (eq ret 0)) (error "Mixmaster barfed.")) | |
| 554 (goto-char beg) | |
| 555 (re-search-forward "^::$") | |
| 556 (delete-region beg (match-beginning 0)))) | |
| 557 | |
| 558 (defun mc-mixmaster-build-alist (&optional n) | |
| 559 ;; Construct an alist mapping Mixmaster Email addresses to integers. | |
| 560 ;; FIXME; this is terrible | |
| 561 (let (buf) | |
| 562 (save-excursion | |
| 563 (unwind-protect | |
| 564 (progn | |
| 565 (setq n (or n 1)) | |
| 566 (setq buf (find-file-noselect mc-mixmaster-list-path)) | |
| 567 (set-buffer buf) | |
| 568 (if (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)" nil t) | |
| 569 (cons (cons (buffer-substring-no-properties | |
| 570 (match-beginning 1) (match-end 1)) | |
| 571 n) | |
| 572 (mc-mixmaster-build-alist (+ n 1))))) | |
| 573 (if buf (kill-buffer buf)))))) | |
| 574 | |
| 575 (defvar mc-mixmaster-alist nil) | |
| 576 | |
| 577 (defsubst mc-mixmaster-alist () | |
| 578 (or mc-mixmaster-alist | |
| 579 (setq mc-mixmaster-alist (mc-mixmaster-build-alist)))) | |
| 580 | |
| 581 (defun mc-mixmaster-translate-chain (chain) | |
| 582 ;; Take a chain of Mixmaster remailers and convert it to the list | |
| 583 ;; of integers which represents them. | |
| 584 (if (or (null chain) | |
| 585 (not (member "mix" (mc-remailer-properties (car chain))))) | |
| 586 nil | |
| 587 (cons (cdr (assoc (mc-strip-address (mc-remailer-address (car chain))) | |
| 588 (mc-mixmaster-alist))) | |
| 589 (mc-mixmaster-translate-chain (cdr chain))))) | |
| 590 | |
| 591 (defun mc-mixmaster-skip (chain) | |
| 592 ;; Return the largest possible suffix of CHAIN whose first element | |
| 593 ;; is not a Mixmaster. | |
| 594 (cond ((null chain) nil) | |
| 595 ((not (member "mix" (mc-remailer-properties (car chain)))) | |
| 596 chain) | |
| 597 (t (mc-mixmaster-skip (cdr chain))))) | |
| 598 | |
| 599 (defun mc-rewrite-for-mixmaster (chain &optional pause) | |
| 600 ;; Rewrite the current mail buffer for a chain of Mixmasters. | |
| 601 (let ((mix-chain (mc-mixmaster-translate-chain chain)) | |
| 602 (main-header (mc-find-main-header)) | |
| 603 (colon-header (mc-find-colon-header)) | |
| 604 (hash-header (mc-find-hash-header)) | |
| 605 recipients preserved newsgroups first last rest preserved-regexp) | |
| 606 | |
| 607 ;; Figure out FIRST and LAST. FIRST is the first Mixmaster in the | |
| 608 ;; chain. LAST is the last. | |
| 609 (setq first (car chain) | |
| 610 rest chain) | |
| 611 (while (and rest (member "mix" (mc-remailer-properties (car rest)))) | |
| 612 (setq last (car rest) | |
| 613 rest (cdr rest))) | |
| 614 | |
| 615 ;; If recipient is not a remailer, deal with hashmark and colon | |
| 616 ;; headers and get rid of them. | |
| 617 (if (mc-recipient-is-remailerp) | |
| 618 nil | |
| 619 (if hash-header | |
| 620 (progn | |
| 621 (setq preserved (mc-get-fields nil hash-header)) | |
| 622 (goto-char (car hash-header)) | |
| 623 (forward-line -1) | |
| 624 (delete-region (point) (+ (cdr hash-header) 1)))) | |
| 625 ;; Preserve pseduonym line... | |
| 626 (if colon-header | |
| 627 (progn | |
| 628 (setq preserved | |
| 629 (append (mc-get-fields "From" colon-header) preserved)) | |
| 630 (goto-char (car colon-header)) | |
| 631 (forward-line -1) | |
| 632 (delete-region (point) (+ (cdr colon-header) 1))))) | |
| 633 | |
| 634 ;; Expand aliases and get recipients. | |
| 635 (and (featurep 'mailalias) | |
| 636 (not (featurep 'mail-abbrevs)) | |
| 637 mail-aliases | |
| 638 (expand-mail-aliases (car main-header) (cdr main-header))) | |
| 639 (setq recipients | |
| 640 (mc-cleanup-recipient-headers | |
| 641 (mapconcat 'cdr (mc-get-fields "To" main-header t) ", "))) | |
| 642 (setq newsgroups (mc-get-fields "Newsgroups" nil t)) | |
| 643 ;; Mixmaster does not support posting... | |
| 644 ;;; (if (and newsgroups | |
| 645 ;;; (not (member "post" (mc-remailer-properties last)))) | |
| 646 (if newsgroups | |
| 647 (error "Remailer %s does not support posting" | |
| 648 (mc-remailer-address last))) | |
| 649 (setq | |
| 650 recipients | |
| 651 (append (mapcar | |
| 652 (function (lambda (c) (concat "Post:" (cdr c)))) newsgroups) | |
| 653 recipients)) | |
| 654 | |
| 655 (setq | |
| 656 preserved-regexp | |
| 657 (mc-disjunction-regexp (cons "Subject" mc-remailer-preserved-headers))) | |
| 658 | |
| 659 (setq preserved | |
| 660 (append (mc-get-fields preserved-regexp main-header t) preserved)) | |
| 661 | |
| 662 ;; Convert preserved header alist to simple list of strings | |
| 663 (setq preserved | |
| 664 (mapcar | |
| 665 (function | |
| 666 (lambda (c) | |
| 667 (concat (car c) ":" | |
| 668 (mc-eliminate-continuation-lines (cdr c))))) | |
| 669 preserved)) | |
| 670 | |
| 671 ;; Do the conversion | |
| 672 (goto-char (cdr main-header)) | |
| 673 (forward-line 1) | |
| 674 (mc-mixmaster-process (point) (point-max) recipients preserved | |
| 675 mix-chain) | |
| 676 | |
| 677 (mc-replace-field "To" | |
| 678 (concat | |
| 679 (mc-remailer-address first) " " mc-remailer-tag) | |
| 680 main-header))) | |
| 681 | |
| 682 ;;}}} | |
| 683 ;;{{{ High level message rewriting | |
| 684 | |
| 685 (defun mc-rewrite-news-to-mail (remailer) | |
| 686 (let ((main-header (mc-find-main-header)) | |
| 687 newsgroups) | |
| 688 (setq newsgroups (mc-get-fields "Newsgroups" main-header t)) | |
| 689 (mc-replace-colon-field "Post-To" (cdr (car newsgroups))) | |
| 690 (mail-mode))) | |
| 691 | |
| 692 (defun mc-rewrite-for-remailer (remailer &optional pause) | |
| 693 ;; Rewrite the current mail buffer for a single remailer. This | |
| 694 ;; includes running the pre-encryption hooks, modifying the To: | |
| 695 ;; field, encrypting with the remailer's public key, and running the | |
| 696 ;; post-encryption hooks. | |
| 697 (let ((addr (mc-remailer-address remailer)) | |
| 698 (main-header (mc-find-main-header))) | |
| 699 ;; If recipient is already a remailer, make sure the "::" and "##" | |
| 700 ;; headers get to it | |
| 701 (if (mc-recipient-is-remailerp) | |
| 702 (progn | |
| 703 (goto-char (cdr main-header)) | |
| 704 (forward-line 1) | |
| 705 (insert "::\n\n"))) | |
| 706 | |
| 707 (mapcar | |
| 708 (function (lambda (hook) (funcall hook remailer))) | |
| 709 (mc-remailer-pre-encrypt-hooks remailer)) | |
| 710 | |
| 711 ;; Move "Subject" lines down. | |
| 712 (goto-char (car (mc-find-colon-header t))) | |
| 713 (mapcar | |
| 714 (function (lambda (f) (insert (car f) ":" (cdr f)))) | |
| 715 (mc-get-fields "Subject" main-header t)) | |
| 716 | |
| 717 (if pause | |
| 718 (let ((cursor-in-echo-area t)) | |
| 719 (message "SPC to encrypt for %s : " addr) | |
| 720 (read-char-exclusive))) | |
| 721 (setq main-header (mc-find-main-header)) | |
| 722 (goto-char (cdr main-header)) | |
| 723 (forward-line 1) | |
| 724 (if (let ((mc-pgp-always-sign 'never) | |
| 725 (mc-encrypt-for-me nil)) | |
| 726 (mc-encrypt-message (mc-remailer-userid remailer) nil (point))) | |
| 727 (progn | |
| 728 (mapcar | |
| 729 (function (lambda (hook) (funcall hook remailer))) | |
| 730 (mc-remailer-post-encrypt-hooks remailer)) | |
| 731 (mc-nuke-field "Comment") | |
| 732 (mc-nuke-field "From")) | |
| 733 (error "Unable to encrypt message to %s" | |
| 734 (mc-remailer-userid remailer))))) | |
| 735 | |
| 736 (defun mc-rewrite-for-chain (chain &optional pause) | |
| 737 ;; Rewrite the current buffer for a chain of remailers. | |
| 738 ;; CHAIN must be in canonical form. | |
| 739 (let (rest) | |
| 740 (if mc-mixmaster-path | |
| 741 (setq rest (mc-mixmaster-skip chain)) | |
| 742 (setq rest chain)) | |
| 743 (if (null chain) nil | |
| 744 (mc-rewrite-for-chain | |
| 745 (if (eq rest chain) (cdr rest) rest) pause) | |
| 746 (if (eq rest chain) | |
| 747 (mc-rewrite-for-remailer (car chain) pause) | |
| 748 (mc-rewrite-for-mixmaster chain pause))))) | |
| 749 | |
| 750 (defun mc-unparse-chain (chain) | |
| 751 ;; Unparse CHAIN into a string suitable for printing. | |
| 752 (if (null chain) | |
| 753 nil | |
| 754 (concat (mc-remailer-address (car chain)) "\n" | |
| 755 (mc-unparse-chain (cdr chain))))) | |
| 756 | |
| 757 (defun mc-disallow-field (field &optional header) | |
| 758 (let ((case-fold-search t)) | |
| 759 (if (null header) | |
| 760 (setq header (mc-find-main-header))) | |
| 761 (goto-char (car header)) | |
| 762 (if (re-search-forward (concat "^" (regexp-quote field) ":") | |
| 763 (cdr header) t) | |
| 764 | |
| 765 (progn | |
| 766 (goto-char (match-beginning 0)) | |
| 767 (error "Cannot use a %s field." field))))) | |
| 768 | |
| 769 ;;;###autoload | |
| 770 (defun mc-remailer-encrypt-for-chain (&optional pause) | |
| 771 "Encrypt message for a remailer chain, prompting for chain to use. | |
| 772 | |
| 773 With \\[universal-argument], pause before each encryption." | |
| 774 (interactive "P") | |
| 775 (let ((chains (mc-remailer-make-chains-alist)) | |
| 776 (buffer (get-buffer-create mc-buffer-name)) | |
| 777 chain-name chain) | |
| 778 (mc-disallow-field "CC") | |
| 779 (mc-disallow-field "FCC") | |
| 780 (mc-disallow-field "BCC") | |
| 781 (setq chain-name | |
| 782 (completing-read | |
| 783 "Choose a remailer or chain: " chains nil 'strict-match)) | |
| 784 (setq chain | |
| 785 (mc-remailer-canonicalize-chain | |
| 786 (cdr (assoc chain-name chains)) | |
| 787 chains)) | |
| 788 (mc-rewrite-for-chain chain pause) | |
| 789 (if chain | |
| 790 (save-excursion | |
| 791 (set-buffer buffer) | |
| 792 (erase-buffer) | |
| 793 (insert "Rewritten for chain `" chain-name "':\n\n" | |
| 794 (mc-unparse-chain chain)) | |
| 795 (message "Done. See %s buffer for details." mc-buffer-name))))) | |
| 796 | |
| 797 ;;}}} | |
| 798 ;;{{{ Response block generation | |
| 799 | |
| 800 ;;;###autoload | |
| 801 (defun mc-remailer-insert-response-block (&optional arg) | |
| 802 "Insert response block at point, prompting for chain to use. | |
| 803 | |
| 804 With \\[universal-argument], enter a recursive edit of the innermost | |
| 805 layer of the block before encrypting it." | |
| 806 (interactive "p") | |
| 807 (let (buf main-header to addr block lines) | |
| 808 (save-excursion | |
| 809 (setq buf | |
| 810 (mc-remailer-make-response-block (if (> arg 1) t))) | |
| 811 (set-buffer buf) | |
| 812 (setq main-header (mc-find-main-header)) | |
| 813 (setq to (cdr (car (mc-get-fields "To" main-header)))) | |
| 814 (setq addr (concat "<" (mc-strip-address to) ">")) | |
| 815 (goto-char (cdr main-header)) | |
| 816 (forward-line 1) | |
| 817 (setq block (buffer-substring-no-properties | |
| 818 (point) (point-max)) | |
| 819 lines (count-lines (point) (point-max))) | |
| 820 (kill-buffer buf)) | |
| 821 (let ((opoint (point))) | |
| 822 (insert (funcall mc-remailer-user-response-block | |
| 823 addr lines block)) | |
| 824 (goto-char opoint)) | |
| 825 (mc-nuke-field "Reply-to" (mc-find-main-header)) | |
| 826 (mc-replace-hash-field "Reply-to" addr))) | |
| 827 | |
| 828 (defun mc-remailer-make-response-block (&optional recurse) | |
| 829 ;; Return a buffer which contains a response block | |
| 830 ;; for the user, and a To: header for the remailer to use. | |
| 831 (let ((buf (generate-new-buffer " *Remailer Response Block*")) | |
| 832 (original-buf (current-buffer)) | |
| 833 (mc-mixmaster-path nil) | |
| 834 all-headers included-regexp included) | |
| 835 (setq all-headers (mc-find-main-header)) | |
| 836 (setcdr all-headers | |
| 837 (max | |
| 838 (cdr all-headers) | |
| 839 (or (cdr-safe (mc-find-colon-header)) 0) | |
| 840 (or (cdr-safe (mc-find-hash-header)) 0))) | |
| 841 (save-excursion | |
| 842 (setq | |
| 843 included-regexp | |
| 844 (mc-disjunction-regexp mc-response-block-included-headers)) | |
| 845 (setq included (mc-get-fields included-regexp all-headers)) | |
| 846 (set-buffer buf) | |
| 847 (insert "To: " (mc-user-mail-address) "\n" mail-header-separator "\n") | |
| 848 (insert ";; Response block created " (current-time-string) "\n") | |
| 849 (mapcar (function (lambda (c) (insert "; " (car c) ":" (cdr c)))) | |
| 850 included) | |
| 851 (if recurse | |
| 852 (progn | |
| 853 (switch-to-buffer buf) | |
| 854 (message "Editing response block ; %s when done." | |
| 855 (substitute-command-keys "\\[exit-recursive-edit]")) | |
| 856 (recursive-edit))) | |
| 857 (set-buffer buf) | |
| 858 (mc-remailer-encrypt-for-chain) | |
| 859 (switch-to-buffer original-buf)) | |
| 860 buf)) | |
| 861 | |
| 862 ;;}}} |