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