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, 2008 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 ;; For Emacs < 22.2.
  34 (eval-and-compile
  35   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  36
  37 (eval-when-compile (require 'cl))
  38 (require 'mm-decode)
  39 (require 'mm-util)
  40 (require 'mml)
  41 (require 'mml-sec)
  42
  43 (defvar mc-pgp-always-sign)
  44
  45 (declare-function epg-check-configuration "ext:epg-config"
  46                   (config &optional minimum-version))
  47 (declare-function epg-configuration "ext:epg-config" ())
  48
  49 (defvar mml2015-use (or
  50                      (condition-case nil
  51                          (progn
  52                            (require 'epg-config)
  53                            (epg-check-configuration (epg-configuration))
  54                            'epg)
  55                        (error))
  56                      (progn
  57                        (ignore-errors
  58                         ;; Avoid the "Recursive load suspected" error
  59                         ;; in Emacs 21.1.
  60                         (let ((recursive-load-depth-limit 100))
  61                           (require 'pgg)))
  62                        (and (fboundp 'pgg-sign-region)
  63                             'pgg))
  64                      (progn
  65                        (ignore-errors
  66                          (require 'gpg))
  67                        (and (fboundp 'gpg-sign-detached)
  68                             'gpg))
  69                      (progn (ignore-errors
  70                               (load "mc-toplev"))
  71                             (and (fboundp 'mc-encrypt-generic)
  72                                  (fboundp 'mc-sign-generic)
  73                                  (fboundp 'mc-cleanup-recipient-headers)
  74                                  'mailcrypt)))
  75   "The package used for PGP/MIME.
  76 Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
  77
  78 ;; Something is not RFC2015.
  79 (defvar mml2015-function-alist
  80   '((mailcrypt mml2015-mailcrypt-sign
  81                mml2015-mailcrypt-encrypt
  82                mml2015-mailcrypt-verify
  83                mml2015-mailcrypt-decrypt
  84                mml2015-mailcrypt-clear-verify
  85                mml2015-mailcrypt-clear-decrypt)
  86     (gpg mml2015-gpg-sign
  87          mml2015-gpg-encrypt
  88          mml2015-gpg-verify
  89          mml2015-gpg-decrypt
  90          mml2015-gpg-clear-verify
  91          mml2015-gpg-clear-decrypt)
  92   (pgg mml2015-pgg-sign
  93        mml2015-pgg-encrypt
  94        mml2015-pgg-verify
  95        mml2015-pgg-decrypt
  96        mml2015-pgg-clear-verify
  97        mml2015-pgg-clear-decrypt)
  98   (epg mml2015-epg-sign
  99        mml2015-epg-encrypt
 100        mml2015-epg-verify
 101        mml2015-epg-decrypt
 102        mml2015-epg-clear-verify
 103        mml2015-epg-clear-decrypt))
 104   "Alist of PGP/MIME functions.")
 105
 106 (defvar mml2015-result-buffer nil)
 107
 108 (defcustom mml2015-unabbrev-trust-alist
 109   '(("TRUST_UNDEFINED" . nil)
 110     ("TRUST_NEVER"     . nil)
 111     ("TRUST_MARGINAL"  . t)
 112     ("TRUST_FULLY"     . t)
 113     ("TRUST_ULTIMATE"  . t))
 114   "Map GnuPG trust output values to a boolean saying if you trust the key."
 115   :version "22.1"
 116   :group 'mime-security
 117   :type '(repeat (cons (regexp :tag "GnuPG output regexp")
 118                        (boolean :tag "Trust key"))))
 119
 120 (defcustom mml2015-verbose mml-secure-verbose
 121   "If non-nil, ask the user about the current operation more verbosely."
 122   :group 'mime-security
 123   :type 'boolean)
 124
 125 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
 126   "If t, cache passphrase."
 127   :group 'mime-security
 128   :type 'boolean)
 129
 130 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
 131   "How many seconds the passphrase is cached.
 132 Whether the passphrase is cached at all is controlled by
 133 `mml2015-cache-passphrase'."
 134   :group 'mime-security
 135   :type 'integer)
 136
 137 (defcustom mml2015-signers nil
 138   "A list of your own key ID which will be used to sign a message."
 139   :group 'mime-security
 140   :type '(repeat (string :tag "Key ID")))
 141
 142 (defcustom mml2015-encrypt-to-self nil
 143   "If t, add your own key ID to recipient list when encryption."
 144   :group 'mime-security
 145   :type 'boolean)
 146
 147 (defcustom mml2015-always-trust t
 148   "If t, GnuPG skip key validation on encryption."
 149   :group 'mime-security
 150   :type 'boolean)
 151
 152 ;; Extract plaintext from cleartext signature.  IMO, this kind of task
 153 ;; should be done by GnuPG rather than Elisp, but older PGP backends
 154 ;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG.
 155 (defun mml2015-extract-cleartext-signature ()
 156   ;; Daiki Ueno in
 157   ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
 158   ;; believe that the right way is to use the plaintext output from GnuPG as
 159   ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
 160   ;; misdesigned libraries like PGG, which have no ability to do that.  So, I
 161   ;; think it should not have descriptive documentation.''
 162   ;;
 163   ;; This function doesn't handle NotDashEscaped correctly.  EasyPG handles it
 164   ;; correctly.
 165   ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
 166   ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
 167   (goto-char (point-min))
 168   (forward-line)
 169   ;; We need to be careful not to strip beyond the armor headers.
 170   ;; Previously, an attacker could replace the text inside our
 171   ;; markup with trailing garbage by injecting whitespace into the
 172   ;; message.
 173   (while (looking-at "Hash:")           ; The only header allowed in cleartext
 174     (forward-line))                     ; signatures according to RFC2440.
 175   (when (looking-at "[\t ]*$")
 176     (forward-line))
 177   (delete-region (point-min) (point))
 178   (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t)
 179       (delete-region (match-beginning 0) (point-max)))
 180   (goto-char (point-min))
 181   (while (re-search-forward "^- " nil t)
 182     (replace-match "" t t)
 183     (forward-line 1)))
 184
 185 ;;; mailcrypt wrapper
 186
 187 (eval-and-compile
 188   (autoload 'mailcrypt-decrypt "mailcrypt")
 189   (autoload 'mailcrypt-verify "mailcrypt")
 190   (autoload 'mc-pgp-always-sign "mailcrypt")
 191   (autoload 'mc-encrypt-generic "mc-toplev")
 192   (autoload 'mc-cleanup-recipient-headers "mc-toplev")
 193   (autoload 'mc-sign-generic "mc-toplev"))
 194
 195 (defvar mc-default-scheme)
 196 (defvar mc-schemes)
 197
 198 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
 199 (defvar mml2015-verify-function 'mailcrypt-verify)
 200
 201 (defun mml2015-format-error (err)
 202   (if (stringp (cadr err))
 203       (cadr err)
 204     (format "%S" (cdr err))))
 205
 206 (defun mml2015-mailcrypt-decrypt (handle ctl)
 207   (catch 'error
 208     (let (child handles result)
 209       (unless (setq child (mm-find-part-by-type
 210                            (cdr handle)
 211                            "application/octet-stream" nil t))
 212         (mm-set-handle-multipart-parameter
 213          mm-security-handle 'gnus-info "Corrupted")
 214         (throw 'error handle))
 215       (with-temp-buffer
 216         (mm-insert-part child)
 217         (setq result
 218               (condition-case err
 219                   (funcall mml2015-decrypt-function)
 220                 (error
 221                  (mm-set-handle-multipart-parameter
 222                   mm-security-handle 'gnus-details (mml2015-format-error err))
 223                  nil)
 224                 (quit
 225                  (mm-set-handle-multipart-parameter
 226                   mm-security-handle 'gnus-details "Quit.")
 227                  nil)))
 228         (unless (car result)
 229           (mm-set-handle-multipart-parameter
 230            mm-security-handle 'gnus-info "Failed")
 231           (throw 'error handle))
 232         (setq handles (mm-dissect-buffer t)))
 233       (mm-destroy-parts handle)
 234       (mm-set-handle-multipart-parameter
 235        mm-security-handle 'gnus-info
 236        (concat "OK"
 237                (let ((sig (with-current-buffer mml2015-result-buffer
 238                             (mml2015-gpg-extract-signature-details))))
 239                  (concat ", Signer: " sig))))
 240       (if (listp (car handles))
 241           handles
 242         (list handles)))))
 243
 244 (defun mml2015-mailcrypt-clear-decrypt ()
 245   (let (result)
 246     (setq result
 247           (condition-case err
 248               (funcall mml2015-decrypt-function)
 249             (error
 250              (mm-set-handle-multipart-parameter
 251               mm-security-handle 'gnus-details (mml2015-format-error err))
 252              nil)
 253             (quit
 254              (mm-set-handle-multipart-parameter
 255               mm-security-handle 'gnus-details "Quit.")
 256              nil)))
 257     (if (car result)
 258         (mm-set-handle-multipart-parameter
 259          mm-security-handle 'gnus-info "OK")
 260       (mm-set-handle-multipart-parameter
 261        mm-security-handle 'gnus-info "Failed"))))
 262
 263 (defun mml2015-fix-micalg (alg)
 264   (and alg
 265        ;; Mutt/1.2.5i has seen sending micalg=php-sha1
 266        (upcase (if (string-match "^p[gh]p-" alg)
 267                    (substring alg (match-end 0))
 268                  alg))))
 269
 270 (defun mml2015-mailcrypt-verify (handle ctl)
 271   (catch 'error
 272     (let (part)
 273       (unless (setq part (mm-find-raw-part-by-type
 274                           ctl (or (mm-handle-multipart-ctl-parameter
 275                                    ctl 'protocol)
 276                                   "application/pgp-signature")
 277                           t))
 278         (mm-set-handle-multipart-parameter
 279          mm-security-handle 'gnus-info "Corrupted")
 280         (throw 'error handle))
 281       (with-temp-buffer
 282         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
 283         (insert (format "Hash: %s\n\n"
 284                         (or (mml2015-fix-micalg
 285                              (mm-handle-multipart-ctl-parameter
 286                               ctl 'micalg))
 287                             "SHA1")))
 288         (save-restriction
 289           (narrow-to-region (point) (point))
 290           (insert part "\n")
 291           (goto-char (point-min))
 292           (while (not (eobp))
 293             (if (looking-at "^-")
 294                 (insert "- "))
 295             (forward-line)))
 296         (unless (setq part (mm-find-part-by-type
 297                             (cdr handle) "application/pgp-signature" nil t))
 298           (mm-set-handle-multipart-parameter
 299            mm-security-handle 'gnus-info "Corrupted")
 300           (throw 'error handle))
 301         (save-restriction
 302           (narrow-to-region (point) (point))
 303           (mm-insert-part part)
 304           (goto-char (point-min))
 305           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
 306               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
 307           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
 308               (replace-match "-----END PGP SIGNATURE-----" t t)))
 309         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 310           (unless (condition-case err
 311                       (prog1
 312                           (funcall mml2015-verify-function)
 313                         (if (get-buffer " *mailcrypt stderr temp")
 314                             (mm-set-handle-multipart-parameter
 315                              mm-security-handle 'gnus-details
 316                              (with-current-buffer " *mailcrypt stderr temp"
 317                                (buffer-string))))
 318                         (if (get-buffer " *mailcrypt stdout temp")
 319                             (kill-buffer " *mailcrypt stdout temp"))
 320                         (if (get-buffer " *mailcrypt stderr temp")
 321                             (kill-buffer " *mailcrypt stderr temp"))
 322                         (if (get-buffer " *mailcrypt status temp")
 323                             (kill-buffer " *mailcrypt status temp"))
 324                         (if (get-buffer mc-gpg-debug-buffer)
 325                             (kill-buffer mc-gpg-debug-buffer)))
 326                     (error
 327                      (mm-set-handle-multipart-parameter
 328                       mm-security-handle 'gnus-details (mml2015-format-error err))
 329                      nil)
 330                     (quit
 331                      (mm-set-handle-multipart-parameter
 332                       mm-security-handle 'gnus-details "Quit.")
 333                      nil))
 334             (mm-set-handle-multipart-parameter
 335              mm-security-handle 'gnus-info "Failed")
 336             (throw 'error handle))))
 337       (mm-set-handle-multipart-parameter
 338        mm-security-handle 'gnus-info "OK")
 339       handle)))
 340
 341 (defun mml2015-mailcrypt-clear-verify ()
 342   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 343     (if (condition-case err
 344             (prog1
 345                 (funcall mml2015-verify-function)
 346               (if (get-buffer " *mailcrypt stderr temp")
 347                   (mm-set-handle-multipart-parameter
 348                    mm-security-handle 'gnus-details
 349                    (with-current-buffer " *mailcrypt stderr temp"
 350                      (buffer-string))))
 351               (if (get-buffer " *mailcrypt stdout temp")
 352                   (kill-buffer " *mailcrypt stdout temp"))
 353               (if (get-buffer " *mailcrypt stderr temp")
 354                   (kill-buffer " *mailcrypt stderr temp"))
 355               (if (get-buffer " *mailcrypt status temp")
 356                   (kill-buffer " *mailcrypt status temp"))
 357               (if (get-buffer mc-gpg-debug-buffer)
 358                   (kill-buffer mc-gpg-debug-buffer)))
 359           (error
 360            (mm-set-handle-multipart-parameter
 361             mm-security-handle 'gnus-details (mml2015-format-error err))
 362            nil)
 363           (quit
 364            (mm-set-handle-multipart-parameter
 365             mm-security-handle 'gnus-details "Quit.")
 366            nil))
 367         (mm-set-handle-multipart-parameter
 368          mm-security-handle 'gnus-info "OK")
 369       (mm-set-handle-multipart-parameter
 370        mm-security-handle 'gnus-info "Failed")))
 371   (mml2015-extract-cleartext-signature))
 372
 373 (defun mml2015-mailcrypt-sign (cont)
 374   (mc-sign-generic (message-options-get 'message-sender)
 375                    nil nil nil nil)
 376   (let ((boundary (mml-compute-boundary cont))
 377         hash point)
 378     (goto-char (point-min))
 379     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
 380       (error "Cannot find signed begin line"))
 381     (goto-char (match-beginning 0))
 382     (forward-line 1)
 383     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 384       (error "Cannot not find PGP hash"))
 385     (setq hash (match-string 1))
 386     (unless (re-search-forward "^$" nil t)
 387       (error "Cannot not find PGP message"))
 388     (forward-line 1)
 389     (delete-region (point-min) (point))
 390     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 391                     boundary))
 392     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 393                     (downcase hash)))
 394     (insert (format "\n--%s\n" boundary))
 395     (setq point (point))
 396     (goto-char (point-max))
 397     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
 398       (error "Cannot find signature part"))
 399     (replace-match "-----END PGP MESSAGE-----" t t)
 400     (goto-char (match-beginning 0))
 401     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
 402                                 nil t)
 403       (error "Cannot find signature part"))
 404     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
 405     (goto-char (match-beginning 0))
 406     (save-restriction
 407       (narrow-to-region point (point))
 408       (goto-char point)
 409       (while (re-search-forward "^- -" nil t)
 410         (replace-match "-" t t))
 411       (goto-char (point-max)))
 412     (insert (format "--%s\n" boundary))
 413     (insert "Content-Type: application/pgp-signature\n\n")
 414     (goto-char (point-max))
 415     (insert (format "--%s--\n" boundary))
 416     (goto-char (point-max))))
 417
 418 ;; We require mm-decode, which requires mm-bodies, which autoloads
 419 ;; message-options-get (!).
 420 (declare-function message-options-set "message" (symbol value))
 421
 422 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
 423   (let ((mc-pgp-always-sign
 424          (or mc-pgp-always-sign
 425              sign
 426              (eq t (or (message-options-get 'message-sign-encrypt)
 427                        (message-options-set
 428                         'message-sign-encrypt
 429                         (or (y-or-n-p "Sign the message? ")
 430                             'not))))
 431              'never)))
 432     (mm-with-unibyte-current-buffer
 433       (mc-encrypt-generic
 434        (or (message-options-get 'message-recipients)
 435            (message-options-set 'message-recipients
 436                               (mc-cleanup-recipient-headers
 437                                (read-string "Recipients: "))))
 438        nil nil nil
 439        (message-options-get 'message-sender))))
 440   (goto-char (point-min))
 441   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
 442     (error "Fail to encrypt the message"))
 443   (let ((boundary (mml-compute-boundary cont)))
 444     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 445                     boundary))
 446     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 447     (insert (format "--%s\n" boundary))
 448     (insert "Content-Type: application/pgp-encrypted\n\n")
 449     (insert "Version: 1\n\n")
 450     (insert (format "--%s\n" boundary))
 451     (insert "Content-Type: application/octet-stream\n\n")
 452     (goto-char (point-max))
 453     (insert (format "--%s--\n" boundary))
 454     (goto-char (point-max))))
 455
 456 ;;; gpg wrapper
 457
 458 (eval-and-compile
 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         ;; set up a function to call the correct gpg encrypt routine
 684         ;; with the right arguments. (FIXME: this should be done
 685         ;; differently.)
 686         (flet ((gpg-encrypt-func
 687                  (sign plaintext ciphertext result recipients &optional
 688                        passphrase sign-with-key armor textmode)
 689                  (if sign
 690                      (gpg-sign-encrypt
 691                       plaintext ciphertext result recipients passphrase
 692                       sign-with-key armor textmode)
 693                    (gpg-encrypt
 694                     plaintext ciphertext result recipients passphrase
 695                     armor textmode))))
 696           (unless (gpg-encrypt-func
 697                     sign ; passed in when using signencrypt
 698                     text (setq cipher (current-buffer))
 699                     mml2015-result-buffer
 700                     (split-string
 701                      (or
 702                       (message-options-get 'message-recipients)
 703                       (message-options-set 'message-recipients
 704                                            (read-string "Recipients: ")))
 705                      "[ \f\t\n\r\v,]+")
 706                     nil
 707                     (message-options-get 'message-sender)
 708                     t t) ; armor & textmode
 709             (unless (> (point-max) (point-min))
 710               (pop-to-buffer mml2015-result-buffer)
 711               (error "Encrypt error"))))
 712         (goto-char (point-min))
 713         (while (re-search-forward "\r+$" nil t)
 714           (replace-match "" t t))
 715         (set-buffer text)
 716         (delete-region (point-min) (point-max))
 717         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 718                         boundary))
 719         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 720         (insert (format "--%s\n" boundary))
 721         (insert "Content-Type: application/pgp-encrypted\n\n")
 722         (insert "Version: 1\n\n")
 723         (insert (format "--%s\n" boundary))
 724         (insert "Content-Type: application/octet-stream\n\n")
 725         (insert-buffer-substring cipher)
 726         (goto-char (point-max))
 727         (insert (format "--%s--\n" boundary))
 728         (goto-char (point-max))))))
 729
 730 ;;; pgg wrapper
 731
 732 (defvar pgg-default-user-id)
 733 (defvar pgg-errors-buffer)
 734 (defvar pgg-output-buffer)
 735
 736 (eval-and-compile
 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 (eval-and-compile
 974   (autoload 'epg-make-context "epg")
 975   (autoload 'epg-context-set-armor "epg")
 976   (autoload 'epg-context-set-textmode "epg")
 977   (autoload 'epg-context-set-signers "epg")
 978   (autoload 'epg-context-result-for "epg")
 979   (autoload 'epg-new-signature-digest-algorithm "epg")
 980   (autoload 'epg-verify-result-to-string "epg")
 981   (autoload 'epg-list-keys "epg")
 982   (autoload 'epg-decrypt-string "epg")
 983   (autoload 'epg-verify-string "epg")
 984   (autoload 'epg-sign-string "epg")
 985   (autoload 'epg-encrypt-string "epg")
 986   (autoload 'epg-passphrase-callback-function "epg")
 987   (autoload 'epg-context-set-passphrase-callback "epg")
 988   (autoload 'epg-key-sub-key-list "epg")
 989   (autoload 'epg-sub-key-capability "epg")
 990   (autoload 'epg-sub-key-validity "epg")
 991   (autoload 'epg-configuration "epg-config")
 992   (autoload 'epg-expand-group "epg-config")
 993   (autoload 'epa-select-keys "epa"))
 994
 995 (defvar password-cache-expiry)
 996
 997 (defvar mml2015-epg-secret-key-id-list nil)
 998
 999 (defun mml2015-epg-passphrase-callback (context key-id ignore)
1000   (if (eq key-id 'SYM)
1001       (epg-passphrase-callback-function context key-id nil)
1002     (let* ((password-cache-key-id
1003             (if (eq key-id 'PIN)
1004                 "PIN"
1005                key-id))
1006            entry
1007            (passphrase
1008             (password-read
1009              (if (eq key-id 'PIN)
1010                  "Passphrase for PIN: "
1011                (if (setq entry (assoc key-id epg-user-id-alist))
1012                    (format "Passphrase for %s %s: " key-id (cdr entry))
1013                  (format "Passphrase for %s: " key-id)))
1014              password-cache-key-id)))
1015       (when passphrase
1016         (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
1017           (password-cache-add password-cache-key-id passphrase))
1018         (setq mml2015-epg-secret-key-id-list
1019               (cons password-cache-key-id mml2015-epg-secret-key-id-list))
1020         (copy-sequence passphrase)))))
1021
1022 (defun mml2015-epg-find-usable-key (keys usage)
1023   (catch 'found
1024     (while keys
1025       (let ((pointer (epg-key-sub-key-list (car keys))))
1026         (while pointer
1027           (if (and (memq usage (epg-sub-key-capability (car pointer)))
1028                    (not (memq (epg-sub-key-validity (car pointer))
1029                               '(revoked expired))))
1030               (throw 'found (car keys)))
1031           (setq pointer (cdr pointer))))
1032       (setq keys (cdr keys)))))
1033
1034 (defun mml2015-epg-decrypt (handle ctl)
1035   (catch 'error
1036     (let ((inhibit-redisplay t)
1037           context plain child handles result decrypt-status)
1038       (unless (setq child (mm-find-part-by-type
1039                            (cdr handle)
1040                            "application/octet-stream" nil t))
1041         (mm-set-handle-multipart-parameter
1042          mm-security-handle 'gnus-info "Corrupted")
1043         (throw 'error handle))
1044       (setq context (epg-make-context))
1045       (if mml2015-cache-passphrase
1046           (epg-context-set-passphrase-callback
1047            context
1048            #'mml2015-epg-passphrase-callback))
1049       (condition-case error
1050           (setq plain (epg-decrypt-string context (mm-get-part child))
1051                 mml2015-epg-secret-key-id-list nil)
1052         (error
1053          (while mml2015-epg-secret-key-id-list
1054            (password-cache-remove (car mml2015-epg-secret-key-id-list))
1055            (setq mml2015-epg-secret-key-id-list
1056                  (cdr mml2015-epg-secret-key-id-list)))
1057          (mm-set-handle-multipart-parameter
1058           mm-security-handle 'gnus-info "Failed")
1059          (if (eq (car error) 'quit)
1060              (mm-set-handle-multipart-parameter
1061               mm-security-handle 'gnus-details "Quit.")
1062            (mm-set-handle-multipart-parameter
1063             mm-security-handle 'gnus-details (mml2015-format-error error)))
1064          (throw 'error handle)))
1065       (with-temp-buffer
1066         (insert plain)
1067         (goto-char (point-min))
1068         (while (search-forward "\r\n" nil t)
1069           (replace-match "\n" t t))
1070         (setq handles (mm-dissect-buffer t))
1071         (mm-destroy-parts handle)
1072         (if (epg-context-result-for context 'verify)
1073             (mm-set-handle-multipart-parameter
1074              mm-security-handle 'gnus-info
1075              (concat "OK\n"
1076                      (epg-verify-result-to-string
1077                       (epg-context-result-for context 'verify))))
1078           (mm-set-handle-multipart-parameter
1079            mm-security-handle 'gnus-info "OK"))
1080         (if (stringp (car handles))
1081             (mm-set-handle-multipart-parameter
1082              mm-security-handle 'gnus-details
1083              (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
1084         (if (listp (car handles))
1085             handles
1086           (list handles)))))
1087
1088 (defun mml2015-epg-clear-decrypt ()
1089   (let ((inhibit-redisplay t)
1090         (context (epg-make-context))
1091         plain)
1092     (if mml2015-cache-passphrase
1093         (epg-context-set-passphrase-callback
1094          context
1095          #'mml2015-epg-passphrase-callback))
1096     (condition-case error
1097         (setq plain (epg-decrypt-string context (buffer-string))
1098               mml2015-epg-secret-key-id-list nil)
1099       (error
1100        (while mml2015-epg-secret-key-id-list
1101          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1102          (setq mml2015-epg-secret-key-id-list
1103                (cdr mml2015-epg-secret-key-id-list)))
1104        (mm-set-handle-multipart-parameter
1105         mm-security-handle 'gnus-info "Failed")
1106        (if (eq (car error) 'quit)
1107            (mm-set-handle-multipart-parameter
1108             mm-security-handle 'gnus-details "Quit.")
1109          (mm-set-handle-multipart-parameter
1110           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1111     (when plain
1112       (erase-buffer)
1113       ;; Treat data which epg returns as a unibyte string.
1114       (mm-disable-multibyte)
1115       (insert plain)
1116       (goto-char (point-min))
1117       (while (search-forward "\r\n" nil t)
1118         (replace-match "\n" t t))
1119       (mm-set-handle-multipart-parameter
1120        mm-security-handle 'gnus-info "OK")
1121       (if (epg-context-result-for context 'verify)
1122           (mm-set-handle-multipart-parameter
1123            mm-security-handle 'gnus-details
1124            (epg-verify-result-to-string
1125             (epg-context-result-for context 'verify)))))))
1126
1127 (defun mml2015-epg-verify (handle ctl)
1128   (catch 'error
1129     (let ((inhibit-redisplay t)
1130           context plain signature-file part signature)
1131       (when (or (null (setq part (mm-find-raw-part-by-type
1132                                   ctl (or (mm-handle-multipart-ctl-parameter
1133                                            ctl 'protocol)
1134                                           "application/pgp-signature")
1135                                   t)))
1136                 (null (setq signature (mm-find-part-by-type
1137                                        (cdr handle) "application/pgp-signature"
1138                                        nil t))))
1139         (mm-set-handle-multipart-parameter
1140          mm-security-handle 'gnus-info "Corrupted")
1141         (throw 'error handle))
1142       (setq part (mm-replace-in-string part "\n" "\r\n" t)
1143             signature (mm-get-part signature)
1144             context (epg-make-context))
1145       (condition-case error
1146           (setq plain (epg-verify-string context signature part))
1147         (error
1148          (mm-set-handle-multipart-parameter
1149           mm-security-handle 'gnus-info "Failed")
1150          (if (eq (car error) 'quit)
1151              (mm-set-handle-multipart-parameter
1152               mm-security-handle 'gnus-details "Quit.")
1153            (mm-set-handle-multipart-parameter
1154             mm-security-handle 'gnus-details (mml2015-format-error error)))
1155          (throw 'error handle)))
1156       (mm-set-handle-multipart-parameter
1157        mm-security-handle 'gnus-info
1158        (epg-verify-result-to-string (epg-context-result-for context 'verify)))
1159       handle)))
1160
1161 (defun mml2015-epg-clear-verify ()
1162   (let ((inhibit-redisplay t)
1163         (context (epg-make-context))
1164         (signature (mm-encode-coding-string (buffer-string)
1165                                             coding-system-for-write))
1166         plain)
1167     (condition-case error
1168         (setq plain (epg-verify-string context signature))
1169       (error
1170        (mm-set-handle-multipart-parameter
1171         mm-security-handle 'gnus-info "Failed")
1172        (if (eq (car error) 'quit)
1173            (mm-set-handle-multipart-parameter
1174             mm-security-handle 'gnus-details "Quit.")
1175          (mm-set-handle-multipart-parameter
1176           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1177     (if plain
1178         (progn
1179           (mm-set-handle-multipart-parameter
1180            mm-security-handle 'gnus-info
1181            (epg-verify-result-to-string
1182             (epg-context-result-for context 'verify)))
1183           (delete-region (point-min) (point-max))
1184           (insert (mm-decode-coding-string plain coding-system-for-read)))
1185       (mml2015-extract-cleartext-signature))))
1186
1187 (defun mml2015-epg-sign (cont)
1188   (let* ((inhibit-redisplay t)
1189          (context (epg-make-context))
1190          (boundary (mml-compute-boundary cont))
1191          signer-key
1192          (signers
1193           (or (message-options-get 'mml2015-epg-signers)
1194               (message-options-set
1195                'mml2015-epg-signers
1196                (if mml2015-verbose
1197                    (epa-select-keys context "\
1198 Select keys for signing.
1199 If no one is selected, default secret key is used.  "
1200                                     mml2015-signers t)
1201                  (if mml2015-signers
1202                      (delq nil
1203                            (mapcar
1204                             (lambda (signer)
1205                               (setq signer-key (mml2015-epg-find-usable-key
1206                                                 (epg-list-keys context signer t)
1207                                                 'sign))
1208                               (unless (or signer-key
1209                                           (y-or-n-p
1210                                            (format
1211                                             "No secret key for %s; skip it? "
1212                                             signer)))
1213                                 (error "No secret key for %s" signer))
1214                               signer-key)
1215                             mml2015-signers)))))))
1216          signature micalg)
1217     (epg-context-set-armor context t)
1218     (epg-context-set-textmode context t)
1219     (epg-context-set-signers context signers)
1220     (if mml2015-cache-passphrase
1221         (epg-context-set-passphrase-callback
1222          context
1223          #'mml2015-epg-passphrase-callback))
1224     (condition-case error
1225         (setq signature (epg-sign-string context (buffer-string) t)
1226               mml2015-epg-secret-key-id-list nil)
1227       (error
1228        (while mml2015-epg-secret-key-id-list
1229          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1230          (setq mml2015-epg-secret-key-id-list
1231                (cdr mml2015-epg-secret-key-id-list)))
1232        (signal (car error) (cdr error))))
1233     (if (epg-context-result-for context 'sign)
1234         (setq micalg (epg-new-signature-digest-algorithm
1235                       (car (epg-context-result-for context 'sign)))))
1236     (goto-char (point-min))
1237     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1238                     boundary))
1239     (if micalg
1240         (insert (format "\tmicalg=pgp-%s; "
1241                         (downcase
1242                          (cdr (assq micalg
1243                                     epg-digest-algorithm-alist))))))
1244     (insert "protocol=\"application/pgp-signature\"\n")
1245     (insert (format "\n--%s\n" boundary))
1246     (goto-char (point-max))
1247     (insert (format "\n--%s\n" boundary))
1248     (insert "Content-Type: application/pgp-signature\n\n")
1249     (insert signature)
1250     (goto-char (point-max))
1251     (insert (format "--%s--\n" boundary))
1252     (goto-char (point-max))))
1253
1254 (defun mml2015-epg-encrypt (cont &optional sign)
1255   (let ((inhibit-redisplay t)
1256         (context (epg-make-context))
1257         (config (epg-configuration))
1258         (recipients (message-options-get 'mml2015-epg-recipients))
1259         cipher signers
1260         (boundary (mml-compute-boundary cont))
1261         recipient-key signer-key)
1262     (unless recipients
1263       (setq recipients
1264             (apply #'nconc
1265                    (mapcar
1266                     (lambda (recipient)
1267                       (or (epg-expand-group config recipient)
1268                           (list (concat "<" recipient ">"))))
1269                     (split-string
1270                      (or (message-options-get 'message-recipients)
1271                          (message-options-set 'message-recipients
1272                                               (read-string "Recipients: ")))
1273                      "[ \f\t\n\r\v,]+"))))
1274       (when mml2015-encrypt-to-self
1275         (unless mml2015-signers
1276           (error "mml2015-signers not set"))
1277         (setq recipients (nconc recipients mml2015-signers)))
1278       (if mml2015-verbose
1279           (setq recipients
1280                 (epa-select-keys context "\
1281 Select recipients for encryption.
1282 If no one is selected, symmetric encryption will be performed.  "
1283                                  recipients))
1284         (setq recipients
1285               (delq nil
1286                     (mapcar
1287                      (lambda (recipient)
1288                        (setq recipient-key (mml2015-epg-find-usable-key
1289                                             (epg-list-keys context recipient)
1290                                             'encrypt))
1291                        (unless (or recipient-key
1292                                    (y-or-n-p
1293                                     (format "No public key for %s; skip it? "
1294                                             recipient)))
1295                          (error "No public key for %s" recipient))
1296                        recipient-key)
1297                      recipients)))
1298         (unless recipients
1299           (error "No recipient specified")))
1300       (message-options-set 'mml2015-epg-recipients recipients))
1301     (when sign
1302       (setq signers
1303             (or (message-options-get 'mml2015-epg-signers)
1304                 (message-options-set
1305                  'mml2015-epg-signers
1306                  (if mml2015-verbose
1307                      (epa-select-keys context "\
1308 Select keys for signing.
1309 If no one is selected, default secret key is used.  "
1310                                       mml2015-signers t)
1311                    (if mml2015-signers
1312                        (delq nil
1313                              (mapcar
1314                               (lambda (signer)
1315                                 (setq signer-key (mml2015-epg-find-usable-key
1316                                                   (epg-list-keys context signer t)
1317                                                   'sign))
1318                                 (unless (or signer-key
1319                                             (y-or-n-p
1320                                              (format
1321                                               "No secret key for %s; skip it? "
1322                                               signer)))
1323                                   (error "No secret key for %s" signer))
1324                                 signer-key)
1325                               mml2015-signers)))))))
1326       (epg-context-set-signers context signers))
1327     (epg-context-set-armor context t)
1328     (epg-context-set-textmode context t)
1329     (if mml2015-cache-passphrase
1330         (epg-context-set-passphrase-callback
1331          context
1332          #'mml2015-epg-passphrase-callback))
1333     (condition-case error
1334         (setq cipher
1335               (epg-encrypt-string context (buffer-string) recipients sign
1336                                   mml2015-always-trust)
1337               mml2015-epg-secret-key-id-list nil)
1338       (error
1339        (while mml2015-epg-secret-key-id-list
1340          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1341          (setq mml2015-epg-secret-key-id-list
1342                (cdr mml2015-epg-secret-key-id-list)))
1343        (signal (car error) (cdr error))))
1344     (delete-region (point-min) (point-max))
1345     (goto-char (point-min))
1346     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1347                     boundary))
1348     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1349     (insert (format "--%s\n" boundary))
1350     (insert "Content-Type: application/pgp-encrypted\n\n")
1351     (insert "Version: 1\n\n")
1352     (insert (format "--%s\n" boundary))
1353     (insert "Content-Type: application/octet-stream\n\n")
1354     (insert cipher)
1355     (goto-char (point-max))
1356     (insert (format "--%s--\n" boundary))
1357     (goto-char (point-max))))
1358
1359 ;;; General wrapper
1360
1361 (autoload 'gnus-buffer-live-p "gnus-util")
1362 (autoload 'gnus-get-buffer-create "gnus")
1363
1364 (defun mml2015-clean-buffer ()
1365   (if (gnus-buffer-live-p mml2015-result-buffer)
1366       (with-current-buffer mml2015-result-buffer
1367         (erase-buffer)
1368         t)
1369     (setq mml2015-result-buffer
1370           (gnus-get-buffer-create " *MML2015 Result*"))
1371     nil))
1372
1373 (defsubst mml2015-clear-decrypt-function ()
1374   (nth 6 (assq mml2015-use mml2015-function-alist)))
1375
1376 (defsubst mml2015-clear-verify-function ()
1377   (nth 5 (assq mml2015-use mml2015-function-alist)))
1378
1379 ;;;###autoload
1380 (defun mml2015-decrypt (handle ctl)
1381   (mml2015-clean-buffer)
1382   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1383     (if func
1384         (funcall func handle ctl)
1385       handle)))
1386
1387 ;;;###autoload
1388 (defun mml2015-decrypt-test (handle ctl)
1389   mml2015-use)
1390
1391 ;;;###autoload
1392 (defun mml2015-verify (handle ctl)
1393   (mml2015-clean-buffer)
1394   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1395     (if func
1396         (funcall func handle ctl)
1397       handle)))
1398
1399 ;;;###autoload
1400 (defun mml2015-verify-test (handle ctl)
1401   mml2015-use)
1402
1403 ;;;###autoload
1404 (defun mml2015-encrypt (cont &optional sign)
1405   (mml2015-clean-buffer)
1406   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1407     (if func
1408         (funcall func cont sign)
1409       (error "Cannot find encrypt function"))))
1410
1411 ;;;###autoload
1412 (defun mml2015-sign (cont)
1413   (mml2015-clean-buffer)
1414   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1415     (if func
1416         (funcall func cont)
1417       (error "Cannot find sign function"))))
1418
1419 ;;;###autoload
1420 (defun mml2015-self-encrypt ()
1421   (mml2015-encrypt nil))
1422
1423 (provide 'mml2015)
1424
1425 ;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
1426 ;;; mml2015.el ends here