cgit.sxemacs.org Git - gnus/blob - lisp/mml2015.el

   1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   7 ;; Keywords: PGP MIME MML
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs 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 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
  27 ;; with both.
  28
  29 ;;; Code:
  30
  31 ;; For Emacs < 22.2.
  32 (eval-and-compile
  33   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
  34
  35   (if (locate-library "password-cache")
  36       (require 'password-cache)
  37     (require 'password)))
  38
  39 (eval-when-compile (require 'cl))
  40 (require 'mm-decode)
  41 (require 'mm-util)
  42 (require 'mml)
  43 (require 'mml-sec)
  44
  45 (defvar mc-pgp-always-sign)
  46
  47 (declare-function epg-check-configuration "ext:epg-config"
  48                   (config &optional minimum-version))
  49 (declare-function epg-configuration "ext:epg-config" ())
  50
  51 (defvar mml2015-use (or
  52                      (condition-case nil
  53                          (progn
  54                            (require 'epg-config)
  55                            (epg-check-configuration (epg-configuration))
  56                            'epg)
  57                        (error))
  58                      (progn
  59                        (ignore-errors
  60                         ;; Avoid the "Recursive load suspected" error
  61                         ;; in Emacs 21.1.
  62                         (let ((recursive-load-depth-limit 100))
  63                           (require 'pgg)))
  64                        (and (fboundp 'pgg-sign-region)
  65                             'pgg))
  66                      (progn
  67                        (ignore-errors
  68                          (require 'gpg))
  69                        (and (fboundp 'gpg-sign-detached)
  70                             'gpg))
  71                      (progn (ignore-errors
  72                               (load "mc-toplev"))
  73                             (and (fboundp 'mc-encrypt-generic)
  74                                  (fboundp 'mc-sign-generic)
  75                                  (fboundp 'mc-cleanup-recipient-headers)
  76                                  'mailcrypt)))
  77   "The package used for PGP/MIME.
  78 Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
  79
  80 ;; Something is not RFC2015.
  81 (defvar mml2015-function-alist
  82   '((mailcrypt mml2015-mailcrypt-sign
  83                mml2015-mailcrypt-encrypt
  84                mml2015-mailcrypt-verify
  85                mml2015-mailcrypt-decrypt
  86                mml2015-mailcrypt-clear-verify
  87                mml2015-mailcrypt-clear-decrypt)
  88     (gpg mml2015-gpg-sign
  89          mml2015-gpg-encrypt
  90          mml2015-gpg-verify
  91          mml2015-gpg-decrypt
  92          mml2015-gpg-clear-verify
  93          mml2015-gpg-clear-decrypt)
  94   (pgg mml2015-pgg-sign
  95        mml2015-pgg-encrypt
  96        mml2015-pgg-verify
  97        mml2015-pgg-decrypt
  98        mml2015-pgg-clear-verify
  99        mml2015-pgg-clear-decrypt)
 100   (epg mml2015-epg-sign
 101        mml2015-epg-encrypt
 102        mml2015-epg-verify
 103        mml2015-epg-decrypt
 104        mml2015-epg-clear-verify
 105        mml2015-epg-clear-decrypt))
 106   "Alist of PGP/MIME functions.")
 107
 108 (defvar mml2015-result-buffer nil)
 109
 110 (defcustom mml2015-unabbrev-trust-alist
 111   '(("TRUST_UNDEFINED" . nil)
 112     ("TRUST_NEVER"     . nil)
 113     ("TRUST_MARGINAL"  . t)
 114     ("TRUST_FULLY"     . t)
 115     ("TRUST_ULTIMATE"  . t))
 116   "Map GnuPG trust output values to a boolean saying if you trust the key."
 117   :version "22.1"
 118   :group 'mime-security
 119   :type '(repeat (cons (regexp :tag "GnuPG output regexp")
 120                        (boolean :tag "Trust key"))))
 121
 122 (defcustom mml2015-verbose mml-secure-verbose
 123   "If non-nil, ask the user about the current operation more verbosely."
 124   :group 'mime-security
 125   :type 'boolean)
 126
 127 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
 128   "If t, cache passphrase."
 129   :group 'mime-security
 130   :type 'boolean)
 131
 132 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
 133   "How many seconds the passphrase is cached.
 134 Whether the passphrase is cached at all is controlled by
 135 `mml2015-cache-passphrase'."
 136   :group 'mime-security
 137   :type 'integer)
 138
 139 (defcustom mml2015-signers nil
 140   "A list of your own key ID which will be used to sign a message."
 141   :group 'mime-security
 142   :type '(repeat (string :tag "Key ID")))
 143
 144 (defcustom mml2015-encrypt-to-self nil
 145   "If t, add your own key ID to recipient list when encryption."
 146   :group 'mime-security
 147   :type 'boolean)
 148
 149 (defcustom mml2015-always-trust t
 150   "If t, GnuPG skip key validation on encryption."
 151   :group 'mime-security
 152   :type 'boolean)
 153
 154 ;; Extract plaintext from cleartext signature.  IMO, this kind of task
 155 ;; should be done by GnuPG rather than Elisp, but older PGP backends
 156 ;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG.
 157 (defun mml2015-extract-cleartext-signature ()
 158   ;; Daiki Ueno in
 159   ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
 160   ;; believe that the right way is to use the plaintext output from GnuPG as
 161   ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
 162   ;; misdesigned libraries like PGG, which have no ability to do that.  So, I
 163   ;; think it should not have descriptive documentation.''
 164   ;;
 165   ;; This function doesn't handle NotDashEscaped correctly.  EasyPG handles it
 166   ;; correctly.
 167   ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
 168   ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
 169   (goto-char (point-min))
 170   (forward-line)
 171   ;; We need to be careful not to strip beyond the armor headers.
 172   ;; Previously, an attacker could replace the text inside our
 173   ;; markup with trailing garbage by injecting whitespace into the
 174   ;; message.
 175   (while (looking-at "Hash:")           ; The only header allowed in cleartext
 176     (forward-line))                     ; signatures according to RFC2440.
 177   (when (looking-at "[\t ]*$")
 178     (forward-line))
 179   (delete-region (point-min) (point))
 180   (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t)
 181       (delete-region (match-beginning 0) (point-max)))
 182   (goto-char (point-min))
 183   (while (re-search-forward "^- " nil t)
 184     (replace-match "" t t)
 185     (forward-line 1)))
 186
 187 ;;; mailcrypt wrapper
 188
 189 (autoload 'mailcrypt-decrypt "mailcrypt")
 190 (autoload 'mailcrypt-verify "mailcrypt")
 191 (autoload 'mc-pgp-always-sign "mailcrypt")
 192 (autoload 'mc-encrypt-generic "mc-toplev")
 193 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
 194 (autoload 'mc-sign-generic "mc-toplev")
 195
 196 (defvar mc-default-scheme)
 197 (defvar mc-schemes)
 198
 199 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
 200 (defvar mml2015-verify-function 'mailcrypt-verify)
 201
 202 (defun mml2015-format-error (err)
 203   (if (stringp (cadr err))
 204       (cadr err)
 205     (format "%S" (cdr err))))
 206
 207 (defun mml2015-mailcrypt-decrypt (handle ctl)
 208   (catch 'error
 209     (let (child handles result)
 210       (unless (setq child (mm-find-part-by-type
 211                            (cdr handle)
 212                            "application/octet-stream" nil t))
 213         (mm-set-handle-multipart-parameter
 214          mm-security-handle 'gnus-info "Corrupted")
 215         (throw 'error handle))
 216       (with-temp-buffer
 217         (mm-insert-part child)
 218         (setq result
 219               (condition-case err
 220                   (funcall mml2015-decrypt-function)
 221                 (error
 222                  (mm-set-handle-multipart-parameter
 223                   mm-security-handle 'gnus-details (mml2015-format-error err))
 224                  nil)
 225                 (quit
 226                  (mm-set-handle-multipart-parameter
 227                   mm-security-handle 'gnus-details "Quit.")
 228                  nil)))
 229         (unless (car result)
 230           (mm-set-handle-multipart-parameter
 231            mm-security-handle 'gnus-info "Failed")
 232           (throw 'error handle))
 233         (setq handles (mm-dissect-buffer t)))
 234       (mm-destroy-parts handle)
 235       (mm-set-handle-multipart-parameter
 236        mm-security-handle 'gnus-info
 237        (concat "OK"
 238                (let ((sig (with-current-buffer mml2015-result-buffer
 239                             (mml2015-gpg-extract-signature-details))))
 240                  (concat ", Signer: " sig))))
 241       (if (listp (car handles))
 242           handles
 243         (list handles)))))
 244
 245 (defun mml2015-mailcrypt-clear-decrypt ()
 246   (let (result)
 247     (setq result
 248           (condition-case err
 249               (funcall mml2015-decrypt-function)
 250             (error
 251              (mm-set-handle-multipart-parameter
 252               mm-security-handle 'gnus-details (mml2015-format-error err))
 253              nil)
 254             (quit
 255              (mm-set-handle-multipart-parameter
 256               mm-security-handle 'gnus-details "Quit.")
 257              nil)))
 258     (if (car result)
 259         (mm-set-handle-multipart-parameter
 260          mm-security-handle 'gnus-info "OK")
 261       (mm-set-handle-multipart-parameter
 262        mm-security-handle 'gnus-info "Failed"))))
 263
 264 (defun mml2015-fix-micalg (alg)
 265   (and alg
 266        ;; Mutt/1.2.5i has seen sending micalg=php-sha1
 267        (upcase (if (string-match "^p[gh]p-" alg)
 268                    (substring alg (match-end 0))
 269                  alg))))
 270
 271 (defun mml2015-mailcrypt-verify (handle ctl)
 272   (catch 'error
 273     (let (part)
 274       (unless (setq part (mm-find-raw-part-by-type
 275                           ctl (or (mm-handle-multipart-ctl-parameter
 276                                    ctl 'protocol)
 277                                   "application/pgp-signature")
 278                           t))
 279         (mm-set-handle-multipart-parameter
 280          mm-security-handle 'gnus-info "Corrupted")
 281         (throw 'error handle))
 282       (with-temp-buffer
 283         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
 284         (insert (format "Hash: %s\n\n"
 285                         (or (mml2015-fix-micalg
 286                              (mm-handle-multipart-ctl-parameter
 287                               ctl 'micalg))
 288                             "SHA1")))
 289         (save-restriction
 290           (narrow-to-region (point) (point))
 291           (insert part "\n")
 292           (goto-char (point-min))
 293           (while (not (eobp))
 294             (if (looking-at "^-")
 295                 (insert "- "))
 296             (forward-line)))
 297         (unless (setq part (mm-find-part-by-type
 298                             (cdr handle) "application/pgp-signature" nil t))
 299           (mm-set-handle-multipart-parameter
 300            mm-security-handle 'gnus-info "Corrupted")
 301           (throw 'error handle))
 302         (save-restriction
 303           (narrow-to-region (point) (point))
 304           (mm-insert-part part)
 305           (goto-char (point-min))
 306           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
 307               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
 308           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
 309               (replace-match "-----END PGP SIGNATURE-----" t t)))
 310         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 311           (unless (condition-case err
 312                       (prog1
 313                           (funcall mml2015-verify-function)
 314                         (if (get-buffer " *mailcrypt stderr temp")
 315                             (mm-set-handle-multipart-parameter
 316                              mm-security-handle 'gnus-details
 317                              (with-current-buffer " *mailcrypt stderr temp"
 318                                (buffer-string))))
 319                         (if (get-buffer " *mailcrypt stdout temp")
 320                             (kill-buffer " *mailcrypt stdout temp"))
 321                         (if (get-buffer " *mailcrypt stderr temp")
 322                             (kill-buffer " *mailcrypt stderr temp"))
 323                         (if (get-buffer " *mailcrypt status temp")
 324                             (kill-buffer " *mailcrypt status temp"))
 325                         (if (get-buffer mc-gpg-debug-buffer)
 326                             (kill-buffer mc-gpg-debug-buffer)))
 327                     (error
 328                      (mm-set-handle-multipart-parameter
 329                       mm-security-handle 'gnus-details (mml2015-format-error err))
 330                      nil)
 331                     (quit
 332                      (mm-set-handle-multipart-parameter
 333                       mm-security-handle 'gnus-details "Quit.")
 334                      nil))
 335             (mm-set-handle-multipart-parameter
 336              mm-security-handle 'gnus-info "Failed")
 337             (throw 'error handle))))
 338       (mm-set-handle-multipart-parameter
 339        mm-security-handle 'gnus-info "OK")
 340       handle)))
 341
 342 (defun mml2015-mailcrypt-clear-verify ()
 343   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 344     (if (condition-case err
 345             (prog1
 346                 (funcall mml2015-verify-function)
 347               (if (get-buffer " *mailcrypt stderr temp")
 348                   (mm-set-handle-multipart-parameter
 349                    mm-security-handle 'gnus-details
 350                    (with-current-buffer " *mailcrypt stderr temp"
 351                      (buffer-string))))
 352               (if (get-buffer " *mailcrypt stdout temp")
 353                   (kill-buffer " *mailcrypt stdout temp"))
 354               (if (get-buffer " *mailcrypt stderr temp")
 355                   (kill-buffer " *mailcrypt stderr temp"))
 356               (if (get-buffer " *mailcrypt status temp")
 357                   (kill-buffer " *mailcrypt status temp"))
 358               (if (get-buffer mc-gpg-debug-buffer)
 359                   (kill-buffer mc-gpg-debug-buffer)))
 360           (error
 361            (mm-set-handle-multipart-parameter
 362             mm-security-handle 'gnus-details (mml2015-format-error err))
 363            nil)
 364           (quit
 365            (mm-set-handle-multipart-parameter
 366             mm-security-handle 'gnus-details "Quit.")
 367            nil))
 368         (mm-set-handle-multipart-parameter
 369          mm-security-handle 'gnus-info "OK")
 370       (mm-set-handle-multipart-parameter
 371        mm-security-handle 'gnus-info "Failed")))
 372   (mml2015-extract-cleartext-signature))
 373
 374 (defun mml2015-mailcrypt-sign (cont)
 375   (mc-sign-generic (message-options-get 'message-sender)
 376                    nil nil nil nil)
 377   (let ((boundary (mml-compute-boundary cont))
 378         hash point)
 379     (goto-char (point-min))
 380     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
 381       (error "Cannot find signed begin line"))
 382     (goto-char (match-beginning 0))
 383     (forward-line 1)
 384     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 385       (error "Cannot not find PGP hash"))
 386     (setq hash (match-string 1))
 387     (unless (re-search-forward "^$" nil t)
 388       (error "Cannot not find PGP message"))
 389     (forward-line 1)
 390     (delete-region (point-min) (point))
 391     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 392  &nbs