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,
   4 ;;   2005, 2006, 2007 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
  13 ;; by the Free Software Foundation; either version 2, or (at your
  14 ;; option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
  29 ;; with both.
  30
  31 ;;; Code:
  32
  33 (eval-when-compile (require 'cl))
  34 (require 'mm-decode)
  35 (require 'mm-util)
  36 (require 'mml)
  37 (require 'mml-sec)
  38
  39 (defvar mc-pgp-always-sign)
  40
  41 (defvar mml2015-use (or
  42                      (condition-case nil
  43                          (progn
  44                            (require 'epg-config)
  45                            (epg-check-configuration (epg-configuration))
  46                            'epg)
  47                        (error))
  48                      (progn
  49                        (ignore-errors
  50                         ;; Avoid the "Recursive load suspected" error
  51                         ;; in Emacs 21.1.
  52                         (let ((recursive-load-depth-limit 100))
  53                           (require 'pgg)))
  54                        (and (fboundp 'pgg-sign-region)
  55                             'pgg))
  56                      (progn
  57                        (ignore-errors
  58                          (require 'gpg))
  59                        (and (fboundp 'gpg-sign-detached)
  60                             'gpg))
  61                      (progn (ignore-errors
  62                               (load "mc-toplev"))
  63                             (and (fboundp 'mc-encrypt-generic)
  64                                  (fboundp 'mc-sign-generic)
  65                                  (fboundp 'mc-cleanup-recipient-headers)
  66                                  'mailcrypt)))
  67   "The package used for PGP/MIME.
  68 Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
  69
  70 ;; Something is not RFC2015.
  71 (defvar mml2015-function-alist
  72   '((mailcrypt mml2015-mailcrypt-sign
  73                mml2015-mailcrypt-encrypt
  74                mml2015-mailcrypt-verify
  75                mml2015-mailcrypt-decrypt
  76                mml2015-mailcrypt-clear-verify
  77                mml2015-mailcrypt-clear-decrypt)
  78     (gpg mml2015-gpg-sign
  79          mml2015-gpg-encrypt
  80          mml2015-gpg-verify
  81          mml2015-gpg-decrypt
  82          mml2015-gpg-clear-verify
  83          mml2015-gpg-clear-decrypt)
  84   (pgg mml2015-pgg-sign
  85        mml2015-pgg-encrypt
  86        mml2015-pgg-verify
  87        mml2015-pgg-decrypt
  88        mml2015-pgg-clear-verify
  89        mml2015-pgg-clear-decrypt)
  90   (epg mml2015-epg-sign
  91        mml2015-epg-encrypt
  92        mml2015-epg-verify
  93        mml2015-epg-decrypt
  94        mml2015-epg-clear-verify
  95        mml2015-epg-clear-decrypt))
  96   "Alist of PGP/MIME functions.")
  97
  98 (defvar mml2015-result-buffer nil)
  99
 100 (defcustom mml2015-unabbrev-trust-alist
 101   '(("TRUST_UNDEFINED" . nil)
 102     ("TRUST_NEVER"     . nil)
 103     ("TRUST_MARGINAL"  . t)
 104     ("TRUST_FULLY"     . t)
 105     ("TRUST_ULTIMATE"  . t))
 106   "Map GnuPG trust output values to a boolean saying if you trust the key."
 107   :version "22.1"
 108   :group 'mime-security
 109   :type '(repeat (cons (regexp :tag "GnuPG output regexp")
 110                        (boolean :tag "Trust key"))))
 111
 112 (defcustom mml2015-verbose mml-secure-verbose
 113   "If non-nil, ask the user about the current operation more verbosely."
 114   :group 'mime-security
 115   :type 'boolean)
 116
 117 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
 118   "If t, cache passphrase."
 119   :group 'mime-security
 120   :type 'boolean)
 121
 122 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
 123   "How many seconds the passphrase is cached.
 124 Whether the passphrase is cached at all is controlled by
 125 `mml2015-cache-passphrase'."
 126   :group 'mime-security
 127   :type 'integer)
 128
 129 (defcustom mml2015-signers nil
 130   "A list of your own key ID which will be used to sign a message."
 131   :group 'mime-security
 132   :type '(repeat (string :tag "Key ID")))
 133
 134 (defcustom mml2015-encrypt-to-self nil
 135   "If t, add your own key ID to recipient list when encryption."
 136   :group 'mime-security
 137   :type 'boolean)
 138
 139 (defcustom mml2015-always-trust t
 140   "If t, GnuPG skip key validation on encryption."
 141   :group 'mime-security
 142   :type 'boolean)
 143
 144 ;;; mailcrypt wrapper
 145
 146 (eval-and-compile
 147   (autoload 'mailcrypt-decrypt "mailcrypt")
 148   (autoload 'mailcrypt-verify "mailcrypt")
 149   (autoload 'mc-pgp-always-sign "mailcrypt")
 150   (autoload 'mc-encrypt-generic "mc-toplev")
 151   (autoload 'mc-cleanup-recipient-headers "mc-toplev")
 152   (autoload 'mc-sign-generic "mc-toplev"))
 153
 154 (eval-when-compile
 155   (defvar mc-default-scheme)
 156   (defvar mc-schemes))
 157
 158 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
 159 (defvar mml2015-verify-function 'mailcrypt-verify)
 160
 161 (defun mml2015-format-error (err)
 162   (if (stringp (cadr err))
 163       (cadr err)
 164     (format "%S" (cdr err))))
 165
 166 (defun mml2015-mailcrypt-decrypt (handle ctl)
 167   (catch 'error
 168     (let (child handles result)
 169       (unless (setq child (mm-find-part-by-type
 170                            (cdr handle)
 171                            "application/octet-stream" nil t))
 172         (mm-set-handle-multipart-parameter
 173          mm-security-handle 'gnus-info "Corrupted")
 174         (throw 'error handle))
 175       (with-temp-buffer
 176         (mm-insert-part child)
 177         (setq result
 178               (condition-case err
 179                   (funcall mml2015-decrypt-function)
 180                 (error
 181                  (mm-set-handle-multipart-parameter
 182                   mm-security-handle 'gnus-details (mml2015-format-error err))
 183                  nil)
 184                 (quit
 185                  (mm-set-handle-multipart-parameter
 186                   mm-security-handle 'gnus-details "Quit.")
 187                  nil)))
 188         (unless (car result)
 189           (mm-set-handle-multipart-parameter
 190            mm-security-handle 'gnus-info "Failed")
 191           (throw 'error handle))
 192         (setq handles (mm-dissect-buffer t)))
 193       (mm-destroy-parts handle)
 194       (mm-set-handle-multipart-parameter
 195        mm-security-handle 'gnus-info
 196        (concat "OK"
 197                (let ((sig (with-current-buffer mml2015-result-buffer
 198                             (mml2015-gpg-extract-signature-details))))
 199                  (concat ", Signer: " sig))))
 200       (if (listp (car handles))
 201           handles
 202         (list handles)))))
 203
 204 (defun mml2015-mailcrypt-clear-decrypt ()
 205   (let (result)
 206     (setq result
 207           (condition-case err
 208               (funcall mml2015-decrypt-function)
 209             (error
 210              (mm-set-handle-multipart-parameter
 211               mm-security-handle 'gnus-details (mml2015-format-error err))
 212              nil)
 213             (quit
 214              (mm-set-handle-multipart-parameter
 215               mm-security-handle 'gnus-details "Quit.")
 216              nil)))
 217     (if (car result)
 218         (mm-set-handle-multipart-parameter
 219          mm-security-handle 'gnus-info "OK")
 220       (mm-set-handle-multipart-parameter
 221        mm-security-handle 'gnus-info "Failed"))))
 222
 223 (defun mml2015-fix-micalg (alg)
 224   (and alg
 225        ;; Mutt/1.2.5i has seen sending micalg=php-sha1
 226        (upcase (if (string-match "^p[gh]p-" alg)
 227                    (substring alg (match-end 0))
 228                  alg))))
 229
 230 (defun mml2015-mailcrypt-verify (handle ctl)
 231   (catch 'error
 232     (let (part)
 233       (unless (setq part (mm-find-raw-part-by-type
 234                           ctl (or (mm-handle-multipart-ctl-parameter
 235                                    ctl 'protocol)
 236                                   "application/pgp-signature")
 237                           t))
 238         (mm-set-handle-multipart-parameter
 239          mm-security-handle 'gnus-info "Corrupted")
 240         (throw 'error handle))
 241       (with-temp-buffer
 242         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
 243         (insert (format "Hash: %s\n\n"
 244                         (or (mml2015-fix-micalg
 245                              (mm-handle-multipart-ctl-parameter
 246                               ctl 'micalg))
 247                             "SHA1")))
 248         (save-restriction
 249           (narrow-to-region (point) (point))
 250           (insert part "\n")
 251           (goto-char (point-min))
 252           (while (not (eobp))
 253             (if (looking-at "^-")
 254                 (insert "- "))
 255             (forward-line)))
 256         (unless (setq part (mm-find-part-by-type
 257                             (cdr handle) "application/pgp-signature" nil t))
 258           (mm-set-handle-multipart-parameter
 259            mm-security-handle 'gnus-info "Corrupted")
 260           (throw 'error handle))
 261         (save-restriction
 262           (narrow-to-region (point) (point))
 263           (mm-insert-part part)
 264           (goto-char (point-min))
 265           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
 266               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
 267           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
 268               (replace-match "-----END PGP SIGNATURE-----" t t)))
 269         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 270           (unless (condition-case err
 271                       (prog1
 272                           (funcall mml2015-verify-function)
 273                         (if (get-buffer " *mailcrypt stderr temp")
 274                             (mm-set-handle-multipart-parameter
 275                              mm-security-handle 'gnus-details
 276                              (with-current-buffer " *mailcrypt stderr temp"
 277                                (buffer-string))))
 278                         (if (get-buffer " *mailcrypt stdout temp")
 279                             (kill-buffer " *mailcrypt stdout temp"))
 280                         (if (get-buffer " *mailcrypt stderr temp")
 281                             (kill-buffer " *mailcrypt stderr temp"))
 282                         (if (get-buffer " *mailcrypt status temp")
 283                             (kill-buffer " *mailcrypt status temp"))
 284                         (if (get-buffer mc-gpg-debug-buffer)
 285                             (kill-buffer mc-gpg-debug-buffer)))
 286                     (error
 287                      (mm-set-handle-multipart-parameter
 288                       mm-security-handle 'gnus-details (mml2015-format-error err))
 289                      nil)
 290                     (quit
 291                      (mm-set-handle-multipart-parameter
 292                       mm-security-handle 'gnus-details "Quit.")
 293                      nil))
 294             (mm-set-handle-multipart-parameter
 295              mm-security-handle 'gnus-info "Failed")
 296             (throw 'error handle))))
 297       (mm-set-handle-multipart-parameter
 298        mm-security-handle 'gnus-info "OK")
 299       handle)))
 300
 301 (defun mml2015-mailcrypt-clear-verify ()
 302   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 303     (if (condition-case err
 304             (prog1
 305                 (funcall mml2015-verify-function)
 306               (if (get-buffer " *mailcrypt stderr temp")
 307                   (mm-set-handle-multipart-parameter
 308                    mm-security-handle 'gnus-details
 309                    (with-current-buffer " *mailcrypt stderr temp"
 310                      (buffer-string))))
 311               (if (get-buffer " *mailcrypt stdout temp")
 312                   (kill-buffer " *mailcrypt stdout temp"))
 313               (if (get-buffer " *mailcrypt stderr temp")
 314                   (kill-buffer " *mailcrypt stderr temp"))
 315               (if (get-buffer " *mailcrypt status temp")
 316                   (kill-buffer " *mailcrypt status temp"))
 317               (if (get-buffer mc-gpg-debug-buffer)
 318                   (kill-buffer mc-gpg-debug-buffer)))
 319           (error
 320            (mm-set-handle-multipart-parameter
 321             mm-security-handle 'gnus-details (mml2015-format-error err))
 322            nil)
 323           (quit
 324            (mm-set-handle-multipart-parameter
 325             mm-security-handle 'gnus-details "Quit.")
 326            nil))
 327         (mm-set-handle-multipart-parameter
 328          mm-security-handle 'gnus-info "OK")
 329       (mm-set-handle-multipart-parameter
 330        mm-security-handle 'gnus-info "Failed"))))
 331
 332 (defun mml2015-mailcrypt-sign (cont)
 333   (mc-sign-generic (message-options-get 'message-sender)
 334                    nil nil nil nil)
 335   (let ((boundary (mml-compute-boundary cont))
 336         hash point)
 337     (goto-char (point-min))
 338     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
 339       (error "Cannot find signed begin line"))
 340     (goto-char (match-beginning 0))
 341     (forward-line 1)
 342     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 343       (error "Cannot not find PGP hash"))
 344     (setq hash (match-string 1))
 345     (unless (re-search-forward "^$" nil t)
 346       (error "Cannot not find PGP message"))
 347     (forward-line 1)
 348     (delete-region (point-min) (point))
 349     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 350                     boundary))
 351     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 352                     (downcase hash)))
 353     (insert (format "\n--%s\n" boundary))
 354     (setq point (point))
 355     (goto-char (point-max))
 356     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
 357       (error "Cannot find signature part"))
 358     (replace-match "-----END PGP MESSAGE-----" t t)
 359     (goto-char (match-beginning 0))
 360     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
 361                                 nil t)