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