[Emacs-diffs] Changes to emacs/lisp/gnus/mml2015.el,v

[Miles Bader]

CVSROOT:        /cvsroot/emacs
Module name:    emacs
Changes by:     Miles Bader <miles>     07/10/28 09:18:40

Index: lisp/gnus/mml2015.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/mml2015.el,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -b -r1.16 -r1.17
--- lisp/gnus/mml2015.el        26 Jul 2007 05:27:02 -0000      1.16
+++ lisp/gnus/mml2015.el        28 Oct 2007 09:18:29 -0000      1.17
@@ -34,13 +34,23 @@
 (require 'mm-decode)
 (require 'mm-util)
 (require 'mml)
+(require 'mml-sec)
 
 (defvar mc-pgp-always-sign)
 
 (defvar mml2015-use (or
+                    (condition-case nil
+                        (progn
+                          (require 'epg-config)
+                          (epg-check-configuration (epg-configuration))
+                          'epg)
+                      (error))
                     (progn
                       (ignore-errors
-                        (require 'pgg))
+                       ;; Avoid the "Recursive load suspected" error
+                       ;; in Emacs 21.1.
+                       (let ((recursive-load-depth-limit 100))
+                         (require 'pgg)))
                       (and (fboundp 'pgg-sign-region)
                            'pgg))
                     (progn
@@ -54,7 +64,8 @@
                                 (fboundp 'mc-sign-generic)
                                 (fboundp 'mc-cleanup-recipient-headers)
                                 'mailcrypt)))
-  "The package used for PGP/MIME.")
+  "The package used for PGP/MIME.
+Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
 
 ;; Something is not RFC2015.
 (defvar mml2015-function-alist
@@ -75,7 +86,13 @@
        mml2015-pgg-verify
        mml2015-pgg-decrypt
        mml2015-pgg-clear-verify
-       mml2015-pgg-clear-decrypt))
+       mml2015-pgg-clear-decrypt)
+  (epg mml2015-epg-sign
+       mml2015-epg-encrypt
+       mml2015-epg-verify
+       mml2015-epg-decrypt
+       mml2015-epg-clear-verify
+       mml2015-epg-clear-decrypt))
   "Alist of PGP/MIME functions.")
 
 (defvar mml2015-result-buffer nil)
@@ -92,6 +109,60 @@
   :type '(repeat (cons (regexp :tag "GnuPG output regexp")
                       (boolean :tag "Trust key"))))
 
+(defcustom mml2015-verbose mml-secure-verbose
+  "If non-nil, ask the user about the current operation more verbosely."
+  :group 'mime-security
+  :type 'boolean)
+
+(defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
+  "If t, cache passphrase."
+  :group 'mime-security
+  :type 'boolean)
+
+(defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
+  "How many seconds the passphrase is cached.
+Whether the passphrase is cached at all is controlled by
+`mml2015-cache-passphrase'."
+  :group 'mime-security
+  :type 'integer)
+
+(defcustom mml2015-signers nil
+  "A list of your own key ID which will be used to sign a message."
+  :group 'mime-security
+  :type '(repeat (string :tag "Key ID")))
+
+(defcustom mml2015-encrypt-to-self nil
+  "If t, add your own key ID to recipient list when encryption."
+  :group 'mime-security
+  :type 'boolean)
+
+(defcustom mml2015-always-trust t
+  "If t, GnuPG skip key validation on encryption."
+  :group 'mime-security
+  :type 'boolean)
+
+;; Extract plaintext from cleartext signature.  IMO, this kind of task
+;; should be done by GnuPG rather than Elisp, but older PGP backends
+;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG.
+(defun mml2015-extract-cleartext-signature ()
+  (goto-char (point-min))
+  (forward-line)
+  ;; We need to be careful not to strip beyond the armor headers.
+  ;; Previously, an attacker could replace the text inside our
+  ;; markup with trailing garbage by injecting whitespace into the
+  ;; message.
+  (while (looking-at "Hash:")          ; The only header allowed in cleartext
+    (forward-line))                    ; signatures according to RFC2440.
+  (when (looking-at "[\t ]*$")
+    (forward-line))
+  (delete-region (point-min) (point))
+  (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t)
+      (delete-region (match-beginning 0) (point-max)))
+  (goto-char (point-min))
+  (while (re-search-forward "^- " nil t)
+    (replace-match "" t t)
+    (forward-line 1)))
+
 ;;; mailcrypt wrapper
 
 (eval-and-compile
@@ -278,7 +349,8 @@
        (mm-set-handle-multipart-parameter
         mm-security-handle 'gnus-info "OK")
       (mm-set-handle-multipart-parameter
-       mm-security-handle 'gnus-info "Failed"))))
+       mm-security-handle 'gnus-info "Failed")))
+  (mml2015-extract-cleartext-signature))
 
 (defun mml2015-mailcrypt-sign (cont)
   (mc-sign-generic (message-options-get 'message-sender)
@@ -475,9 +547,8 @@
       (with-temp-buffer
        (setq message (current-buffer))
        (insert part)
-       ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
-       ;; clearsign use --textmode. The conversion is not necessary.
-       ;; In clearverify, the conversion is not necessary either.
+       ;; Convert <LF> to <CR><LF> in signed text.  If --textmode is
+       ;; specified when signing, the conversion is not necessary.
        (goto-char (point-min))
        (end-of-line)
        (while (not (eobp))
@@ -545,7 +616,8 @@
        (with-current-buffer mml2015-result-buffer
         (mml2015-gpg-extract-signature-details)))
     (mm-set-handle-multipart-parameter
-     mm-security-handle 'gnus-info "Failed")))
+     mm-security-handle 'gnus-info "Failed"))
+  (mml2015-extract-cleartext-signature))
 
 (defun mml2015-gpg-sign (cont)
   (let ((boundary (mml-compute-boundary cont))
@@ -734,9 +806,8 @@
          handle)
       (with-temp-buffer
        (insert part)
-       ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
-       ;; clearsign use --textmode. The conversion is not necessary.
-       ;; In clearverify, the conversion is not necessary either.
+       ;; Convert <LF> to <CR><LF> in signed text.  If --textmode is
+       ;; specified when signing, the conversion is not necessary.
        (goto-char (point-min))
        (end-of-line)
        (while (not (eobp))
@@ -809,7 +880,8 @@
         (with-current-buffer pgg-errors-buffer
           (mml2015-gpg-extract-signature-details)))
       (mm-set-handle-multipart-parameter
-       mm-security-handle 'gnus-info "Failed"))))
+       mm-security-handle 'gnus-info "Failed")))
+  (mml2015-extract-cleartext-signature))
 
 (defun mml2015-pgg-sign (cont)
   (let ((pgg-errors-buffer mml2015-result-buffer)
@@ -871,6 +943,397 @@
     (insert (format "--%s--\n" boundary))
     (goto-char (point-max))))
 
+;;; epg wrapper
+
+(eval-and-compile
+  (autoload 'epg-make-context "epg"))
+
+(eval-when-compile
+  (defvar epg-user-id-alist)
+  (defvar epg-digest-algorithm-alist)
+  (defvar inhibit-redisplay)
+  (autoload 'epg-context-set-armor "epg")
+  (autoload 'epg-context-set-textmode "epg")
+  (autoload 'epg-context-set-signers "epg")
+  (autoload 'epg-context-result-for "epg")
+  (autoload 'epg-new-signature-digest-algorithm "epg")
+  (autoload 'epg-verify-result-to-string "epg")
+  (autoload 'epg-list-keys "epg")
+  (autoload 'epg-decrypt-string "epg")
+  (autoload 'epg-verify-string "epg")
+  (autoload 'epg-sign-string "epg")
+  (autoload 'epg-encrypt-string "epg")
+  (autoload 'epg-passphrase-callback-function "epg")
+  (autoload 'epg-context-set-passphrase-callback "epg")
+  (autoload 'epg-key-sub-key-list "epg")
+  (autoload 'epg-sub-key-capability "epg")
+  (autoload 'epg-sub-key-validity "epg")
+  (autoload 'epg-configuration "epg-config")
+  (autoload 'epg-expand-group "epg-config")
+  (autoload 'epa-select-keys "epa"))
+
+(eval-when-compile
+  (defvar password-cache-expiry)
+  (autoload 'password-read "password")
+  (autoload 'password-cache-add "password")
+  (autoload 'password-cache-remove "password"))
+
+(defvar mml2015-epg-secret-key-id-list nil)
+
+(defun mml2015-epg-passphrase-callback (context key-id ignore)
+  (if (eq key-id 'SYM)
+      (epg-passphrase-callback-function context key-id nil)
+    (let* (entry
+          (passphrase
+           (password-read
+            (if (eq key-id 'PIN)
+                "Passphrase for PIN: "
+              (if (setq entry (assoc key-id epg-user-id-alist))
+                  (format "Passphrase for %s %s: " key-id (cdr entry))
+                (format "Passphrase for %s: " key-id)))
+            (if (eq key-id 'PIN)
+                "PIN"
+              key-id))))
+      (when passphrase
+       (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
+         (password-cache-add key-id passphrase))
+       (setq mml2015-epg-secret-key-id-list
+             (cons key-id mml2015-epg-secret-key-id-list))
+       (copy-sequence passphrase)))))
+
+(defun mml2015-epg-find-usable-key (keys usage)
+  (catch 'found
+    (while keys
+      (let ((pointer (epg-key-sub-key-list (car keys))))
+       (while pointer
+         (if (and (memq usage (epg-sub-key-capability (car pointer)))
+                  (not (memq (epg-sub-key-validity (car pointer))
+                             '(revoked expired))))
+             (throw 'found (car keys)))
+         (setq pointer (cdr pointer))))
+      (setq keys (cdr keys)))))
+
+(defun mml2015-epg-decrypt (handle ctl)
+  (catch 'error
+    (let ((inhibit-redisplay t)
+         context plain child handles result decrypt-status)
+      (unless (setq child (mm-find-part-by-type
+                          (cdr handle)
+                          "application/octet-stream" nil t))
+       (mm-set-handle-multipart-parameter
+        mm-security-handle 'gnus-info "Corrupted")
+       (throw 'error handle))
+      (setq context (epg-make-context))
+      (if mml2015-cache-passphrase
+         (epg-context-set-passphrase-callback
+          context
+          #'mml2015-epg-passphrase-callback))
+      (condition-case error
+         (setq plain (epg-decrypt-string context (mm-get-part child))
+               mml2015-epg-secret-key-id-list nil)
+       (error
+        (while mml2015-epg-secret-key-id-list
+          (password-cache-remove (car mml2015-epg-secret-key-id-list))
+          (setq mml2015-epg-secret-key-id-list
+                (cdr mml2015-epg-secret-key-id-list)))
+        (mm-set-handle-multipart-parameter
+         mm-security-handle 'gnus-info "Failed")
+        (if (eq (car error) 'quit)
+            (mm-set-handle-multipart-parameter
+             mm-security-handle 'gnus-details "Quit.")
+          (mm-set-handle-multipart-parameter
+           mm-security-handle 'gnus-details (mml2015-format-error error)))
+        (throw 'error handle)))
+      (with-temp-buffer
+       (insert plain)
+       (goto-char (point-min))
+       (while (search-forward "\r\n" nil t)
+         (replace-match "\n" t t))
+       (setq handles (mm-dissect-buffer t))
+       (mm-destroy-parts handle)
+       (if (epg-context-result-for context 'verify)
+           (mm-set-handle-multipart-parameter
+            mm-security-handle 'gnus-info
+            (concat "OK\n"
+                    (epg-verify-result-to-string
+                     (epg-context-result-for context 'verify))))
+         (mm-set-handle-multipart-parameter
+          mm-security-handle 'gnus-info "OK"))
+       (if (stringp (car handles))
+           (mm-set-handle-multipart-parameter
+            mm-security-handle 'gnus-details
+            (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
+       (if (listp (car handles))
+           handles
+         (list handles)))))
+
+(defun mml2015-epg-clear-decrypt ()
+  (let ((inhibit-redisplay t)
+       (context (epg-make-context))
+       plain)
+    (if mml2015-cache-passphrase
+       (epg-context-set-passphrase-callback
+        context
+        #'mml2015-epg-passphrase-callback))
+    (condition-case error
+       (setq plain (epg-decrypt-string context (buffer-string))
+             mml2015-epg-secret-key-id-list nil)
+      (error
+       (while mml2015-epg-secret-key-id-list
+        (password-cache-remove (car mml2015-epg-secret-key-id-list))
+        (setq mml2015-epg-secret-key-id-list
+              (cdr mml2015-epg-secret-key-id-list)))
+       (mm-set-handle-multipart-parameter
+       mm-security-handle 'gnus-info "Failed")
+       (if (eq (car error) 'quit)
+          (mm-set-handle-multipart-parameter
+           mm-security-handle 'gnus-details "Quit.")
+        (mm-set-handle-multipart-parameter
+         mm-security-handle 'gnus-details (mml2015-format-error error)))))
+    (when plain
+      (erase-buffer)
+      ;; Treat data which epg returns as a unibyte string.
+      (mm-disable-multibyte)
+      (insert plain)
+      (goto-char (point-min))
+      (while (search-forward "\r\n" nil t)
+       (replace-match "\n" t t))
+      (mm-set-handle-multipart-parameter
+       mm-security-handle 'gnus-info "OK")
+      (if (epg-context-result-for context 'verify)
+         (mm-set-handle-multipart-parameter
+          mm-security-handle 'gnus-details
+          (epg-verify-result-to-string
+           (epg-context-result-for context 'verify)))))))
+
+(defun mml2015-epg-verify (handle ctl)
+  (catch 'error
+    (let ((inhibit-redisplay t)
+         context plain signature-file part signature)
+      (when (or (null (setq part (mm-find-raw-part-by-type
+                                 ctl (or (mm-handle-multipart-ctl-parameter
+                                          ctl 'protocol)
+                                         "application/pgp-signature")
+                                 t)))
+               (null (setq signature (mm-find-part-by-type
+                                      (cdr handle) "application/pgp-signature"
+                                      nil t))))
+       (mm-set-handle-multipart-parameter
+        mm-security-handle 'gnus-info "Corrupted")
+       (throw 'error handle))
+      (setq part (mm-replace-in-string part "\n" "\r\n" t)
+           signature (mm-get-part signature)
+           context (epg-make-context))
+      (condition-case error
+         (setq plain (epg-verify-string context signature part))
+       (error
+        (mm-set-handle-multipart-parameter
+         mm-security-handle 'gnus-info "Failed")
+        (if (eq (car error) 'quit)
+            (mm-set-handle-multipart-parameter
+             mm-security-handle 'gnus-details "Quit.")
+          (mm-set-handle-multipart-parameter
+           mm-security-handle 'gnus-details (mml2015-format-error error)))
+        (throw 'error handle)))
+      (mm-set-handle-multipart-parameter
+       mm-security-handle 'gnus-info
+       (epg-verify-result-to-string (epg-context-result-for context 'verify)))
+      handle)))
+
+(defun mml2015-epg-clear-verify ()
+  (let ((inhibit-redisplay t)
+       (context (epg-make-context))
+       (signature (mm-encode-coding-string (buffer-string)
+                                           coding-system-for-write))
+       plain)
+    (condition-case error
+       (setq plain (epg-verify-string context signature))
+      (error
+       (mm-set-handle-multipart-parameter
+       mm-security-handle 'gnus-info "Failed")
+       (if (eq (car error) 'quit)
+          (mm-set-handle-multipart-parameter
+           mm-security-handle 'gnus-details "Quit.")
+        (mm-set-handle-multipart-parameter
+         mm-security-handle 'gnus-details (mml2015-format-error error)))))
+    (if plain
+       (progn
+         (mm-set-handle-multipart-parameter
+          mm-security-handle 'gnus-info
+          (epg-verify-result-to-string
+           (epg-context-result-for context 'verify)))
+         (delete-region (point-min) (point-max))
+         (insert (mm-decode-coding-string plain coding-system-for-read)))
+      (mml2015-extract-cleartext-signature))))
+
+(defun mml2015-epg-sign (cont)
+  (let* ((inhibit-redisplay t)
+        (context (epg-make-context))
+        (boundary (mml-compute-boundary cont))
+        signer-key
+        (signers
+         (or (message-options-get 'mml2015-epg-signers)
+             (message-options-set
+              'mml2015-epg-signers
+              (if mml2015-verbose
+                  (epa-select-keys context "\
+Select keys for signing.
+If no one is selected, default secret key is used.  "
+                                   mml2015-signers t)
+                (if mml2015-signers
+                    (mapcar
+                     (lambda (signer)
+                       (setq signer-key (mml2015-epg-find-usable-key
+                                         (epg-list-keys context signer t)
+                                         'sign))
+                       (unless (or signer-key
+                                   (y-or-n-p
+                                    (format "No secret key for %s; skip it? "
+                                            signer)))
+                         (error "No secret key for %s" signer))
+                       signer-key)
+                     mml2015-signers))))))
+        signature micalg)
+    (epg-context-set-armor context t)
+    (epg-context-set-textmode context t)
+    (epg-context-set-signers context signers)
+    (if mml2015-cache-passphrase
+       (epg-context-set-passphrase-callback
+        context
+        #'mml2015-epg-passphrase-callback))
+    (condition-case error
+       (setq signature (epg-sign-string context (buffer-string) t)
+             mml2015-epg-secret-key-id-list nil)
+      (error
+       (while mml2015-epg-secret-key-id-list
+        (password-cache-remove (car mml2015-epg-secret-key-id-list))
+        (setq mml2015-epg-secret-key-id-list
+              (cdr mml2015-epg-secret-key-id-list)))
+       (signal (car error) (cdr error))))
+    (if (epg-context-result-for context 'sign)
+       (setq micalg (epg-new-signature-digest-algorithm
+                     (car (epg-context-result-for context 'sign)))))
+    (goto-char (point-min))
+    (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
+                   boundary))
+    (if micalg
+       (insert (format "\tmicalg=pgp-%s; "
+                       (downcase
+                        (cdr (assq micalg
+                                   epg-digest-algorithm-alist))))))
+    (insert "protocol=\"application/pgp-signature\"\n")
+    (insert (format "\n--%s\n" boundary))
+    (goto-char (point-max))
+    (insert (format "\n--%s\n" boundary))
+    (insert "Content-Type: application/pgp-signature\n\n")
+    (insert signature)
+    (goto-char (point-max))
+    (insert (format "--%s--\n" boundary))
+    (goto-char (point-max))))
+
+(defun mml2015-epg-encrypt (cont &optional sign)
+  (let ((inhibit-redisplay t)
+       (context (epg-make-context))
+       (config (epg-configuration))
+       (recipients (message-options-get 'mml2015-epg-recipients))
+       cipher signers
+       (boundary (mml-compute-boundary cont))
+       recipient-key signer-key)
+    (unless recipients
+      (setq recipients
+           (apply #'nconc
+                  (mapcar
+                   (lambda (recipient)
+                     (or (epg-expand-group config recipient)
+                         (list (concat "<" recipient ">"))))
+                   (split-string
+                    (or (message-options-get 'message-recipients)
+                        (message-options-set 'message-recipients
+                                             (read-string "Recipients: ")))
+                    "[ \f\t\n\r\v,]+"))))
+      (when mml2015-encrypt-to-self
+       (unless mml2015-signers
+         (error "mml2015-signers not set"))
+       (setq recipients (nconc recipients mml2015-signers)))
+      (if mml2015-verbose
+         (setq recipients
+               (epa-select-keys context "\
+Select recipients for encryption.
+If no one is selected, symmetric encryption will be performed.  "
+                                recipients))
+       (setq recipients
+             (mapcar
+              (lambda (recipient)
+                (setq recipient-key (mml2015-epg-find-usable-key
+                                     (epg-list-keys context recipient)
+                                     'encrypt))
+                (unless (or recipient-key
+                            (y-or-n-p
+                             (format "No public key for %s; skip it? "
+                                     recipient)))
+                  (error "No public key for %s" recipient))
+                recipient-key)
+              recipients))
+       (unless recipients
+         (error "No recipient specified")))
+      (message-options-set 'mml2015-epg-recipients recipients))
+    (when sign
+      (setq signers
+           (or (message-options-get 'mml2015-epg-signers)
+               (message-options-set
+                'mml2015-epg-signers
+                (if mml2015-verbose
+                    (epa-select-keys context "\
+Select keys for signing.
+If no one is selected, default secret key is used.  "
+                                     mml2015-signers t)
+                  (if mml2015-signers
+                      (mapcar
+                       (lambda (signer)
+                         (setq signer-key (mml2015-epg-find-usable-key
+                                           (epg-list-keys context signer t)
+                                           'sign))
+                         (unless (or signer-key
+                                     (y-or-n-p
+                                      (format
+                                       "No secret key for %s; skip it? "
+                                       signer)))
+                           (error "No secret key for %s" signer))
+                         signer-key)
+                       mml2015-signers))))))
+      (epg-context-set-signers context signers))
+    (epg-context-set-armor context t)
+    (epg-context-set-textmode context t)
+    (if mml2015-cache-passphrase
+       (epg-context-set-passphrase-callback
+        context
+        #'mml2015-epg-passphrase-callback))
+    (condition-case error
+       (setq cipher
+             (epg-encrypt-string context (buffer-string) recipients sign
+                                 mml2015-always-trust)
+             mml2015-epg-secret-key-id-list nil)
+      (error
+       (while mml2015-epg-secret-key-id-list
+        (password-cache-remove (car mml2015-epg-secret-key-id-list))
+        (setq mml2015-epg-secret-key-id-list
+              (cdr mml2015-epg-secret-key-id-list)))
+       (signal (car error) (cdr error))))
+    (delete-region (point-min) (point-max))
+    (goto-char (point-min))
+    (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
+                   boundary))
+    (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
+    (insert (format "--%s\n" boundary))
+    (insert "Content-Type: application/pgp-encrypted\n\n")
+    (insert "Version: 1\n\n")
+    (insert (format "--%s\n" boundary))
+    (insert "Content-Type: application/octet-stream\n\n")
+    (insert cipher)
+    (goto-char (point-max))
+    (insert (format "--%s--\n" boundary))
+    (goto-char (point-max))))
+
 ;;; General wrapper
 
 (defun mml2015-clean-buffer ()
@@ -879,7 +1342,7 @@
        (erase-buffer)
        t)
     (setq mml2015-result-buffer
-         (gnus-get-buffer-create "*MML2015 Result*"))
+         (gnus-get-buffer-create " *MML2015 Result*"))
     nil))
 
 (defsubst mml2015-clear-decrypt-function ()