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