Download
(require 'mh-e)
(eval-and-compile
(if (fboundp 'mh-version)
(require 'mh-pick)))
(require 'crypt++)
(require 'advice)
(defvar mhc-move-headers nil
"*Non-nil means mh-crypt will encrypt message headers.
Those fields specified in mhc-preserved-fields will not be encrypted. On
decryption, mh-crypt will check for and restore encrypted headers. This
variable is buffer-local and can be set in your mh-folder-mode-hook. For
example:
(add-hook 'mh-folder-mode-hook
(function (lambda ()
(if (equal mh-current-folder \"+private\")
(setq mhc-move-headers t)))))
The default value is nil.")
(make-variable-buffer-local 'mhc-move-headers)
(defvar mhc-preserved-fields '("Date" "From" "To")
"*A list of header fields that mh-crypt should leave as plaintext.
\"From\" and \"Date\" should generally be included at a minimum, as
without them MH scan listings will be very uninformative.")
(defvar mhc-key-timeout "10 min"
"*Time to deactivate key in after a use, or nil for immediately.
If you are not running Emacs 19, mh-crypt will not cache keys and will
remind you of this until this variable is set to nil.")
(defvar mhc-auto-crypt t
"*If non-nil, MH messages will be decrypted or decoded when displayed.")
(defvar mhc-key nil "The cached key value.")
(defvar mhc-decrypted nil)
(make-variable-buffer-local 'mhc-decrypted)
(or (assq 'mhc-decrypted minor-mode-alist)
(setq minor-mode-alist (cons '(mhc-decrypted mhc-decrypted)
minor-mode-alist)))
(defun mhc-encrypt-folder (range)
"Encrypt all messages in the current folder.
If optional prefix argument is provided, prompt for the range of
messages to display after encrypting. Otherwise, show the entire
folder."
(interactive (list (if current-prefix-arg
(mh-read-msg-range
"Range to scan after encrypting [all]? "))))
(mhc-enc-folder t range))
(defun mhc-encode-folder (range)
"Encode all messages in the current folder.
If optional prefix argument is provided, prompt for the range of
messages to display after encoding. Otherwise, show the entire
folder."
(interactive (list (if current-prefix-arg
(mh-read-msg-range
"Range to scan after encoding [all]? "))))
(mhc-enc-folder nil range))
(defun mhc-enc-folder (encrypt range)
(if (or range mh-do-not-confirm
(y-or-n-p (format "%s folder %s? "
(if encrypt "Encrypt" "Encode")
mh-current-folder)))
(progn
(if (null range) (setq range "all"))
(let ((show-buffer (get-buffer mh-show-buffer)))
(if (and show-buffer (null (buffer-file-name show-buffer)))
(progn
(delete-windows-on show-buffer)
(kill-buffer show-buffer))))
(mh-add-msgs-to-seq
(mh-seq-from-command mh-current-folder 'dummy
(list "pick" "all" mh-current-folder))
'all t)
(mhc-enc-msg 'all encrypt)
(mh-delete-seq-locally 'all)
(mh-regenerate-headers range))))
(defun mhc-encrypt-msg (msg-or-seq)
"Encrypt the specified messages on disk. Default is the displayed message.
If optional prefix argument is provided then prompt for the message sequence."
(interactive (list (if current-prefix-arg
(mh-read-seq "Encrypt" t)
(mh-get-msg-num t))))
(mhc-enc-msg msg-or-seq t))
(defun mhc-encode-msg (msg-or-seq)
"Encode the specified messages on disk. Default is the displayed message.
If optional prefix argument is provided then prompt for the message sequence."
(interactive (list (if current-prefix-arg
(mh-read-seq "Encode" t)
(mh-get-msg-num t))))
(mhc-enc-msg msg-or-seq nil))
(defun mhc-enc-msg (msg-or-seq encrypt)
(let ((key-or-type
(if encrypt
(mhc-get-key "Encrypt using key: " "Encrypt using cached key? " t)
(crypt-read-encoding-type)
crypt-buffer-encoding-type)))
(if (numberp msg-or-seq)
(mhc-enc-a-msg msg-or-seq encrypt key-or-type)
(mhc-map-to-seq-msgs 'mhc-enc-a-msg msg-or-seq encrypt key-or-type)
(message "Done."))))
(defun mhc-enc-a-msg (msg encrypt key-or-type)
(let* ((local-mhc-move-headers mhc-move-headers)
(msg-filename (mh-msg-filename msg))
(show-buffer (get-buffer mh-show-buffer))
(msg-shown (and show-buffer
(equal msg-filename (buffer-file-name show-buffer)))))
(save-excursion
(set-buffer (create-file-buffer msg-filename))
(insert-file-contents msg-filename t)
(mhc-alter-header encrypt local-mhc-move-headers key-or-type)
(mhc-goto-header-end 1)
(if encrypt
(crypt-encrypt-region (point) (point-max) key-or-type)
(let ((crypt-buffer-encoding-type key-or-type))
(crypt-encode-region (point) (point-max))))
(save-buffer)
(kill-buffer nil))
(if msg-shown
(if mhc-auto-crypt
(save-excursion
(set-buffer show-buffer)
(setq mhc-decrypted (if encrypt " Encrypted" " Encoded")))
(save-excursion
(save-window-excursion
(mh-invalidate-show-buffer)
(mh-display-msg msg (buffer-name))))))))
(defun mhc-decrypt-or-decode-folder (range)
"Decrypt or decode (as appropriate) all messages in the current folder.
If optional prefix argument is provided, prompt for the range of
messages to display after decrypting/decoding. Otherwise, show the entire
folder."
(interactive (list (if current-prefix-arg
(mh-read-msg-range
"Range to scan after decrypting/decoding [all]? "))))
(if (or range mh-do-not-confirm
(y-or-n-p (format "Decrypt/Decode folder %s? " mh-current-folder)))
(progn
(if (null range) (setq range "all"))
(mh-add-msgs-to-seq
(mh-seq-from-command mh-current-folder 'dummy
(list "pick" "all" mh-current-folder))
'all t)
(mhc-decrypt-or-decode-msg 'all)
(mh-delete-seq-locally 'all)
(mh-regenerate-headers range))))
(defun mhc-decrypt-or-decode-msg (msg-or-seq &optional decrypt-on-disk)
"Decrypt or decode the specified message into the show buffer.
Default is the displayed message. If optional prefix argument is provided
then decrypt/decode on disk. If prefix argument is 0 then prompt for a
message sequence and decrypt/decode the messages to disk."
(interactive (list (if (and (numberp current-prefix-arg)
(eq current-prefix-arg 0))
(mh-read-seq "Decrypt/Decode" t)
(mh-get-msg-num t))
current-prefix-arg))
(mhc-dec-msg msg-or-seq 'guess decrypt-on-disk))
(defun mhc-decrypt-msg (msg-or-seq &optional decrypt-on-disk)
"Decrypt the specified message into the show buffer.
Default is the displayed message. If optional prefix argument is
provided then decrypt on disk. If prefix argument is 0 then prompt for a
message sequence and decrypt the messages to disk."
(interactive (list (if (and (numberp current-prefix-arg)
(eq current-prefix-arg 0))
(mh-read-seq "Decrypt" t)
(mh-get-msg-num t))
current-prefix-arg))
(mhc-dec-msg msg-or-seq 'decrypt decrypt-on-disk
(mhc-get-key "Decrypt using key: "
"Decrypt using cached key? ")))
(defun mhc-decode-msg (msg-or-seq &optional decode-on-disk)
"Decode the specified message into the show buffer.
Default is the displayed message. If optional prefix argument is
provided then decode on disk. If prefix argument is 0 then prompt for a
message sequence and decode the messages to disk."
(interactive (list (if (and (numberp current-prefix-arg)
(eq current-prefix-arg 0))
(mh-read-seq "Decode" t)
(mh-get-msg-num t))
current-prefix-arg))
(mhc-dec-msg msg-or-seq 'decode decode-on-disk
(progn
(crypt-read-encoding-type)
crypt-buffer-encoding-type)))
(defun mhc-dec-msg (msg-or-seq action &optional decrypt-on-disk key-or-type)
(if (numberp msg-or-seq)
(mhc-dec-a-msg msg-or-seq action key-or-type decrypt-on-disk)
(mhc-map-to-seq-msgs 'mhc-dec-a-msg msg-or-seq action key-or-type t)
(message "Done.")))
(defvar mhc-guess-flag nil)
(defun mhc-dec-a-msg (msg action key-or-type decrypt-on-disk)
(while (not (if decrypt-on-disk
(mhc-dec-on-disk msg (eq action 'decrypt) key-or-type
(eq action 'guess))
(mhc-dec-buffer msg (eq action 'decrypt) key-or-type
(eq action 'guess))))
(cond
((or (eq action 'decrypt) (and (eq action 'guess)
(eq mhc-guess-flag 'decrypt)
(setq action 'decrypt)))
(beep)
(setq key-or-type
(mhc-get-key
(format "Decryption of message %s failed. Decrypt using key: "
msg))))
((or (eq action 'decode)
(and (eq action 'guess) (eq mhc-guess-flag 'decode)))
(error "Decoding of message %s failed." msg))
((eq mhc-guess-flag 'badmethod)
(error "Message %s requires an unavailable decoding method." msg))
((eq mhc-guess-flag 'nofield)
(error "Message %s has no visible X-MH-Crypt field." msg))
((eq mhc-guess-flag 'quit)
(signal 'quit nil)))))
(defun mhc-dec-on-disk (msg decrypt key-or-type guess)
(let* ((msg-filename (mh-msg-filename msg))
(show-buffer (get-buffer mh-show-buffer))
(msg-shown (and show-buffer
(equal msg-filename
(buffer-file-name show-buffer))))
mhc-auto-crypt decrypt-okay guesses)
(save-excursion
(set-buffer (create-file-buffer msg-filename))
(insert-file-contents msg-filename t)
(mhc-goto-header-end 1)
(if (and guess (setq guesses (mhc-guess)))
(setq decrypt (car guesses)
key-or-type (cdr guesses)))
(if (not (and guess (null guesses)))
(progn
(if decrypt
(crypt-encrypt-region (point) (point-max) key-or-type t)
(let ((crypt-buffer-encoding-type key-or-type))
(crypt-encode-region (point) (point-max) t)))
(setq decrypt-okay (mhc-restore-header))))
(if decrypt-okay
(save-buffer)
(set-buffer-modified-p nil))
(kill-buffer nil))
(if (and decrypt-okay msg-shown)
(save-excursion
(save-window-excursion
(mh-invalidate-show-buffer)
(mh-display-msg msg (buffer-name)))))
decrypt-okay))
(defun mhc-dec-buffer (msg decrypt key-or-type guess)
(let (mhc-auto-crypt decrypt-okay guesses)
(mh-invalidate-show-buffer)
(mh-show msg)
(save-excursion
(set-buffer mh-show-buffer)
(goto-char (point-min))
(mhc-goto-header-end 1)
(if (and guess (setq guesses (mhc-guess)))
(setq decrypt (car guesses)
key-or-type (cdr guesses)))
(if (not (and guess (null guesses)))
(progn
(if decrypt
(crypt-encrypt-region (point) (point-max) key-or-type t)
(let ((crypt-buffer-encoding-type key-or-type))
(crypt-encode-region (point) (point-max) t)))
(setq decrypt-okay (mhc-restore-header))))
(if decrypt-okay
(progn
(goto-char (point-min))
(setq mhc-decrypted (if decrypt " Encrypted" " Encoded"))
(set-buffer-modified-p nil))))
(if (not decrypt-okay)
(progn
(mh-invalidate-show-buffer)
(mh-show msg)))
decrypt-okay))
(defun mhc-guess ()
(setq mhc-guess-flag nil)
(condition-case nil
(let (decrypt key-or-type)
(save-excursion
(goto-char (point-min))
(mhc-goto-header-end 0)
(if (re-search-backward "^X-MH-Crypt:" nil t)
(progn
(setq decrypt
(not (looking-at "X-MH-Crypt:.*Encoded \\(.*\\)")))
(if decrypt
(setq mhc-guess-flag 'decrypt
key-or-type (mhc-get-key "Decrypt using key: " t))
(setq mhc-guess-flag 'decode
key-or-type
(intern (buffer-substring (match-beginning 1)
(match-end 1)))))
(if (or decrypt (crypt-get-encoding-program key-or-type))
(cons decrypt key-or-type)
(setq mhc-guess-flag 'badmethod)
nil))
(setq mhc-guess-flag 'nofield)
nil)))
(quit (setq mhc-guess-flag 'quit)
nil)))
(defun mhc-do-auto-crypt ()
"Automatically decrypt or decode the current buffer containing a message."
(if mhc-auto-crypt
(let (decrypt key-or-type guess)
(if (setq guess (mhc-guess))
(condition-case nil
(progn
(setq decrypt (car guess)
key-or-type (cdr guess))
(while
(save-excursion
(goto-char (point-min))
(mhc-goto-header-end 1)
(undo-boundary)
(if decrypt
(crypt-encrypt-region (point) (point-max)
key-or-type t)
(let ((crypt-buffer-encoding-type key-or-type))
(crypt-encode-region (point) (point-max) t)))
(if (mhc-restore-header)
(progn
(goto-char (point-min))
(setq mhc-decrypted
(if decrypt " Encrypted" " Encoded"))
(set-buffer-modified-p nil)
nil)
(primitive-undo 1 buffer-undo-list)
(beep)
(if decrypt
t
(message "Decoding failed.")
nil)))
(setq key-or-type
(mhc-get-key
"Decryption failed. Decrypt using key: "))))
(quit (beep)))
(if (eq mhc-guess-flag 'quit) (beep))))))
(defadvice mh-display-msg (after mhc-display-msg act)
"If mhc-auto-crypt is non-nil, decrypt or decode messages when shown."
(save-excursion
(if mh-show-buffer (set-buffer mh-show-buffer))
(mhc-do-auto-crypt)))
(defvar mhc-timer nil "Timer object for key deactivation.")
(defun mhc-get-key (prompt &optional use-cache confirm)
(let ((key (and use-cache (copy-sequence mhc-key))))
(if (not (and key (or (eq use-cache t)
(and (stringp use-cache)
(condition-case nil
(prog1
(y-or-n-p use-cache)
(message ""))
(quit (fillarray key 0)
(signal 'quit nil)))))))
(progn
(if (arrayp key) (fillarray key 0))
(setq key (crypt-read-string-no-echo
prompt (and confirm crypt-confirm-password)))))
(if mhc-key-timeout
(if (fboundp 'run-at-time)
(progn
(if mhc-timer (cancel-timer mhc-timer))
(setq mhc-timer (run-at-time mhc-key-timeout
nil 'mhc-deactivate-key))
(if (arrayp mhc-key) (fillarray mhc-key 0))
(setq mhc-key key))
(message
"This version of Emacs does not support timers. Key not cached."))
(setq mhc-timer nil))
key))
(defun mhc-deactivate-key ()
"Deactivates the MH-Crypt encryption/decryption key."
(interactive)
(fillarray mhc-key 0)
(setq mhc-key nil)
(and mhc-timer (fboundp 'cancel-timer) (cancel-timer mhc-timer))
(message "MH-Crypt password deactivated"))
(defun mhc-map-to-seq-msgs (func seq &rest args)
(save-excursion
(let ((msgs (mh-seq-to-msgs seq)))
(while msgs
(apply func (car msgs) args)
(setq msgs (cdr msgs))))))
(defun mhc-alter-header (encrypt encrypt-fields type)
(let ((case-fold-search t)
(header-start (copy-marker (point-min)))
(header-end (progn (mhc-goto-header-end 0)
(copy-marker (point))))
(fields mhc-preserved-fields)
(bofd (make-marker))
(eofd (make-marker))
(moved-at-least-one nil)
(xmh-crypt-field (concat "X-MH-Crypt: "
(if encrypt "Encrypted"
(concat "Encoded " (symbol-name type)))
"\n")))
(while (and encrypt-fields (consp fields))
(goto-char header-end)
(if (re-search-backward (format "^%s:" (car fields)) header-start t)
(progn
(setq moved-at-least-one t)
(set-marker bofd (point))
(end-of-line)
(set-marker eofd (+ 1 (point)))
(goto-char header-start)
(insert-before-markers (buffer-substring bofd eofd))
(delete-region bofd eofd)))
(setq fields (cdr fields)))
(goto-char header-end)
(insert-string xmh-crypt-field)
(goto-char (point-max))
(insert-string (concat "\n\n" xmh-crypt-field))
(if moved-at-least-one
(progn
(insert-string (buffer-substring header-start header-end))
(delete-region header-start header-end)))
(goto-char (point-min))))
(defun mhc-restore-header ()
(let ((stored-fields (make-marker))
pos)
(goto-char (point-min))
(mhc-goto-header-end 0)
(condition-case nil
(progn
(if (re-search-backward "^X-MH-Crypt:" nil t)
(progn
(setq pos (point))
(beginning-of-line 2)
(delete-region pos (point))))
(goto-char (point-max))
(re-search-backward "\n\n")
(delete-char 2)
(set-marker stored-fields (point))
(goto-char (point-min))
(mhc-goto-header-end 0)
(insert-before-markers (buffer-substring stored-fields (point-max)))
(delete-region stored-fields (point-max))
(goto-char (point-min))
(mhc-goto-header-end 0)
(re-search-backward "^X-MH-Crypt:")
(setq pos (point))
(beginning-of-line 2)
(delete-region pos (point))
t)
(search-failed nil))))
(defun mhc-goto-header-end (arg)
(if (re-search-forward "^$\\|^-+$" nil t)
(forward-line arg)))
(define-key mh-folder-mode-map "E" 'mhc-encrypt-msg)
(define-key mh-folder-mode-map "C" 'mhc-encode-msg)
(define-key mh-folder-mode-map "D" 'mhc-decrypt-or-decode-msg)
(define-key mh-folder-mode-map "\eE" 'mhc-encrypt-folder)
(define-key mh-folder-mode-map "\eC" 'mhc-encode-folder)
(define-key mh-folder-mode-map "\eD" 'mhc-decrypt-or-decode-folder)
(provide 'mh-crypt)