lisp/gnus/mml2015.el

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