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-cache-passphrase mml-secure-cache-passphrase
 123   "If t, cache passphrase."
 124   :group 'mime-security
 125   :type 'boolean)
 126
 127 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
 128   "How many seconds the passphrase is cached.
 129 Whether the passphrase is cached at all is controlled by
 130 `mml2015-cache-passphrase'."
 131   :group 'mime-security
 132   :type 'integer)
 133
 134 (defcustom mml2015-signers nil
 135   "A list of your own key ID which will be used to sign a message."
 136   :group 'mime-security
 137   :type '(repeat (string :tag "Key ID")))
 138
 139 (defcustom mml2015-encrypt-to-self nil
 140   "If t, add your own key ID to recipient list when encryption."
 141   :group 'mime-security
 142   :type 'boolean)
 143
 144 (defcustom mml2015-always-trust t
 145   "If t, GnuPG skip key validation on encryption."
 146   :group 'mime-security
 147   :type 'boolean)
 148
 149 ;; Extract plaintext from cleartext signature.  IMO, this kind of task
 150 ;; should be done by GnuPG rather than Elisp, but older PGP backends
 151 ;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG.
 152 (defun mml2015-extract-cleartext-signature ()
 153   ;; Daiki Ueno in
 154   ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
 155   ;; believe that the right way is to use the plaintext output from GnuPG as
 156   ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
 157   ;; misdesigned libraries like PGG, which have no ability to do that.  So, I
 158   ;; think it should not have descriptive documentation.''
 159   ;;
 160   ;; This function doesn't handle NotDashEscaped correctly.  EasyPG handles it
 161   ;; correctly.
 162   ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
 163   ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
 164   (goto-char (point-min))
 165   (forward-line)
 166   ;; We need to be careful not to strip beyond the armor headers.
 167   ;; Previously, an attacker could replace the text inside our
 168   ;; markup with trailing garbage by injecting whitespace into the
 169   ;; message.
 170   (while (looking-at "Hash:")           ; The only header allowed in cleartext
 171     (forward-line))                     ; signatures according to RFC2440.
 172   (when (looking-at "[\t ]*$")
 173     (forward-line))
 174   (delete-region (point-min) (point))
 175   (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t)
 176       (delete-region (match-beginning 0) (point-max)))
 177   (goto-char (point-min))
 178   (while (re-search-forward "^- " nil t)
 179     (replace-match "" t t)
 180     (forward-line 1)))
 181
 182 ;;; mailcrypt wrapper
 183
 184 (autoload 'mailcrypt-decrypt "mailcrypt")
 185 (autoload 'mailcrypt-verify "mailcrypt")
 186 (autoload 'mc-pgp-always-sign "mailcrypt")
 187 (autoload 'mc-encrypt-generic "mc-toplev")
 188 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
 189 (autoload 'mc-sign-generic "mc-toplev")
 190
 191 (defvar mc-default-scheme)
 192 (defvar mc-schemes)
 193
 194 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
 195 (defvar mml2015-verify-function 'mailcrypt-verify)
 196
 197 (defun mml2015-format-error (err)
 198   (if (stringp (cadr err))
 199       (cadr err)
 200     (format "%S" (cdr err))))
 201
 202 (defun mml2015-mailcrypt-decrypt (handle ctl)
 203   (catch 'error
 204     (let (child handles result)
 205       (unless (setq child (mm-find-part-by-type
 206                            (cdr handle)
 207                            "application/octet-stream" nil t))
 208         (mm-set-handle-multipart-parameter
 209          mm-security-handle 'gnus-info "Corrupted")
 210         (throw 'error handle))
 211       (with-temp-buffer
 212         (mm-insert-part child)
 213         (setq result
 214               (condition-case err
 215                   (funcall mml2015-decrypt-function)
 216                 (error
 217                  (mm-set-handle-multipart-parameter
 218                   mm-security-handle 'gnus-details (mml2015-format-error err))
 219                  nil)
 220                 (quit
 221                  (mm-set-handle-multipart-parameter
 222                   mm-security-handle 'gnus-details "Quit.")
 223                  nil)))
 224         (unless (car result)
 225           (mm-set-handle-multipart-parameter
 226            mm-security-handle 'gnus-info "Failed")
 227           (throw 'error handle))
 228         (setq handles (mm-dissect-buffer t)))
 229       (mm-destroy-parts handle)
 230       (mm-set-handle-multipart-parameter
 231        mm-security-handle 'gnus-info
 232        (concat "OK"
 233                (let ((sig (with-current-buffer mml2015-result-buffer
 234                             (mml2015-gpg-extract-signature-details))))
 235                  (concat ", Signer: " sig))))
 236       (if (listp (car handles))
 237           handles
 238         (list handles)))))
 239
 240 (defun mml2015-mailcrypt-clear-decrypt ()
 241   (let (result)
 242     (setq result
 243           (condition-case err
 244               (funcall mml2015-decrypt-function)
 245             (error
 246              (mm-set-handle-multipart-parameter
 247               mm-security-handle 'gnus-details (mml2015-format-error err))
 248              nil)
 249             (quit
 250              (mm-set-handle-multipart-parameter
 251               mm-security-handle 'gnus-details "Quit.")
 252              nil)))
 253     (if (car result)
 254         (mm-set-handle-multipart-parameter
 255          mm-security-handle 'gnus-info "OK")
 256       (mm-set-handle-multipart-parameter
 257        mm-security-handle 'gnus-info "Failed"))))
 258
 259 (defun mml2015-fix-micalg (alg)
 260   (and alg
 261        ;; Mutt/1.2.5i has seen sending micalg=php-sha1
 262        (upcase (if (string-match "^p[gh]p-" alg)
 263                    (substring alg (match-end 0))
 264                  alg))))
 265
 266 (defun mml2015-mailcrypt-verify (handle ctl)
 267   (catch 'error
 268     (let (part)
 269       (unless (setq part (mm-find-raw-part-by-type
 270                           ctl (or (mm-handle-multipart-ctl-parameter
 271                                    ctl 'protocol)
 272                                   "application/pgp-signature")
 273                           t))
 274         (mm-set-handle-multipart-parameter
 275          mm-security-handle 'gnus-info "Corrupted")
 276         (throw 'error handle))
 277       (with-temp-buffer
 278         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
 279         (insert (format "Hash: %s\n\n"
 280                         (or (mml2015-fix-micalg
 281                              (mm-handle-multipart-ctl-parameter
 282                               ctl 'micalg))
 283                             "SHA1")))
 284         (save-restriction
 285           (narrow-to-region (point) (point))
 286           (insert part "\n")
 287           (goto-char (point-min))
 288           (while (not (eobp))
 289             (if (looking-at "^-")
 290                 (insert "- "))
 291             (forward-line)))
 292         (unless (setq part (mm-find-part-by-type
 293                             (cdr handle) "application/pgp-signature" nil t))
 294           (mm-set-handle-multipart-parameter
 295            mm-security-handle 'gnus-info "Corrupted")
 296           (throw 'error handle))
 297         (save-restriction
 298           (narrow-to-region (point) (point))
 299           (mm-insert-part part)
 300           (goto-char (point-min))
 301           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
 302               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
 303           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
 304               (replace-match "-----END PGP SIGNATURE-----" t t)))
 305         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 306           (unless (condition-case err
 307                       (prog1
 308                           (funcall mml2015-verify-function)
 309                         (if (get-buffer " *mailcrypt stderr temp")
 310                             (mm-set-handle-multipart-parameter
 311                              mm-security-handle 'gnus-details
 312                              (with-current-buffer " *mailcrypt stderr temp"
 313                                (buffer-string))))
 314                         (if (get-buffer " *mailcrypt stdout temp")
 315                             (kill-buffer " *mailcrypt stdout temp"))
 316                         (if (get-buffer " *mailcrypt stderr temp")
 317                             (kill-buffer " *mailcrypt stderr temp"))
 318                         (if (get-buffer " *mailcrypt status temp")
 319                             (kill-buffer " *mailcrypt status temp"))
 320                         (if (get-buffer mc-gpg-debug-buffer)
 321                             (kill-buffer mc-gpg-debug-buffer)))
 322                     (error
 323                      (mm-set-handle-multipart-parameter
 324                       mm-security-handle 'gnus-details (mml2015-format-error err))
 325                      nil)
 326                     (quit
 327                      (mm-set-handle-multipart-parameter
 328                       mm-security-handle 'gnus-details "Quit.")
 329                      nil))
 330             (mm-set-handle-multipart-parameter
 331              mm-security-handle 'gnus-info "Failed")
 332             (throw 'error handle))))
 333       (mm-set-handle-multipart-parameter
 334        mm-security-handle 'gnus-info "OK")
 335       handle)))
 336
 337 (defun mml2015-mailcrypt-clear-verify ()
 338   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 339     (if (condition-case err
 340             (prog1
 341                 (funcall mml2015-verify-function)
 342               (if (get-buffer " *mailcrypt stderr temp")
 343                   (mm-set-handle-multipart-parameter
 344                    mm-security-handle 'gnus-details
 345                    (with-current-buffer " *mailcrypt stderr temp"
 346                      (buffer-string))))
 347               (if (get-buffer " *mailcrypt stdout temp")
 348                   (kill-buffer " *mailcrypt stdout temp"))
 349               (if (get-buffer " *mailcrypt stderr temp")
 350                   (kill-buffer " *mailcrypt stderr temp"))
 351               (if (get-buffer " *mailcrypt status temp")
 352                   (kill-buffer " *mailcrypt status temp"))
 353               (if (get-buffer mc-gpg-debug-buffer)
 354                   (kill-buffer mc-gpg-debug-buffer)))
 355           (error
 356            (mm-set-handle-multipart-parameter
 357             mm-security-handle 'gnus-details (mml2015-format-error err))
 358            nil)
 359           (quit
 360            (mm-set-handle-multipart-parameter
 361             mm-security-handle 'gnus-details "Quit.")
 362            nil))
 363         (mm-set-handle-multipart-parameter
 364          mm-security-handle 'gnus-info "OK")
 365       (mm-set-handle-multipart-parameter
 366        mm-security-handle 'gnus-info "Failed")))
 367   (mml2015-extract-cleartext-signature))
 368
 369 (defun mml2015-mailcrypt-sign (cont)
 370   (mc-sign-generic (message-options-get 'message-sender)
 371                    nil nil nil nil)
 372   (let ((boundary (mml-compute-boundary cont))
 373         hash point)
 374     (goto-char (point-min))
 375     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
 376       (error "Cannot find signed begin line"))
 377     (goto-char (match-beginning 0))
 378     (forward-line 1)
 379     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 380       (error "Cannot not find PGP hash"))
 381     (setq hash (match-string 1))
 382     (unless (re-search-forward "^$" nil t)
 383       (error "Cannot not find PGP message"))
 384     (forward-line 1)
 385     (delete-region (point-min) (point))
 386     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 387                     boundary))
 388     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 389                     (downcase hash)))
 390     (insert (format "\n--%s\n" boundary))
 391     (setq point (point))
 392     (goto-char (point-max))
 393     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
 394       (error "Cannot find signature part"))
 395     (replace-match "-----END PGP MESSAGE-----" t t)
 396     (goto-char (match-beginning 0))
 397     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
 398                                 nil t)
 399       (error "Cannot find signature part"))
 400     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
 401     (goto-char (match-beginning 0))
 402     (save-restriction
 403       (narrow-to-region point (point))
 404       (goto-char point)
 405       (while (re-search-forward "^- -" nil t)
 406         (replace-match "-" t t))
 407       (goto-char (point-max)))
 408     (insert (format "--%s\n" boundary))
 409     (insert "Content-Type: application/pgp-signature\n\n")
 410     (goto-char (point-max))
 411     (insert (format "--%s--\n" boundary))
 412     (goto-char (point-max))))
 413
 414 ;; We require mm-decode, which requires mm-bodies, which autoloads
 415 ;; message-options-get (!).
 416 (declare-function message-options-set "message" (symbol value))
 417
 418 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
 419   (let ((mc-pgp-always-sign
 420          (or mc-pgp-always-sign
 421              sign
 422              (eq t (or (message-options-get 'message-sign-encrypt)
 423                        (message-options-set
 424                         'message-sign-encrypt
 425                         (or (y-or-n-p "Sign the message? ")
 426                             'not))))
 427              'never)))
 428     (mm-with-unibyte-current-buffer
 429       (mc-encrypt-generic
 430        (or (message-options-get 'message-recipients)
 431            (message-options-set 'message-recipients
 432                               (mc-cleanup-recipient-headers
 433                                (read-string "Recipients: "))))
 434        nil nil nil
 435        (message-options-get 'message-sender))))
 436   (goto-char (point-min))
 437   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
 438     (error "Fail to encrypt the message"))
 439   (let ((boundary (mml-compute-boundary cont)))
 440     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 441                     boundary))
 442     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 443     (insert (format "--%s\n" boundary))
 444     (insert "Content-Type: application/pgp-encrypted\n\n")
 445     (insert "Version: 1\n\n")
 446     (insert (format "--%s\n" boundary))
 447     (insert "Content-Type: application/octet-stream\n\n")
 448     (goto-char (point-max))
 449     (insert (format "--%s--\n" boundary))
 450     (goto-char (point-max))))
 451
 452 ;;; gpg wrapper
 453
 454 (autoload 'gpg-decrypt "gpg")
 455 (autoload 'gpg-verify "gpg")
 456 (autoload 'gpg-verify-cleartext "gpg")
 457 (autoload 'gpg-sign-detached "gpg")
 458 (autoload 'gpg-sign-encrypt "gpg")
 459 (autoload 'gpg-encrypt "gpg")
 460 (autoload 'gpg-passphrase-read "gpg")
 461
 462 (defun mml2015-gpg-passphrase ()
 463   (or (message-options-get 'gpg-passphrase)
 464       (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
 465
 466 (defun mml2015-gpg-decrypt-1 ()
 467   (let ((cipher (current-buffer)) plain result)
 468     (if (with-temp-buffer
 469           (prog1
 470               (gpg-decrypt cipher (setq plain (current-buffer))
 471                            mml2015-result-buffer nil)
 472             (mm-set-handle-multipart-parameter
 473              mm-security-handle 'gnus-details
 474              (with-current-buffer mml2015-result-buffer
 475                (buffer-string)))
 476             (set-buffer cipher)
 477             (erase-buffer)
 478             (insert-buffer-substring plain)
 479             (goto-char (point-min))
 480             (while (search-forward "\r\n" nil t)
 481               (replace-match "\n" t t))))
 482         '(t)
 483       ;; Some wrong with the return value, check plain text buffer.
 484       (if (> (point-max) (point-min))
 485           '(t)
 486         nil))))
 487
 488 (defun mml2015-gpg-decrypt (handle ctl)
 489   (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
 490     (mml2015-mailcrypt-decrypt handle ctl)))
 491
 492 (defun mml2015-gpg-clear-decrypt ()
 493   (let (result)
 494     (setq result (mml2015-gpg-decrypt-1))
 495     (if (car result)
 496         (mm-set-handle-multipart-parameter
 497          mm-security-handle 'gnus-info "OK")
 498       (mm-set-handle-multipart-parameter
 499        mm-security-handle 'gnus-info "Failed"))))
 500
 501 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
 502   (let* ((result "")
 503          (fpr-length (string-width fingerprint))
 504          (n-slice 0)
 505          slice)
 506     (setq fingerprint (string-to-list fingerprint))
 507     (while fingerprint
 508       (setq fpr-length (- fpr-length 4))
 509       (setq slice (butlast fingerprint fpr-length))
 510       (setq fingerprint (nthcdr 4 fingerprint))
 511       (setq n-slice (1+ n-slice))
 512       (setq result
 513             (concat
 514              result
 515              (case n-slice
 516                (1  slice)
 517                (otherwise (concat " " slice))))))
 518     result))
 519
 520 (defun mml2015-gpg-extract-signature-details ()
 521   (goto-char (point-min))
 522   (let* ((expired (re-search-forward
 523                    "^\\[GNUPG:\\] SIGEXPIRED$"
 524                    nil t))
 525          (signer (and (re-search-forward
 526                        "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
 527                        nil t)
 528                       (cons (match-string 1) (match-string 2))))
 529          (fprint (and (re-search-forward
 530                        "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
 531                        nil t)
 532                       (match-string 1)))
 533          (trust  (and (re-search-forward
 534                        "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
 535                        nil t)
 536                       (match-string 1)))
 537          (trust-good-enough-p
 538           (cdr (assoc trust mml2015-unabbrev-trust-alist))))
 539     (cond ((and signer fprint)
 540            (concat (cdr signer)
 541                    (unless trust-good-enough-p
 542                      (concat "\nUntrusted, Fingerprint: "
 543                              (mml2015-gpg-pretty-print-fpr fprint)))
 544                    (when expired
 545                      (format "\nWARNING: Signature from expired key (%s)"
 546                              (car signer)))))
 547           ((re-search-forward
 548             "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
 549            (match-string 2))
 550           (t
 551            "From unknown user"))))
 552
 553 (defun mml2015-gpg-verify (handle ctl)
 554   (catch 'error
 555     (let (part message signature info-is-set-p)
 556       (unless (setq part (mm-find-raw-part-by-type
 557                           ctl (or (mm-handle-multipart-ctl-parameter
 558                                    ctl 'protocol)
 559                                   "application/pgp-signature")
 560                           t))
 561         (mm-set-handle-multipart-parameter
 562          mm-security-handle 'gnus-info "Corrupted")
 563         (throw 'error handle))
 564       (with-temp-buffer
 565         (setq message (current-buffer))
 566         (insert part)
 567         ;; Convert <LF> to <CR><LF> in signed text.  If --textmode is
 568         ;; specified when signing, the conversion is not necessary.
 569         (goto-char (point-min))
 570         (end-of-line)
 571         (while (not (eobp))
 572           (unless (eq (char-before) ?\r)
 573             (insert "\r"))
 574           (forward-line)
 575           (end-of-line))
 576         (with-temp-buffer
 577           (setq signature (current-buffer))
 578           (unless (setq part (mm-find-part-by-type
 579                               (cdr handle) "application/pgp-signature" nil t))
 580             (mm-set-handle-multipart-parameter
 581              mm-security-handle 'gnus-info "Corrupted")
 582             (throw 'error handle))
 583           (mm-insert-part part)
 584           (unless (condition-case err
 585                       (prog1
 586                           (gpg-verify message signature mml2015-result-buffer)
 587                         (mm-set-handle-multipart-parameter
 588                          mm-security-handle 'gnus-details
 589                          (with-current-buffer mml2015-result-buffer
 590                            (buffer-string))))
 591                     (error
 592                      (mm-set-handle-multipart-parameter
 593                       mm-security-handle 'gnus-details (mml2015-format-error err))
 594                      (mm-set-handle-multipart-parameter
 595                       mm-security-handle 'gnus-info "Error.")
 596                      (setq info-is-set-p t)
 597                      nil)
 598                     (quit
 599                      (mm-set-handle-multipart-parameter
 600                       mm-security-handle 'gnus-details "Quit.")
 601                      (mm-set-handle-multipart-parameter
 602                       mm-security-handle 'gnus-info "Quit.")
 603                      (setq info-is-set-p t)
 604                      nil))
 605             (unless info-is-set-p
 606               (mm-set-handle-multipart-parameter
 607                mm-security-handle 'gnus-info "Failed"))
 608             (throw 'error handle)))
 609         (mm-set-handle-multipart-parameter
 610          mm-security-handle 'gnus-info
 611          (with-current-buffer mml2015-result-buffer
 612            (mml2015-gpg-extract-signature-details))))
 613       handle)))
 614
 615 (defun mml2015-gpg-clear-verify ()
 616   (if (condition-case err
 617           (prog1
 618               (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
 619             (mm-set-handle-multipart-parameter
 620              mm-security-handle 'gnus-details
 621              (with-current-buffer mml2015-result-buffer
 622                (buffer-string))))
 623         (error
 624          (mm-set-handle-multipart-parameter
 625           mm-security-handle 'gnus-details (mml2015-format-error err))
 626          nil)
 627         (quit
 628          (mm-set-handle-multipart-parameter
 629           mm-security-handle 'gnus-details "Quit.")
 630          nil))
 631       (mm-set-handle-multipart-parameter
 632        mm-security-handle 'gnus-info
 633        (with-current-buffer mml2015-result-buffer
 634          (mml2015-gpg-extract-signature-details)))
 635     (mm-set-handle-multipart-parameter
 636      mm-security-handle 'gnus-info "Failed"))
 637   (mml2015-extract-cleartext-signature))
 638
 639 (defun mml2015-gpg-sign (cont)
 640   (let ((boundary (mml-compute-boundary cont))
 641         (text (current-buffer)) signature)
 642     (goto-char (point-max))
 643     (unless (bolp)
 644       (insert "\n"))
 645     (with-temp-buffer
 646       (unless (gpg-sign-detached text (setq signature (current-buffer))
 647                                  mml2015-result-buffer
 648                                  nil
 649                                  (message-options-get 'message-sender)
 650                                  t t) ; armor & textmode
 651         (unless (> (point-max) (point-min))
 652           (pop-to-buffer mml2015-result-buffer)
 653           (error "Sign error")))
 654       (goto-char (point-min))
 655       (while (re-search-forward "\r+$" nil t)
 656         (replace-match "" t t))
 657       (set-buffer text)
 658       (goto-char (point-min))
 659       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 660                       boundary))
 661       ;;; FIXME: what is the micalg?
 662       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 663       (insert (format "\n--%s\n" boundary))
 664       (goto-char (point-max))
 665       (insert (format "\n--%s\n" boundary))
 666       (insert "Content-Type: application/pgp-signature\n\n")
 667       (insert-buffer-substring signature)
 668       (goto-char (point-max))
 669       (insert (format "--%s--\n" boundary))
 670       (goto-char (point-max)))))
 671
 672 (defun mml2015-gpg-encrypt (cont &optional sign)
 673   (let ((boundary (mml-compute-boundary cont))
 674         (text (current-buffer))
 675         cipher)
 676     (mm-with-unibyte-current-buffer
 677       (with-temp-buffer
 678         (mm-disable-multibyte)
 679         ;; set up a function to call the correct gpg encrypt routine
 680         ;; with the right arguments. (FIXME: this should be done
 681         ;; differently.)
 682         (flet ((gpg-encrypt-func
 683                  (sign plaintext ciphertext result recipients &optional
 684                        passphrase sign-with-key armor textmode)
 685                  (if sign
 686                      (gpg-sign-encrypt
 687                       plaintext ciphertext result recipients passphrase
 688                       sign-with-key armor textmode)
 689                    (gpg-encrypt
 690                     plaintext ciphertext result recipients passphrase
 691                     armor textmode))))
 692           (unless (gpg-encrypt-func
 693                     sign ; passed in when using signencrypt
 694                     text (setq cipher (current-buffer))
 695                     mml2015-result-buffer
 696                     (split-string
 697                      (or
 698                       (message-options-get 'message-recipients)
 699                       (message-options-set 'message-recipients
 700                                            (read-string "Recipients: ")))
 701                      "[ \f\t\n\r\v,]+")
 702                     nil
 703                     (message-options-get 'message-sender)
 704                     t t) ; armor & textmode
 705             (unless (> (point-max) (point-min))
 706               (pop-to-buffer mml2015-result-buffer)
 707               (error "Encrypt error"))))
 708         (goto-char (point-min))
 709         (while (re-search-forward "\r+$" nil t)
 710           (replace-match "" t t))
 711         (set-buffer text)
 712         (delete-region (point-min) (point-max))
 713         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 714                         boundary))
 715         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 716         (insert (format "--%s\n" boundary))
 717         (insert "Content-Type: application/pgp-encrypted\n\n")
 718         (insert "Version: 1\n\n")
 719         (insert (format "--%s\n" boundary))
 720         (insert "Content-Type: application/octet-stream\n\n")
 721         (insert-buffer-substring cipher)
 722         (goto-char (point-max))
 723         (insert (format "--%s--\n" boundary))
 724         (goto-char (point-max))))))
 725
 726 ;;; pgg wrapper
 727
 728 (defvar pgg-default-user-id)
 729 (defvar pgg-errors-buffer)
 730 (defvar pgg-output-buffer)
 731
 732 (autoload 'pgg-decrypt-region "pgg")
 733 (autoload 'pgg-verify-region "pgg")
 734 (autoload 'pgg-sign-region "pgg")
 735 (autoload 'pgg-encrypt-region "pgg")
 736 (autoload 'pgg-parse-armor "pgg-parse")
 737
 738 (defun mml2015-pgg-decrypt (handle ctl)
 739   (catch 'error
 740     (let ((pgg-errors-buffer mml2015-result-buffer)
 741           child handles result decrypt-status)
 742       (unless (setq child (mm-find-part-by-type
 743                            (cdr handle)
 744                            "application/octet-stream" nil t))
 745         (mm-set-handle-multipart-parameter
 746          mm-security-handle 'gnus-info "Corrupted")
 747         (throw 'error handle))
 748       (with-temp-buffer
 749         (mm-insert-part child)
 750         (if (condition-case err
 751                 (prog1
 752                     (pgg-decrypt-region (point-min) (point-max))
 753                   (setq decrypt-status
 754                         (with-current-buffer mml2015-result-buffer
 755                           (buffer-string)))
 756                   (mm-set-handle-multipart-parameter
 757                    mm-security-handle 'gnus-details
 758                    decrypt-status))
 759               (error
 760                (mm-set-handle-multipart-parameter
 761                 mm-security-handle 'gnus-details (mml2015-format-error err))
 762                nil)
 763               (quit
 764                (mm-set-handle-multipart-parameter
 765                 mm-security-handle 'gnus-details "Quit.")
 766                nil))
 767             (with-current-buffer pgg-output-buffer
 768               (goto-char (point-min))
 769               (while (search-forward "\r\n" nil t)
 770                 (replace-match "\n" t t))
 771               (setq handles (mm-dissect-buffer t))
 772               (mm-destroy-parts handle)
 773               (mm-set-handle-multipart-parameter
 774                mm-security-handle 'gnus-info "OK")
 775               (mm-set-handle-multipart-parameter
 776                mm-security-handle 'gnus-details
 777                (concat decrypt-status
 778                        (when (stringp (car handles))
 779                          "\n" (mm-handle-multipart-ctl-parameter
 780                                handles 'gnus-details))))
 781               (if (listp (car handles))
 782                   handles
 783                 (list handles)))
 784           (mm-set-handle-multipart-parameter
 785            mm-security-handle 'gnus-info "Failed")
 786           (throw 'error handle))))))
 787
 788 (defun mml2015-pgg-clear-decrypt ()
 789   (let ((pgg-errors-buffer mml2015-result-buffer))
 790     (if (prog1
 791             (pgg-decrypt-region (point-min) (point-max))
 792           (mm-set-handle-multipart-parameter
 793            mm-security-handle 'gnus-details
 794            (with-current-buffer mml2015-result-buffer
 795              (buffer-string))))
 796         (progn
 797           (erase-buffer)
 798           ;; Treat data which pgg returns as a unibyte string.
 799           (mm-disable-multibyte)
 800           (insert-buffer-substring pgg-output-buffer)
 801           (goto-char (point-min))
 802           (while (search-forward "\r\n" nil t)
 803             (replace-match "\n" t t))
 804           (mm-set-handle-multipart-parameter
 805            mm-security-handle 'gnus-info "OK"))
 806       (mm-set-handle-multipart-parameter
 807        mm-security-handle 'gnus-info "Failed"))))
 808
 809 (defun mml2015-pgg-verify (handle ctl)
 810   (let ((pgg-errors-buffer mml2015-result-buffer)
 811         signature-file part signature)
 812     (if (or (null (setq part (mm-find-raw-part-by-type
 813                               ctl (or (mm-handle-multipart-ctl-parameter
 814                                        ctl 'protocol)
 815                                       "application/pgp-signature")
 816                               t)))
 817             (null (setq signature (mm-find-part-by-type
 818                                    (cdr handle) "application/pgp-signature" nil t))))
 819         (progn
 820           (mm-set-handle-multipart-parameter
 821            mm-security-handle 'gnus-info "Corrupted")
 822           handle)
 823       (with-temp-buffer
 824         (insert part)
 825         ;; Convert <LF> to <CR><LF> in signed text.  If --textmode is
 826         ;; specified when signing, the conversion is not necessary.
 827         (goto-char (point-min))
 828         (end-of-line)
 829         (while (not (eobp))
 830           (unless (eq (char-before) ?\r)
 831             (insert "\r"))
 832           (forward-line)
 833           (end-of-line))
 834         (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
 835           (mm-insert-part signature))
 836         (if (condition-case err
 837                 (prog1
 838                     (pgg-verify-region (point-min) (point-max)
 839                                        signature-file t)
 840                   (goto-char (point-min))
 841                   (while (search-forward "\r\n" nil t)
 842                     (replace-match "\n" t t))
 843                   (mm-set-handle-multipart-parameter
 844                    mm-security-handle 'gnus-details
 845                    (concat (with-current-buffer pgg-output-buffer
 846                              (buffer-string))
 847                            (with-current-buffer pgg-errors-buffer
 848                              (buffer-string)))))
 849               (error
 850                (mm-set-handle-multipart-parameter
 851                 mm-security-handle 'gnus-details (mml2015-format-error err))
 852                nil)
 853               (quit
 854                (mm-set-handle-multipart-parameter
 855                 mm-security-handle 'gnus-details "Quit.")
 856                nil))
 857             (progn
 858               (delete-file signature-file)
 859               (mm-set-handle-multipart-parameter
 860                mm-security-handle 'gnus-info
 861                (with-current-buffer pgg-errors-buffer
 862                  (mml2015-gpg-extract-signature-details))))
 863           (delete-file signature-file)
 864           (mm-set-handle-multipart-parameter
 865            mm-security-handle 'gnus-info "Failed")))))
 866   handle)
 867
 868 (defun mml2015-pgg-clear-verify ()
 869   (let ((pgg-errors-buffer mml2015-result-buffer)
 870         (text (buffer-string))
 871         (coding-system buffer-file-coding-system))
 872     (if (condition-case err
 873             (prog1
 874                 (mm-with-unibyte-buffer
 875                   (insert (mm-encode-coding-string text coding-system))
 876                   (pgg-verify-region (point-min) (point-max) nil t))
 877               (goto-char (point-min))
 878               (while (search-forward "\r\n" nil t)
 879                 (replace-match "\n" t t))
 880               (mm-set-handle-multipart-parameter
 881                mm-security-handle 'gnus-details
 882                (concat (with-current-buffer pgg-output-buffer
 883                          (buffer-string))
 884                        (with-current-buffer pgg-errors-buffer
 885                          (buffer-string)))))
 886           (error
 887            (mm-set-handle-multipart-parameter
 888             mm-security-handle 'gnus-details (mml2015-format-error err))
 889            nil)
 890           (quit
 891            (mm-set-handle-multipart-parameter
 892             mm-security-handle 'gnus-details "Quit.")
 893            nil))
 894         (mm-set-handle-multipart-parameter
 895          mm-security-handle 'gnus-info
 896          (with-current-buffer pgg-errors-buffer
 897            (mml2015-gpg-extract-signature-details)))
 898       (mm-set-handle-multipart-parameter
 899        mm-security-handle 'gnus-info "Failed")))
 900   (mml2015-extract-cleartext-signature))
 901
 902 (defun mml2015-pgg-sign (cont)
 903   (let ((pgg-errors-buffer mml2015-result-buffer)
 904         (boundary (mml-compute-boundary cont))
 905         (pgg-default-user-id (or (message-options-get 'mml-sender)
 906                                  pgg-default-user-id))
 907         (pgg-text-mode t)
 908         entry)
 909     (unless (pgg-sign-region (point-min) (point-max))
 910       (pop-to-buffer mml2015-result-buffer)
 911       (error "Sign error"))
 912     (goto-char (point-min))
 913     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 914                     boundary))
 915     (if (setq entry (assq 2 (pgg-parse-armor
 916                              (with-current-buffer pgg-output-buffer
 917                                (buffer-string)))))
 918         (setq entry (assq 'hash-algorithm (cdr entry))))
 919     (insert (format "\tmicalg=%s; "
 920                     (if (cdr entry)
 921                         (downcase (format "pgp-%s" (cdr entry)))
 922                       "pgp-sha1")))
 923     (insert "protocol=\"application/pgp-signature\"\n")
 924     (insert (format "\n--%s\n" boundary))
 925     (goto-char (point-max))
 926     (insert (format "\n--%s\n" boundary))
 927     (insert "Content-Type: application/pgp-signature\n\n")
 928     (insert-buffer-substring pgg-output-buffer)
 929     (goto-char (point-max))
 930     (insert (format "--%s--\n" boundary))
 931     (goto-char (point-max))))
 932
 933 (defun mml2015-pgg-encrypt (cont &optional sign)
 934   (let ((pgg-errors-buffer mml2015-result-buffer)
 935         (pgg-text-mode t)
 936         (boundary (mml-compute-boundary cont)))
 937     (unless (pgg-encrypt-region (point-min) (point-max)
 938                                 (split-string
 939                                  (or
 940                                   (message-options-get 'message-recipients)
 941                                   (message-options-set 'message-recipients
 942                                                        (read-string "Recipients: ")))
 943                                  "[ \f\t\n\r\v,]+")
 944                                 sign)
 945       (pop-to-buffer mml2015-result-buffer)
 946       (error "Encrypt error"))
 947     (delete-region (point-min) (point-max))
 948     (goto-char (point-min))
 949     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 950                     boundary))
 951     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 952     (insert (format "--%s\n" boundary))
 953     (insert "Content-Type: application/pgp-encrypted\n\n")
 954     (insert "Version: 1\n\n")
 955     (insert (format "--%s\n" boundary))
 956     (insert "Content-Type: application/octet-stream\n\n")
 957     (insert-buffer-substring pgg-output-buffer)
 958     (goto-char (point-max))
 959     (insert (format "--%s--\n" boundary))
 960     (goto-char (point-max))))
 961
 962 ;;; epg wrapper
 963
 964 (defvar epg-user-id-alist)
 965 (defvar epg-digest-algorithm-alist)
 966 (defvar inhibit-redisplay)
 967
 968 (autoload 'epg-make-context "epg")
 969 (autoload 'epg-context-set-armor "epg")
 970 (autoload 'epg-context-set-textmode "epg")
 971 (autoload 'epg-context-set-signers "epg")
 972 (autoload 'epg-context-result-for "epg")
 973 (autoload 'epg-new-signature-digest-algorithm "epg")
 974 (autoload 'epg-verify-result-to-string "epg")
 975 (autoload 'epg-list-keys "epg")
 976 (autoload 'epg-decrypt-string "epg")
 977 (autoload 'epg-verify-string "epg")
 978 (autoload 'epg-sign-string "epg")
 979 (autoload 'epg-encrypt-string "epg")
 980 (autoload 'epg-passphrase-callback-function "epg")
 981 (autoload 'epg-context-set-passphrase-callback "epg")
 982 (autoload 'epg-key-sub-key-list "epg")
 983 (autoload 'epg-sub-key-capability "epg")
 984 (autoload 'epg-sub-key-validity "epg")
 985 (autoload 'epg-configuration "epg-config")
 986 (autoload 'epg-expand-group "epg-config")
 987 (autoload 'epa-select-keys "epa")
 988
 989 (defvar mml2015-epg-secret-key-id-list nil)
 990
 991 (defun mml2015-epg-passphrase-callback (context key-id ignore)
 992   (if (eq key-id 'SYM)
 993       (epg-passphrase-callback-function context key-id nil)
 994     (let* ((password-cache-key-id
 995             (if (eq key-id 'PIN)
 996                 "PIN"
 997                key-id))
 998            entry
 999            (passphrase
1000             (password-read
1001              (if (eq key-id 'PIN)
1002                  "Passphrase for PIN: "
1003                (if (setq entry (assoc key-id epg-user-id-alist))
1004                    (format "Passphrase for %s %s: " key-id (cdr entry))
1005                  (format "Passphrase for %s: " key-id)))
1006              password-cache-key-id)))
1007       (when passphrase
1008         (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
1009           (password-cache-add password-cache-key-id passphrase))
1010         (setq mml2015-epg-secret-key-id-list
1011               (cons password-cache-key-id mml2015-epg-secret-key-id-list))
1012         (copy-sequence passphrase)))))
1013
1014 (defun mml2015-epg-find-usable-key (keys usage)
1015   (catch 'found
1016     (while keys
1017       (let ((pointer (epg-key-sub-key-list (car keys))))
1018         (while pointer
1019           (if (and (memq usage (epg-sub-key-capability (car pointer)))
1020                    (not (memq 'disabled (epg-sub-key-capability (car pointer))))
1021                    (not (memq (epg-sub-key-validity (car pointer))
1022                               '(revoked expired))))
1023               (throw 'found (car keys)))
1024           (setq pointer (cdr pointer))))
1025       (setq keys (cdr keys)))))
1026
1027 (defun mml2015-epg-decrypt (handle ctl)
1028   (catch 'error
1029     (let ((inhibit-redisplay t)
1030           context plain child handles result decrypt-status)
1031       (unless (setq child (mm-find-part-by-type
1032                            (cdr handle)
1033                            "application/octet-stream" nil t))
1034         (mm-set-handle-multipart-parameter
1035          mm-security-handle 'gnus-info "Corrupted")
1036         (throw 'error handle))
1037       (setq context (epg-make-context))
1038       (if mml2015-cache-passphrase
1039           (epg-context-set-passphrase-callback
1040            context
1041            #'mml2015-epg-passphrase-callback))
1042       (condition-case error
1043           (setq plain (epg-decrypt-string context (mm-get-part child))
1044                 mml2015-epg-secret-key-id-list nil)
1045         (error
1046          (while mml2015-epg-secret-key-id-list
1047            (password-cache-remove (car mml2015-epg-secret-key-id-list))
1048            (setq mml2015-epg-secret-key-id-list
1049                  (cdr mml2015-epg-secret-key-id-list)))
1050          (mm-set-handle-multipart-parameter
1051           mm-security-handle 'gnus-info "Failed")
1052          (if (eq (car error) 'quit)
1053              (mm-set-handle-multipart-parameter
1054               mm-security-handle 'gnus-details "Quit.")
1055            (mm-set-handle-multipart-parameter
1056             mm-security-handle 'gnus-details (mml2015-format-error error)))
1057          (throw 'error handle)))
1058       (with-temp-buffer
1059         (insert plain)
1060         (goto-char (point-min))
1061         (while (search-forward "\r\n" nil t)
1062           (replace-match "\n" t t))
1063         (setq handles (mm-dissect-buffer t))
1064         (mm-destroy-parts handle)
1065         (if (epg-context-result-for context 'verify)
1066             (mm-set-handle-multipart-parameter
1067              mm-security-handle 'gnus-info
1068              (concat "OK\n"
1069                      (epg-verify-result-to-string
1070                       (epg-context-result-for context 'verify))))
1071           (mm-set-handle-multipart-parameter
1072            mm-security-handle 'gnus-info "OK"))
1073         (if (stringp (car handles))
1074             (mm-set-handle-multipart-parameter
1075              mm-security-handle 'gnus-details
1076              (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
1077         (if (listp (car handles))
1078             handles
1079           (list handles)))))
1080
1081 (defun mml2015-epg-clear-decrypt ()
1082   (let ((inhibit-redisplay t)
1083         (context (epg-make-context))
1084         plain)
1085     (if mml2015-cache-passphrase
1086         (epg-context-set-passphrase-callback
1087          context
1088          #'mml2015-epg-passphrase-callback))
1089     (condition-case error
1090         (setq plain (epg-decrypt-string context (buffer-string))
1091               mml2015-epg-secret-key-id-list nil)
1092       (error
1093        (while mml2015-epg-secret-key-id-list
1094          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1095          (setq mml2015-epg-secret-key-id-list
1096                (cdr mml2015-epg-secret-key-id-list)))
1097        (mm-set-handle-multipart-parameter
1098         mm-security-handle 'gnus-info "Failed")
1099        (if (eq (car error) 'quit)
1100            (mm-set-handle-multipart-parameter
1101             mm-security-handle 'gnus-details "Quit.")
1102          (mm-set-handle-multipart-parameter
1103           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1104     (when plain
1105       (erase-buffer)
1106       ;; Treat data which epg returns as a unibyte string.
1107       (mm-disable-multibyte)
1108       (insert plain)
1109       (goto-char (point-min))
1110       (while (search-forward "\r\n" nil t)
1111         (replace-match "\n" t t))
1112       (mm-set-handle-multipart-parameter
1113        mm-security-handle 'gnus-info "OK")
1114       (if (epg-context-result-for context 'verify)
1115           (mm-set-handle-multipart-parameter
1116            mm-security-handle 'gnus-details
1117            (epg-verify-result-to-string
1118             (epg-context-result-for context 'verify)))))))
1119
1120 (defun mml2015-epg-verify (handle ctl)
1121   (catch 'error
1122     (let ((inhibit-redisplay t)
1123           context plain signature-file part signature)
1124       (when (or (null (setq part (mm-find-raw-part-by-type
1125                                   ctl (or (mm-handle-multipart-ctl-parameter
1126                                            ctl 'protocol)
1127                                           "application/pgp-signature")
1128                                   t)))
1129                 (null (setq signature (mm-find-part-by-type
1130                                        (cdr handle) "application/pgp-signature"
1131                                        nil t))))
1132         (mm-set-handle-multipart-parameter
1133          mm-security-handle 'gnus-info "Corrupted")
1134         (throw 'error handle))
1135       (setq part (mm-replace-in-string part "\n" "\r\n" t)
1136             signature (mm-get-part signature)
1137             context (epg-make-context))
1138       (condition-case error
1139           (setq plain (epg-verify-string context signature part))
1140         (error
1141          (mm-set-handle-multipart-parameter
1142           mm-security-handle 'gnus-info "Failed")
1143          (if (eq (car error) 'quit)
1144              (mm-set-handle-multipart-parameter
1145               mm-security-handle 'gnus-details "Quit.")
1146            (mm-set-handle-multipart-parameter
1147             mm-security-handle 'gnus-details (mml2015-format-error error)))
1148          (throw 'error handle)))
1149       (mm-set-handle-multipart-parameter
1150        mm-security-handle 'gnus-info
1151        (epg-verify-result-to-string (epg-context-result-for context 'verify)))
1152       handle)))
1153
1154 (defun mml2015-epg-clear-verify ()
1155   (let ((inhibit-redisplay t)
1156         (context (epg-make-context))
1157         (signature (mm-encode-coding-string (buffer-string)
1158                                             coding-system-for-write))
1159         plain)
1160     (condition-case error
1161         (setq plain (epg-verify-string context signature))
1162       (error
1163        (mm-set-handle-multipart-parameter
1164         mm-security-handle 'gnus-info "Failed")
1165        (if (eq (car error) 'quit)
1166            (mm-set-handle-multipart-parameter
1167             mm-security-handle 'gnus-details "Quit.")
1168          (mm-set-handle-multipart-parameter
1169           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1170     (if plain
1171         (progn
1172           (mm-set-handle-multipart-parameter
1173            mm-security-handle 'gnus-info
1174            (epg-verify-result-to-string
1175             (epg-context-result-for context 'verify)))
1176           (delete-region (point-min) (point-max))
1177           (insert (mm-decode-coding-string plain coding-system-for-read)))
1178       (mml2015-extract-cleartext-signature))))
1179
1180 (defun mml2015-epg-sign (cont)
1181   (let* ((inhibit-redisplay t)
1182          (context (epg-make-context))
1183          (boundary (mml-compute-boundary cont))
1184          signer-key
1185          (signers
1186           (or (message-options-get 'mml2015-epg-signers)
1187               (message-options-set
1188                'mml2015-epg-signers
1189                (if (eq mm-sign-option 'guided)
1190                    (epa-select-keys context "\
1191 Select keys for signing.
1192 If no one is selected, default secret key is used.  "
1193                                     mml2015-signers t)
1194                  (if mml2015-signers
1195                      (delq nil
1196                            (mapcar
1197                             (lambda (signer)
1198                               (setq signer-key (mml2015-epg-find-usable-key
1199                                                 (epg-list-keys context signer t)
1200                                                 'sign))
1201                               (unless (or signer-key
1202                                           (y-or-n-p
1203                                            (format
1204                                             "No secret key for %s; skip it? "
1205                                             signer)))
1206                                 (error "No secret key for %s" signer))
1207                               signer-key)
1208                             mml2015-signers)))))))
1209          signature micalg)
1210     (epg-context-set-armor context t)
1211     (epg-context-set-textmode context t)
1212     (epg-context-set-signers context signers)
1213     (if mml2015-cache-passphrase
1214         (epg-context-set-passphrase-callback
1215          context
1216          #'mml2015-epg-passphrase-callback))
1217     (condition-case error
1218         (setq signature (epg-sign-string context (buffer-string) t)
1219               mml2015-epg-secret-key-id-list nil)
1220       (error
1221        (while mml2015-epg-secret-key-id-list
1222          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1223          (setq mml2015-epg-secret-key-id-list
1224                (cdr mml2015-epg-secret-key-id-list)))
1225        (signal (car error) (cdr error))))
1226     (if (epg-context-result-for context 'sign)
1227         (setq micalg (epg-new-signature-digest-algorithm
1228                       (car (epg-context-result-for context 'sign)))))
1229     (goto-char (point-min))
1230     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1231                     boundary))
1232     (if micalg
1233         (insert (format "\tmicalg=pgp-%s; "
1234                         (downcase
1235                          (cdr (assq micalg
1236                                     epg-digest-algorithm-alist))))))
1237     (insert "protocol=\"application/pgp-signature\"\n")
1238     (insert (format "\n--%s\n" boundary))
1239     (goto-char (point-max))
1240     (insert (format "\n--%s\n" boundary))
1241     (insert "Content-Type: application/pgp-signature\n\n")
1242     (insert signature)
1243     (goto-char (point-max))
1244     (insert (format "--%s--\n" boundary))
1245     (goto-char (point-max))))
1246
1247 (defun mml2015-epg-encrypt (cont &optional sign)
1248   (let ((inhibit-redisplay t)
1249         (context (epg-make-context))
1250         (config (epg-configuration))
1251         (recipients (message-options-get 'mml2015-epg-recipients))
1252         cipher signers
1253         (boundary (mml-compute-boundary cont))
1254         recipient-key signer-key)
1255     (unless recipients
1256       (setq recipients
1257             (apply #'nconc
1258                    (mapcar
1259                     (lambda (recipient)
1260                       (or (epg-expand-group config recipient)
1261                           (list (concat "<" recipient ">"))))
1262                     (split-string
1263                      (or (message-options-get 'message-recipients)
1264                          (message-options-set 'message-recipients
1265                                               (read-string "Recipients: ")))
1266                      "[ \f\t\n\r\v,]+"))))
1267       (when mml2015-encrypt-to-self
1268         (unless mml2015-signers
1269           (error "mml2015-signers not set"))
1270         (setq recipients (nconc recipients mml2015-signers)))
1271       (if (eq mm-encrypt-option 'guided)
1272           (setq recipients
1273                 (epa-select-keys context "\
1274 Select recipients for encryption.
1275 If no one is selected, symmetric encryption will be performed.  "
1276                                  recipients))
1277         (setq recipients
1278               (delq nil
1279                     (mapcar
1280                      (lambda (recipient)
1281                        (setq recipient-key (mml2015-epg-find-usable-key
1282                                             (epg-list-keys context recipient)
1283                                             'encrypt))
1284                        (unless (or recipient-key
1285                                    (y-or-n-p
1286                                     (format "No public key for %s; skip it? "
1287                                             recipient)))
1288                          (error "No public key for %s" recipient))
1289                        recipient-key)
1290                      recipients)))
1291         (unless recipients
1292           (error "No recipient specified")))
1293       (message-options-set 'mml2015-epg-recipients recipients))
1294     (when sign
1295       (setq signers
1296             (or (message-options-get 'mml2015-epg-signers)
1297                 (message-options-set
1298                  'mml2015-epg-signers
1299                  (if (eq mm-sign-option 'guided)
1300                      (epa-select-keys context "\
1301 Select keys for signing.
1302 If no one is selected, default secret key is used.  "
1303                                       mml2015-signers t)
1304                    (if mml2015-signers
1305                        (delq nil
1306                              (mapcar
1307                               (lambda (signer)
1308                                 (setq signer-key (mml2015-epg-find-usable-key
1309                                                   (epg-list-keys context signer t)
1310                                                   'sign))
1311                                 (unless (or signer-key
1312                                             (y-or-n-p
1313                                              (format
1314                                               "No secret key for %s; skip it? "
1315                                               signer)))
1316                                   (error "No secret key for %s" signer))
1317                                 signer-key)
1318                               mml2015-signers)))))))
1319       (epg-context-set-signers context signers))
1320     (epg-context-set-armor context t)
1321     (epg-context-set-textmode context t)
1322     (if mml2015-cache-passphrase
1323         (epg-context-set-passphrase-callback
1324          context
1325          #'mml2015-epg-passphrase-callback))
1326     (condition-case error
1327         (setq cipher
1328               (epg-encrypt-string context (buffer-string) recipients sign
1329                                   mml2015-always-trust)
1330               mml2015-epg-secret-key-id-list nil)
1331       (error
1332        (while mml2015-epg-secret-key-id-list
1333          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1334          (setq mml2015-epg-secret-key-id-list
1335                (cdr mml2015-epg-secret-key-id-list)))
1336        (signal (car error) (cdr error))))
1337     (delete-region (point-min) (point-max))
1338     (goto-char (point-min))
1339     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1340                     boundary))
1341     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1342     (insert (format "--%s\n" boundary))
1343     (insert "Content-Type: application/pgp-encrypted\n\n")
1344     (insert "Version: 1\n\n")
1345     (insert (format "--%s\n" boundary))
1346     (insert "Content-Type: application/octet-stream\n\n")
1347     (insert cipher)
1348     (goto-char (point-max))
1349     (insert (format "--%s--\n" boundary))
1350     (goto-char (point-max))))
1351
1352 ;;; General wrapper
1353
1354 (autoload 'gnus-buffer-live-p "gnus-util")
1355 (autoload 'gnus-get-buffer-create "gnus")
1356
1357 (defun mml2015-clean-buffer ()
1358   (if (gnus-buffer-live-p mml2015-result-buffer)
1359       (with-current-buffer mml2015-result-buffer
1360         (erase-buffer)
1361         t)
1362     (setq mml2015-result-buffer
1363           (gnus-get-buffer-create " *MML2015 Result*"))
1364     nil))
1365
1366 (defsubst mml2015-clear-decrypt-function ()
1367   (nth 6 (assq mml2015-use mml2015-function-alist)))
1368
1369 (defsubst mml2015-clear-verify-function ()
1370   (nth 5 (assq mml2015-use mml2015-function-alist)))
1371
1372 ;;;###autoload
1373 (defun mml2015-decrypt (handle ctl)
1374   (mml2015-clean-buffer)
1375   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1376     (if func
1377         (funcall func handle ctl)
1378       handle)))
1379
1380 ;;;###autoload
1381 (defun mml2015-decrypt-test (handle ctl)
1382   mml2015-use)
1383
1384 ;;;###autoload
1385 (defun mml2015-verify (handle ctl)
1386   (mml2015-clean-buffer)
1387   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1388     (if func
1389         (funcall func handle ctl)
1390       handle)))
1391
1392 ;;;###autoload
1393 (defun mml2015-verify-test (handle ctl)
1394   mml2015-use)
1395
1396 ;;;###autoload
1397 (defun mml2015-encrypt (cont &optional sign)
1398   (mml2015-clean-buffer)
1399   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1400     (if func
1401         (funcall func cont sign)
1402       (error "Cannot find encrypt function"))))
1403
1404 ;;;###autoload
1405 (defun mml2015-sign (cont)
1406   (mml2015-clean-buffer)
1407   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1408     (if func
1409         (funcall func cont)
1410       (error "Cannot find sign function"))))
1411
1412 ;;;###autoload
1413 (defun mml2015-self-encrypt ()
1414   (mml2015-encrypt nil))
1415
1416 (provide 'mml2015)
1417
1418 ;;; mml2015.el ends here