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