cgit.sxemacs.org Git - gnus/blob - lisp/mml2015.el

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