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 / mailcrypt.el < prev    next >
Encoding:
Text File  |  1995-08-04  |  15.5 KB  |  464 lines
  1. ;; mailcrypt.el v3.2, mail encryption with PGP
  2. ;; Copyright (C) 1995  Jin Choi <jin@atype.com>
  3. ;;                     Patrick LoPresti <patl@lcs.mit.edu>
  4. ;; Any comments or suggestions welcome.
  5. ;; Inspired by pgp.el, by Gray Watson <gray@antaire.com>.
  6.  
  7. ;;{{{ Licensing
  8. ;; This file is intended to be used with GNU Emacs.
  9.  
  10. ;; This program is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; This program is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23. ;;}}}
  24.  
  25. ;;{{{ Load some required packages
  26.  
  27. (eval-when-compile
  28.   ;; Quiet warnings
  29.   (autoload 'start-itimer "itimer")
  30.   (autoload 'cancel-itimer "itimer")
  31.   (autoload 'delete-itimer "itimer"))
  32.  
  33. (require 'easymenu)
  34. (require 'comint)
  35.  
  36. (eval-and-compile
  37.   (condition-case nil (require 'itimer) (error nil))
  38.   (if (not (featurep 'itimer))
  39.       (condition-case nil (require 'timer) (error nil)))
  40.  
  41.   (if (not (fboundp 'buffer-substring-no-properties))
  42.       (fset 'buffer-substring-no-properties 'buffer-substring)))
  43.  
  44. (defconst mc-xemacs-p (string-match "Xemacs" emacs-version))
  45.  
  46. (autoload 'mc-decrypt "mc-toplev" nil t)
  47. (autoload 'mc-verify "mc-toplev" nil t)
  48. (autoload 'mc-snarf "mc-toplev" nil t)
  49. (autoload 'mc-pgp-fetch-key "mc-pgp" nil t)
  50. (autoload 'mc-encrypt "mc-toplev" nil t)
  51. (autoload 'mc-sign "mc-toplev" nil t)
  52. (autoload 'mc-insert-public-key "mc-toplev" nil t)
  53. (autoload 'mc-remailer-encrypt-for-chain "mc-remail" nil t)
  54. (autoload 'mc-remailer-insert-response-block "mc-remail" nil t)
  55. (autoload 'mc-remailer-insert-pseudonym "mc-remail" nil t)
  56.  
  57. ;;}}}
  58.  
  59. ;;{{{ Minor mode variables and functions
  60.  
  61. (defvar mc-read-mode nil
  62.   "Non-nil means Mailcrypt read mode key bindings are available.")
  63.  
  64. (defvar mc-write-mode nil
  65.   "Non-nil means Mailcrypt write mode key bindings are available.")
  66.  
  67. (make-variable-buffer-local 'mc-read-mode)
  68. (make-variable-buffer-local 'mc-write-mode)
  69.  
  70. (defvar mc-read-mode-string " MC-r"
  71.   "*String to put in mode line when Mailcrypt read mode is active.")
  72.  
  73. (defvar mc-write-mode-string " MC-w"
  74.   "*String to put in mode line when Mailcrypt write mode is active.")
  75.  
  76. (defvar mc-read-mode-map nil
  77.   "Keymap for Mailcrypt read mode bindings.")
  78.  
  79. (defvar mc-write-mode-map nil
  80.   "Keymap for Mailcrypt write mode bindings.")
  81.  
  82. (or mc-read-mode-map
  83.     (progn
  84.       (setq mc-read-mode-map (make-sparse-keymap))
  85.       (define-key mc-read-mode-map "\C-c/f" 'mc-deactivate-passwd)
  86.       (define-key mc-read-mode-map "\C-c/d" 'mc-decrypt)
  87.       (define-key mc-read-mode-map "\C-c/v" 'mc-verify)
  88.       (define-key mc-read-mode-map "\C-c/a" 'mc-snarf)
  89.       (define-key mc-read-mode-map "\C-c/k" 'mc-pgp-fetch-key)))
  90.  
  91. (or mc-write-mode-map
  92.     (progn
  93.       (setq mc-write-mode-map (make-sparse-keymap))
  94.       (define-key mc-write-mode-map "\C-c/f" 'mc-deactivate-passwd)
  95.       (define-key mc-write-mode-map "\C-c/e" 'mc-encrypt)
  96.       (define-key mc-write-mode-map "\C-c/s" 'mc-sign)
  97.       (define-key mc-write-mode-map "\C-c/x" 'mc-insert-public-key)
  98.       (define-key mc-write-mode-map "\C-c/k" 'mc-pgp-fetch-key)
  99.       (define-key mc-write-mode-map "\C-c/r"
  100.     'mc-remailer-encrypt-for-chain)
  101.       (define-key mc-write-mode-map "\C-c/b"
  102.     'mc-remailer-insert-response-block)
  103.       (define-key mc-write-mode-map "\C-c/p"
  104.     'mc-remailer-insert-pseudonym)))
  105.  
  106. (easy-menu-define
  107.  mc-read-mode-menu (if mc-xemacs-p nil (list mc-read-mode-map))
  108.  "Mailcrypt read mode menu."
  109.  '("Mailcrypt"
  110.    ["Decrypt Message" mc-decrypt t]
  111.    ["Verify Signature" mc-verify t]
  112.    ["Snarf Keys" mc-snarf t]
  113.    ["Fetch Key" mc-pgp-fetch-key t]
  114.    ["Forget Passphrase(s)" mc-deactivate-passwd t]))
  115.  
  116. (easy-menu-define
  117.  mc-write-mode-menu (if mc-xemacs-p nil (list mc-write-mode-map))
  118.  "Mailcrypt write mode menu."
  119.  '("Mailcrypt"
  120.    ["Encrypt Message" mc-encrypt t]
  121.    ["Sign Message" mc-sign t]
  122.    ["Insert Public Key" mc-insert-public-key t]
  123.    ["Fetch Key" mc-pgp-fetch-key t]
  124.    ["Encrypt for Remailer(s)" mc-remailer-encrypt-for-chain t]
  125.    ["Insert Pseudonym" mc-remailer-insert-pseudonym t]
  126.    ["Insert Response Block" mc-remailer-insert-response-block t]
  127.    ["Forget Passphrase(s)" mc-deactivate-passwd t]))
  128.  
  129. (or (assq 'mc-read-mode minor-mode-map-alist)
  130.     (setq minor-mode-map-alist
  131.       (cons (cons 'mc-read-mode mc-read-mode-map)
  132.         minor-mode-map-alist)))
  133.  
  134. (or (assq 'mc-write-mode minor-mode-map-alist)
  135.     (setq minor-mode-map-alist
  136.       (cons (cons 'mc-write-mode mc-write-mode-map)
  137.         minor-mode-map-alist)))
  138.  
  139. (or (assq 'mc-read-mode minor-mode-alist)
  140.     (setq minor-mode-alist
  141.       (cons '(mc-read-mode mc-read-mode-string) minor-mode-alist)))
  142.  
  143. (or (assq 'mc-write-mode minor-mode-alist)
  144.     (setq minor-mode-alist
  145.       (cons '(mc-write-mode mc-write-mode-string) minor-mode-alist)))
  146.  
  147. (defun mc-read-mode (&optional arg)
  148.   "\nMinor mode for interfacing with cryptographic functions.
  149.  
  150. \\[mc-decrypt]\t\tDecrypt an encrypted message
  151. \\[mc-verify]\t\tVerify signature on a clearsigned message
  152. \\[mc-snarf]\t\tAdd public key(s) to keyring
  153. \\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP
  154. \\[mc-deactivate-passwd]\t\tForget passphrase(s)\n"
  155.   (interactive)
  156.   (setq mc-read-mode
  157.     (if (null arg) (not mc-read-mode)
  158.       (> (prefix-numeric-value arg) 0)))
  159.   (and mc-read-mode mc-write-mode (mc-write-mode nil))
  160.   (if mc-read-mode
  161.       (easy-menu-add mc-read-mode-menu)
  162.     (easy-menu-remove mc-read-mode-menu)))
  163.     
  164. (defun mc-write-mode (&optional arg)
  165.   "\nMinor mode for interfacing with cryptographic functions.
  166.  
  167. \\[mc-encrypt]\t\tEncrypt (and optionally sign) message
  168. \\[mc-sign]\t\tClearsign message
  169. \\[mc-insert-public-key]\t\tExtract public key from keyring and insert into message
  170. \\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP
  171. \\[mc-remailer-encrypt-for-chain]\t\tEncrypt message for remailing
  172. \\[mc-remailer-insert-pseudonym]\t\tInsert a pseudonym (for remailing)
  173. \\[mc-remailer-insert-response-block]\t\tInsert a response block (for remailing)
  174. \\[mc-deactivate-passwd]\t\tForget passphrase(s)\n"
  175.   (interactive)
  176.   (setq mc-write-mode
  177.     (if (null arg) (not mc-write-mode)
  178.       (> (prefix-numeric-value arg) 0)))
  179.   (and mc-write-mode mc-read-mode (mc-read-mode nil))
  180.   (if mc-write-mode
  181.       (easy-menu-add mc-write-mode-menu)
  182.     (easy-menu-remove mc-write-mode-menu)))
  183.  
  184. (defun mc-install-read-mode ()
  185.   (interactive)
  186.   (mc-read-mode 1))
  187.  
  188. (defun mc-install-write-mode ()
  189.   (interactive)
  190.   (mc-write-mode 1))
  191.  
  192. ;;}}}
  193.  
  194. ;;{{{ Note:
  195. ;; The funny triple braces you see are used by `folding-mode', a minor
  196. ;; mode by Jamie Lokier, available from the elisp archive.
  197. ;;}}}
  198.  
  199. ;;{{{ User variables.
  200. (defconst mc-version "3.3")
  201. (defvar mc-default-scheme 'mc-scheme-pgp "*Default encryption scheme to use.")
  202. (defvar mc-passwd-timeout 60
  203.   "*Time to deactivate password in seconds after a use.
  204. nil or 0 means deactivate immediately.  If the only timer package available
  205. is the 'timer' package, then this can be a string in timer format.")
  206.  
  207. (defvar mc-ripem-user-id (or (getenv "RIPEM_USER_NAME")
  208.                  (user-full-name) "*Your RIPEM user ID."))
  209.  
  210. (defvar mc-always-replace nil
  211.   "*If t, decrypt mail messages in place without prompting.
  212.  
  213. If 'never, always use a viewer instead of replacing.")
  214.  
  215. (defvar mc-use-default-recipients nil "*Assume that the message should
  216.   be encoded for everyone listed in the To, Cc, and Bcc fields.")
  217.  
  218. (defvar mc-encrypt-for-me nil "*Encrypt all outgoing messages with
  219.   user's public key.")
  220.  
  221. (defvar mc-pre-signature-hook nil
  222.   "*List of hook functions to run immediately before signing.")
  223. (defvar mc-post-signature-hook nil
  224.   "*List of hook functions to run immediately after signing.")
  225. (defvar mc-pre-encryption-hook nil 
  226.   "*List of hook functions to run immediately before encrypting.")
  227. (defvar mc-post-encryption-hook nil 
  228.   "*List of hook functions to run after encrypting.")
  229. (defvar mc-pre-decryption-hook nil 
  230.   "*List of hook functions to run immediately before decrypting.")
  231. (defvar mc-post-decryption-hook nil 
  232.   "*List of hook functions to run after decrypting.")
  233.  
  234. (defconst mc-buffer-name "*MailCrypt*"
  235.   "Name of temporary buffer for mailcrypt")
  236.  
  237. (defvar mc-modes-alist
  238.   '((rmail-mode (decrypt . mc-rmail-decrypt-message)
  239.         (verify . mc-rmail-verify-signature))
  240.     (rmail-summary-mode (decrypt . mc-rmail-summary-decrypt-message)
  241.             (verify . mc-rmail-summary-verify-signature)
  242.             (snarf . mc-rmail-summary-snarf-keys))
  243.     (vm-mode (decrypt . mc-vm-decrypt-message)
  244.          (verify . mc-vm-verify-signature)
  245.          (snarf . mc-vm-snarf-keys))
  246.     (vm-summary-mode (decrypt . mc-vm-decrypt-message)
  247.              (verify . mc-vm-verify-signature)
  248.              (snarf . mc-vm-snarf-keys))
  249.     (mh-folder-mode (decrypt . mc-mh-decrypt-message)
  250.             (verify . mc-mh-verify-signature)
  251.             (snarf . mc-mh-snarf-keys))
  252.     (gnus-summary-mode (decrypt . mc-gnus-summary-decrypt-message)
  253.                (verify . mc-gnus-summary-verify-signature)
  254.                (snarf . mc-gnus-summary-snarf-keys))
  255.     (mail-mode (encrypt . mc-encrypt-message)
  256.            (sign . mc-sign-message))
  257.     (vm-mail-mode (encrypt . mc-encrypt-message)
  258.           (sign . mc-sign-message))
  259.     (mh-letter-mode (encrypt . mc-encrypt-message)
  260.             (sign . mc-sign-message))
  261.     (news-reply-mode (encrypt . mc-encrypt-message)
  262.              (sign . mc-sign-message)))
  263.  
  264.   "Association list (indexed by major mode) of association lists
  265. (indexed by operation) of functions to call for each major mode.")
  266.  
  267. ;;}}}
  268. ;;{{{ Program variables and constants.
  269.  
  270. (defvar mc-timer nil "Timer object for password deactivation.")
  271.  
  272. (defvar mc-passwd-cache nil "Cache for passphrases.")
  273.  
  274. (defvar mc-schemes '(("pgp" . mc-scheme-pgp)))
  275.  
  276. ;;}}}
  277.  
  278. ;;{{{ Utility functions.
  279.  
  280. (defun mc-message-delimiter-positions (start-re end-re &optional begin)
  281.   ;; Returns pair of integers (START . END) that delimit message marked off
  282.   ;; by the regular expressions start-re and end-re. Optional argument BEGIN
  283.   ;; determines where we should start looking from.
  284.   (setq begin (or begin (point-min)))
  285.   (let (start)
  286.     (save-excursion
  287.       (goto-char begin)
  288.       (and (re-search-forward start-re nil t)
  289.        (setq start (match-beginning 0))
  290.        (re-search-forward end-re nil t)
  291.        (cons start (point))))))
  292.  
  293.  
  294. (defun mc-split (regexp str)
  295.   "Splits STR into a list of elements which were separated by REGEXP,
  296. stripping initial and trailing whitespace."
  297.   (let ((data (match-data))
  298.     (retval '())
  299.     beg end)
  300.     (unwind-protect
  301.     (progn
  302.       (string-match "[ \t\n]*" str)    ; Will always match at 0
  303.       (setq beg (match-end 0))
  304.       (setq end (string-match "[ \t\n]*\\'" str))
  305.       (while (string-match regexp str beg)
  306.         (setq retval
  307.           (cons (substring str beg (match-beginning 0)) 
  308.             retval))
  309.         (setq beg (match-end 0)))
  310.       (if (not (= (length str) beg)) ; Not end
  311.           (setq retval (cons (substring str beg end) retval)))
  312.       (nreverse retval))
  313.       (store-match-data data))))
  314.  
  315. ;;; FIXME - Function never called?
  316. (defun mc-temp-display (beg end &optional name)
  317.   (let (tmp)
  318.     (if (not name)
  319.     (setq name mc-buffer-name))
  320.     (if (string-match name "*ERROR*")
  321.     (progn
  322.       (message "mailcrypt: An error occured!  See *ERROR* buffer.")
  323.       (beep)))
  324.     (setq tmp (buffer-substring beg end))
  325.     (delete-region beg end)
  326.     (save-excursion
  327.       (save-window-excursion
  328.     (with-output-to-temp-buffer name
  329.       (princ tmp))))))
  330.  
  331. (defun mc-display-buffer (buffer)
  332.   "Like display-buffer, but always display top of the buffer."
  333.   (save-excursion
  334.     (set-buffer buffer)
  335.     (goto-char (point-min))
  336.     (display-buffer buffer)))
  337.  
  338. (defun mc-message (msg &optional buffer default)
  339.   ;; returns t if we used msg, nil if we used default
  340.   (let ((retval t))
  341.     (if buffer
  342.     (setq msg
  343.           (save-excursion
  344.         (set-buffer buffer)
  345.         (goto-char (point-min))
  346.         (if (re-search-forward msg nil t)
  347.             (buffer-substring (match-beginning 0) (match-end 0))
  348.           (setq retval nil)
  349.           default))))
  350.     (if msg (message "%s" msg))
  351.     retval))
  352.  
  353. (defun mc-process-region (beg end passwd program args parser &optional buffer)
  354.   (let ((obuf (current-buffer))
  355.     (process-connection-type nil)
  356.     mybuf result rgn proc)
  357.     (unwind-protect
  358.     (progn
  359.       (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
  360.       (set-buffer mybuf)
  361.       (erase-buffer)
  362.       (buffer-disable-undo mybuf)
  363.       (setq proc
  364.         (apply 'start-process "*PGP*" mybuf program args))
  365.       (if passwd
  366.           (progn
  367.         (process-send-string proc (concat passwd "\n"))
  368.         (or mc-passwd-timeout (mc-deactivate-passwd))))
  369.       (set-buffer obuf)
  370.       (process-send-region proc beg end)
  371.       (process-send-eof proc)
  372.       (while (eq 'run (process-status proc))
  373.         (accept-process-output proc 5))
  374.       (setq result (process-exit-status proc))
  375.       (set-buffer mybuf)
  376.       (goto-char (point-max))
  377.       (if (re-search-backward "\nProcess .* finished\n\\'" nil t)
  378.           (delete-region (match-beginning 0) (match-end 0)))
  379.       (goto-char (point-min))
  380.       ;; CRNL -> NL
  381.       (while (search-forward "\r\n" nil t)
  382.         (replace-match "\n"))
  383.       ;; Hurm.  FIXME; must get better result codes.
  384.       (if (stringp result)
  385.           (error "%s exited abnormally: '%s'" program result)
  386.         (setq rgn (funcall parser result))
  387.         ;; If the parser found something, migrate it
  388.         (if (consp rgn)
  389.         (progn
  390.           (set-buffer obuf)
  391.           (delete-region beg end)
  392.           (goto-char beg)
  393.           (insert-buffer-substring mybuf (car rgn) (cdr rgn))
  394.           (set-buffer mybuf)
  395.           (delete-region (car rgn) (cdr rgn)))))
  396.       ;; Return nil on failure and exit code on success
  397.       (if rgn result))
  398.       ;; Cleanup even on nonlocal exit
  399.       (if (and proc (eq 'run (process-status proc)))
  400.       (interrupt-process proc))
  401.       (set-buffer obuf)
  402.       (or buffer (null mybuf) (kill-buffer mybuf)))))
  403.  
  404. ;;}}}
  405.  
  406. ;;{{{ Passphrase management
  407. (defun mc-activate-passwd (id &optional prompt)
  408.   "Activate the passphrase matching ID, using PROMPT for a prompt.
  409. Return the passphrase.  If PROMPT is nil, only return value if cached."
  410.   (cond ((featurep 'itimer)
  411.      (if mc-timer (delete-itimer mc-timer))
  412.      (setq mc-timer (if mc-passwd-timeout
  413.                 (start-itimer "mc-itimer"
  414.                       'mc-deactivate-passwd
  415.                       mc-passwd-timeout)
  416.               nil)))
  417.     ((featurep 'timer)
  418.      (let ((string-time (if (integerp mc-passwd-timeout)
  419.                 (format "%d sec" mc-passwd-timeout)
  420.                   mc-passwd-timeout)))
  421.        (if mc-timer (cancel-timer mc-timer))
  422.        (setq mc-timer (if string-time
  423.                   (run-at-time string-time 
  424.                        nil 'mc-deactivate-passwd)
  425.                 nil)))))
  426.   (let ((cell (assoc id mc-passwd-cache))
  427.     passwd)
  428.     (setq passwd (cdr-safe cell))
  429.     (if (and (not passwd) prompt)
  430.     (setq passwd (comint-read-noecho prompt)))
  431.     (if cell
  432.     (setcdr cell passwd)
  433.       (setq mc-passwd-cache (cons (cons id passwd) mc-passwd-cache)))
  434.     passwd))
  435.  
  436. (defun mc-deactivate-passwd (&optional inhibit-message)
  437.   "*Deactivate the passphrase cache."
  438.   (interactive)
  439.   (if mc-timer
  440.       (cond ((featurep 'itimer) (delete-itimer mc-timer))
  441.         ((featurep 'timer) (cancel-timer mc-timer))))
  442.   (mapcar
  443.    (function
  444.     (lambda (cell)
  445.       (if (stringp (cdr-safe cell)) (fillarray (cdr cell) 0))
  446.       (setcdr cell nil)))
  447.    mc-passwd-cache)
  448.   (or inhibit-message
  449.       (message "Passphrase%s deactivated"
  450.            (if (> (length mc-passwd-cache) 1) "s" ""))))
  451.  
  452. ;;}}}
  453.  
  454. ;;{{{ Define several aliases so that an apropos on `mailcrypt' will
  455. ;; return something.
  456. (defalias 'mailcrypt-encrypt 'mc-encrypt)
  457. (defalias 'mailcrypt-decrypt 'mc-decrypt)
  458. (defalias 'mailcrypt-sign 'mc-sign)
  459. (defalias 'mailcrypt-verify 'mc-verify)
  460. (defalias 'mailcrypt-insert-public-key 'mc-insert-public-key)
  461. (defalias 'mailcrypt-snarf 'mc-snarf)
  462. ;;}}}
  463. (provide 'mailcrypt)
  464.