lisp/gnus/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 (eval-when-compile
 975   (autoload 'password-read "password")
 976   (autoload 'password-cache-add "password")
 977   (autoload 'password-cache-remove "password"))
 978
 979 (defvar mml2015-epg-secret-key-id-list nil)
 980
 981 (defun mml2015-epg-passphrase-callback (context key-id ignore)
 982   (if (eq key-id 'SYM)
 983       (epg-passphrase-callback-function context key-id nil)
 984     (let* (entry
 985            (passphrase
 986             (password-read
 987              (if (eq key-id 'PIN)
 988                  "Passphrase for PIN: "
 989                (if (setq entry (assoc key-id epg-user-id-alist))
 990                    (format "Passphrase for %s %s: " key-id (cdr entry))
 991                  (format "Passphrase for %s: " key-id)))
 992              (if (eq key-id 'PIN)
 993                  "PIN"
 994                key-id))))
 995       (when passphrase
 996         (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
 997           (password-cache-add key-id passphrase))
 998         (setq mml2015-epg-secret-key-id-list
 999               (cons key-id mml2015-epg-secret-key-id-list))
1000         (copy-sequence passphrase)))))
1001
1002 (defun mml2015-epg-find-usable-key (keys usage)
1003   (catch 'found
1004     (while keys
1005       (let ((pointer (epg-key-sub-key-list (car keys))))
1006         (while pointer
1007           (if (and (memq usage (epg-sub-key-capability (car pointer)))
1008                    (not (memq (epg-sub-key-validity (car pointer))
1009                               '(revoked expired))))
1010               (throw 'found (car keys)))
1011           (setq pointer (cdr pointer))))
1012       (setq keys (cdr keys)))))
1013
1014 (defun mml2015-epg-decrypt (handle ctl)
1015   (catch 'error
1016     (let ((inhibit-redisplay t)
1017           context plain child handles result decrypt-status)
1018       (unless (setq child (mm-find-part-by-type
1019                            (cdr handle)
1020                            "application/octet-stream" nil t))
1021         (mm-set-handle-multipart-parameter
1022          mm-security-handle 'gnus-info "Corrupted")
1023         (throw 'error handle))
1024       (setq context (epg-make-context))
1025       (if mml2015-cache-passphrase
1026           (epg-context-set-passphrase-callback
1027            context
1028            #'mml2015-epg-passphrase-callback))
1029       (condition-case error
1030           (setq plain (epg-decrypt-string context (mm-get-part child))
1031                 mml2015-epg-secret-key-id-list nil)
1032         (error
1033          (while mml2015-epg-secret-key-id-list
1034            (password-cache-remove (car mml2015-epg-secret-key-id-list))
1035            (setq mml2015-epg-secret-key-id-list
1036                  (cdr mml2015-epg-secret-key-id-list)))
1037          (mm-set-handle-multipart-parameter
1038           mm-security-handle 'gnus-info "Failed")
1039          (if (eq (car error) 'quit)
1040              (mm-set-handle-multipart-parameter
1041               mm-security-handle 'gnus-details "Quit.")
1042            (mm-set-handle-multipart-parameter
1043             mm-security-handle 'gnus-details (mml2015-format-error error)))
1044          (throw 'error handle)))
1045       (with-temp-buffer
1046         (insert plain)
1047         (goto-char (point-min))
1048         (while (search-forward "\r\n" nil t)
1049           (replace-match "\n" t t))
1050         (setq handles (mm-dissect-buffer t))
1051         (mm-destroy-parts handle)
1052         (if (epg-context-result-for context 'verify)
1053             (mm-set-handle-multipart-parameter
1054              mm-security-handle 'gnus-info
1055              (concat "OK\n"
1056                      (epg-verify-result-to-string
1057                       (epg-context-result-for context 'verify))))
1058           (mm-set-handle-multipart-parameter
1059            mm-security-handle 'gnus-info "OK"))
1060         (if (stringp (car handles))
1061             (mm-set-handle-multipart-parameter
1062              mm-security-handle 'gnus-details
1063              (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
1064         (if (listp (car handles))
1065             handles
1066           (list handles)))))
1067
1068 (defun mml2015-epg-clear-decrypt ()
1069   (let ((inhibit-redisplay t)
1070         (context (epg-make-context))
1071         plain)
1072     (if mml2015-cache-passphrase
1073         (epg-context-set-passphrase-callback
1074          context
1075          #'mml2015-epg-passphrase-callback))
1076     (condition-case error
1077         (setq plain (epg-decrypt-string context (buffer-string))
1078               mml2015-epg-secret-key-id-list nil)
1079       (error
1080        (while mml2015-epg-secret-key-id-list
1081          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1082          (setq mml2015-epg-secret-key-id-list
1083                (cdr mml2015-epg-secret-key-id-list)))
1084        (mm-set-handle-multipart-parameter
1085         mm-security-handle 'gnus-info "Failed")
1086        (if (eq (car error) 'quit)
1087            (mm-set-handle-multipart-parameter
1088             mm-security-handle 'gnus-details "Quit.")
1089          (mm-set-handle-multipart-parameter
1090           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1091     (when plain
1092       (erase-buffer)
1093       ;; Treat data which epg returns as a unibyte string.
1094       (mm-disable-multibyte)
1095       (insert plain)
1096       (goto-char (point-min))
1097       (while (search-forward "\r\n" nil t)
1098         (replace-match "\n" t t))
1099       (mm-set-handle-multipart-parameter
1100        mm-security-handle 'gnus-info "OK")
1101       (if (epg-context-result-for context 'verify)
1102           (mm-set-handle-multipart-parameter
1103            mm-security-handle 'gnus-details
1104            (epg-verify-result-to-string
1105             (epg-context-result-for context 'verify)))))))
1106
1107 (defun mml2015-epg-verify (handle ctl)
1108   (catch 'error
1109     (let ((inhibit-redisplay t)
1110           context plain signature-file part signature)
1111       (when (or (null (setq part (mm-find-raw-part-by-type
1112                                   ctl (or (mm-handle-multipart-ctl-parameter
1113                                            ctl 'protocol)
1114                                           "application/pgp-signature")
1115                                   t)))
1116                 (null (setq signature (mm-find-part-by-type
1117                                        (cdr handle) "application/pgp-signature"
1118                                        nil t))))
1119         (mm-set-handle-multipart-parameter
1120          mm-security-handle 'gnus-info "Corrupted")
1121         (throw 'error handle))
1122       (setq part (mm-replace-in-string part "\n" "\r\n" t)
1123             signature (mm-get-part signature)
1124             context (epg-make-context))
1125       (condition-case error
1126           (setq plain (epg-verify-string context signature part))
1127         (error
1128          (mm-set-handle-multipart-parameter
1129           mm-security-handle 'gnus-info "Failed")
1130          (if (eq (car error) 'quit)
1131              (mm-set-handle-multipart-parameter
1132               mm-security-handle 'gnus-details "Quit.")
1133            (mm-set-handle-multipart-parameter
1134             mm-security-handle 'gnus-details (mml2015-format-error error)))
1135          (throw 'error handle)))
1136       (mm-set-handle-multipart-parameter
1137        mm-security-handle 'gnus-info
1138        (epg-verify-result-to-string (epg-context-result-for context 'verify)))
1139       handle)))
1140
1141 (defun mml2015-epg-clear-verify ()
1142   (let ((inhibit-redisplay t)
1143         (context (epg-make-context))
1144         (signature (mm-encode-coding-string (buffer-string)
1145                                             coding-system-for-write))
1146         plain)
1147     (condition-case error
1148         (setq plain (epg-verify-string context signature))
1149       (error
1150        (mm-set-handle-multipart-parameter
1151         mm-security-handle 'gnus-info "Failed")
1152        (if (eq (car error) 'quit)
1153            (mm-set-handle-multipart-parameter
1154             mm-security-handle 'gnus-details "Quit.")
1155          (mm-set-handle-multipart-parameter
1156           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1157     (if plain
1158         (progn
1159           (mm-set-handle-multipart-parameter
1160            mm-security-handle 'gnus-info
1161            (epg-verify-result-to-string
1162             (epg-context-result-for context 'verify)))
1163           (delete-region (point-min) (point-max))
1164           (insert (mm-decode-coding-string plain coding-system-for-read)))
1165       (mml2015-extract-cleartext-signature))))
1166
1167 (defun mml2015-epg-sign (cont)
1168   (let* ((inhibit-redisplay t)
1169          (context (epg-make-context))
1170          (boundary (mml-compute-boundary cont))
1171          signer-key
1172          (signers
1173           (or (message-options-get 'mml2015-epg-signers)
1174               (message-options-set
1175                'mml2015-epg-signers
1176                (if mml2015-verbose
1177                    (epa-select-keys context "\
1178 Select keys for signing.
1179 If no one is selected, default secret key is used.  "
1180                                     mml2015-signers t)
1181                  (if mml2015-signers
1182                      (mapcar
1183                       (lambda (signer)
1184                         (setq signer-key (mml2015-epg-find-usable-key
1185                                           (epg-list-keys context signer t)
1186                                           'sign))
1187                         (unless (or signer-key
1188                                     (y-or-n-p
1189                                      (format "No secret key for %s; skip it? "
1190                                              signer)))
1191                           (error "No secret key for %s" signer))
1192                         signer-key)
1193                       mml2015-signers))))))
1194          signature micalg)
1195     (epg-context-set-armor context t)
1196     (epg-context-set-textmode context t)
1197     (epg-context-set-signers context signers)
1198     (if mml2015-cache-passphrase
1199         (epg-context-set-passphrase-callback
1200          context
1201          #'mml2015-epg-passphrase-callback))
1202     (condition-case error
1203         (setq signature (epg-sign-string context (buffer-string) t)
1204               mml2015-epg-secret-key-id-list nil)
1205       (error
1206        (while mml2015-epg-secret-key-id-list
1207          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1208          (setq mml2015-epg-secret-key-id-list
1209                (cdr mml2015-epg-secret-key-id-list)))
1210        (signal (car error) (cdr error))))
1211     (if (epg-context-result-for context 'sign)
1212         (setq micalg (epg-new-signature-digest-algorithm
1213                       (car (epg-context-result-for context 'sign)))))
1214     (goto-char (point-min))
1215     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1216                     boundary))
1217     (if micalg
1218         (insert (format "\tmicalg=pgp-%s; "
1219                         (downcase
1220                          (cdr (assq micalg
1221                                     epg-digest-algorithm-alist))))))
1222     (insert "protocol=\"application/pgp-signature\"\n")
1223     (insert (format "\n--%s\n" boundary))
1224     (goto-char (point-max))
1225     (insert (format "\n--%s\n" boundary))
1226     (insert "Content-Type: application/pgp-signature\n\n")
1227     (insert signature)
1228     (goto-char (point-max))
1229     (insert (format "--%s--\n" boundary))
1230     (goto-char (point-max))))
1231
1232 (defun mml2015-epg-encrypt (cont &optional sign)
1233   (let ((inhibit-redisplay t)
1234         (context (epg-make-context))
1235         (config (epg-configuration))
1236         (recipients (message-options-get 'mml2015-epg-recipients))
1237         cipher signers
1238         (boundary (mml-compute-boundary cont))
1239         recipient-key signer-key)
1240     (unless recipients
1241       (setq recipients
1242             (apply #'nconc
1243                    (mapcar
1244                     (lambda (recipient)
1245                       (or (epg-expand-group config recipient)
1246                           (list (concat "<" recipient ">"))))
1247                     (split-string
1248                      (or (message-options-get 'message-recipients)
1249                          (message-options-set 'message-recipients
1250                                               (read-string "Recipients: ")))
1251                      "[ \f\t\n\r\v,]+"))))
1252       (when mml2015-encrypt-to-self
1253         (unless mml2015-signers
1254           (error "mml2015-signers not set"))
1255         (setq recipients (nconc recipients mml2015-signers)))
1256       (if mml2015-verbose
1257           (setq recipients
1258                 (epa-select-keys context "\
1259 Select recipients for encryption.
1260 If no one is selected, symmetric encryption will be performed.  "
1261                                  recipients))
1262         (setq recipients
1263               (mapcar
1264                (lambda (recipient)
1265                  (setq recipient-key (mml2015-epg-find-usable-key
1266                                       (epg-list-keys context recipient)
1267                                       'encrypt))
1268                  (unless (or recipient-key
1269                              (y-or-n-p
1270                               (format "No public key for %s; skip it? "
1271                                       recipient)))
1272                    (error "No public key for %s" recipient))
1273                  recipient-key)
1274                recipients))
1275         (unless recipients
1276           (error "No recipient specified")))
1277       (message-options-set 'mml2015-epg-recipients recipients))
1278     (when sign
1279       (setq signers
1280             (or (message-options-get 'mml2015-epg-signers)
1281                 (message-options-set
1282                  'mml2015-epg-signers
1283                  (if mml2015-verbose
1284                      (epa-select-keys context "\
1285 Select keys for signing.
1286 If no one is selected, default secret key is used.  "
1287                                       mml2015-signers t)
1288                    (if mml2015-signers
1289                        (mapcar
1290                         (lambda (signer)
1291                           (setq signer-key (mml2015-epg-find-usable-key
1292                                             (epg-list-keys context signer t)
1293                                             'sign))
1294                           (unless (or signer-key
1295                                       (y-or-n-p
1296                                        (format
1297                                         "No secret key for %s; skip it? "
1298                                         signer)))
1299                             (error "No secret key for %s" signer))
1300                           signer-key)
1301                         mml2015-signers))))))
1302       (epg-context-set-signers context signers))
1303     (epg-context-set-armor context t)
1304     (epg-context-set-textmode context t)
1305     (if mml2015-cache-passphrase
1306         (epg-context-set-passphrase-callback
1307          context
1308          #'mml2015-epg-passphrase-callback))
1309     (condition-case error
1310         (setq cipher
1311               (epg-encrypt-string context (buffer-string) recipients sign
1312                                   mml2015-always-trust)
1313               mml2015-epg-secret-key-id-list nil)
1314       (error
1315        (while mml2015-epg-secret-key-id-list
1316          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1317          (setq mml2015-epg-secret-key-id-list
1318                (cdr mml2015-epg-secret-key-id-list)))
1319        (signal (car error) (cdr error))))
1320     (delete-region (point-min) (point-max))
1321     (goto-char (point-min))
1322     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1323                     boundary))
1324     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1325     (insert (format "--%s\n" boundary))
1326     (insert "Content-Type: application/pgp-encrypted\n\n")
1327     (insert "Version: 1\n\n")
1328     (insert (format "--%s\n" boundary))
1329     (insert "Content-Type: application/octet-stream\n\n")
1330     (insert cipher)
1331     (goto-char (point-max))
1332     (insert (format "--%s--\n" boundary))
1333     (goto-char (point-max))))
1334
1335 ;;; General wrapper
1336
1337 (defun mml2015-clean-buffer ()
1338   (if (gnus-buffer-live-p mml2015-result-buffer)
1339       (with-current-buffer mml2015-result-buffer
1340         (erase-buffer)
1341         t)
1342     (setq mml2015-result-buffer
1343           (gnus-get-buffer-create " *MML2015 Result*"))
1344     nil))
1345
1346 (defsubst mml2015-clear-decrypt-function ()
1347   (nth 6 (assq mml2015-use mml2015-function-alist)))
1348
1349 (defsubst mml2015-clear-verify-function ()
1350   (nth 5 (assq mml2015-use mml2015-function-alist)))
1351
1352 ;;;###autoload
1353 (defun mml2015-decrypt (handle ctl)
1354   (mml2015-clean-buffer)
1355   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1356     (if func
1357         (funcall func handle ctl)
1358       handle)))
1359
1360 ;;;###autoload
1361 (defun mml2015-decrypt-test (handle ctl)
1362   mml2015-use)
1363
1364 ;;;###autoload
1365 (defun mml2015-verify (handle ctl)
1366   (mml2015-clean-buffer)
1367   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1368     (if func
1369         (funcall func handle ctl)
1370       handle)))
1371
1372 ;;;###autoload
1373 (defun mml2015-verify-test (handle ctl)
1374   mml2015-use)
1375
1376 ;;;###autoload
1377 (defun mml2015-encrypt (cont &optional sign)
1378   (mml2015-clean-buffer)
1379   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1380     (if func
1381         (funcall func cont sign)
1382       (error "Cannot find encrypt function"))))
1383
1384 ;;;###autoload
1385 (defun mml2015-sign (cont)
1386   (mml2015-clean-buffer)
1387   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1388     (if func
1389         (funcall func cont)
1390       (error "Cannot find sign function"))))
1391
1392 ;;;###autoload
1393 (defun mml2015-self-encrypt ()
1394   (mml2015-encrypt nil))
1395
1396 (provide 'mml2015)
1397
1398 ;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
1399 ;;; mml2015.el ends here