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

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