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