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