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

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