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

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