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 (eval-and-compile
  32   ;; For Emacs <22.2 and XEmacs.
  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 (require 'pgg))
  60                        (and (fboundp 'pgg-sign-region)
  61                             'pgg))
  62                      (progn (ignore-errors
  63                               (load "mc-toplev"))
  64                             (and (fboundp 'mc-encrypt-generic)
  65                                  (fboundp 'mc-sign-generic)
  66                                  (fboundp 'mc-cleanup-recipient-headers)
  67                                  'mailcrypt)))
  68   "The package used for PGP/MIME.
  69 Valid packages include `epg', `pgg' and `mailcrypt'.")
  70
  71 ;; Something is not RFC2015.
  72 (defvar mml2015-function-alist
  73   '((mailcrypt mml2015-mailcrypt-sign
  74                mml2015-mailcrypt-encrypt
  75                mml2015-mailcrypt-verify
  76                mml2015-mailcrypt-decrypt
  77                mml2015-mailcrypt-clear-verify
  78                mml2015-mailcrypt-clear-decrypt)
  79     (pgg mml2015-pgg-sign
  80          mml2015-pgg-encrypt
  81          mml2015-pgg-verify
  82          mml2015-pgg-decrypt
  83          mml2015-pgg-clear-verify
  84          mml2015-pgg-clear-decrypt)
  85     (epg mml2015-epg-sign
  86          mml2015-epg-encrypt
  87          mml2015-epg-verify
  88          mml2015-epg-decrypt
  89          mml2015-epg-clear-verify
  90          mml2015-epg-clear-decrypt))
  91   "Alist of PGP/MIME functions.")
  92
  93 (defvar mml2015-result-buffer nil)
  94
  95 (defcustom mml2015-unabbrev-trust-alist
  96   '(("TRUST_UNDEFINED" . nil)
  97     ("TRUST_NEVER"     . nil)
  98     ("TRUST_MARGINAL"  . t)
  99     ("TRUST_FULLY"     . t)
 100     ("TRUST_ULTIMATE"  . t))
 101   "Map GnuPG trust output values to a boolean saying if you trust the key."
 102   :version "22.1"
 103   :group 'mime-security
 104   :type '(repeat (cons (regexp :tag "GnuPG output regexp")
 105                        (boolean :tag "Trust key"))))
 106
 107 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
 108   "If t, cache passphrase."
 109   :group 'mime-security
 110   :type 'boolean)
 111
 112 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
 113   "How many seconds the passphrase is cached.
 114 Whether the passphrase is cached at all is controlled by
 115 `mml2015-cache-passphrase'."
 116   :group 'mime-security
 117   :type 'integer)
 118
 119 (defcustom mml2015-signers nil
 120   "A list of your own key ID which will be used to sign a message."
 121   :group 'mime-security
 122   :type '(repeat (string :tag "Key ID")))
 123
 124 (defcustom mml2015-encrypt-to-self nil
 125   "If t, add your own key ID to recipient list when encryption."
 126   :group 'mime-security
 127   :type 'boolean)
 128
 129 (defcustom mml2015-always-trust t
 130   "If t, GnuPG skip key validation on encryption."
 131   :group 'mime-security
 132   :type 'boolean)
 133
 134 ;; Extract plaintext from cleartext signature.  IMO, this kind of task
 135 ;; should be done by GnuPG rather than Elisp, but older PGP backends
 136 ;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
 137 (defun mml2015-extract-cleartext-signature ()
 138   ;; Daiki Ueno in
 139   ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
 140   ;; believe that the right way is to use the plaintext output from GnuPG as
 141   ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
 142   ;; misdesigned libraries like PGG, which have no ability to do that.  So, I
 143   ;; think it should not have descriptive documentation.''
 144   ;;
 145   ;; This function doesn't handle NotDashEscaped correctly.  EasyPG handles it
 146   ;; correctly.
 147   ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
 148   ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
 149   (goto-char (point-min))
 150   (forward-line)
 151   ;; We need to be careful not to strip beyond the armor headers.
 152   ;; Previously, an attacker could replace the text inside our
 153   ;; markup with trailing garbage by injecting whitespace into the
 154   ;; message.
 155   (while (looking-at "Hash:")           ; The only header allowed in cleartext
 156     (forward-line))                     ; signatures according to RFC2440.
 157   (when (looking-at "[\t ]*$")
 158     (forward-line))
 159   (delete-region (point-min) (point))
 160   (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t)
 161       (delete-region (match-beginning 0) (point-max)))
 162   (goto-char (point-min))
 163   (while (re-search-forward "^- " nil t)
 164     (replace-match "" t t)
 165     (forward-line 1)))
 166
 167 ;;; mailcrypt wrapper
 168
 169 (autoload 'mailcrypt-decrypt "mailcrypt")
 170 (autoload 'mailcrypt-verify "mailcrypt")
 171 (autoload 'mc-pgp-always-sign "mailcrypt")
 172 (autoload 'mc-encrypt-generic "mc-toplev")
 173 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
 174 (autoload 'mc-sign-generic "mc-toplev")
 175
 176 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
 177 (defvar mml2015-verify-function 'mailcrypt-verify)
 178
 179 (defun mml2015-format-error (err)
 180   (if (stringp (cadr err))
 181       (cadr err)
 182     (format "%S" (cdr err))))
 183
 184 (defun mml2015-mailcrypt-decrypt (handle ctl)
 185   (catch 'error
 186     (let (child handles result)
 187       (unless (setq child (mm-find-part-by-type
 188                            (cdr handle)
 189                            "application/octet-stream" nil t))
 190         (mm-set-handle-multipart-parameter
 191          mm-security-handle 'gnus-info "Corrupted")
 192         (throw 'error handle))
 193       (with-temp-buffer
 194         (mm-insert-part child)
 195         (setq result
 196               (condition-case err
 197                   (funcall mml2015-decrypt-function)
 198                 (error
 199                  (mm-set-handle-multipart-parameter
 200                   mm-security-handle 'gnus-details (mml2015-format-error err))
 201                  nil)
 202                 (quit
 203                  (mm-set-handle-multipart-parameter
 204                   mm-security-handle 'gnus-details "Quit.")
 205                  nil)))
 206         (unless (car result)
 207           (mm-set-handle-multipart-parameter
 208            mm-security-handle 'gnus-info "Failed")
 209           (throw 'error handle))
 210         (setq handles (mm-dissect-buffer t)))
 211       (mm-destroy-parts handle)
 212       (mm-set-handle-multipart-parameter
 213        mm-security-handle 'gnus-info
 214        (concat "OK"
 215                (let ((sig (with-current-buffer mml2015-result-buffer
 216                             (mml2015-gpg-extract-signature-details))))
 217                  (concat ", Signer: " sig))))
 218       (if (listp (car handles))
 219           handles
 220         (list handles)))))
 221
 222 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
 223   (let* ((result "")
 224          (fpr-length (string-width fingerprint))
 225          (n-slice 0)
 226          slice)
 227     (setq fingerprint (string-to-list fingerprint))
 228     (while fingerprint
 229       (setq fpr-length (- fpr-length 4))
 230       (setq slice (butlast fingerprint fpr-length))
 231       (setq fingerprint (nthcdr 4 fingerprint))
 232       (setq n-slice (1+ n-slice))
 233       (setq result
 234             (concat
 235              result
 236              (case n-slice
 237                (1  slice)
 238                (otherwise (concat " " slice))))))
 239     result))
 240
 241 (defun mml2015-gpg-extract-signature-details ()
 242   (goto-char (point-min))
 243   (let* ((expired (re-search-forward
 244                    "^\\[GNUPG:\\] SIGEXPIRED$"
 245                    nil t))
 246          (signer (and (re-search-forward
 247                        "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
 248                        nil t)
 249                       (cons (match-string 1) (match-string 2))))
 250          (fprint (and (re-search-forward
 251                        "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
 252                        nil t)
 253                       (match-string 1)))
 254          (trust  (and (re-search-forward
 255                        "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
 256                        nil t)
 257                       (match-string 1)))
 258          (trust-good-enough-p
 259           (cdr (assoc trust mml2015-unabbrev-trust-alist))))
 260     (cond ((and signer fprint)
 261            (concat (cdr signer)
 262                    (unless trust-good-enough-p
 263                      (concat "\nUntrusted, Fingerprint: "
 264                              (mml2015-gpg-pretty-print-fpr fprint)))
 265                    (when expired
 266                      (format "\nWARNING: Signature from expired key (%s)"
 267                              (car signer)))))
 268           ((re-search-forward
 269             "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
 270            (match-string 2))
 271           (t
 272            "From unknown user"))))
 273
 274 (defun mml2015-mailcrypt-clear-decrypt ()
 275   (let (result)
 276     (setq result
 277           (condition-case err
 278               (funcall mml2015-decrypt-function)
 279             (error
 280              (mm-set-handle-multipart-parameter
 281               mm-security-handle 'gnus-details (mml2015-format-error err))
 282              nil)
 283             (quit
 284              (mm-set-handle-multipart-parameter
 285               mm-security-handle 'gnus-details "Quit.")
 286              nil)))
 287     (if (car result)
 288         (mm-set-handle-multipart-parameter