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