cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-pgg.el

   1 ;;; vm-pgg.el --- PGP/MIME support for VM by pgg.el
   2 ;;
   3 ;; Copyright (C) 2006 Robert Widhopf-Fenk
   4 ;;
   5 ;; Author:      Robert Widhopf-Fenk, Jens Gustedt
   6 ;; Status:      Tested with XEmacs 21.4.19 & VM 7.19
   7 ;; Keywords:    VM helpers
   8 ;; X-URL:       http://www.robf.de/Hacking/elisp
   9
  10 ;;
  11 ;; This code is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 1, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; if not, write to the Free Software
  23 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26 ;;
  27 ;; This is a replacement for mailcrypt adding PGP/MIME support to VM.
  28 ;;
  29 ;; It requires PGG which is a standard package for XEmacs and is a part
  30 ;; of Gnus for GNU Emacs.  On Debian "apt-get install gnus" should do the
  31 ;; trick.
  32 ;;
  33 ;; It is still in BETA state thus you must explicitly load it by
  34 ;;
  35 ;;      (and (locate-library "vm-pgg") (require 'vm-pgg))
  36 ;;
  37 ;; If you set `vm-auto-displayed-mime-content-types' and/or
  38 ;; `vm-mime-internal-content-types' make sure that they contain
  39 ;; "application/pgp-keys" or set them before loading vm-pgg.
  40 ;; Otherwise public  keys are not detected automatically .
  41 ;;
  42 ;; To customize vm-pgg use: M-x customize-group RET vm-pgg RET
  43 ;;
  44 ;; Displaying of messages in the PGP(/MIME) format will automatically trigger:
  45 ;;  * decrypted of encrypted MIME parts
  46 ;;  * verification of signed MIME parts
  47 ;;  * snarfing of public keys
  48 ;;
  49 ;; The status of the current message will also be displayed in the modeline.
  50 ;;
  51 ;; To create messages according to PGP/MIME you should use:
  52 ;;  * M-x vm-pgg-encrypt       for encrypting
  53 ;;  * M-x vm-pgg-sign          for signing
  54 ;;  * C-u M-x vm-pgg-encrypt   for encrypting + signing
  55 ;;
  56 ;; All these commands are also available in the menu PGP/MIME which is
  57 ;; activated by the minor mode `vm-pgg-compose-mode'.  There are also
  58 ;; commands for the old style clear text format as MC had them.
  59 ;;
  60 ;; If you get annoyed by answering password prompts you might want to set the
  61 ;; variable `pgg-cache-passphrase' to t and `pgg-passphrase-cache-expiry' to a
  62 ;; higher value or nil!
  63 ;;
  64
  65 ;;; References:
  66 ;;
  67 ;; Code partially stems from the sources:
  68 ;; * mml2015.el (Gnus)
  69 ;; * mc-toplev.el (Mailcrypt)
  70 ;;
  71 ;; For PGP/MIME see:
  72 ;; * http://www.faqs.org/rfcs/rfc2015.html
  73 ;; * http://www.faqs.org/rfcs/rfc2440.html
  74 ;; * http://www.faqs.org/rfcs/rfc3156.html
  75 ;;
  76
  77 ;;; TODO:
  78 ;;
  79 ;; * add annotation see to signed/encrypted regions.  XEmacs has annotations
  80 ;;   and GNU Emacs?  Maybe I simply use overlays at the line start without eys
  81 ;;   candy.
  82 ;; * allow attaching of other keys from key-ring
  83 ;;
  84
  85 ;;; Code:
  86
  87 ;; handle missing pgg.el gracefully
  88 (eval-and-compile
  89   (if (and (boundp 'byte-compile-current-file) byte-compile-current-file)
  90       (condition-case nil
  91           (require 'pgg)
  92         (error (message "WARNING: Cannot load pgg.el, related functions may not work!")))
  93     (require 'pgg))
  94
  95   (require 'easymenu)
  96   (require 'vm-version)
  97   (require 'vm-misc)
  98   (require 'vm-page)
  99   (require 'vm-vars)
 100   (require 'vm-mime)
 101   (require 'vm-reply)
 102
 103   (require 'advice))
 104
 105
 106 (eval-when-compile
 107   (require 'cl)
 108   ;; avoid warnings
 109   (defvar vm-mode-line-format)
 110   (defvar vm-message-pointer)
 111   (defvar vm-presentation-buffer)
 112   (defvar vm-summary-buffer)
 113   ;; avoid bytecompile warnings
 114   (defvar vm-pgg-cleartext-state nil "For interfunction communication.")
 115 )
 116
 117 (defgroup vm nil
 118   "VM"
 119   :group 'mail)
 120
 121 (defgroup vm-pgg nil
 122   "PGP and PGP/MIME support for VM by PGG."
 123   :group  'vm)
 124
 125 (defface vm-pgg-bad-signature
 126   '((((type tty) (class color))
 127      (:foreground "red" :bold t))
 128     (((type tty))
 129      (:bold t))
 130     (((background light))
 131      (:foreground "red" :bold t))
 132     (((background dark))
 133      (:foreground "red" :bold t)))
 134   "The face used to highlight bad signature messages."
 135   :group 'vm-pgg
 136   :group 'faces)
 137
 138 (defface vm-pgg-good-signature
 139   '((((type tty) (class color))
 140      (:foreground "green" :bold t))
 141     (((type tty))
 142      (:bold t))
 143     (((background light))
 144      (:foreground "green4"))
 145     (((background dark))
 146      (:foreground "green")))
 147   "The face used to highlight good signature messages."
 148   :group 'vm-pgg
 149   :group 'faces)
 150
 151 (defface vm-pgg-unknown-signature-type
 152   '((((type tty) (class color))
 153      (:bold t))
 154     (((type tty))
 155      (:bold t)))
 156   "The face used to highlight unknown signature types."
 157   :group 'vm-pgg
 158   :group 'faces)
 159
 160 (defface vm-pgg-error
 161   '((((type tty) (class color))
 162      (:foreground "red" :bold t))
 163     (((type tty))
 164      (:bold t))
 165     (((background light))
 166      (:foreground "red" :bold t))
 167     (((background dark))
 168      (:foreground "red" :bold t)))
 169   "The face used to highlight error messages."
 170   :group 'vm-pgg
 171   :group 'faces)
 172
 173 (defface vm-pgg-bad-signature-modeline
 174   '((((type tty) (class color))
 175      (:inherit modeline :foreground "red" :bold t))
 176     (((type tty))
 177      (:inherit modeline :bold t))
 178     (((background light))
 179      (:inherit modeline :foreground "red" :bold t))
 180     (((background dark))
 181      (:inherit modeline :foreground "red" :bold t)))
 182   "The face used to highlight bad signature messages."
 183   :group 'vm-pgg
 184   :group 'faces)
 185
 186 (defface vm-pgg-good-signature-modeline
 187   '((((type tty) (class color))
 188      (:inherit modeline :foreground "green" :bold t))
 189     (((type tty))
 190      (:inherit modeline :bold t))
 191     (((background light))
 192      (:inherit modeline :foreground "green4"))
 193     (((background dark))
 194      (:inherit modeline :foreground "green")))
 195   "The face used to highlight good signature messages."
 196   :group 'vm-pgg
 197   :group 'faces)
 198
 199 (defface vm-pgg-unknown-signature-type-modeline
 200   '((((type tty) (class color))
 201      (:inherit modeline :bold t))
 202     (((type tty))
 203      (:inherit modeline :bold t)))
 204     "The face used to highlight unknown signature types."
 205   :group 'vm-pgg
 206   :group 'faces)
 207
 208 (defface vm-pgg-error-modeline
 209   '((((type tty) (class color))
 210      (:inherit modeline :foreground "red" :bold t))
 211     (((type tty))
 212      (:inherit modeline :bold t))
 213     (((background light))
 214      (:inherit modeline :foreground "red"))
 215     (((background dark))
 216      (:inherit modeline :foreground "red")))
 217   "The face used to highlight error messages."
 218   :group 'vm-pgg
 219   :group 'faces)
 220
 221 ;; hack to work around the missing support for :inherit in XEmacs
 222 (when (featurep 'xemacs)
 223   (let ((faces '(vm-pgg-bad-signature-modeline
 224                  vm-pgg-good-signature-modeline
 225                  vm-pgg-unknown-signature-type-modeline
 226                  vm-pgg-error-modeline))
 227         (faces-list (face-list))
 228         f)
 229     (while faces
 230       (setq f (car faces))
 231       (set-face-parent f 'modeline)
 232       (face-display-set f (custom-face-get-spec f) nil '(custom))
 233       (setq faces (cdr faces)))))
 234
 235 (defcustom vm-pgg-fetch-missing-keys t
 236   "*If t, PGP will try to fetch missing keys from `pgg-default-keyserver-address'."
 237   :group 'vm-pgg
 238    :type 'boolean)
 239
 240 (defcustom vm-pgg-auto-snarf t
 241   "*If t, snarfing of keys will happen automatically."
 242   :group 'vm-pgg
 243    :type 'boolean)
 244
 245 (defcustom vm-pgg-auto-decrypt t
 246   "*If t, decrypting will happen automatically."
 247   :group 'vm-pgg
 248    :type 'boolean)
 249
 250 (defcustom vm-pgg-get-author-headers '("From:" "Sender:")
 251   "*The list of headers to get the author of a mail that is to be send.
 252 If nil, `pgg-default-user-id' is used as a fallback."
 253   :group 'vm-pgg
 254   :type '(repeat string))
 255
 256 (defcustom vm-pgg-sign-text-transfer-encoding 'quoted-printable
 257   "*The encoding used for signed MIME parts of type text.
 258 See `vm-pgg-sign' for details."
 259   :group 'vm-pgg
 260   :type '(choice (const quoted-printable) (const base64)))
 261
 262 (defvar vm-pgg-compose-mode-map
 263   (let ((map (make-sparse-keymap)))
 264     (define-key map "\C-c#s" 'vm-pgg-sign)
 265     (define-key map "\C-c#e" 'vm-pgg-encrypt)
 266     (define-key map "\C-c#E" 'vm-pgg-sign-and-encrypt)
 267     (define-key map "\C-c#a" 'vm-pgg-ask-hook)
 268     (define-key map "\C-c#k" 'vm-pgg-attach-public-key)
 269     map))
 270
 271 (defvar vm-pgg-compose-mode-menu nil
 272   "The composition menu of vm-pgg.")
 273
 274 (easy-menu-define
 275  vm-pgg-compose-mode-menu (if (featurep 'xemacs) nil (list vm-pgg-compose-mode-map))
 276  "PGP/MIME compose mode menu."
 277  '("PGP/MIME"
 278    ["Sign"              vm-pgg-sign t]
 279    ["Encrypt"           vm-pgg-encrypt t]
 280    ["Sign+Encrypt"      vm-pgg-sign-and-encrypt t]
 281    ["Ask For An Action" vm-pgg-ask-hook t]
 282    "----"
 283    ["Attach Public Key" vm-pgg-attach-public-key t]
 284    ["Insert Public Key" pgg-insert-key t]))
 285
 286 (defvar vm-pgg-compose-mode nil
 287   "None-nil means PGP/MIME composition mode key bindings and menu are available.")
 288
 289 (make-variable-buffer-local 'vm-pgg-compose-mode)
 290
 291 (defun vm-pgg-compose-mode (&optional arg)
 292   "\nMinor mode for interfacing with cryptographic functions.
 293
 294 Switch mode on/off according to ARG.
 295
 296 \\<vm-pgg-compose-mode-map>"
 297   (interactive)
 298   (setq vm-pgg-compose-mode
 299         (if (null arg) (not vm-pgg-compose-mode)
 300           (> (prefix-numeric-value arg) 0)))
 301   (if vm-pgg-compose-mode
 302       (easy-menu-add vm-pgg-compose-mode-menu)
 303     (easy-menu-remove vm-pgg-compose-mode-menu)))
 304
 305 (defvar vm-pgg-compose-mode-string " vm-pgg"
 306   "*String to put in mode line when function `vm-pgg-compose-mode' is active.")
 307
 308 (defcustom vm-pgg-ask-function 'vm-pgg-prompt-for-action
 309   "*The function to use in `vm-pgg-ask-hook'."
 310   :group 'vm-pgg
 311   :type '(choice
 312           (const
 313            :tag "do nothing"
 314            :doc "Disable `vm-pgg-ask-hook'"
 315            nil)
 316           (const
 317            :tag "sign"
 318            :doc "Ask whether to sign the message before sending"
 319            sign)
 320           (const
 321            :tag "encrypt"
 322            :doc "Ask whether to encryt the message before sending"
 323            encrypt)
 324           (const
 325            :tag "encrypt and sign"
 326            :doc "Ask whether to encrypt and sign the message before sending"
 327            encrypt-and-sign)
 328           (function
 329            :tag "ask for the action"
 330            :doc "Will prompt for an action by calling `vm-pgg-prompt-for-action'"
 331            vm-pgg-prompt-for-action)
 332           (function
 333            :tag "your own function"
 334            :doc "It should returning one of the other const values.")))
 335
 336
 337 (if (not (assq 'vm-pgg-compose-mode minor-mode-map-alist))
 338     (setq minor-mode-map-alist
 339           (cons (cons 'vm-pgg-compose-mode vm-pgg-compose-mode-map)
 340                 minor-mode-map-alist)))
 341
 342 (if (not (assq 'vm-pgg-compose-mode minor-mode-alist))
 343     (setq minor-mode-alist
 344           (cons '(vm-pgg-compose-mode vm-pgg-compose-mode-string) minor-mode-alist)))
 345
 346 (defun vm-pgg-compose-mode-activate ()
 347   "Activate function `vm-pgg-compose-mode'."
 348   (vm-pgg-compose-mode 1))
 349
 350 (add-hook 'vm-mail-mode-hook 'vm-pgg-compose-mode-activate t)
 351
 352 (defun vm-pgg-get-emails (headers)
 353   "Return email addresses found in the given HEADERS."
 354   (let (content recipients)
 355     (while headers
 356       (setq content (vm-mail-mode-get-header-contents (car headers)))
 357       (when content
 358         (setq recipients (append (rfc822-addresses content) recipients)))
 359       (setq headers (cdr headers)))
 360     recipients))
 361
 362 (defvar vm-pgg-get-recipients-headers '("To:" "CC:" "BCC:")
 363   "The list of headers to get recipients from.")
 364
 365 (defun vm-pgg-get-recipients ()
 366   "Return a list of recipients."
 367   (vm-pgg-get-emails vm-pgg-get-recipients-headers))
 368
 369 (defun vm-pgg-get-author ()
 370   "Return the author of the message."
 371   (car (vm-pgg-get-emails vm-pgg-get-author-headers)))
 372
 373 (defun vm-pgp-goto-body-start ()
 374   "Goto the start of the body and return point."
 375   (goto-char (point-min))
 376   (search-forward (concat "\n" mail-header-separator "\n"))
 377   (goto-char (match-end 0))
 378   (point))
 379
 380 (defun vm-pgp-prepare-composition ()
 381   "Prepare the composition for encrypting or signing."
 382   ;; encode message
 383   (unless (vm-mail-mode-get-header-contents "MIME-Version:")
 384     (vm-mime-encode-composition))
 385   ;; ensure newline at the end
 386   (goto-char (point-max))
 387   (skip-chars-backward " \t\r\n\f")
 388   (delete-region (point) (point-max))
 389   (insert "\n")
 390   ;; skip headers
 391   (vm-pgp-goto-body-start)
 392   ;; guess the author
 393   (make-local-variable 'pgg-default-user-id)
 394   (setq pgg-default-user-id
 395         (or
 396          (and vm-pgg-get-author-headers (vm-pgg-get-author))
 397          pgg-default-user-id)))
 398
 399 ;;; ###autoload
 400 (defun vm-pgg-cleartext-encrypt (sign)
 401   "*Encrypt the composition as cleartext and with a prefix also SIGN it."
 402   (interactive "P")
 403   (save-excursion
 404     (vm-pgp-prepare-composition)
 405     (let ((start (point)) (end   (point-max)))
 406       (unless (pgg-encrypt-region start end (vm-pgg-get-recipients) sign)
 407         (pop-to-buffer pgg-errors-buffer)
 408         (error "Encrypt error"))
 409       (delete-region start end)
 410       (insert-buffer-substring pgg-output-buffer))))
 411
 412 (defun vm-pgg-make-presentation-copy ()
 413   "Make a presentation copy also for cleartext PGP messages."
 414   (let* ((m (car vm-message-pointer))
 415          (layout (vm-mm-layout m)))
 416     ;; make a presentation copy
 417     (vm-make-presentation-copy m)
 418     (vm-save-buffer-excursion
 419      (vm-replace-buffer-in-windows (current-buffer)
 420                                    vm-presentation-buffer))
 421     (set-buffer vm-presentation-buffer)
 422
 423     ;; remove From line
 424     (goto-char (point-min))
 425     (forward-line 1)
 426     (let ((buffer-read-only nil))
 427       (delete-region (point-min) (point))
 428       (vm-reorder-message-headers nil vm-visible-headers
 429                                   vm-invisible-header-regexp)
 430       (vm-decode-mime-message-headers m)
 431       (when (vectorp layout)
 432         ;; skip headers otherwise they get removed
 433         (goto-char (point-min))
 434         (search-forward "\n\n")
 435         (vm-decode-mime-layout layout)
 436         (delete-region (point) (point-max)))
 437       (vm-energize-urls-in-message-region)
 438       (vm-highlight-headers-maybe)
 439       (vm-energize-headers-and-xfaces))))
 440
 441 (defvar vm-pgg-state nil
 442   "State of the currently viewed message.")
 443
 444 (make-variable-buffer-local 'vm-pgg-state)
 445
 446 (defvar vm-pgg-state-message nil
 447   "The message for `vm-pgg-state'.")
 448
 449 (make-variable-buffer-local 'vm-pgg-state-message)
 450
 451 (defvar vm-pgg-mode-line-items
 452   (let ((items '((error " ERROR" vm-pgg-error-modeline)
 453                  (unknown " unknown" vm-pgg-unknown-signature-type-modeline)
 454                  (verified " verified" vm-pgg-good-signature-modeline)))
 455         mode-line-items
 456         x i s f)
 457     (while (and (featurep 'xemacs) items)
 458       (setq x (car items)
 459             i (car x)
 460             s (cadr x)
 461             f (caddr x)
 462             x (vm-make-extent 0 (length s) s))
 463       (vm-set-extent-property x 'face f)
 464       (setq items (cdr items))
 465       (setq mode-line-items (append mode-line-items (list (list i x s)))))
 466     mode-line-items)
 467   "An alist mapping states to modeline strings.")
 468
 469 (if (not (member 'vm-pgg-state vm-mode-line-format))
 470     (setq vm-mode-line-format (append '("" vm-pgg-state) vm-mode-line-format)))
 471
 472 (defun vm-pgg-state-set (&rest states)
 473   "Set the message state  displayed in the modeline acording to STATES.
 474 If STATES is nil, clear it."
 475   ;; clear state for a new message
 476   (save-excursion
 477     (vm-select-folder-buffer-if-possible)
 478     (when (not (equal (car vm-message-pointer) vm-pgg-state-message))
 479       (setq vm-pgg-state-message (car vm-message-pointer))
 480       (setq vm-pgg-state nil)
 481       (when vm-presentation-buffer
 482         (save-excursion
 483           (set-buffer vm-presentation-buffer)
 484           (setq vm-pgg-state nil)))
 485       (when vm-summary-buffer
 486         (save-excursion
 487           (set-buffer vm-summary-buffer)
 488           (setq vm-pgg-state nil))))
 489     ;; add prefix
 490     (if (and states (not vm-pgg-state))
 491         (setq vm-pgg-state '("PGP:")))
 492     ;; add new states
 493     (let (s)
 494       (while states
 495         (setq s (car states)
 496               vm-pgg-state (append vm-pgg-state
 497                                    (list (or (cdr (assoc s vm-pgg-mode-line-items))
 498                                              (format " %s" s))))
 499               states (cdr states))))
 500     ;; propagate state
 501     (setq states vm-pgg-state)
 502     (when vm-presentation-buffer
 503       (save-excursion
 504         (set-buffer vm-presentation-buffer)
 505         (setq vm-pgg-state states)))
 506     (when vm-summary-buffer
 507       (save-excursion
 508         (set-buffer vm-summary-buffer)
 509         (setq vm-pgg-state states)))))
 510
 511 (defvar vm-pgg-cleartext-begin-regexp
 512   "^-----BEGIN PGP \\(\\(SIGNED \\)?MESSAGE\\|PUBLIC KEY BLOCK\\)-----$"
 513     "Regexp used to match PGP armor.")
 514
 515 (defvar vm-pgg-cleartext-end-regexp
 516   "^-----END PGP %s-----$"
 517     "Regexp used to match PGP armor.")
 518
 519 (defcustom vm-pgg-cleartext-search-limit 4096
 520   "Number of bytes to peek into the message for a PGP clear text armor."
 521    :group 'vm-pgg
 522    :group 'faces)
 523
 524 (defun vm-pgg-cleartext-automode-button (label action)
 525   "Cleartext thing by a button with text LABEL and associate ACTION with it.
 526 When the button is pressed ACTION is called."
 527   (save-excursion
 528     (unless (eq major-mode 'vm-presentation-mode)
 529       (vm-pgg-make-presentation-copy))
 530     (goto-char (match-beginning 0))
 531     (let ((buffer-read-only nil)
 532           (start (point))
 533           o)
 534       (if (re-search-forward (format vm-pgg-cleartext-end-regexp
 535                                      (match-string 0))
 536                              (point-max) t)
 537           (delete-region start (match-end 0)))
 538       (insert label)
 539       (setq o (make-overlay start (point)))
 540       (overlay-put o 'vm-pgg t)
 541       (overlay-put o 'face vm-mime-button-face)
 542       (overlay-put o 'vm-button t)
 543       (overlay-put o 'mouse-face 'highlight)
 544       (let ((keymap (make-sparse-keymap)))
 545         (define-key keymap [mouse-2] action)
 546         (define-key keymap "\r"  action)
 547         (overlay-put o 'local-map keymap)))))
 548
 549 (defvar vm-pgg-cleartext-decoded nil
 550   "State of the cleartext message.")
 551 (make-variable-buffer-local 'vm-pgg-cleartext-decoded)
 552
 553 (defun vm-pgg-set-cleartext-decoded ()
 554    (save-excursion
 555     (vm-select-folder-buffer)
 556     (setq vm-pgg-cleartext-decoded (car vm-message-pointer))))
 557
 558 (defun vm-pgg-cleartext-automode ()
 559   "Check for PGP ASCII armor and triggers automatic verification/decryption."
 560   (save-excursion
 561     (vm-select-folder-buffer-if-possible)
 562     (if (equal vm-pgg-cleartext-decoded (car vm-message-pointer))
 563         (setq vm-pgg-cleartext-decoded nil)
 564       (setq vm-pgg-cleartext-decoded nil)
 565       (if vm-presentation-buffer
 566           (set-buffer vm-presentation-buffer))
 567       (goto-char (point-min))
 568       (when (and (vm-mime-plain-message-p (car vm-message-pointer))
 569                  (re-search-forward vm-pgg-cleartext-begin-regexp
 570                                     (+ (point) vm-pgg-cleartext-search-limit)
 571                                     t))
 572         (cond ((string= (match-string 1) "SIGNED MESSAGE")
 573                (vm-pgg-set-cleartext-decoded)
 574                (vm-pgg-cleartext-verify))
 575               ((string= (match-string 1) "MESSAGE")
 576                (vm-pgg-set-cleartext-decoded)
 577                (if vm-pgg-auto-decrypt
 578                    (vm-pgg-cleartext-decrypt)
 579                  (vm-pgg-cleartext-automode-button
 580                   "Decrypt PGP message\n"
 581                   (lambda ()
 582                     (interactive)
 583                     (let ((vm-pgg-auto-decrypt t))
 584                       (vm-pgg-cleartext-decrypt))))))
 585               ((string= (match-string 1) "PUBLIC KEY BLOCK")
 586                (vm-pgg-set-cleartext-decoded)
 587                (if vm-pgg-auto-snarf
 588                    (vm-pgg-snarf-keys)
 589                  (vm-pgg-cleartext-automode-button
 590                   "Snarf PGP key\n"
 591                   (lambda ()
 592                     (interactive)
 593                     (let ((vm-pgg-auto-snarf t))
 594                       (vm-pgg-snarf-keys))))))
 595               (t
 596                (error "This should never happen!")))))))
 597
 598 (defadvice vm-preview-current-message (after vm-pgg-cleartext-automode activate)
 599   "Decode or check signature on clear text messages."
 600   (vm-pgg-state-set)
 601   (when (and vm-pgg-cleartext-decoded
 602              (not (equal vm-pgg-cleartext-decoded (car vm-message-pointer))))
 603     (setq vm-pgg-cleartext-decoded nil))
 604   (when (and (not (eq vm-system-state 'previewing))
 605              (not vm-mime-decoded))
 606     (vm-pgg-cleartext-automode)))
 607
 608 (defadvice vm-scroll-forward (around vm-pgg-cleartext-automode activate)
 609   "Decode or check signature on clear text messages."
 610   (let ((vm-system-state-was
 611          (save-excursion
 612            (vm-select-folder-buffer-if-possible)
 613            vm-system-state)))
 614     ad-do-it
 615     (vm-pgg-state-set)
 616     (when (and (eq vm-system-state-was 'previewing)
 617                (not vm-mime-decoded))
 618       (vm-pgg-cleartext-automode))))
 619
 620 ;;; ###autoload
 621 (defun vm-pgg-cleartext-sign ()
 622   "*Sign the message."
 623   (interactive)
 624   (save-excursion
 625     (vm-pgp-prepare-composition)
 626     (let ((start (point)) (end (point-max)))
 627       (unless (pgg-sign-region start end t)
 628         (pop-to-buffer pgg-errors-buffer)
 629         (error "Signing error"))
 630       (delete-region start end)
 631       (insert-buffer-substring pgg-output-buffer))))
 632
 633 (defun vm-pgg-cleartext-cleanup (status)
 634   "Removed ASCII armor and insert PGG output depending on STATUS."
 635   (let (start end)
 636     (setq start (and (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----$")
 637                      (match-beginning 0))
 638           end   (and (search-forward "\n\n")
 639                      (match-end 0)))
 640     (delete-region start end)
 641     (setq start (and (re-search-forward "^-----BEGIN PGP SIGNATURE-----$")
 642                      (match-beginning 0))
 643           end (and (re-search-forward "^-----END PGP SIGNATURE-----$")
 644                    (match-end 0)))
 645     (delete-region start end)
 646     ;; add output from PGP
 647     (insert "\n")
 648     (let ((start (point)) end)
 649       (if (eq status 'error)
 650           (insert-buffer-substring pgg-errors-buffer)
 651         (insert-buffer-substring pgg-output-buffer)
 652         (vm-pgg-crlf-cleanup start (point)))
 653       (setq end (point))
 654       (put-text-property start end 'face
 655                          (if (eq status 'error)
 656                              'vm-pgg-bad-signature
 657                            'vm-pgg-good-signature)))))
 658
 659 (defadvice vm-mime-transfer-decode-region (around vm-pgg-cleartext-automode activate)
 660   "Decode or check signature on clear text messages parts."
 661   (let ((vm-pgg-part-start (point)))
 662     ad-do-it
 663     ;; BUGME should we use marks here?
 664     (when (and (vm-mime-text-type-layout-p (ad-get-arg 0))
 665                (< vm-pgg-part-start (point)))
 666       (save-excursion
 667         (save-restriction
 668           (narrow-to-region vm-pgg-part-start (point))
 669           (vm-pgg-cleartext-automode)
 670           (widen)
 671 ;          (set-window-start (selected-window) 0)
 672           ;(scroll-down 1000)
 673           )))))
 674
 675 (defadvice vm-mime-display-internal-text/plain (around vm-pgg-cleartext-automode activate)
 676   "Decode or check signature on clear text messages parts.
 677 We use the advice here in order to avoid overwriting VMs internal text display
 678 function.  Faces will get lost if a charset conversion happens thus we do the
 679 cleanup here after verification and decoding took place."
 680   (let ((vm-pgg-cleartext-state nil)
 681         (start (point))
 682         end)
 683     ad-do-it
 684     (when vm-pgg-cleartext-state
 685       (setq end (point))
 686       (save-restriction
 687         (narrow-to-region start end)
 688         (goto-char (point-min))
 689         (vm-pgg-cleartext-cleanup vm-pgg-cleartext-state)
 690         (widen)))))
 691
 692 ;;; ###autoload
 693 (defun vm-pgg-cleartext-verify ()
 694   "*Verify the signature in the current message."
 695   (interactive)
 696   (message "Verifying PGP cleartext message...")
 697   (when (interactive-p)
 698     (vm-follow-summary-cursor)
 699     (vm-select-folder-buffer-if-possible)
 700     (vm-check-for-killed-summary)
 701     (vm-error-if-folder-empty))
 702
 703   ;; make a presentation copy
 704   (unless (eq major-mode 'vm-presentation-mode)
 705     (vm-pgg-make-presentation-copy))
 706
 707   ;; verify
 708   (save-excursion
 709     (goto-char (point-min))
 710     (let ((buffer-read-only nil)
 711           (status (pgg-verify-region (point) (point-max) nil
 712                                      vm-pgg-fetch-missing-keys)))
 713
 714       (vm-pgg-state-set 'signed)
 715       (setq status (if (not status) 'error 'verified))
 716       (vm-pgg-state-set status)
 717       (if (boundp 'vm-pgg-cleartext-state)
 718           (setq vm-pgg-cleartext-state status)
 719         (vm-pgg-cleartext-cleanup status)))))
 720
 721 ;;; ###autoload
 722 (defun vm-pgg-cleartext-decrypt ()
 723   "*Decrypt the contents of the current message."
 724   (interactive)
 725   (if (interactive-p)
 726       (vm-follow-summary-cursor))
 727   (vm-select-folder-buffer-if-possible)
 728   (vm-check-for-killed-summary)
 729   (vm-error-if-folder-read-only)
 730   (vm-error-if-folder-empty)
 731
 732   ;; make a presentation copy
 733   (unless (eq major-mode 'vm-presentation-mode)
 734     (vm-pgg-make-presentation-copy))
 735   (goto-char (point-min))
 736
 737   ;; decrypt
 738   (let (state start end)
 739     (setq start (and (re-search-forward "^-----BEGIN PGP MESSAGE-----$")
 740                      (match-beginning 0))
 741           end   (and (re-search-forward "^-----END PGP MESSAGE-----$")
 742                      (match-end 0))
 743           state (condition-case nil
 744                     (pgg-decrypt-region start end)
 745                   (error nil)))
 746
 747     (vm-pgg-state-set 'encrypted)
 748
 749     (if (not state)
 750         ;; insert the error message
 751         (let ((buffer-read-only nil))
 752           (vm-pgg-state-set 'error)
 753           (goto-char start)
 754           (insert-buffer-substring pgg-errors-buffer)
 755           (put-text-property start (point) 'face 'vm-pgg-error))
 756       ;; replace it with decrypted message
 757       (let ((buffer-read-only nil))
 758         (delete-region start end)
 759         (insert-buffer-substring pgg-output-buffer))
 760       ;; if it signed then also verify it
 761       (goto-char start)
 762       (if (looking-at "^-----BEGIN PGP \\(SIGNED \\)?MESSAGE-----$")
 763           (vm-pgg-cleartext-verify)))))
 764
 765 (defun vm-pgg-crlf-cleanup (start end)
 766   "Convert CRLF to LF in region from START to END."
 767   (save-excursion
 768     (goto-char start)
 769     (while (search-forward "\r\n" end t)
 770       (replace-match "\n" t t))))
 771
 772 (defun vm-pgg-make-crlf (start end)
 773   "Convert CRLF to LF in region from START to END."
 774   (save-excursion
 775     (goto-char end)
 776     (while (search-backward "\n" start t)
 777       (replace-match "\r\n" t t)
 778       (backward-char))))
 779
 780 (defvar vm-pgg-mime-decoded nil
 781   "Saves decoded state for later use, i.e. decoding to buttons.")
 782 (make-variable-buffer-local 'vm-pgg-mime-decoded)
 783
 784 (defun vm-pgg-get-mime-decoded ()
 785   "Return `vm-pgg-mime-decoded'."
 786   (save-excursion
 787     (vm-select-folder-buffer)
 788     vm-pgg-mime-decoded))
 789
 790 (defvar vm-pgg-recursion nil
 791   "Detect recursive calles.")
 792
 793 (defadvice vm-decode-mime-message (around vm-pgg-clear-state activate)
 794   "Clear the modeline state before decoding."
 795   (vm-select-folder-buffer)
 796   (when (not vm-pgg-recursion)
 797     (setq vm-pgg-mime-decoded vm-mime-decoded))
 798   (setq vm-pgg-state-message nil)
 799   (setq vm-pgg-state nil)
 800   (if (vm-mime-plain-message-p (car vm-message-pointer))
 801       (if vm-pgg-cleartext-decoded
 802           (vm-preview-current-message))
 803     (let ((vm-pgg-recursion t))
 804       ad-do-it)))
 805
 806 (defun vm-pgg-mime-decrypt (button)
 807   "Replace the BUTTON with the output from `pgg-snarf-keys'."
 808   (let ((vm-pgg-auto-decrypt t)
 809         (layout (copy-sequence (vm-extent-property button 'vm-mime-layout))))
 810     (vm-set-extent-property button 'vm-mime-disposable t)
 811     (vm-set-extent-property button 'vm-mime-layout layout)
 812     (goto-char (vm-extent-start-position button))
 813     (let ((buffer-read-only nil))
 814       (vm-decode-mime-layout button t))))
 815
 816 ;;; ###autoload
 817 (defun vm-mime-display-internal-multipart/encrypted (layout)
 818   "Display multipart/encrypted LAYOUT."
 819   (vm-pgg-state-set 'encrypted)
 820   (let* ((part-list (vm-mm-layout-parts layout))
 821          (header (car part-list))
 822          (message (car (cdr part-list)))
 823          status)
 824     (cond ((eq (vm-pgg-get-mime-decoded) 'decoded)
 825            ;; after decode the state of vm-mime-decoded is 'buttons
 826            nil)
 827           ((not (and (= (length part-list) 2)
 828                      (vm-mime-types-match (car (vm-mm-layout-type header))
 829                                           "application/pgp-encrypted")
 830                      ;; TODO: check version and protocol here?
 831                      (vm-mime-types-match (car (vm-mm-layout-type message))
 832                                           "application/octet-stream")))
 833            (insert "Unknown multipart/encrypted format."))
 834           ((not vm-pgg-auto-decrypt)
 835            ;; add a button
 836            (let ((buffer-read-only nil))
 837              (vm-mime-insert-button
 838               (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout)
 839               'vm-pgg-mime-decrypt
 840               layout nil)))
 841           (t
 842            ;; decode the message now
 843            (save-excursion
 844              (set-buffer (vm-buffer-of (vm-mm-layout-message message)))
 845              (save-restriction
 846                (widen)
 847                (setq status (pgg-decrypt-region (vm-mm-layout-body-start message)
 848                                                 (vm-mm-layout-body-end message)))))
 849            (if (not status)
 850                (let ((start (point)))
 851                  (vm-pgg-state-set 'error)
 852                  (insert-buffer-substring pgg-errors-buffer)
 853                  (put-text-property start (point) 'face 'vm-pgg-error))
 854              (save-excursion
 855                (set-buffer pgg-output-buffer)
 856                (vm-pgg-crlf-cleanup (point-min) (point-max))
 857                (setq message (vm-mime-parse-entity-safe nil nil nil t)))
 858              (if message
 859                  (vm-decode-mime-layout message)
 860                (insert-buffer-substring pgg-output-buffer))
 861              (setq status (save-excursion
 862                             (set-buffer pgg-errors-buffer)
 863                             (goto-char (point-min))
 864                             ;; TODO: care for BADSIG
 865                             (when (re-search-forward "GOODSIG [^\n\r]+" (point-max) t)
 866                               (vm-pgg-state-set 'signed 'verified)
 867                               (buffer-substring (match-beginning 0) (match-end 0)))))
 868              (if status
 869                  (let ((start (point)))
 870                    (insert "\n" status "\n")
 871                    (put-text-property start (point) 'face 'vm-pgg-good-signature))))
 872            t))))
 873
 874 ;;; ###autoload
 875 (defun vm-mime-display-internal-multipart/signed (layout)
 876   "Display multipart/signed LAYOUT."
 877   (vm-pgg-state-set 'signed)
 878   (let* ((part-list (vm-mm-layout-parts layout))
 879          (message (car part-list))
 880          (signature (car (cdr part-list)))
 881          status signature-file start end)
 882     (cond ((eq (vm-pgg-get-mime-decoded) 'decoded)
 883            ;; after decode the state of vm-mime-decoded is 'buttons
 884            nil)
 885           ((not (and (= (length part-list) 2)
 886                      signature
 887                      ;; TODO: check version and protocol here?
 888                      (vm-mime-types-match (car (vm-mm-layout-type signature))
 889                                           "application/pgp-signature")))
 890            ;; insert the message
 891            (vm-decode-mime-layout message)
 892            (let (start end)
 893              (vm-pgg-state-set 'unknown)
 894              (setq start (point))
 895              (insert
 896               (format
 897                "******* unknown signature type %s *******\n"
 898                (car (and signature (vm-mm-layout-type signature)))))
 899              (setq end (point))
 900              (when signature
 901                (vm-decode-mime-layout signature))
 902              (put-text-property start end 'face 'vm-pgg-unknown-signature-type))
 903            t)
 904           (t
 905            ;; insert the message
 906            (vm-decode-mime-layout message)
 907            ;; write signature to a temp file
 908            (setq start (point))
 909            (vm-mime-insert-mime-body signature)
 910            (setq end (point))
 911            (write-region start end
 912                          (setq signature-file (pgg-make-temp-file "vm-pgg-signature")))
 913            (delete-region start end)
 914            (setq start (point))
 915            (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-header-start
 916                                                          message))
 917                                          (vm-mm-layout-header-start message)
 918                                          (vm-mm-layout-body-end message))
 919            (setq end (point-marker))
 920            (vm-pgg-make-crlf start end)
 921            (setq status (pgg-verify-region start end signature-file
 922                                            vm-pgg-fetch-missing-keys))
 923            (delete-file signature-file)
 924            (delete-region start end)
 925            ;; now insert the content
 926            (insert "\n")
 927            (let ((start (point)) end)
 928              (if (not status)
 929                  (progn
 930                    (vm-pgg-state-set 'error)
 931                    (insert-buffer-substring pgg-errors-buffer))
 932                (vm-pgg-state-set 'verified)
 933                (insert-buffer-substring
 934                 (if vm-fsfemacs-p pgg-errors-buffer pgg-output-buffer))
 935                (vm-pgg-crlf-cleanup start (point)))
 936              (setq end (point))
 937              (put-text-property start end 'face
 938                                 (if status 'vm-pgg-good-signature
 939                                   'vm-pgg-bad-signature)))
 940            t))))
 941
 942 ;; we must add these in order to force VM to call our handler
 943 (eval-and-compile
 944 ;; (if (listp vm-auto-displayed-mime-content-types)
 945 ;;       (add-to-list 'vm-auto-displayed-mime-content-types "application/pgp-keys"))
 946   (if (listp vm-mime-internal-content-types)
 947       (add-to-list 'vm-mime-internal-content-types "application/pgp-keys"))
 948   (add-to-list 'vm-mime-button-format-alist
 949                '("application/pgp-keys" . "Snarf %d"))
 950   (add-to-list 'vm-mime-button-format-alist
 951                '("multipart/encrypted" . "Decrypt PGP/MIME message")))
 952
 953 (defun vm-pgg-mime-snarf-keys (button)
 954   "Replace the BUTTON with the output from `pgg-snarf-keys'."
 955   (let ((vm-pgg-auto-snarf t)
 956         (layout (copy-sequence (vm-extent-property button 'vm-mime-layout))))
 957     (vm-set-extent-property button 'vm-mime-disposable t)
 958     (vm-set-extent-property button 'vm-mime-layout layout)
 959     (goto-char (vm-extent-start-position button))
 960     (let ((buffer-read-only nil))
 961       (vm-decode-mime-layout button t))))
 962
 963 ;;; ###autoload
 964 (defun vm-mime-display-internal-application/pgp-keys (layout)
 965   "Snarf keys in LAYOUT and display result of snarfing."
 966   (vm-pgg-state-set 'public-key)
 967   ;; insert the keys
 968   (if vm-pgg-auto-snarf
 969       (let ((start (point)) end status)
 970         (vm-mime-insert-mime-body layout)
 971         (setq end (point-marker))
 972         (vm-mime-transfer-decode-region layout start end)
 973         (save-excursion
 974           (setq status (pgg-snarf-keys-region start end)))
 975         (delete-region start end)
 976         ;; now insert the result of snafing
 977         (if status
 978             (insert-buffer-substring pgg-output-buffer)
 979           (insert-buffer-substring pgg-errors-buffer)))
 980     (let ((buffer-read-only nil))
 981       (vm-mime-insert-button
 982        (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout)
 983        'vm-pgg-mime-snarf-keys
 984        layout nil)))
 985   t)
 986
 987 ;;; ###autoload
 988 (defun vm-pgg-snarf-keys ()
 989   "*Snarf keys from the current message."
 990   (interactive)
 991   (if (interactive-p)
 992       (vm-follow-summary-cursor))
 993   (vm-select-folder-buffer)
 994   (vm-check-for-killed-summary)
 995   (vm-error-if-folder-empty)
 996   (save-restriction
 997     ;; ensure we are in the right buffer
 998     (if vm-presentation-buffer
 999         (set-buffer vm-presentation-buffer))
1000     ;; skip headers
1001     (goto-char (point-min))
1002     (search-forward "\n\n")
1003     (goto-char (match-end 0))
1004     ;; verify
1005     (unless (pgg-snarf-keys)
1006       (error "Snarfing failed"))
1007     (save-excursion
1008       (set-buffer (if vm-fsfemacs-p pgg-errors-buffer pgg-output-buffer))
1009       (message (buffer-substring (point-min) (point-max))))))
1010
1011 ;;; ###autoload
1012 (defun vm-pgg-attach-public-key ()
1013   "Attach your public key to a composition."
1014   (interactive)
1015   (let* ((pgg-default-user-id
1016           (or
1017            (and vm-pgg-get-author-headers (vm-pgg-get-author))
1018            pgg-default-user-id))
1019          (description (concat "public key of " pgg-default-user-id))
1020          (buffer (get-buffer-create (concat " *" description "*")))
1021          start)
1022     (save-excursion
1023       (set-buffer buffer)
1024       (erase-buffer)
1025       (setq start (point))
1026       (pgg-insert-key)
1027       (if (= start (point))
1028           (error "%s has no public key!" pgg-default-user-id)))
1029     (save-excursion
1030       (goto-char (point-max))
1031       (insert "\n")
1032       (setq start (point))
1033       (vm-mime-attach-object buffer
1034                              "application/pgp-keys"
1035                              (list (concat "name=\"" pgg-default-user-id ".asc\""))
1036                              description
1037                              nil)
1038       ;; a crude hack to set the disposition
1039       (let ((disposition (list "attachment"
1040                                (concat "filename=\"" pgg-default-user-id ".asc\"")))
1041             (end (point)))
1042         (if (featurep 'xemacs)
1043             (set-extent-property (extent-at start nil 'vm-mime-disposition)
1044                                  'vm-mime-disposition disposition)
1045           (put-text-property start end 'vm-mime-disposition disposition))))))
1046
1047 (defun vm-pgg-make-multipart-boundary (word)
1048   "Create a mime part boundery starting with WORD and return it.
1049
1050 We cannot use `vm-mime-make-multipart-boundary' as it uses the current time as
1051 seed and thus creates the same boundery when called twice in a short period."
1052   (if word (setq word (concat word "+")))
1053   (let ((boundary (concat word (make-string 15 ?a)))
1054         (i (length word)))
1055     (random)
1056     (while (< i (length boundary))
1057       (aset boundary i (aref vm-mime-base64-alphabet
1058                              (% (vm-abs (lsh (random) -8))
1059                                 (length vm-mime-base64-alphabet))))
1060       (vm-increment i))
1061     boundary))
1062
1063 (defun vm-pgg-save-work (function &rest args)
1064   "Call FUNCTION with ARGS without messing up the composition in case of an error."
1065   (let ((composition-buffer (current-buffer))
1066         (undo-list-backup buffer-undo-list)
1067         (work-buffer (get-buffer-create " *VM-PGG-WORK*")))
1068     (save-excursion
1069       (set-buffer work-buffer)
1070       (buffer-disable-undo)
1071       (erase-buffer)
1072       (insert-buffer-substring composition-buffer)
1073       (setq major-mode 'mail-mode)
1074       (apply function args))
1075     (erase-buffer)
1076     (insert-buffer-substring work-buffer)
1077     (kill-buffer work-buffer)))
1078
1079 ;;; ###autoload
1080 (defun vm-pgg-sign ()
1081   "Sign the composition with PGP/MIME.
1082
1083 If the composition is not encoded so far, it is encoded before signing.
1084 Signing of already encoded messages is discouraged.
1085
1086 RFC 2015 and its successor 3156 forbid the use of 8bit encoding for signed
1087 messages, but require to use quoted-printable or base64 instead.  Also lines
1088 starting with \"From \" cause trouble and should be quoted.
1089
1090 Thus signing of encoded messages may cause an error.  To avoid this you must
1091 set `vm-mime-8bit-text-transfer-encoding' to something different than 8bit and
1092 `vm-mime-composition-armor-from-lines' to t.
1093
1094 The transfer encoding done by `vm-pgg-sign' can be controlled by the variable
1095 `vm-pgg-sign-text-transfer-encoding'."
1096   (interactive)
1097
1098   (when (vm-mail-mode-get-header-contents "MIME-Version:")
1099     ;; do a simple sanity check ... too simple as we should walk the MIME part
1100     ;; hierarchy and only check the MIME headers ...
1101     (goto-char (point-min))
1102     (when (re-search-forward "Content-Transfer-Encoding:\\s-*8bit" nil t)
1103       (describe-function 'vm-pgg-sign)
1104       (error "Signing is broken for 8bit encoding!"))
1105     (goto-char (point-min))
1106     (when (re-search-forward "^From\\s-+" nil t)
1107       (describe-function 'vm-pgg-sign)
1108       (error "Signing is broken for lines starting with \"From \"!")))
1109
1110   (vm-pgg-save-work 'vm-pgg-sign-internal))
1111
1112 (defun vm-pgg-sign-internal ()
1113   "Do the signing."
1114   ;; prepare composition
1115   (let ((vm-mime-8bit-text-transfer-encoding
1116          vm-pgg-sign-text-transfer-encoding)
1117         (vm-mime-composition-armor-from-lines t))
1118     (vm-pgp-prepare-composition))
1119
1120   (let ((content-type (vm-mail-mode-get-header-contents "Content-Type:"))
1121         (encoding (vm-mail-mode-get-header-contents "Content-Transfer-Encoding:"))
1122         (boundary (vm-pgg-make-multipart-boundary "pgp+signed"))
1123         (pgg-text-mode t) ;; For GNU Emacs PGG
1124         (micalg "sha1")
1125         entry
1126         body-start)
1127     ;; fix the body
1128     (setq body-start (vm-marker (vm-pgp-goto-body-start)))
1129     (insert "Content-Type: " (or content-type "text/plain") "\n")
1130     (insert "Content-Transfer-Encoding: " (or encoding "7bit") "\n")
1131     (if (not (looking-at "\n"))
1132         (insert "\n"))
1133     ;; now create the signature
1134     (save-excursion
1135       ;; BUGME do we need the CRLF conversion?
1136 ;      (vm-pgg-make-crlf (point) (point-max))
1137       (unless (pgg-sign-region body-start (point-max) nil)
1138         (pop-to-buffer pgg-errors-buffer)
1139         (error "Signing error"))
1140       (and (setq entry (assq 2 (pgg-parse-armor
1141                                 (with-current-buffer pgg-output-buffer
1142                                   (buffer-string)))))
1143            (setq entry (assq 'hash-algorithm (cdr entry)))
1144            (if (cdr entry)
1145                (setq micalg (downcase (format "%s" (cdr entry)))))))
1146     ;; insert mime part bounderies
1147     (goto-char body-start)
1148     (insert "This is an OpenPGP/MIME signed message (RFC 2440 and 3156)\n")
1149     (insert "--" boundary "\n")
1150     (goto-char (point-max))
1151     (insert "\n--" boundary "\n")
1152     ;; insert the signature
1153     (insert "Content-Type: application/pgp-signature\n\n")
1154     (goto-char (point-max))
1155     (insert-buffer-substring pgg-output-buffer)
1156     (insert "\n--" boundary "--\n")
1157     ;; fix the headers
1158     (vm-mail-mode-remove-header "MIME-Version:")
1159     (vm-mail-mode-remove-header "Content-Type:")
1160     (vm-mail-mode-remove-header "Content-Transfer-Encoding:")
1161     (mail-position-on-field "MIME-Version")
1162     (insert "1.0")
1163     (mail-position-on-field "Content-Type")
1164     (insert "multipart/signed; boundary=\"" boundary "\";\n"
1165             "\tmicalg=pgg-" micalg "; protocol=\"application/pgp-signature\"")))
1166
1167 ;;; ###autoload
1168 (defun vm-pgg-encrypt (&optional sign)
1169   "Encrypt the composition as PGP/MIME.  With a prefix arg SIGN also sign it."
1170   (interactive "P")
1171   (vm-pgg-save-work 'vm-pgg-encrypt-internal sign))
1172
1173 (defun vm-pgg-encrypt-internal (sign)
1174   "Do the encrypting, if SIGN is t also sign it."
1175   (unless (vm-mail-mode-get-header-contents "MIME-Version:")
1176     (vm-mime-encode-composition))
1177   (let ((content-type (vm-mail-mode-get-header-contents "Content-Type:"))
1178         (encoding (vm-mail-mode-get-header-contents "Content-Transfer-Encoding:"))
1179         (boundary (vm-pgg-make-multipart-boundary "pgp+encrypted"))
1180         (pgg-text-mode t) ;; For GNU Emacs PGG
1181         body-start)
1182     ;; fix the body
1183     (setq body-start (vm-marker (vm-pgp-goto-body-start)))
1184     (insert "Content-Type: " (or content-type "text/plain") "\n")
1185     (insert "Content-Transfer-Encoding: " (or encoding "7bit") "\n")
1186     (insert "\n")
1187     (goto-char (point-max))
1188     (insert "\n")
1189     (vm-pgg-cleartext-encrypt sign)
1190     (goto-char body-start)
1191     (insert "This is an OpenPGP/MIME encrypted message (RFC 2440 and 3156)\n")
1192     (insert "--" boundary "\n")
1193     (insert "Content-Type: application/pgp-encrypted\n\n")
1194     (insert "Version: 1\n\n")
1195     (insert "--" boundary "\n")
1196     (insert "Content-Type: application/octet-stream\n\n")
1197     (goto-char (point-max))
1198     (insert "\n--" boundary "--\n")
1199     ;; fix the headers
1200     (vm-mail-mode-remove-header "MIME-Version:")
1201     (vm-mail-mode-remove-header "Content-Type:")
1202     (vm-mail-mode-remove-header "Content-Transfer-Encoding:")
1203     (mail-position-on-field "MIME-Version")
1204     (insert "1.0")
1205     (mail-position-on-field "Content-Type")
1206     (insert "multipart/encrypted; boundary=\"" boundary "\";\n"
1207             "\tprotocol=\"application/pgp-encrypted\"")))
1208
1209 (defun vm-pgg-sign-and-encrypt ()
1210   "*Sign and encrypt the composition as PGP/MIME."
1211   (interactive)
1212   (vm-pgg-encrypt t))
1213
1214 (defvar vm-pgg-prompt-last-action nil
1215   "The action last taken in `vm-pgg-prompt-for-action'.")
1216
1217 (defvar vm-pgg-prompt-action-alist
1218   '((?s sign "Sign")
1219     (?e encrypt "encrypt")
1220     (?E sign-and-encrypt "both")
1221     (?n nil "nothing")
1222     (?q quit "quit"))
1223   "Alist of (KEY ACTION LABEL) elements.")
1224
1225 (defun vm-pgg-prompt-for-action ()
1226   "Prompt for an action and return it. See also `vm-pgg-prompt-action-alist'."
1227   (interactive)
1228   (let (prompt event action)
1229     (setq prompt (mapconcat (lambda (a)
1230                               (format "%s (%c)" (nth 2 a) (car a)))
1231                             vm-pgg-prompt-action-alist ", ")
1232           action (mapcar (lambda (a)
1233                            (if (eq (nth 1 a)
1234                                    vm-pgg-prompt-last-action)
1235                                (downcase (nth 2 a))))
1236                          vm-pgg-prompt-action-alist)
1237           prompt (format "%s (default %s)?"
1238                          prompt
1239                          (car (delete nil action)))
1240           action nil)
1241     (while (not event)
1242       (setq event (read-key-sequence prompt))
1243       (if (featurep 'xemacs)
1244           (setq event (event-to-character (aref event 0)))
1245         (setq event (if (stringp event) (aref event 0))))
1246       (if (eq event ?\r)
1247           (setq action vm-pgg-prompt-last-action)
1248         (setq action (assoc event vm-pgg-prompt-action-alist))
1249         (if action
1250             (setq action (nth 1 action))
1251           (setq event nil))))
1252     (when (eq action 'quit)
1253       (error "Sending aborted!"))
1254     (if action
1255         (message "Action is %s." action)
1256       (message "No action selected."))
1257     (setq vm-pgg-prompt-last-action action)
1258     action))
1259
1260 ;;; ###autoload
1261 (defun vm-pgg-ask-hook ()
1262   "Hook to automatically ask for signing or encrypting outgoing messages with PGP/MIME.
1263
1264 Put this function into `vm-mail-send-hook' to be asked each time you
1265 send a message whether or not you want to sign or encrypt the
1266 message. See `vm-pgg-ask-function' to determine which function is
1267 proposed.
1268
1269 This hook should probably be the last of your hooks if you have several
1270 other functions there.  Signing crucially relies on the fact that the
1271 message is not altered afterwards. To put it into `vm-mail-send-hook'
1272 put something like
1273
1274        (add-hook 'vm-mail-send-hook 'vm-pgg-ask-hook t)
1275
1276 into your VM init file."
1277   (interactive)
1278
1279   ;; ensure we are the last hook
1280   (when (and (member 'vm-pgg-ask-hook vm-mail-send-hook)
1281              (cdr (member 'vm-pgg-ask-hook vm-mail-send-hook)))
1282     (describe-function 'vm-pgg-ask-hook)
1283     (error "`vm-pgg-ask-function' must be the last hook in `vm-mail-send-hook'!"))
1284
1285   (let ((handler vm-pgg-ask-function)
1286         action)
1287     (when handler
1288       (setq action (if (fboundp handler)
1289                        (funcall handler)
1290                      (if (y-or-n-p (format "%s the composition? " handler))
1291                          handler)))
1292       (when action
1293         (funcall (intern (format "vm-pgg-%s" action)))))))
1294
1295 (provide 'vm-pgg)
1296
1297 ;;; vm-pgg.el ends here