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                      (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 t
 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 verify mode.  Sign and
 528         ;; clearsign use --textmode. The conversion is not necessary.
 529         ;; In clearverify, the conversion is not necessary either.
 530         (goto-char (point-min))
 531         (end-of-line)
 532         (while (not (eobp))
 533           (unless (eq (char-before) ?\r)
 534             (insert "\r"))
 535           (forward-line)
 536           (end-of-line))
 537         (with-temp-buffer
 538           (setq signature (current-buffer))
 539           (unless (setq part (mm-find-part-by-type
 540                               (cdr handle) "application/pgp-signature" nil t))
 541             (mm-set-handle-multipart-parameter
 542              mm-security-handle 'gnus-info "Corrupted")
 543             (throw 'error handle))
 544           (mm-insert-part part)
 545           (unless (condition-case err
 546                       (prog1
 547                           (gpg-verify message signature mml2015-result-buffer)
 548                         (mm-set-handle-multipart-parameter
 549                          mm-security-handle 'gnus-details
 550                          (with-current-buffer mml2015-result-buffer
 551                            (buffer-string))))
 552                     (error
 553                      (mm-set-handle-multipart-parameter
 554                       mm-security-handle 'gnus-details (mml2015-format-error err))
 555                      (mm-set-handle-multipart-parameter
 556                       mm-security-handle 'gnus-info "Error.")
 557                      (setq info-is-set-p t)
 558                      nil)
 559                     (quit
 560                      (mm-set-handle-multipart-parameter
 561                       mm-security-handle 'gnus-details "Quit.")
 562                      (mm-set-handle-multipart-parameter
 563                       mm-security-handle 'gnus-info "Quit.")
 564                      (setq info-is-set-p t)
 565                      nil))
 566             (unless info-is-set-p
 567               (mm-set-handle-multipart-parameter
 568                mm-security-handle 'gnus-info "Failed"))
 569             (throw 'error handle)))
 570         (mm-set-handle-multipart-parameter
 571          mm-security-handle 'gnus-info
 572          (with-current-buffer mml2015-result-buffer
 573            (mml2015-gpg-extract-signature-details))))
 574       handle)))
 575
 576 (defun mml2015-gpg-clear-verify ()
 577   (if (condition-case err
 578           (prog1
 579               (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
 580             (mm-set-handle-multipart-parameter
 581              mm-security-handle 'gnus-details
 582              (with-current-buffer mml2015-result-buffer
 583                (buffer-string))))
 584         (error
 585          (mm-set-handle-multipart-parameter
 586           mm-security-handle 'gnus-details (mml2015-format-error err))
 587          nil)
 588         (quit
 589          (mm-set-handle-multipart-parameter
 590           mm-security-handle 'gnus-details "Quit.")
 591          nil))
 592       (mm-set-handle-multipart-parameter
 593        mm-security-handle 'gnus-info
 594        (with-current-buffer mml2015-result-buffer
 595          (mml2015-gpg-extract-signature-details)))
 596     (mm-set-handle-multipart-parameter
 597      mm-security-handle 'gnus-info "Failed")))
 598
 599 (defun mml2015-gpg-sign (cont)
 600   (let ((boundary (mml-compute-boundary cont))
 601         (text (current-buffer)) signature)
 602     (goto-char (point-max))
 603     (unless (bolp)
 604       (insert "\n"))
 605     (with-temp-buffer
 606       (unless (gpg-sign-detached text (setq signature (current-buffer))
 607                                  mml2015-result-buffer
 608                                  nil
 609                                  (message-options-get 'message-sender)
 610                                  t t) ; armor & textmode
 611         (unless (> (point-max) (point-min))
 612           (pop-to-buffer mml2015-result-buffer)
 613           (error "Sign error")))
 614       (goto-char (point-min))
 615       (while (re-search-forward "\r+$" nil t)
 616         (replace-match "" t t))
 617       (set-buffer text)
 618       (goto-char (point-min))
 619       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 620                       boundary))
 621       ;;; FIXME: what is the micalg?
 622       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 623       (insert (format "\n--%s\n" boundary))
 624       (goto-char (point-max))
 625       (insert (format "\n--%s\n" boundary))
 626       (insert "Content-Type: application/pgp-signature\n\n")
 627       (insert-buffer-substring signature)
 628       (goto-char (point-max))
 629       (insert (format "--%s--\n" boundary))
 630       (goto-char (point-max)))))
 631
 632 (defun mml2015-gpg-encrypt (cont &optional sign)
 633   (let ((boundary (mml-compute-boundary cont))
 634         (text (current-buffer))
 635         cipher)
 636     (mm-with-unibyte-current-buffer
 637       (with-temp-buffer
 638         ;; set up a function to call the correct gpg encrypt routine
 639         ;; with the right arguments. (FIXME: this should be done
 640         ;; differently.)
 641         (flet ((gpg-encrypt-func
 642                  (sign plaintext ciphertext result recipients &optional
 643                        passphrase sign-with-key armor textmode)
 644                  (if sign
 645                      (gpg-sign-encrypt
 646                       plaintext ciphertext result recipients passphrase
 647                       sign-with-key armor textmode)
 648                    (gpg-encrypt
 649                     plaintext ciphertext result recipients passphrase
 650                     armor textmode))))
 651           (unless (gpg-encrypt-func
 652                     sign ; passed in when using signencrypt
 653                     text (setq cipher (current-buffer))
 654                     mml2015-result-buffer
 655                     (split-string
 656                      (or
 657                       (message-options-get 'message-recipients)
 658                       (message-options-set 'message-recipients
 659                                            (read-string "Recipients: ")))
 660                      "[ \f\t\n\r\v,]+")
 661                     nil
 662                     (message-options-get 'message-sender)
 663                     t t) ; armor & textmode
 664             (unless (> (point-max) (point-min))
 665               (pop-to-buffer mml2015-result-buffer)
 666               (error "Encrypt error"))))
 667         (goto-char (point-min))
 668         (while (re-search-forward "\r+$" nil t)
 669           (replace-match "" t t))
 670         (set-buffer text)
 671         (delete-region (point-min) (point-max))
 672         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 673                         boundary))
 674         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 675         (insert (format "--%s\n" boundary))
 676         (insert "Content-Type: application/pgp-encrypted\n\n")
 677         (insert "Version: 1\n\n")
 678         (insert (format "--%s\n" boundary))
 679         (insert "Content-Type: application/octet-stream\n\n")
 680         (insert-buffer-substring cipher)
 681         (goto-char (point-max))
 682         (insert (format "--%s--\n" boundary))
 683         (goto-char (point-max))))))
 684
 685 ;;; pgg wrapper
 686
 687 (eval-when-compile
 688   (defvar pgg-default-user-id)
 689   (defvar pgg-errors-buffer)
 690   (defvar pgg-output-buffer))
 691
 692 (eval-and-compile
 693   (autoload 'pgg-decrypt-region "pgg")
 694   (autoload 'pgg-verify-region "pgg")
 695   (autoload 'pgg-sign-region "pgg")
 696   (autoload 'pgg-encrypt-region "pgg")
 697   (autoload 'pgg-parse-armor "pgg-parse"))
 698
 699 (defun mml2015-pgg-decrypt (handle ctl)
 700   (catch 'error
 701     (let ((pgg-errors-buffer mml2015-result-buffer)
 702           child handles result decrypt-status)
 703       (unless (setq child (mm-find-part-by-type
 704                            (cdr handle)
 705                            "application/octet-stream" nil t))
 706         (mm-set-handle-multipart-parameter
 707          mm-security-handle 'gnus-info "Corrupted")
 708         (throw 'error handle))
 709       (with-temp-buffer
 710         (mm-insert-part child)
 711         (if (condition-case err
 712                 (prog1
 713                     (pgg-decrypt-region (point-min) (point-max))
 714                   (setq decrypt-status
 715                         (with-current-buffer mml2015-result-buffer
 716                           (buffer-string)))
 717                   (mm-set-handle-multipart-parameter
 718                    mm-security-handle 'gnus-details
 719                    decrypt-status))
 720               (error
 721                (mm-set-handle-multipart-parameter
 722                 mm-security-handle 'gnus-details (mml2015-format-error err))
 723                nil)
 724               (quit
 725                (mm-set-handle-multipart-parameter
 726                 mm-security-handle 'gnus-details "Quit.")
 727                nil))
 728             (with-current-buffer pgg-output-buffer
 729               (goto-char (point-min))
 730               (while (search-forward "\r\n" nil t)
 731                 (replace-match "\n" t t))
 732               (setq handles (mm-dissect-buffer t))
 733               (mm-destroy-parts handle)
 734               (mm-set-handle-multipart-parameter
 735                mm-security-handle 'gnus-info "OK")
 736               (mm-set-handle-multipart-parameter
 737                mm-security-handle 'gnus-details
 738                (concat decrypt-status
 739                        (when (stringp (car handles))
 740                          "\n" (mm-handle-multipart-ctl-parameter
 741                                handles 'gnus-details))))
 742               (if (listp (car handles))
 743                   handles
 744                 (list handles)))
 745           (mm-set-handle-multipart-parameter
 746            mm-security-handle 'gnus-info "Failed")
 747           (throw 'error handle))))))
 748
 749 (defun mml2015-pgg-clear-decrypt ()
 750   (let ((pgg-errors-buffer mml2015-result-buffer))
 751     (if (prog1
 752             (pgg-decrypt-region (point-min) (point-max))
 753           (mm-set-handle-multipart-parameter
 754            mm-security-handle 'gnus-details
 755            (with-current-buffer mml2015-result-buffer
 756              (buffer-string))))
 757         (progn
 758           (erase-buffer)
 759           ;; Treat data which pgg returns as a unibyte string.
 760           (mm-disable-multibyte)
 761           (insert-buffer-substring pgg-output-buffer)
 762           (goto-char (point-min))
 763           (while (search-forward "\r\n" nil t)
 764             (replace-match "\n" t t))
 765           (mm-set-handle-multipart-parameter
 766            mm-security-handle 'gnus-info "OK"))
 767       (mm-set-handle-multipart-parameter
 768        mm-security-handle 'gnus-info "Failed"))))
 769
 770 (defun mml2015-pgg-verify (handle ctl)
 771   (let ((pgg-errors-buffer mml2015-result-buffer)
 772         signature-file part signature)
 773     (if (or (null (setq part (mm-find-raw-part-by-type
 774                               ctl (or (mm-handle-multipart-ctl-parameter
 775                                        ctl 'protocol)
 776                                       "application/pgp-signature")
 777                               t)))
 778             (null (setq signature (mm-find-part-by-type
 779                                    (cdr handle) "application/pgp-signature" nil t))))
 780         (progn
 781           (mm-set-handle-multipart-parameter
 782            mm-security-handle 'gnus-info "Corrupted")
 783           handle)
 784       (with-temp-buffer
 785         (insert part)
 786         ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
 787         ;; clearsign use --textmode. The conversion is not necessary.
 788         ;; In clearverify, the conversion is not necessary either.
 789         (goto-char (point-min))
 790         (end-of-line)
 791         (while (not (eobp))
 792           (unless (eq (char-before) ?\r)
 793             (insert "\r"))
 794           (forward-line)
 795           (end-of-line))
 796         (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
 797           (mm-insert-part signature))
 798         (if (condition-case err
 799                 (prog1
 800                     (pgg-verify-region (point-min) (point-max)
 801                                        signature-file t)
 802                   (goto-char (point-min))
 803                   (while (search-forward "\r\n" nil t)
 804                     (replace-match "\n" t t))
 805                   (mm-set-handle-multipart-parameter
 806                    mm-security-handle 'gnus-details
 807                    (concat (with-current-buffer pgg-output-buffer
 808                              (buffer-string))
 809                            (with-current-buffer pgg-errors-buffer
 810                              (buffer-string)))))
 811               (error
 812                (mm-set-handle-multipart-parameter
 813                 mm-security-handle 'gnus-details (mml2015-format-error err))
 814                nil)
 815               (quit
 816                (mm-set-handle-multipart-parameter
 817                 mm-security-handle 'gnus-details "Quit.")
 818                nil))
 819             (progn
 820               (delete-file signature-file)
 821               (mm-set-handle-multipart-parameter
 822                mm-security-handle 'gnus-info
 823                (with-current-buffer pgg-errors-buffer
 824                  (mml2015-gpg-extract-signature-details))))
 825           (delete-file signature-file)
 826           (mm-set-handle-multipart-parameter
 827            mm-security-handle 'gnus-info "Failed")))))
 828   handle)
 829
 830 (defun mml2015-pgg-clear-verify ()
 831   (let ((pgg-errors-buffer mml2015-result-buffer)
 832         (text (buffer-string))
 833         (coding-system buffer-file-coding-system))
 834     (if (condition-case err
 835             (prog1
 836                 (mm-with-unibyte-buffer
 837                   (insert (encode-coding-string text coding-system))
 838                   (pgg-verify-region (point-min) (point-max) nil t))
 839               (goto-char (point-min))
 840               (while (search-forward "\r\n" nil t)
 841                 (replace-match "\n" t t))
 842               (mm-set-handle-multipart-parameter
 843                mm-security-handle 'gnus-details
 844                (concat (with-current-buffer pgg-output-buffer
 845                          (buffer-string))
 846                        (with-current-buffer pgg-errors-buffer
 847                          (buffer-string)))))
 848           (error
 849            (mm-set-handle-multipart-parameter
 850             mm-security-handle 'gnus-details (mml2015-format-error err))
 851            nil)
 852           (quit
 853            (mm-set-handle-multipart-parameter
 854             mm-security-handle 'gnus-details "Quit.")
 855            nil))
 856         (mm-set-handle-multipart-parameter
 857          mm-security-handle 'gnus-info
 858          (with-current-buffer pgg-errors-buffer
 859            (mml2015-gpg-extract-signature-details)))
 860       (mm-set-handle-multipart-parameter
 861        mm-security-handle 'gnus-info "Failed"))))
 862
 863 (defun mml2015-pgg-sign (cont)
 864   (let ((pgg-errors-buffer mml2015-result-buffer)
 865         (boundary (mml-compute-boundary cont))
 866         (pgg-default-user-id (or (message-options-get 'mml-sender)
 867                                  pgg-default-user-id))
 868         (pgg-text-mode t)
 869         entry)
 870     (unless (pgg-sign-region (point-min) (point-max))
 871       (pop-to-buffer mml2015-result-buffer)
 872       (error "Sign error"))
 873     (goto-char (point-min))
 874     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 875                     boundary))
 876     (if (setq entry (assq 2 (pgg-parse-armor
 877                              (with-current-buffer pgg-output-buffer
 878                                (buffer-string)))))
 879         (setq entry (assq 'hash-algorithm (cdr entry))))
 880     (insert (format "\tmicalg=%s; "
 881                     (if (cdr entry)
 882                         (downcase (format "pgp-%s" (cdr entry)))
 883                       "pgp-sha1")))
 884     (insert "protocol=\"application/pgp-signature\"\n")
 885     (insert (format "\n--%s\n" boundary))
 886     (goto-char (point-max))
 887     (insert (format "\n--%s\n" boundary))
 888     (insert "Content-Type: application/pgp-signature\n\n")
 889     (insert-buffer-substring pgg-output-buffer)
 890     (goto-char (point-max))
 891     (insert (format "--%s--\n" boundary))
 892     (goto-char (point-max))))
 893
 894 (defun mml2015-pgg-encrypt (cont &optional sign)
 895   (let ((pgg-errors-buffer mml2015-result-buffer)
 896         (pgg-text-mode t)
 897         (boundary (mml-compute-boundary cont)))
 898     (unless (pgg-encrypt-region (point-min) (point-max)
 899                                 (split-string
 900                                  (or
 901                                   (message-options-get 'message-recipients)
 902                                   (message-options-set 'message-recipients
 903                                                        (read-string "Recipients: ")))
 904                                  "[ \f\t\n\r\v,]+")
 905                                 sign)
 906       (pop-to-buffer mml2015-result-buffer)
 907       (error "Encrypt error"))
 908     (delete-region (point-min) (point-max))
 909     (goto-char (point-min))
 910     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 911                     boundary))
 912     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 913     (insert (format "--%s\n" boundary))
 914     (insert "Content-Type: application/pgp-encrypted\n\n")
 915     (insert "Version: 1\n\n")
 916     (insert (format "--%s\n" boundary))
 917     (insert "Content-Type: application/octet-stream\n\n")
 918     (insert-buffer-substring pgg-output-buffer)
 919     (goto-char (point-max))
 920     (insert (format "--%s--\n" boundary))
 921     (goto-char (point-max))))
 922
 923 ;;; epg wrapper
 924
 925 (eval-and-compile
 926   (autoload 'epg-make-context "epg"))
 927
 928 (eval-when-compile
 929   (defvar epg-user-id-alist)
 930   (defvar epg-digest-algorithm-alist)
 931   (defvar inhibit-redisplay)
 932   (autoload 'epg-context-set-armor "epg")
 933   (autoload 'epg-context-set-textmode "epg")
 934   (autoload 'epg-context-set-signers "epg")
 935   (autoload 'epg-context-result-for "epg")
 936   (autoload 'epg-new-signature-digest-algorithm "epg")
 937   (autoload 'epg-verify-result-to-string "epg")
 938   (autoload 'epg-list-keys "epg")
 939   (autoload 'epg-decrypt-string "epg")
 940   (autoload 'epg-verify-string "epg")
 941   (autoload 'epg-sign-string "epg")
 942   (autoload 'epg-encrypt-string "epg")
 943   (autoload 'epg-passphrase-callback-function "epg")
 944   (autoload 'epg-context-set-passphrase-callback "epg")
 945   (autoload 'epg-configuration "epg-config")
 946   (autoload 'epg-expand-group "epg-config"))
 947
 948 (eval-when-compile
 949   (defvar password-cache-expiry)
 950   (autoload 'password-read "password")
 951   (autoload 'password-cache-add "password")
 952   (autoload 'password-cache-remove "password"))
 953
 954 (defvar mml2015-epg-secret-key-id-list nil)
 955
 956 (defun mml2015-epg-passphrase-callback (context key-id ignore)
 957   (if (eq key-id 'SYM)
 958       (epg-passphrase-callback-function context key-id nil)
 959     (let* (entry
 960            (passphrase
 961             (password-read
 962              (if (eq key-id 'PIN)
 963                  "Passphrase for PIN: "
 964                (if (setq entry (assoc key-id epg-user-id-alist))
 965                    (format "Passphrase for %s %s: " key-id (cdr entry))
 966                  (format "Passphrase for %s: " key-id)))
 967              (if (eq key-id 'PIN)
 968                  "PIN"
 969                key-id))))
 970       (when passphrase
 971         (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
 972           (password-cache-add key-id passphrase))
 973         (setq mml2015-epg-secret-key-id-list
 974               (cons key-id mml2015-epg-secret-key-id-list))
 975         (copy-sequence passphrase)))))
 976
 977 (defun mml2015-epg-decrypt (handle ctl)
 978   (catch 'error
 979     (let ((inhibit-redisplay t)
 980           context plain child handles result decrypt-status)
 981       (unless (setq child (mm-find-part-by-type
 982                            (cdr handle)
 983                            "application/octet-stream" nil t))
 984         (mm-set-handle-multipart-parameter
 985          mm-security-handle 'gnus-info "Corrupted")
 986         (throw 'error handle))
 987       (setq context (epg-make-context))
 988       (if mml2015-cache-passphrase
 989           (epg-context-set-passphrase-callback
 990            context
 991            #'mml2015-epg-passphrase-callback))
 992       (condition-case error
 993           (setq plain (epg-decrypt-string context (mm-get-part child))
 994                 mml2015-epg-secret-key-id-list nil)
 995         (error
 996          (while mml2015-epg-secret-key-id-list
 997            (password-cache-remove (car mml2015-epg-secret-key-id-list))
 998            (setq mml2015-epg-secret-key-id-list
 999                  (cdr mml2015-epg-secret-key-id-list)))
1000          (mm-set-handle-multipart-parameter
1001           mm-security-handle 'gnus-info "Failed")
1002          (if (eq (car error) 'quit)
1003              (mm-set-handle-multipart-parameter
1004               mm-security-handle 'gnus-details "Quit.")
1005            (mm-set-handle-multipart-parameter
1006             mm-security-handle 'gnus-details (mml2015-format-error error)))
1007          (throw 'error handle)))
1008       (with-temp-buffer
1009         (insert plain)
1010         (goto-char (point-min))
1011         (while (search-forward "\r\n" nil t)
1012           (replace-match "\n" t t))
1013         (setq handles (mm-dissect-buffer t))
1014         (mm-destroy-parts handle)
1015         (if (epg-context-result-for context 'verify)
1016             (mm-set-handle-multipart-parameter
1017              mm-security-handle 'gnus-info
1018              (concat "OK\n"
1019                      (epg-verify-result-to-string
1020                       (epg-context-result-for context 'verify))))
1021           (mm-set-handle-multipart-parameter
1022            mm-security-handle 'gnus-info "OK"))
1023         (if (stringp (car handles))
1024             (mm-set-handle-multipart-parameter
1025              mm-security-handle 'gnus-details
1026              (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
1027         (if (listp (car handles))
1028             handles
1029           (list handles)))))
1030
1031 (defun mml2015-epg-clear-decrypt ()
1032   (let ((inhibit-redisplay t)
1033         (context (epg-make-context))
1034         plain)
1035     (if mml2015-cache-passphrase
1036         (epg-context-set-passphrase-callback
1037          context
1038          #'mml2015-epg-passphrase-callback))
1039     (condition-case error
1040         (setq plain (epg-decrypt-string context (buffer-string))
1041               mml2015-epg-secret-key-id-list nil)
1042       (error
1043        (while mml2015-epg-secret-key-id-list
1044          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1045          (setq mml2015-epg-secret-key-id-list
1046                (cdr mml2015-epg-secret-key-id-list)))
1047        (mm-set-handle-multipart-parameter
1048         mm-security-handle 'gnus-info "Failed")
1049        (if (eq (car error) 'quit)
1050            (mm-set-handle-multipart-parameter
1051             mm-security-handle 'gnus-details "Quit.")
1052          (mm-set-handle-multipart-parameter
1053           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1054     (when plain
1055       (erase-buffer)
1056       ;; Treat data which epg returns as a unibyte string.
1057       (mm-disable-multibyte)
1058       (insert plain)
1059       (goto-char (point-min))
1060       (while (search-forward "\r\n" nil t)
1061         (replace-match "\n" t t))
1062       (mm-set-handle-multipart-parameter
1063        mm-security-handle 'gnus-info "OK")
1064       (if (epg-context-result-for context 'verify)
1065           (mm-set-handle-multipart-parameter
1066            mm-security-handle 'gnus-details
1067            (epg-verify-result-to-string
1068             (epg-context-result-for context 'verify)))))))
1069
1070 (defun mml2015-epg-verify (handle ctl)
1071   (catch 'error
1072     (let ((inhibit-redisplay t)
1073           context plain signature-file part signature)
1074       (when (or (null (setq part (mm-find-raw-part-by-type
1075                                   ctl (or (mm-handle-multipart-ctl-parameter
1076                                            ctl 'protocol)
1077                                           "application/pgp-signature")
1078                                   t)))
1079                 (null (setq signature (mm-find-part-by-type
1080                                        (cdr handle) "application/pgp-signature"
1081                                        nil t))))
1082         (mm-set-handle-multipart-parameter
1083          mm-security-handle 'gnus-info "Corrupted")
1084         (throw 'error handle))
1085       (setq context (epg-make-context))
1086       (condition-case error
1087           (setq plain (epg-verify-string context (mm-get-part signature) part))
1088         (error
1089          (mm-set-handle-multipart-parameter
1090           mm-security-handle 'gnus-info "Failed")
1091          (if (eq (car error) 'quit)
1092              (mm-set-handle-multipart-parameter
1093               mm-security-handle 'gnus-details "Quit.")
1094            (mm-set-handle-multipart-parameter
1095             mm-security-handle 'gnus-details (mml2015-format-error error)))
1096          (throw 'error handle)))
1097       (mm-set-handle-multipart-parameter
1098        mm-security-handle 'gnus-info
1099        (epg-verify-result-to-string (epg-context-result-for context 'verify)))
1100       handle)))
1101
1102 (defun mml2015-epg-clear-verify ()
1103   (let ((inhibit-redisplay t)
1104         (context (epg-make-context))
1105         (signature (encode-coding-string (buffer-string)
1106                                          buffer-file-coding-system))
1107         plain)
1108     (condition-case error
1109         (setq plain (epg-verify-string context signature))
1110       (error
1111        (mm-set-handle-multipart-parameter
1112         mm-security-handle 'gnus-info "Failed")
1113        (if (eq (car error) 'quit)
1114            (mm-set-handle-multipart-parameter
1115             mm-security-handle 'gnus-details "Quit.")
1116          (mm-set-handle-multipart-parameter
1117           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1118     (if plain
1119         (mm-set-handle-multipart-parameter
1120          mm-security-handle 'gnus-info
1121          (epg-verify-result-to-string
1122           (epg-context-result-for context 'verify))))))
1123
1124 (defun mml2015-epg-sign (cont)
1125   (let* ((inhibit-redisplay t)
1126         (context (epg-make-context))
1127         (boundary (mml-compute-boundary cont))
1128         (signers
1129          (or (message-options-get 'mml2015-epg-signers)
1130              (message-options-set
1131               'mml2015-epg-signers
1132               (if mml2015-verbose
1133                   (epa-select-keys context "\
1134 Select keys for signing.
1135 If no one is selected, default secret key is used.  "
1136                                    mml2015-signers t)
1137                 (if mml2015-signers
1138                     (mapcar (lambda (name)
1139                               (car (epg-list-keys context name t)))
1140                             mml2015-signers))))))
1141         signature micalg)
1142     (epg-context-set-armor context t)
1143     (epg-context-set-textmode context t)
1144     (epg-context-set-signers context signers)
1145     (if mml2015-cache-passphrase
1146         (epg-context-set-passphrase-callback
1147          context
1148          #'mml2015-epg-passphrase-callback))
1149     (condition-case error
1150         (setq signature (epg-sign-string context (buffer-string) t)
1151               mml2015-epg-secret-key-id-list nil)
1152       (error
1153        (while mml2015-epg-secret-key-id-list
1154          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1155          (setq mml2015-epg-secret-key-id-list
1156                (cdr mml2015-epg-secret-key-id-list)))
1157        (signal (car error) (cdr error))))
1158     (if (epg-context-result-for context 'sign)
1159         (setq micalg (epg-new-signature-digest-algorithm
1160                       (car (epg-context-result-for context 'sign)))))
1161     (goto-char (point-min))
1162     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1163                     boundary))
1164     (if micalg
1165         (insert (format "\tmicalg=%s; "
1166                         (downcase
1167                          (cdr (assq micalg
1168                                     epg-digest-algorithm-alist))))))
1169     (insert "protocol=\"application/pgp-signature\"\n")
1170     (insert (format "\n--%s\n" boundary))
1171     (goto-char (point-max))
1172     (insert (format "\n--%s\n" boundary))
1173     (insert "Content-Type: application/pgp-signature\n\n")
1174     (insert signature)
1175     (goto-char (point-max))
1176     (insert (format "--%s--\n" boundary))
1177     (goto-char (point-max))))
1178
1179 (defun mml2015-epg-encrypt (cont &optional sign)
1180   (let ((inhibit-redisplay t)
1181         (context (epg-make-context))
1182         (config (epg-configuration))
1183         (recipients (split-string
1184                      (or (message-options-get 'message-recipients)
1185                          (message-options-set 'message-recipients
1186                                               (read-string "Recipients: ")))
1187                      "[ \f\t\n\r\v,]+"))
1188         cipher signers
1189         (boundary (mml-compute-boundary cont)))
1190     (setq recipients (apply #'nconc
1191                             (mapcar
1192                              (lambda (recipient)
1193                                (or (epg-expand-group config recipient)
1194                                    (list recipient)))
1195                              recipients)))
1196     (if mml2015-verbose
1197         (setq recipients
1198               (epa-select-keys context "Select recipients for encryption.
1199 If no one is selected, symmetric encryption will be performed.  "
1200                                recipients))
1201       (setq recipients
1202             (delq nil (mapcar (lambda (name)
1203                                 (car (epg-list-keys context name)))
1204                               recipients))))
1205     (if mml2015-encrypt-to-self
1206         (if mml2015-signers
1207             (setq recipients
1208                   (nconc recipients
1209                          (mapcar (lambda (name)
1210                                    (car (epg-list-keys context name)))
1211                                  mml2015-signers)))
1212           (error "mml2015-signers not set")))
1213     (when sign
1214       (if mml2015-verbose
1215           (setq signers (epa-select-keys context "Select keys for signing.
1216 If no one is selected, default secret key is used.  "
1217                                          mml2015-signers t))
1218         (if mml2015-signers
1219             (setq signers (mapcar (lambda (name)
1220                                     (car (epg-list-keys context name t)))
1221                                   mml2015-signers))))
1222       (epg-context-set-signers context signers))
1223     (epg-context-set-armor context t)
1224     (epg-context-set-textmode context t)
1225     (if mml2015-cache-passphrase
1226         (epg-context-set-passphrase-callback
1227          context
1228          #'mml2015-epg-passphrase-callback))
1229     (condition-case error
1230         (setq cipher
1231               (epg-encrypt-string context (buffer-string) recipients sign
1232                                   mml2015-always-trust)
1233               mml2015-epg-secret-key-id-list nil)
1234       (error
1235        (while mml2015-epg-secret-key-id-list
1236          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1237          (setq mml2015-epg-secret-key-id-list
1238                (cdr mml2015-epg-secret-key-id-list)))
1239        (signal (car error) (cdr error))))
1240     (delete-region (point-min) (point-max))
1241     (goto-char (point-min))
1242     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1243                     boundary))
1244     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1245     (insert (format "--%s\n" boundary))
1246     (insert "Content-Type: application/pgp-encrypted\n\n")
1247     (insert "Version: 1\n\n")
1248     (insert (format "--%s\n" boundary))
1249     (insert "Content-Type: application/octet-stream\n\n")
1250     (insert cipher)
1251     (goto-char (point-max))
1252     (insert (format "--%s--\n" boundary))
1253     (goto-char (point-max))))
1254
1255 ;;; General wrapper
1256
1257 (defun mml2015-clean-buffer ()
1258   (if (gnus-buffer-live-p mml2015-result-buffer)
1259       (with-current-buffer mml2015-result-buffer
1260         (erase-buffer)
1261         t)
1262     (setq mml2015-result-buffer
1263           (gnus-get-buffer-create " *MML2015 Result*"))
1264     nil))
1265
1266 (defsubst mml2015-clear-decrypt-function ()
1267   (nth 6 (assq mml2015-use mml2015-function-alist)))
1268
1269 (defsubst mml2015-clear-verify-function ()
1270   (nth 5 (assq mml2015-use mml2015-function-alist)))
1271
1272 ;;;###autoload
1273 (defun mml2015-decrypt (handle ctl)
1274   (mml2015-clean-buffer)
1275   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1276     (if func
1277         (funcall func handle ctl)
1278       handle)))
1279
1280 ;;;###autoload
1281 (defun mml2015-decrypt-test (handle ctl)
1282   mml2015-use)
1283
1284 ;;;###autoload
1285 (defun mml2015-verify (handle ctl)
1286   (mml2015-clean-buffer)
1287   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1288     (if func
1289         (funcall func handle ctl)
1290       handle)))
1291
1292 ;;;###autoload
1293 (defun mml2015-verify-test (handle ctl)
1294   mml2015-use)
1295
1296 ;;;###autoload
1297 (defun mml2015-encrypt (cont &optional sign)
1298   (mml2015-clean-buffer)
1299   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1300     (if func
1301         (funcall func cont sign)
1302       (error "Cannot find encrypt function"))))
1303
1304 ;;;###autoload
1305 (defun mml2015-sign (cont)
1306   (mml2015-clean-buffer)
1307   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1308     (if func
1309         (funcall func cont)
1310       (error "Cannot find sign function"))))
1311
1312 ;;;###autoload
1313 (defun mml2015-self-encrypt ()
1314   (mml2015-encrypt nil))
1315
1316 (provide 'mml2015)
1317
1318 ;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
1319 ;;; mml2015.el ends here