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                     boundary))
 393     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 394                     (downcase hash)))
 395     (insert (format "\n--%s\n" boundary))
 396     (setq point (point))
 397     (goto-char (point-max))
 398     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
 399       (error "Cannot find signature part"))
 400     (replace-match "-----END PGP MESSAGE-----" t t)
 401     (goto-char (match-beginning 0))
 402     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
 403                                 nil t)
 404       (error "Cannot find signature part"))
 405     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
 406     (goto-char (match-beginning 0))
 407     (save-restriction
 408       (narrow-to-region point (point))
 409       (goto-char point)
 410       (while (re-search-forward "^- -" nil t)
 411         (replace-match "-" t t))
 412       (goto-char (point-max)))
 413     (insert (format "--%s\n" boundary))
 414     (insert "Content-Type: application/pgp-signature\n\n")
 415     (goto-char (point-max))
 416     (insert (format "--%s--\n" boundary))
 417     (goto-char (point-max))))
 418
 419 ;; We require mm-decode, which requires mm-bodies, which autoloads
 420 ;; message-options-get (!).
 421 (declare-function message-options-set "message" (symbol value))
 422
 423 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
 424   (let ((mc-pgp-always-sign
 425          (or mc-pgp-always-sign
 426              sign
 427              (eq t (or (message-options-get 'message-sign-encrypt)
 428                        (message-options-set
 429                         'message-sign-encrypt
 430                         (or (y-or-n-p "Sign the message? ")
 431                             'not))))
 432              'never)))
 433     (mm-with-unibyte-current-buffer
 434       (mc-encrypt-generic
 435        (or (message-options-get 'message-recipients)
 436            (message-options-set 'message-recipients
 437                               (mc-cleanup-recipient-headers
 438                                (read-string "Recipients: "))))
 439        nil nil nil
 440        (message-options-get 'message-sender))))
 441   (goto-char (point-min))
 442   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
 443     (error "Fail to encrypt the message"))
 444   (let ((boundary (mml-compute-boundary cont)))
 445     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 446                     boundary))
 447     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 448     (insert (format "--%s\n" boundary))
 449     (insert "Content-Type: application/pgp-encrypted\n\n")
 450     (insert "Version: 1\n\n")
 451     (insert (format "--%s\n" boundary))
 452     (insert "Content-Type: application/octet-stream\n\n")
 453     (goto-char (point-max))
 454     (insert (format "--%s--\n" boundary))
 455     (goto-char (point-max))))
 456
 457 ;;; gpg wrapper
 458
 459 (autoload 'gpg-decrypt "gpg")
 460 (autoload 'gpg-verify "gpg")
 461 (autoload 'gpg-verify-cleartext "gpg")
 462 (autoload 'gpg-sign-detached "gpg")
 463 (autoload 'gpg-sign-encrypt "gpg")
 464 (autoload 'gpg-encrypt "gpg")
 465 (autoload 'gpg-passphrase-read "gpg")
 466
 467 (defun mml2015-gpg-passphrase ()
 468   (or (message-options-get 'gpg-passphrase)
 469       (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
 470
 471 (defun mml2015-gpg-decrypt-1 ()
 472   (let ((cipher (current-buffer)) plain result)
 473     (if (with-temp-buffer
 474           (prog1
 475               (gpg-decrypt cipher (setq plain (current-buffer))
 476                            mml2015-result-buffer nil)
 477             (mm-set-handle-multipart-parameter
 478              mm-security-handle 'gnus-details
 479              (with-current-buffer mml2015-result-buffer
 480                (buffer-string)))
 481             (set-buffer cipher)
 482             (erase-buffer)
 483             (insert-buffer-substring plain)
 484             (goto-char (point-min))
 485             (while (search-forward "\r\n" nil t)
 486               (replace-match "\n" t t))))
 487         '(t)
 488       ;; Some wrong with the return value, check plain text buffer.
 489       (if (> (point-max) (point-min))
 490           '(t)
 491         nil))))
 492
 493 (defun mml2015-gpg-decrypt (handle ctl)
 494   (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
 495     (mml2015-mailcrypt-decrypt handle ctl)))
 496
 497 (defun mml2015-gpg-clear-decrypt ()
 498   (let (result)
 499     (setq result (mml2015-gpg-decrypt-1))
 500     (if (car result)
 501         (mm-set-handle-multipart-parameter
 502          mm-security-handle 'gnus-info "OK")
 503       (mm-set-handle-multipart-parameter
 504        mm-security-handle 'gnus-info "Failed"))))
 505
 506 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
 507   (let* ((result "")
 508          (fpr-length (string-width fingerprint))
 509          (n-slice 0)
 510          slice)
 511     (setq fingerprint (string-to-list fingerprint))
 512     (while fingerprint
 513       (setq fpr-length (- fpr-length 4))
 514       (setq slice (butlast fingerprint fpr-length))
 515       (setq fingerprint (nthcdr 4 fingerprint))
 516       (setq n-slice (1+ n-slice))
 517       (setq result
 518             (concat
 519              result
 520              (case n-slice
 521                (1  slice)
 522                (otherwise (concat " " slice))))))
 523     result))
 524
 525 (defun mml2015-gpg-extract-signature-details ()
 526   (goto-char (point-min))
 527   (let* ((expired (re-search-forward
 528                    "^\\[GNUPG:\\] SIGEXPIRED$"
 529                    nil t))
 530          (signer (and (re-search-forward
 531                        "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
 532                        nil t)
 533                       (cons (match-string 1) (match-string 2))))
 534          (fprint (and (re-search-forward
 535                        "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
 536                        nil t)
 537                       (match-string 1)))
 538          (trust  (and (re-search-forward
 539                        "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
 540                        nil t)
 541                       (match-string 1)))
 542          (trust-good-enough-p
 543           (cdr (assoc trust mml2015-unabbrev-trust-alist))))
 544     (cond ((and signer fprint)
 545            (concat (cdr signer)
 546                    (unless trust-good-enough-p
 547                      (concat "\nUntrusted, Fingerprint: "
 548                              (mml2015-gpg-pretty-print-fpr fprint)))
 549                    (when expired
 550                      (format "\nWARNING: Signature from expired key (%s)"
 551                              (car signer)))))
 552           ((re-search-forward
 553             "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
 554            (match-string 2))
 555           (t
 556            "From unknown user"))))
 557
 558 (defun mml2015-gpg-verify (handle ctl)
 559   (catch 'error
 560     (let (part message signature info-is-set-p)
 561       (unless (setq part (mm-find-raw-part-by-type
 562                           ctl (or (mm-handle-multipart-ctl-parameter
 563                                    ctl 'protocol)
 564                                   "application/pgp-signature")
 565                           t))
 566         (mm-set-handle-multipart-parameter
 567          mm-security-handle 'gnus-info "Corrupted")
 568         (throw 'error handle))
 569       (with-temp-buffer
 570         (setq message (current-buffer))
 571         (insert part)
 572         ;; Convert <LF> to <CR><LF> in signed text.  If --textmode is
 573         ;; specified when signing, the conversion is not necessary.
 574         (goto-char (point-min))
 575         (end-of-line)
 576         (while (not (eobp))
 577           (unless (eq (char-before) ?\r)
 578             (insert "\r"))
 579           (forward-line)
 580           (end-of-line))
 581         (with-temp-buffer
 582           (setq signature (current-buffer))
 583           (unless (setq part (mm-find-part-by-type
 584                               (cdr handle) "application/pgp-signature" nil t))
 585             (mm-set-handle-multipart-parameter
 586              mm-security-handle 'gnus-info "Corrupted")
 587             (throw 'error handle))
 588           (mm-insert-part part)
 589           (unless (condition-case err
 590                       (prog1
 591                           (gpg-verify message signature mml2015-result-buffer)
 592                         (mm-set-handle-multipart-parameter
 593                          mm-security-handle 'gnus-details
 594                          (with-current-buffer mml2015-result-buffer
 595                            (buffer-string))))
 596                     (error
 597                      (mm-set-handle-multipart-parameter
 598                       mm-security-handle 'gnus-details (mml2015-format-error err))
 599                      (mm-set-handle-multipart-parameter
 600                       mm-security-handle 'gnus-info "Error.")
 601                      (setq info-is-set-p t)
 602                      nil)
 603                     (quit
 604                      (mm-set-handle-multipart-parameter
 605                       mm-security-handle 'gnus-details "Quit.")
 606                      (mm-set-handle-multipart-parameter
 607                       mm-security-handle 'gnus-info "Quit.")
 608                      (setq info-is-set-p t)
 609                      nil))
 610             (unless info-is-set-p
 611               (mm-set-handle-multipart-parameter
 612                mm-security-handle 'gnus-info "Failed"))
 613             (throw 'error handle)))
 614         (mm-set-handle-multipart-parameter
 615          mm-security-handle 'gnus-info
 616          (with-current-buffer mml2015-result-buffer
 617            (mml2015-gpg-extract-signature-details))))
 618       handle)))
 619
 620 (defun mml2015-gpg-clear-verify ()
 621   (if (condition-case err
 622           (prog1
 623               (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
 624             (mm-set-handle-multipart-parameter
 625              mm-security-handle 'gnus-details
 626              (with-current-buffer mml2015-result-buffer
 627                (buffer-string))))
 628         (error
 629          (mm-set-handle-multipart-parameter
 630           mm-security-handle 'gnus-details (mml2015-format-error err))
 631          nil)
 632         (quit
 633          (mm-set-handle-multipart-parameter
 634           mm-security-handle 'gnus-details "Quit.")
 635          nil))
 636       (mm-set-handle-multipart-parameter
 637        mm-security-handle 'gnus-info
 638        (with-current-buffer mml2015-result-buffer
 639          (mml2015-gpg-extract-signature-details)))
 640     (mm-set-handle-multipart-parameter
 641      mm-security-handle 'gnus-info "Failed"))
 642   (mml2015-extract-cleartext-signature))
 643
 644 (defun mml2015-gpg-sign (cont)
 645   (let ((boundary (mml-compute-boundary cont))
 646         (text (current-buffer)) signature)
 647     (goto-char (point-max))
 648     (unless (bolp)
 649       (insert "\n"))
 650     (with-temp-buffer
 651       (unless (gpg-sign-detached text (setq signature (current-buffer))
 652                                  mml2015-result-buffer
 653                                  nil
 654                                  (message-options-get 'message-sender)
 655                                  t t) ; armor & textmode
 656         (unless (> (point-max) (point-min))
 657           (pop-to-buffer mml2015-result-buffer)
 658           (error "Sign error")))
 659       (goto-char (point-min))
 660       (while (re-search-forward "\r+$" nil t)
 661         (replace-match "" t t))
 662       (set-buffer text)
 663       (goto-char (point-min))
 664       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 665                       boundary))
 666       ;;; FIXME: what is the micalg?
 667       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 668       (insert (format "\n--%s\n" boundary))
 669       (goto-char (point-max))
 670       (insert (format "\n--%s\n" boundary))
 671       (insert "Content-Type: application/pgp-signature\n\n")
 672       (insert-buffer-substring signature)
 673       (goto-char (point-max))
 674       (insert (format "--%s--\n" boundary))
 675       (goto-char (point-max)))))
 676
 677 (defun mml2015-gpg-encrypt (cont &optional sign)
 678   (let ((boundary (mml-compute-boundary cont))
 679         (text (current-buffer))
 680         cipher)
 681     (mm-with-unibyte-current-buffer
 682       (with-temp-buffer
 683         ;; set up a function to call the correct gpg encrypt routine
 684         ;; with the right arguments. (FIXME: this should be done
 685         ;; differently.)
 686         (flet ((gpg-encrypt-func
 687                  (sign plaintext ciphertext result recipients &optional
 688                        passphrase sign-with-key armor textmode)
 689                  (if sign
 690                      (gpg-sign-encrypt
 691                       plaintext ciphertext result recipients passphrase
 692                       sign-with-key armor textmode)
 693                    (gpg-encrypt
 694                     plaintext ciphertext result recipients passphrase
 695                     armor textmode))))
 696           (unless (gpg-encrypt-func
 697                     sign ; passed in when using signencrypt
 698                     text (setq cipher (current-buffer))
 699                     mml2015-result-buffer
 700                     (split-string
 701                      (or
 702                       (message-options-get 'message-recipients)
 703                       (message-options-set 'message-recipients
 704                                            (read-string "Recipients: ")))
 705                      "[ \f\t\n\r\v,]+")
 706                     nil
 707                     (message-options-get 'message-sender)
 708                     t t) ; armor & textmode
 709             (unless (> (point-max) (point-min))
 710               (pop-to-buffer mml2015-result-buffer)
 711               (error "Encrypt error"))))
 712         (goto-char (point-min))
 713         (while (re-search-forward "\r+$" nil t)
 714           (replace-match "" t t))
 715         (set-buffer text)
 716         (delete-region (point-min) (point-max))
 717         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 718                         boundary))
 719         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 720         (insert (format "--%s\n" boundary))
 721         (insert "Content-Type: application/pgp-encrypted\n\n")
 722         (insert "Version: 1\n\n")
 723         (insert (format "--%s\n" boundary))
 724         (insert "Content-Type: application/octet-stream\n\n")
 725         (insert-buffer-substring cipher)
 726         (goto-char (point-max))
 727         (insert (format "--%s--\n" boundary))
 728         (goto-char (point-max))))))
 729
 730 ;;; pgg wrapper
 731
 732 (defvar pgg-default-user-id)
 733 (defvar pgg-errors-buffer)
 734 (defvar pgg-output-buffer)
 735
 736 (autoload 'pgg-decrypt-region "pgg")
 737 (autoload 'pgg-verify-region "pgg")
 738 (autoload 'pgg-sign-region "pgg")
 739 (autoload 'pgg-encrypt-region "pgg")
 740 (autoload 'pgg-parse-armor "pgg-parse")
 741
 742 (defun mml2015-pgg-decrypt (handle ctl)
 743   (catch 'error
 744     (let ((pgg-errors-buffer mml2015-result-buffer)
 745           child handles result decrypt-status)
 746       (unless (setq child (mm-find-part-by-type
 747                            (cdr handle)
 748                            "application/octet-stream" nil t))
 749         (mm-set-handle-multipart-parameter
 750          mm-security-handle 'gnus-info "Corrupted")
 751         (throw 'error handle))
 752       (with-temp-buffer
 753         (mm-insert-part child)
 754         (if (condition-case err
 755                 (prog1
 756                     (pgg-decrypt-region (point-min) (point-max))
 757                   (setq decrypt-status
 758                         (with-current-buffer mml2015-result-buffer
 759                           (buffer-string)))
 760                   (mm-set-handle-multipart-parameter
 761                    mm-security-handle 'gnus-details
 762                    decrypt-status))
 763               (error
 764                (mm-set-handle-multipart-parameter
 765                 mm-security-handle 'gnus-details (mml2015-format-error err))
 766                nil)
 767               (quit
 768                (mm-set-handle-multipart-parameter
 769                 mm-security-handle 'gnus-details "Quit.")
 770                nil))
 771             (with-current-buffer pgg-output-buffer
 772               (goto-char (point-min))
 773               (while (search-forward "\r\n" nil t)
 774                 (replace-match "\n" t t))
 775               (setq handles (mm-dissect-buffer t))
 776               (mm-destroy-parts handle)
 777               (mm-set-handle-multipart-parameter
 778                mm-security-handle 'gnus-info "OK")
 779               (mm-set-handle-multipart-parameter
 780                mm-security-handle 'gnus-details
 781                (concat decrypt-status
 782                        (when (stringp (car handles))
 783                          "\n" (mm-handle-multipart-ctl-parameter
 784                                handles 'gnus-details))))
 785               (if (listp (car handles))
 786                   handles
 787                 (list handles)))
 788           (mm-set-handle-multipart-parameter
 789            mm-security-handle 'gnus-info "Failed")
 790           (throw 'error handle))))))
 791
 792 (defun mml2015-pgg-clear-decrypt ()
 793   (let ((pgg-errors-buffer mml2015-result-buffer))
 794     (if (prog1
 795             (pgg-decrypt-region (point-min) (point-max))
 796           (mm-set-handle-multipart-parameter
 797            mm-security-handle 'gnus-details
 798            (with-current-buffer mml2015-result-buffer
 799              (buffer-string))))
 800         (progn
 801           (erase-buffer)
 802           ;; Treat data which pgg returns as a unibyte string.
 803           (mm-disable-multibyte)
 804           (insert-buffer-substring pgg-output-buffer)
 805           (goto-char (point-min))
 806           (while (search-forward "\r\n" nil t)
 807             (replace-match "\n" t t))
 808           (mm-set-handle-multipart-parameter
 809            mm-security-handle 'gnus-info "OK"))
 810       (mm-set-handle-multipart-parameter
 811        mm-security-handle 'gnus-info "Failed"))))
 812
 813 (defun mml2015-pgg-verify (handle ctl)
 814   (let ((pgg-errors-buffer mml2015-result-buffer)
 815         signature-file part signature)
 816     (if (or (null (setq part (mm-find-raw-part-by-type
 817                               ctl (or (mm-handle-multipart-ctl-parameter
 818                                        ctl 'protocol)
 819                                       "application/pgp-signature")
 820                               t)))
 821             (null (setq signature (mm-find-part-by-type
 822                                    (cdr handle) "application/pgp-signature" nil t))))
 823         (progn
 824           (mm-set-handle-multipart-parameter
 825            mm-security-handle 'gnus-info "Corrupted")
 826           handle)
 827       (with-temp-buffer
 828         (insert part)
 829         ;; Convert <LF> to <CR><LF> in signed text.  If --textmode is
 830         ;; specified when signing, the conversion is not necessary.
 831         (goto-char (point-min))
 832         (end-of-line)
 833         (while (not (eobp))
 834           (unless (eq (char-before) ?\r)
 835             (insert "\r"))
 836           (forward-line)
 837           (end-of-line))
 838         (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
 839           (mm-insert-part signature))
 840         (if (condition-case err
 841                 (prog1
 842                     (pgg-verify-region (point-min) (point-max)
 843                                        signature-file t)
 844                   (goto-char (point-min))
 845                   (while (search-forward "\r\n" nil t)
 846                     (replace-match "\n" t t))
 847                   (mm-set-handle-multipart-parameter
 848                    mm-security-handle 'gnus-details
 849                    (concat (with-current-buffer pgg-output-buffer
 850                              (buffer-string))
 851                            (with-current-buffer pgg-errors-buffer
 852                              (buffer-string)))))
 853               (error
 854                (mm-set-handle-multipart-parameter
 855                 mm-security-handle 'gnus-details (mml2015-format-error err))
 856                nil)
 857               (quit
 858                (mm-set-handle-multipart-parameter
 859                 mm-security-handle 'gnus-details "Quit.")
 860                nil))
 861             (progn
 862               (delete-file signature-file)
 863               (mm-set-handle-multipart-parameter
 864                mm-security-handle 'gnus-info
 865                (with-current-buffer pgg-errors-buffer
 866                  (mml2015-gpg-extract-signature-details))))
 867           (delete-file signature-file)
 868           (mm-set-handle-multipart-parameter
 869            mm-security-handle 'gnus-info "Failed")))))
 870   handle)
 871
 872 (defun mml2015-pgg-clear-verify ()
 873   (let ((pgg-errors-buffer mml2015-result-buffer)
 874         (text (buffer-string))
 875         (coding-system buffer-file-coding-system))
 876     (if (condition-case err
 877             (prog1
 878                 (mm-with-unibyte-buffer
 879                   (insert (mm-encode-coding-string text coding-system))
 880                   (pgg-verify-region (point-min) (point-max) nil t))
 881               (goto-char (point-min))
 882               (while (search-forward "\r\n" nil t)
 883                 (replace-match "\n" t t))
 884               (mm-set-handle-multipart-parameter
 885                mm-security-handle 'gnus-details
 886                (concat (with-current-buffer pgg-output-buffer
 887                          (buffer-string))
 888                        (with-current-buffer pgg-errors-buffer
 889                          (buffer-string)))))
 890           (error
 891            (mm-set-handle-multipart-parameter
 892             mm-security-handle 'gnus-details (mml2015-format-error err))
 893            nil)
 894           (quit
 895            (mm-set-handle-multipart-parameter
 896             mm-security-handle 'gnus-details "Quit.")
 897            nil))
 898         (mm-set-handle-multipart-parameter
 899          mm-security-handle 'gnus-info
 900          (with-current-buffer pgg-errors-buffer
 901            (mml2015-gpg-extract-signature-details)))
 902       (mm-set-handle-multipart-parameter
 903        mm-security-handle 'gnus-info "Failed")))
 904   (mml2015-extract-cleartext-signature))
 905
 906 (defun mml2015-pgg-sign (cont)
 907   (let ((pgg-errors-buffer mml2015-result-buffer)
 908         (boundary (mml-compute-boundary cont))
 909         (pgg-default-user-id (or (message-options-get 'mml-sender)
 910                                  pgg-default-user-id))
 911         (pgg-text-mode t)
 912         entry)
 913     (unless (pgg-sign-region (point-min) (point-max))
 914       (pop-to-buffer mml2015-result-buffer)
 915       (error "Sign error"))
 916     (goto-char (point-min))
 917     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 918                     boundary))
 919     (if (setq entry (assq 2 (pgg-parse-armor
 920                              (with-current-buffer pgg-output-buffer
 921                                (buffer-string)))))
 922         (setq entry (assq 'hash-algorithm (cdr entry))))
 923     (insert (format "\tmicalg=%s; "
 924                     (if (cdr entry)
 925                         (downcase (format "pgp-%s" (cdr entry)))
 926                       "pgp-sha1")))
 927     (insert "protocol=\"application/pgp-signature\"\n")
 928     (insert (format "\n--%s\n" boundary))
 929     (goto-char (point-max))
 930     (insert (format "\n--%s\n" boundary))
 931     (insert "Content-Type: application/pgp-signature\n\n")
 932     (insert-buffer-substring pgg-output-buffer)
 933     (goto-char (point-max))
 934     (insert (format "--%s--\n" boundary))
 935     (goto-char (point-max))))
 936
 937 (defun mml2015-pgg-encrypt (cont &optional sign)
 938   (let ((pgg-errors-buffer mml2015-result-buffer)
 939         (pgg-text-mode t)
 940         (boundary (mml-compute-boundary cont)))
 941     (unless (pgg-encrypt-region (point-min) (point-max)
 942                                 (split-string
 943                                  (or
 944                                   (message-options-get 'message-recipients)
 945                                   (message-options-set 'message-recipients
 946                                                        (read-string "Recipients: ")))
 947                                  "[ \f\t\n\r\v,]+")
 948                                 sign)
 949       (pop-to-buffer mml2015-result-buffer)
 950       (error "Encrypt error"))
 951     (delete-region (point-min) (point-max))
 952     (goto-char (point-min))
 953     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 954                     boundary))
 955     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 956     (insert (format "--%s\n" boundary))
 957     (insert "Content-Type: application/pgp-encrypted\n\n")
 958     (insert "Version: 1\n\n")
 959     (insert (format "--%s\n" boundary))
 960     (insert "Content-Type: application/octet-stream\n\n")
 961     (insert-buffer-substring pgg-output-buffer)
 962     (goto-char (point-max))
 963     (insert (format "--%s--\n" boundary))
 964     (goto-char (point-max))))
 965
 966 ;;; epg wrapper
 967
 968 (defvar epg-user-id-alist)
 969 (defvar epg-digest-algorithm-alist)
 970 (defvar inhibit-redisplay)
 971
 972 (autoload 'epg-make-context "epg")
 973 (autoload 'epg-context-set-armor "epg")
 974 (autoload 'epg-context-set-textmode "epg")
 975 (autoload 'epg-context-set-signers "epg")
 976 (autoload 'epg-context-result-for "epg")
 977 (autoload 'epg-new-signature-digest-algorithm "epg")
 978 (autoload 'epg-verify-result-to-string "epg")
 979 (autoload 'epg-list-keys "epg")
 980 (autoload 'epg-decrypt-string "epg")
 981 (autoload 'epg-verify-string "epg")
 982 (autoload 'epg-sign-string "epg")
 983 (autoload 'epg-encrypt-string "epg")
 984 (autoload 'epg-passphrase-callback-function "epg")
 985 (autoload 'epg-context-set-passphrase-callback "epg")
 986 (autoload 'epg-key-sub-key-list "epg")
 987 (autoload 'epg-sub-key-capability "epg")
 988 (autoload 'epg-sub-key-validity "epg")
 989 (autoload 'epg-configuration "epg-config")
 990 (autoload 'epg-expand-group "epg-config")
 991 (autoload 'epa-select-keys "epa")
 992
 993 (defvar mml2015-epg-secret-key-id-list nil)
 994
 995 (defun mml2015-epg-passphrase-callback (context key-id ignore)
 996   (if (eq key-id 'SYM)
 997       (epg-passphrase-callback-function context key-id nil)
 998     (let* ((password-cache-key-id
 999             (if (eq key-id 'PIN)
1000                 "PIN"
1001                key-id))
1002            entry
1003            (passphrase
1004             (password-read
1005              (if (eq key-id 'PIN)
1006                  "Passphrase for PIN: "
1007                (if (setq entry (assoc key-id epg-user-id-alist))
1008                    (format "Passphrase for %s %s: " key-id (cdr entry))
1009                  (format "Passphrase for %s: " key-id)))
1010              password-cache-key-id)))
1011       (when passphrase
1012         (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
1013           (password-cache-add password-cache-key-id passphrase))
1014         (setq mml2015-epg-secret-key-id-list
1015               (cons password-cache-key-id mml2015-epg-secret-key-id-list))
1016         (copy-sequence passphrase)))))
1017
1018 (defun mml2015-epg-find-usable-key (keys usage)
1019   (catch 'found
1020     (while keys
1021       (let ((pointer (epg-key-sub-key-list (car keys))))
1022         (while pointer
1023           (if (and (memq usage (epg-sub-key-capability (car pointer)))
1024                    (not (memq (epg-sub-key-validity (car pointer))
1025                               '(revoked expired))))
1026               (throw 'found (car keys)))
1027           (setq pointer (cdr pointer))))
1028       (setq keys (cdr keys)))))
1029
1030 (defun mml2015-epg-decrypt (handle ctl)
1031   (catch 'error
1032     (let ((inhibit-redisplay t)
1033           context plain child handles result decrypt-status)
1034       (unless (setq child (mm-find-part-by-type
1035                            (cdr handle)
1036                            "application/octet-stream" nil t))
1037         (mm-set-handle-multipart-parameter
1038          mm-security-handle 'gnus-info "Corrupted")
1039         (throw 'error handle))
1040       (setq context (epg-make-context))
1041       (if mml2015-cache-passphrase
1042           (epg-context-set-passphrase-callback
1043            context
1044            #'mml2015-epg-passphrase-callback))
1045       (condition-case error
1046           (setq plain (epg-decrypt-string context (mm-get-part child))
1047                 mml2015-epg-secret-key-id-list nil)
1048         (error
1049          (while mml2015-epg-secret-key-id-list
1050            (password-cache-remove (car mml2015-epg-secret-key-id-list))
1051            (setq mml2015-epg-secret-key-id-list
1052                  (cdr mml2015-epg-secret-key-id-list)))
1053          (mm-set-handle-multipart-parameter
1054           mm-security-handle 'gnus-info "Failed")
1055          (if (eq (car error) 'quit)
1056              (mm-set-handle-multipart-parameter
1057               mm-security-handle 'gnus-details "Quit.")
1058            (mm-set-handle-multipart-parameter
1059             mm-security-handle 'gnus-details (mml2015-format-error error)))
1060          (throw 'error handle)))
1061       (with-temp-buffer
1062         (insert plain)
1063         (goto-char (point-min))
1064         (while (search-forward "\r\n" nil t)
1065           (replace-match "\n" t t))
1066         (setq handles (mm-dissect-buffer t))
1067         (mm-destroy-parts handle)
1068         (if (epg-context-result-for context 'verify)
1069             (mm-set-handle-multipart-parameter
1070              mm-security-handle 'gnus-info
1071              (concat "OK\n"
1072                      (epg-verify-result-to-string
1073                       (epg-context-result-for context 'verify))))
1074           (mm-set-handle-multipart-parameter
1075            mm-security-handle 'gnus-info "OK"))
1076         (if (stringp (car handles))
1077             (mm-set-handle-multipart-parameter
1078              mm-security-handle 'gnus-details
1079              (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
1080         (if (listp (car handles))
1081             handles
1082           (list handles)))))
1083
1084 (defun mml2015-epg-clear-decrypt ()
1085   (let ((inhibit-redisplay t)
1086         (context (epg-make-context))
1087         plain)
1088     (if mml2015-cache-passphrase
1089         (epg-context-set-passphrase-callback
1090          context
1091          #'mml2015-epg-passphrase-callback))
1092     (condition-case error
1093         (setq plain (epg-decrypt-string context (buffer-string))
1094               mml2015-epg-secret-key-id-list nil)
1095       (error
1096        (while mml2015-epg-secret-key-id-list
1097          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1098          (setq mml2015-epg-secret-key-id-list
1099                (cdr mml2015-epg-secret-key-id-list)))
1100        (mm-set-handle-multipart-parameter
1101         mm-security-handle 'gnus-info "Failed")
1102        (if (eq (car error) 'quit)
1103            (mm-set-handle-multipart-parameter
1104             mm-security-handle 'gnus-details "Quit.")
1105          (mm-set-handle-multipart-parameter
1106           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1107     (when plain
1108       (erase-buffer)
1109       ;; Treat data which epg returns as a unibyte string.
1110       (mm-disable-multibyte)
1111       (insert plain)
1112       (goto-char (point-min))
1113       (while (search-forward "\r\n" nil t)
1114         (replace-match "\n" t t))
1115       (mm-set-handle-multipart-parameter
1116        mm-security-handle 'gnus-info "OK")
1117       (if (epg-context-result-for context 'verify)
1118           (mm-set-handle-multipart-parameter
1119            mm-security-handle 'gnus-details
1120            (epg-verify-result-to-string
1121             (epg-context-result-for context 'verify)))))))
1122
1123 (defun mml2015-epg-verify (handle ctl)
1124   (catch 'error
1125     (let ((inhibit-redisplay t)
1126           context plain signature-file part signature)
1127       (when (or (null (setq part (mm-find-raw-part-by-type
1128                                   ctl (or (mm-handle-multipart-ctl-parameter
1129                                            ctl 'protocol)
1130                                           "application/pgp-signature")
1131                                   t)))
1132                 (null (setq signature (mm-find-part-by-type
1133                                        (cdr handle) "application/pgp-signature"
1134                                        nil t))))
1135         (mm-set-handle-multipart-parameter
1136          mm-security-handle 'gnus-info "Corrupted")
1137         (throw 'error handle))
1138       (setq part (mm-replace-in-string part "\n" "\r\n" t)
1139             signature (mm-get-part signature)
1140             context (epg-make-context))
1141       (condition-case error
1142           (setq plain (epg-verify-string context signature part))
1143         (error
1144          (mm-set-handle-multipart-parameter
1145           mm-security-handle 'gnus-info "Failed")
1146          (if (eq (car error) 'quit)
1147              (mm-set-handle-multipart-parameter
1148               mm-security-handle 'gnus-details "Quit.")
1149            (mm-set-handle-multipart-parameter
1150             mm-security-handle 'gnus-details (mml2015-format-error error)))
1151          (throw 'error handle)))
1152       (mm-set-handle-multipart-parameter
1153        mm-security-handle 'gnus-info
1154        (epg-verify-result-to-string (epg-context-result-for context 'verify)))
1155       handle)))
1156
1157 (defun mml2015-epg-clear-verify ()
1158   (let ((inhibit-redisplay t)
1159         (context (epg-make-context))
1160         (signature (mm-encode-coding-string (buffer-string)
1161                                             coding-system-for-write))
1162         plain)
1163     (condition-case error
1164         (setq plain (epg-verify-string context signature))
1165       (error
1166        (mm-set-handle-multipart-parameter
1167         mm-security-handle 'gnus-info "Failed")
1168        (if (eq (car error) 'quit)
1169            (mm-set-handle-multipart-parameter
1170             mm-security-handle 'gnus-details "Quit.")
1171          (mm-set-handle-multipart-parameter
1172           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1173     (if plain
1174         (progn
1175           (mm-set-handle-multipart-parameter
1176            mm-security-handle 'gnus-info
1177            (epg-verify-result-to-string
1178             (epg-context-result-for context 'verify)))
1179           (delete-region (point-min) (point-max))
1180           (insert (mm-decode-coding-string plain coding-system-for-read)))
1181       (mml2015-extract-cleartext-signature))))
1182
1183 (defun mml2015-epg-sign (cont)
1184   (let* ((inhibit-redisplay t)
1185          (context (epg-make-context))
1186          (boundary (mml-compute-boundary cont))
1187          signer-key
1188          (signers
1189           (or (message-options-get 'mml2015-epg-signers)
1190               (message-options-set
1191                'mml2015-epg-signers
1192                (if (eq mm-sign-option 'guided)
1193                    (epa-select-keys context "\
1194 Select keys for signing.
1195 If no one is selected, default secret key is used.  "
1196                                     mml2015-signers t)
1197                  (if mml2015-signers
1198                      (delq nil
1199                            (mapcar
1200                             (lambda (signer)
1201                               (setq signer-key (mml2015-epg-find-usable-key
1202                                                 (epg-list-keys context signer t)
1203                                                 'sign))
1204                               (unless (or signer-key
1205                                           (y-or-n-p
1206                                            (format
1207                                             "No secret key for %s; skip it? "
1208                                             signer)))
1209                                 (error "No secret key for %s" signer))
1210                               signer-key)
1211                             mml2015-signers)))))))
1212          signature micalg)
1213     (epg-context-set-armor context t)
1214     (epg-context-set-textmode context t)
1215     (epg-context-set-signers context signers)
1216     (if mml2015-cache-passphrase
1217         (epg-context-set-passphrase-callback
1218          context
1219          #'mml2015-epg-passphrase-callback))
1220     (condition-case error
1221         (setq signature (epg-sign-string context (buffer-string) t)
1222               mml2015-epg-secret-key-id-list nil)
1223       (error
1224        (while mml2015-epg-secret-key-id-list
1225          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1226          (setq mml2015-epg-secret-key-id-list
1227                (cdr mml2015-epg-secret-key-id-list)))
1228        (signal (car error) (cdr error))))
1229     (if (epg-context-result-for context 'sign)
1230         (setq micalg (epg-new-signature-digest-algorithm
1231                       (car (epg-context-result-for context 'sign)))))
1232     (goto-char (point-min))
1233     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1234                     boundary))
1235     (if micalg
1236         (insert (format "\tmicalg=pgp-%s; "
1237                         (downcase
1238                          (cdr (assq micalg
1239                                     epg-digest-algorithm-alist))))))
1240     (insert "protocol=\"application/pgp-signature\"\n")
1241     (insert (format "\n--%s\n" boundary))
1242     (goto-char (point-max))
1243     (insert (format "\n--%s\n" boundary))
1244     (insert "Content-Type: application/pgp-signature\n\n")
1245     (insert signature)
1246     (goto-char (point-max))
1247     (insert (format "--%s--\n" boundary))
1248     (goto-char (point-max))))
1249
1250 (defun mml2015-epg-encrypt (cont &optional sign)
1251   (let ((inhibit-redisplay t)
1252         (context (epg-make-context))
1253         (config (epg-configuration))
1254         (recipients (message-options-get 'mml2015-epg-recipients))
1255         cipher signers
1256         (boundary (mml-compute-boundary cont))
1257         recipient-key signer-key)
1258     (unless recipients
1259       (setq recipients
1260             (apply #'nconc
1261                    (mapcar
1262                     (lambda (recipient)
1263                       (or (epg-expand-group config recipient)
1264                           (list (concat "<" recipient ">"))))
1265                     (split-string
1266                      (or (message-options-get 'message-recipients)
1267                          (message-options-set 'message-recipients
1268                                               (read-string "Recipients: ")))
1269                      "[ \f\t\n\r\v,]+"))))
1270       (when mml2015-encrypt-to-self
1271         (unless mml2015-signers
1272           (error "mml2015-signers not set"))
1273         (setq recipients (nconc recipients mml2015-signers)))
1274       (if (eq mm-encrypt-option 'guided)
1275           (setq recipients
1276                 (epa-select-keys context "\
1277 Select recipients for encryption.
1278 If no one is selected, symmetric encryption will be performed.  "
1279                                  recipients))
1280         (setq recipients
1281               (delq nil
1282                     (mapcar
1283                      (lambda (recipient)
1284                        (setq recipient-key (mml2015-epg-find-usable-key
1285                                             (epg-list-keys context recipient)
1286                                             'encrypt))
1287                        (unless (or recipient-key
1288                                    (y-or-n-p
1289                                     (format "No public key for %s; skip it? "
1290                                             recipient)))
1291                          (error "No public key for %s" recipient))
1292                        recipient-key)
1293                      recipients)))
1294         (unless recipients
1295           (error "No recipient specified")))
1296       (message-options-set 'mml2015-epg-recipients recipients))
1297     (when sign
1298       (setq signers
1299             (or (message-options-get 'mml2015-epg-signers)
1300                 (message-options-set
1301                  'mml2015-epg-signers
1302                  (if (eq mm-sign-option 'guided)
1303                      (epa-select-keys context "\
1304 Select keys for signing.
1305 If no one is selected, default secret key is used.  "
1306                                       mml2015-signers t)
1307                    (if mml2015-signers
1308                        (delq nil
1309                              (mapcar
1310                               (lambda (signer)
1311                                 (setq signer-key (mml2015-epg-find-usable-key
1312                                                   (epg-list-keys context signer t)
1313                                                   'sign))
1314                                 (unless (or signer-key
1315                                             (y-or-n-p
1316                                              (format
1317                                               "No secret key for %s; skip it? "
1318                                               signer)))
1319                                   (error "No secret key for %s" signer))
1320                                 signer-key)
1321                               mml2015-signers)))))))
1322       (epg-context-set-signers context signers))
1323     (epg-context-set-armor context t)
1324     (epg-context-set-textmode context t)
1325     (if mml2015-cache-passphrase
1326         (epg-context-set-passphrase-callback
1327          context
1328          #'mml2015-epg-passphrase-callback))
1329     (condition-case error
1330         (setq cipher
1331               (epg-encrypt-string context (buffer-string) recipients sign
1332                                   mml2015-always-trust)
1333               mml2015-epg-secret-key-id-list nil)
1334       (error
1335        (while mml2015-epg-secret-key-id-list
1336          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1337          (setq mml2015-epg-secret-key-id-list
1338                (cdr mml2015-epg-secret-key-id-list)))
1339        (signal (car error) (cdr error))))
1340     (delete-region (point-min) (point-max))
1341     (goto-char (point-min))
1342     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1343                     boundary))
1344     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1345     (insert (format "--%s\n" boundary))
1346     (insert "Content-Type: application/pgp-encrypted\n\n")
1347     (insert "Version: 1\n\n")
1348     (insert (format "--%s\n" boundary))
1349     (insert "Content-Type: application/octet-stream\n\n")
1350     (insert cipher)
1351     (goto-char (point-max))
1352     (insert (format "--%s--\n" boundary))
1353     (goto-char (point-max))))
1354
1355 ;;; General wrapper
1356
1357 (autoload 'gnus-buffer-live-p "gnus-util")
1358 (autoload 'gnus-get-buffer-create "gnus")
1359
1360 (defun mml2015-clean-buffer ()
1361   (if (gnus-buffer-live-p mml2015-result-buffer)
1362       (with-current-buffer mml2015-result-buffer
1363         (erase-buffer)
1364         t)
1365     (setq mml2015-result-buffer
1366           (gnus-get-buffer-create " *MML2015 Result*"))
1367     nil))
1368
1369 (defsubst mml2015-clear-decrypt-function ()
1370   (nth 6 (assq mml2015-use mml2015-function-alist)))
1371
1372 (defsubst mml2015-clear-verify-function ()
1373   (nth 5 (assq mml2015-use mml2015-function-alist)))
1374
1375 ;;;###autoload
1376 (defun mml2015-decrypt (handle ctl)
1377   (mml2015-clean-buffer)
1378   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1379     (if func
1380         (funcall func handle ctl)
1381       handle)))
1382
1383 ;;;###autoload
1384 (defun mml2015-decrypt-test (handle ctl)
1385   mml2015-use)
1386
1387 ;;;###autoload
1388 (defun mml2015-verify (handle ctl)
1389   (mml2015-clean-buffer)
1390   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1391     (if func
1392         (funcall func handle ctl)
1393       handle)))
1394
1395 ;;;###autoload
1396 (defun mml2015-verify-test (handle ctl)
1397   mml2015-use)
1398
1399 ;;;###autoload
1400 (defun mml2015-encrypt (cont &optional sign)
1401   (mml2015-clean-buffer)
1402   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1403     (if func
1404         (funcall func cont sign)
1405       (error "Cannot find encrypt function"))))
1406
1407 ;;;###autoload
1408 (defun mml2015-sign (cont)
1409   (mml2015-clean-buffer)
1410   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1411     (if func
1412         (funcall func cont)
1413       (error "Cannot find sign function"))))
1414
1415 ;;;###autoload
1416 (defun mml2015-self-encrypt ()
1417   (mml2015-encrypt nil))
1418
1419 (provide 'mml2015)
1420
1421 ;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
1422 ;;; mml2015.el ends here