git.chise.org Git - elisp/gnus.git-/blob - lisp/mml2015.el

   1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
   2 ;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
   3
   4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   5 ;; Keywords: PGP MIME MML
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published
  11 ;; by the Free Software Foundation; either version 2, or (at your
  12 ;; option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  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 (eval-when-compile (require 'cl))
  32 (eval-when-compile (require 'gnus-clfns))
  33 (require 'mm-decode)
  34
  35 (defvar mml2015-use (or
  36                      (progn
  37                        (ignore-errors
  38                          (require 'gpg))
  39                        (and (fboundp 'gpg-sign-detached)
  40                             'gpg))
  41                      (progn (ignore-errors
  42                               (load "mc-toplev"))
  43                             (and (fboundp 'mc-encrypt-generic)
  44                                  (fboundp 'mc-sign-generic)
  45                                  (fboundp 'mc-cleanup-recipient-headers)
  46                                  'mailcrypt)))
  47   "The package used for PGP/MIME.")
  48
  49 ;; Something is not RFC2015.
  50 (defvar mml2015-function-alist
  51   '((mailcrypt mml2015-mailcrypt-sign
  52                mml2015-mailcrypt-encrypt
  53                mml2015-mailcrypt-verify
  54                mml2015-mailcrypt-decrypt
  55                mml2015-mailcrypt-clear-verify
  56                mml2015-mailcrypt-clear-decrypt)
  57     (gpg mml2015-gpg-sign
  58          mml2015-gpg-encrypt
  59          mml2015-gpg-verify
  60          mml2015-gpg-decrypt
  61          mml2015-gpg-clear-verify
  62          mml2015-gpg-clear-decrypt))
  63   "Alist of PGP/MIME functions.")
  64
  65 (defvar mml2015-result-buffer nil)
  66
  67 (defvar mml2015-trust-boundaries-alist
  68   '((trust-undefined . nil)
  69     (trust-none      . nil)
  70     (trust-marginal  . t)
  71     (trust-full      . t)
  72     (trust-ultimate  . t))
  73   "Trust boundaries for a signer's GnuPG key.
  74 This alist contains pairs of the form (trust-symbol . boolean), with
  75 symbols that are contained in `gpg-unabbrev-trust-alist'. The boolean
  76 specifies whether the given trust value is good enough to be trusted
  77 by you.")
  78
  79 ;;; mailcrypt wrapper
  80
  81 (eval-and-compile
  82   (autoload 'mailcrypt-decrypt "mailcrypt")
  83   (autoload 'mailcrypt-verify "mailcrypt")
  84   (autoload 'mc-pgp-always-sign "mailcrypt")
  85   (autoload 'mc-encrypt-generic "mc-toplev")
  86   (autoload 'mc-cleanup-recipient-headers "mc-toplev")
  87   (autoload 'mc-sign-generic "mc-toplev"))
  88
  89 (eval-when-compile
  90   (defvar mc-default-scheme)
  91   (defvar mc-schemes))
  92
  93 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
  94 (defvar mml2015-verify-function 'mailcrypt-verify)
  95
  96 (defun mml2015-format-error (err)
  97   (if (stringp (cadr err))
  98       (cadr err)
  99     (format "%S" (cdr err))))
 100
 101 (defun mml2015-mailcrypt-decrypt (handle ctl)
 102   (catch 'error
 103     (let (child handles result)
 104       (unless (setq child (mm-find-part-by-type
 105                            (cdr handle)
 106                            "application/octet-stream" nil t))
 107         (mm-set-handle-multipart-parameter
 108          mm-security-handle 'gnus-info "Corrupted")
 109         (throw 'error handle))
 110       (with-temp-buffer
 111         (mm-insert-part child)
 112         (setq result
 113               (condition-case err
 114                   (funcall mml2015-decrypt-function)
 115                 (error
 116                  (mm-set-handle-multipart-parameter
 117                   mm-security-handle 'gnus-details (mml2015-format-error err))
 118                  nil)
 119                 (quit
 120                  (mm-set-handle-multipart-parameter
 121                   mm-security-handle 'gnus-details "Quit.")
 122                  nil)))
 123         (unless (car result)
 124           (mm-set-handle-multipart-parameter
 125            mm-security-handle 'gnus-info "Failed")
 126           (throw 'error handle))
 127         (setq handles (mm-dissect-buffer t)))
 128       (mm-destroy-parts handle)
 129       (mm-set-handle-multipart-parameter
 130        mm-security-handle 'gnus-info
 131        (concat "OK"
 132                (let ((sig (with-current-buffer mml2015-result-buffer
 133                             (mml2015-gpg-extract-signature-details))))
 134                  (concat ", Signer: " sig))))
 135       (if (listp (car handles))
 136           handles
 137         (list handles)))))
 138
 139 (defun mml2015-mailcrypt-clear-decrypt ()
 140   (let (result)
 141     (setq result
 142           (condition-case err
 143               (funcall mml2015-decrypt-function)
 144             (error
 145              (mm-set-handle-multipart-parameter
 146               mm-security-handle 'gnus-details (mml2015-format-error err))
 147              nil)
 148             (quit
 149              (mm-set-handle-multipart-parameter
 150               mm-security-handle 'gnus-details "Quit.")
 151              nil)))
 152     (if (car result)
 153         (mm-set-handle-multipart-parameter
 154          mm-security-handle 'gnus-info "OK")
 155       (mm-set-handle-multipart-parameter
 156        mm-security-handle 'gnus-info "Failed"))))
 157
 158 (defun mml2015-fix-micalg (alg)
 159   (and alg
 160        ;; Mutt/1.2.5i has seen sending micalg=php-sha1
 161        (upcase (if (string-match "^p[gh]p-" alg)
 162                    (substring alg (match-end 0))
 163                  alg))))
 164
 165 (defun mml2015-mailcrypt-verify (handle ctl)
 166   (catch 'error
 167     (let (part)
 168       (unless (setq part (mm-find-raw-part-by-type
 169                           ctl (or (mm-handle-multipart-ctl-parameter
 170                                    ctl 'protocol)
 171                                   "application/pgp-signature")
 172                           t))
 173         (mm-set-handle-multipart-parameter
 174          mm-security-handle 'gnus-info "Corrupted")
 175         (throw 'error handle))
 176       (with-temp-buffer
 177         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
 178         (insert (format "Hash: %s\n\n"
 179                         (or (mml2015-fix-micalg
 180                              (mm-handle-multipart-ctl-parameter
 181                               ctl 'micalg))
 182                             "SHA1")))
 183         (save-restriction
 184           (narrow-to-region (point) (point))
 185           (insert part "\n")
 186           (goto-char (point-min))
 187           (while (not (eobp))
 188             (if (looking-at "^-")
 189                 (insert "- "))
 190             (forward-line)))
 191         (unless (setq part (mm-find-part-by-type
 192                             (cdr handle) "application/pgp-signature" nil t))
 193           (mm-set-handle-multipart-parameter
 194            mm-security-handle 'gnus-info "Corrupted")
 195           (throw 'error handle))
 196         (save-restriction
 197           (narrow-to-region (point) (point))
 198           (mm-insert-part part)
 199           (goto-char (point-min))
 200           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
 201               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
 202           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
 203               (replace-match "-----END PGP SIGNATURE-----" t t)))
 204         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 205           (unless (condition-case err
 206                       (prog1
 207                           (funcall mml2015-verify-function)
 208                         (if (get-buffer " *mailcrypt stderr temp")
 209                             (mm-set-handle-multipart-parameter
 210                              mm-security-handle 'gnus-details
 211                              (with-current-buffer " *mailcrypt stderr temp"
 212                                (buffer-string))))
 213                         (if (get-buffer " *mailcrypt stdout temp")
 214                             (kill-buffer " *mailcrypt stdout temp"))
 215                         (if (get-buffer " *mailcrypt stderr temp")
 216                             (kill-buffer " *mailcrypt stderr temp"))
 217                         (if (get-buffer " *mailcrypt status temp")
 218                             (kill-buffer " *mailcrypt status temp"))
 219                         (if (get-buffer mc-gpg-debug-buffer)
 220                             (kill-buffer mc-gpg-debug-buffer)))
 221                     (error
 222                      (mm-set-handle-multipart-parameter
 223                       mm-security-handle 'gnus-details (mml2015-format-error err))
 224                      nil)
 225                     (quit
 226                      (mm-set-handle-multipart-parameter
 227                       mm-security-handle 'gnus-details "Quit.")
 228                      nil))
 229             (mm-set-handle-multipart-parameter
 230              mm-security-handle 'gnus-info "Failed")
 231             (throw 'error handle))))
 232       (mm-set-handle-multipart-parameter
 233        mm-security-handle 'gnus-info "OK")
 234       handle)))
 235
 236 (defun mml2015-mailcrypt-clear-verify ()
 237   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 238     (if (condition-case err
 239             (prog1
 240                 (funcall mml2015-verify-function)
 241               (if (get-buffer " *mailcrypt stderr temp")
 242                   (mm-set-handle-multipart-parameter
 243                    mm-security-handle 'gnus-details
 244                    (with-current-buffer " *mailcrypt stderr temp"
 245                      (buffer-string))))
 246               (if (get-buffer " *mailcrypt stdout temp")
 247                   (kill-buffer " *mailcrypt stdout temp"))
 248               (if (get-buffer " *mailcrypt stderr temp")
 249                   (kill-buffer " *mailcrypt stderr temp"))
 250               (if (get-buffer " *mailcrypt status temp")
 251                   (kill-buffer " *mailcrypt status temp"))
 252               (if (get-buffer mc-gpg-debug-buffer)
 253                   (kill-buffer mc-gpg-debug-buffer)))
 254           (error
 255            (mm-set-handle-multipart-parameter
 256             mm-security-handle 'gnus-details (mml2015-format-error err))
 257            nil)
 258           (quit
 259            (mm-set-handle-multipart-parameter
 260             mm-security-handle 'gnus-details "Quit.")
 261            nil))
 262         (mm-set-handle-multipart-parameter
 263          mm-security-handle 'gnus-info "OK")
 264       (mm-set-handle-multipart-parameter
 265        mm-security-handle 'gnus-info "Failed"))))
 266
 267 (defun mml2015-mailcrypt-sign (cont)
 268   (mc-sign-generic (message-options-get 'message-sender)
 269                    nil nil nil nil)
 270   (let ((boundary
 271          (funcall mml-boundary-function (incf mml-multipart-number)))
 272         hash point)
 273     (goto-char (point-min))
 274     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
 275       (error "Cannot find signed begin line"))
 276     (goto-char (match-beginning 0))
 277     (forward-line 1)
 278     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 279       (error "Cannot not find PGP hash"))
 280     (setq hash (match-string 1))
 281     (unless (re-search-forward "^$" nil t)
 282       (error "Cannot not find PGP message"))
 283     (forward-line 1)
 284     (delete-region (point-min) (point))
 285     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 286                     boundary))
 287     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 288                     (downcase hash)))
 289     (insert (format "\n--%s\n" boundary))
 290     (setq point (point))
 291     (goto-char (point-max))
 292     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
 293       (error "Cannot find signature part"))
 294     (replace-match "-----END PGP MESSAGE-----" t t)
 295     (goto-char (match-beginning 0))
 296     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
 297                                 nil t)
 298       (error "Cannot find signature part"))
 299     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
 300     (goto-char (match-beginning 0))
 301     (save-restriction
 302       (narrow-to-region point (point))
 303       (goto-char point)
 304       (while (re-search-forward "^- -" nil t)
 305         (replace-match "-" t t))
 306       (goto-char (point-max)))
 307     (insert (format "--%s\n" boundary))
 308     (insert "Content-Type: application/pgp-signature\n\n")
 309     (goto-char (point-max))
 310     (insert (format "--%s--\n" boundary))
 311     (goto-char (point-max))))
 312
 313 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
 314   (let ((mc-pgp-always-sign
 315          (or mc-pgp-always-sign
 316              sign
 317              (eq t (or (message-options-get 'message-sign-encrypt)
 318                        (message-options-set
 319                         'message-sign-encrypt
 320                         (or (y-or-n-p "Sign the message? ")
 321                             'not))))
 322              'never)))
 323     (mm-with-unibyte-current-buffer-mule4
 324       (mc-encrypt-generic
 325        (or (message-options-get 'message-recipients)
 326            (message-options-set 'message-recipients
 327                                 (mc-cleanup-recipient-headers
 328                                  (read-string "Recipients: "))))
 329        nil nil nil
 330        (message-options-get 'message-sender))))
 331   (goto-char (point-min))
 332   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
 333     (error "Fail to encrypt the message"))
 334   (let ((boundary
 335          (funcall mml-boundary-function (incf mml-multipart-number))))
 336     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 337                     boundary))
 338     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 339     (insert (format "--%s\n" boundary))
 340     (insert "Content-Type: application/pgp-encrypted\n\n")
 341     (insert "Version: 1\n\n")
 342     (insert (format "--%s\n" boundary))
 343     (insert "Content-Type: application/octet-stream\n\n")
 344     (goto-char (point-max))
 345     (insert (format "--%s--\n" boundary))
 346     (goto-char (point-max))))
 347
 348 ;;; gpg wrapper
 349
 350 (eval-and-compile
 351   (autoload 'gpg-decrypt "gpg")
 352   (autoload 'gpg-verify "gpg")
 353   (autoload 'gpg-verify-cleartext "gpg")
 354   (autoload 'gpg-sign-detached "gpg")
 355   (autoload 'gpg-sign-encrypt "gpg")
 356   (autoload 'gpg-encrypt "gpg")
 357   (autoload 'gpg-passphrase-read "gpg"))
 358
 359 (defun mml2015-gpg-passphrase ()
 360   (or (message-options-get 'gpg-passphrase)
 361       (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
 362
 363 (defun mml2015-gpg-decrypt-1 ()
 364   (let ((cipher (current-buffer)) plain result)
 365     (if (with-temp-buffer
 366           (prog1
 367               (gpg-decrypt cipher (setq plain (current-buffer))
 368                            mml2015-result-buffer nil)
 369             (mm-set-handle-multipart-parameter
 370              mm-security-handle 'gnus-details
 371              (with-current-buffer mml2015-result-buffer
 372                (buffer-string)))
 373             (set-buffer cipher)
 374             (erase-buffer)
 375             (insert-buffer plain)
 376             (goto-char (point-min))
 377             (while (search-forward "\r\n" nil t)
 378               (replace-match "\n" t t))))
 379         '(t)
 380       ;; Some wrong with the return value, check plain text buffer.
 381       (if (> (point-max) (point-min))
 382           '(t)
 383         nil))))
 384
 385 (defun mml2015-gpg-decrypt (handle ctl)
 386   (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
 387     (mml2015-mailcrypt-decrypt handle ctl)))
 388
 389 (defun mml2015-gpg-clear-decrypt ()
 390   (let (result)
 391     (setq result (mml2015-gpg-decrypt-1))
 392     (if (car result)
 393         (mm-set-handle-multipart-parameter
 394          mm-security-handle 'gnus-info "OK")
 395       (mm-set-handle-multipart-parameter
 396        mm-security-handle 'gnus-info "Failed"))))
 397
 398 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
 399   (let* ((result "")
 400          (fpr-length (string-width fingerprint))
 401          (n-slice 0)
 402          slice)
 403     (setq fingerprint (string-to-list fingerprint))
 404     (while fingerprint
 405       (setq fpr-length (- fpr-length 4))
 406       (setq slice (butlast fingerprint fpr-length))
 407       (setq fingerprint (nthcdr 4 fingerprint))
 408       (setq n-slice (1+ n-slice))
 409       (setq result
 410             (concat
 411              result
 412              (case n-slice
 413                (1  slice)
 414                (otherwise (concat " " slice))))))
 415     result))
 416
 417 (defun mml2015-gpg-extract-signature-details ()
 418   (goto-char (point-min))
 419   (if (boundp 'gpg-unabbrev-trust-alist)
 420       (let* ((expired (re-search-forward
 421                        "^\\[GNUPG:\\] SIGEXPIRED$"
 422                        nil t))
 423              (signer (and (re-search-forward
 424                            "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
 425                            nil t)
 426                           (cons (match-string 1) (match-string 2))))
 427              (fprint (and (re-search-forward
 428                            "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
 429                        nil t)
 430                           (match-string 1)))
 431              (trust  (and (re-search-forward "^\\[GNUPG:\\] \\(TRUST_.*\\)$" nil t)
 432                           (match-string 1)))
 433              (trust-good-enough-p
 434               (cdr (assoc (cdr (assoc trust gpg-unabbrev-trust-alist))
 435                       mml2015-trust-boundaries-alist))))
 436         (cond ((and signer fprint)
 437                (concat (cdr signer)
 438                        (unless trust-good-enough-p
 439                          (concat "\nUntrusted, Fingerprint: "
 440                                  (mml2015-gpg-pretty-print-fpr fprint)))
 441                        (when expired
 442                          (format "\nWARNING: Signature from expired key (%s)"
 443                                  (car signer)))))
 444               (t
 445                "From unknown user")))
 446     (if (re-search-forward "^gpg: Good signature from \"\\(.*\\)\"$" nil t)
 447         (match-string 1)
 448       "From unknown user")))
 449
 450 (defun mml2015-gpg-verify (handle ctl)
 451   (catch 'error
 452     (let (part message signature info-is-set-p)
 453       (unless (setq part (mm-find-raw-part-by-type
 454                           ctl (or (mm-handle-multipart-ctl-parameter
 455                                    ctl 'protocol)
 456                                   "application/pgp-signature")
 457                           t))
 458         (mm-set-handle-multipart-parameter
 459          mm-security-handle 'gnus-info "Corrupted")
 460         (throw 'error handle))
 461       (with-temp-buffer
 462         (setq message (current-buffer))
 463         (insert part)
 464         ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
 465         ;; clearsign use --textmode. The conversion is not necessary.
 466         ;; In clearverify, the conversion is not necessary either.
 467         (goto-char (point-min))
 468         (end-of-line)
 469         (while (not (eobp))
 470           (unless (eq (char-before) ?\r)
 471             (insert "\r"))
 472           (forward-line)
 473           (end-of-line))
 474         (with-temp-buffer
 475           (setq signature (current-buffer))
 476           (unless (setq part (mm-find-part-by-type
 477                               (cdr handle) "application/pgp-signature" nil t))
 478             (mm-set-handle-multipart-parameter
 479              mm-security-handle 'gnus-info "Corrupted")
 480             (throw 'error handle))
 481           (mm-insert-part part)
 482           (unless (condition-case err
 483                       (prog1
 484                           (gpg-verify message signature mml2015-result-buffer)
 485                         (mm-set-handle-multipart-parameter
 486                          mm-security-handle 'gnus-details
 487                          (with-current-buffer mml2015-result-buffer
 488                            (buffer-string))))
 489                     (error
 490                      (mm-set-handle-multipart-parameter
 491                       mm-security-handle 'gnus-details (mml2015-format-error err))
 492                      (mm-set-handle-multipart-parameter
 493                       mm-security-handle 'gnus-info "Error.")
 494                      (setq info-is-set-p t)
 495                      nil)
 496                     (quit
 497                      (mm-set-handle-multipart-parameter
 498                       mm-security-handle 'gnus-details "Quit.")
 499                      (mm-set-handle-multipart-parameter
 500                       mm-security-handle 'gnus-info "Quit.")
 501                      (setq info-is-set-p t)
 502                      nil))
 503             (unless info-is-set-p
 504               (mm-set-handle-multipart-parameter
 505                mm-security-handle 'gnus-info "Failed"))
 506             (throw 'error handle)))
 507         (mm-set-handle-multipart-parameter
 508          mm-security-handle 'gnus-info
 509          (with-current-buffer mml2015-result-buffer
 510            (mml2015-gpg-extract-signature-details))))
 511       handle)))
 512
 513 (defun mml2015-gpg-clear-verify ()
 514   (if (condition-case err
 515           (prog1
 516               (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
 517             (mm-set-handle-multipart-parameter
 518              mm-security-handle 'gnus-details
 519              (with-current-buffer mml2015-result-buffer
 520                (buffer-string))))
 521         (error
 522          (mm-set-handle-multipart-parameter
 523           mm-security-handle 'gnus-details (mml2015-format-error err))
 524          nil)
 525         (quit
 526          (mm-set-handle-multipart-parameter
 527           mm-security-handle 'gnus-details "Quit.")
 528          nil))
 529       (mm-set-handle-multipart-parameter
 530        mm-security-handle 'gnus-info
 531        (with-current-buffer mml2015-result-buffer
 532          (mml2015-gpg-extract-signature-details)))
 533     (mm-set-handle-multipart-parameter
 534      mm-security-handle 'gnus-info "Failed")))
 535
 536 (defun mml2015-gpg-sign (cont)
 537   (let ((boundary
 538          (funcall mml-boundary-function (incf mml-multipart-number)))
 539         (text (current-buffer)) signature)
 540     (goto-char (point-max))
 541     (unless (bolp)
 542       (insert "\n"))
 543     (with-temp-buffer
 544       (unless (gpg-sign-detached text (setq signature (current-buffer))
 545                                  mml2015-result-buffer
 546                                  nil
 547                                  (message-options-get 'message-sender)
 548                                  t t) ; armor & textmode
 549         (unless (> (point-max) (point-min))
 550           (pop-to-buffer mml2015-result-buffer)
 551           (error "Sign error")))
 552       (goto-char (point-min))
 553       (while (re-search-forward "\r+$" nil t)
 554         (replace-match "" t t))
 555       (set-buffer text)
 556       (goto-char (point-min))
 557       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 558                       boundary))
 559       ;;; FIXME: what is the micalg?
 560       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 561       (insert (format "\n--%s\n" boundary))
 562       (goto-char (point-max))
 563       (insert (format "\n--%s\n" boundary))
 564       (insert "Content-Type: application/pgp-signature\n\n")
 565       (insert-buffer signature)
 566       (goto-char (point-max))
 567       (insert (format "--%s--\n" boundary))
 568       (goto-char (point-max)))))
 569
 570 (defun mml2015-gpg-encrypt (cont &optional sign)
 571   (let ((boundary
 572          (funcall mml-boundary-function (incf mml-multipart-number)))
 573         (text (current-buffer))
 574         cipher)
 575     (mm-with-unibyte-current-buffer-mule4
 576       (with-temp-buffer
 577         ;; set up a function to call the correct gpg encrypt routine
 578         ;; with the right arguments. (FIXME: this should be done
 579         ;; differently.)
 580         (flet ((gpg-encrypt-func
 581                  (sign plaintext ciphertext result recipients &optional
 582                        passphrase sign-with-key armor textmode)
 583                  (if sign
 584                      (gpg-sign-encrypt
 585                       plaintext ciphertext result recipients passphrase
 586                       sign-with-key armor textmode)
 587                    (gpg-encrypt
 588                     plaintext ciphertext result recipients passphrase
 589                     armor textmode))))
 590           (unless (gpg-encrypt-func
 591                     sign ; passed in when using signencrypt
 592                     text (setq cipher (current-buffer))
 593                     mml2015-result-buffer
 594                     (split-string
 595                      (or
 596                       (message-options-get 'message-recipients)
 597                       (message-options-set 'message-recipients
 598                                            (read-string "Recipients: ")))
 599                      "[ \f\t\n\r\v,]+")
 600                     nil
 601                     (message-options-get 'message-sender)
 602                     t t) ; armor & textmode
 603             (unless (> (point-max) (point-min))
 604               (pop-to-buffer mml2015-result-buffer)
 605               (error "Encrypt error"))))
 606         (goto-char (point-min))
 607         (while (re-search-forward "\r+$" nil t)
 608           (replace-match "" t t))
 609         (set-buffer text)
 610         (delete-region (point-min) (point-max))
 611         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 612                         boundary))
 613         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 614         (insert (format "--%s\n" boundary))
 615         (insert "Content-Type: application/pgp-encrypted\n\n")
 616         (insert "Version: 1\n\n")
 617         (insert (format "--%s\n" boundary))
 618         (insert "Content-Type: application/octet-stream\n\n")
 619         (insert-buffer cipher)
 620         (goto-char (point-max))
 621         (insert (format "--%s--\n" boundary))
 622         (goto-char (point-max))))))
 623
 624 ;;; General wrapper
 625
 626 (defun mml2015-clean-buffer ()
 627   (if (gnus-buffer-live-p mml2015-result-buffer)
 628       (with-current-buffer mml2015-result-buffer
 629         (erase-buffer)
 630         t)
 631     (setq mml2015-result-buffer
 632           (gnus-get-buffer-create "*MML2015 Result*"))
 633     nil))
 634
 635 (defsubst mml2015-clear-decrypt-function ()
 636   (nth 6 (assq mml2015-use mml2015-function-alist)))
 637
 638 (defsubst mml2015-clear-verify-function ()
 639   (nth 5 (assq mml2015-use mml2015-function-alist)))
 640
 641 ;;;###autoload
 642 (defun mml2015-decrypt (handle ctl)
 643   (mml2015-clean-buffer)
 644   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
 645     (if func
 646         (funcall func handle ctl)
 647       handle)))
 648
 649 ;;;###autoload
 650 (defun mml2015-decrypt-test (handle ctl)
 651   mml2015-use)
 652
 653 ;;;###autoload
 654 (defun mml2015-verify (handle ctl)
 655   (mml2015-clean-buffer)
 656   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
 657     (if func
 658         (funcall func handle ctl)
 659       handle)))
 660
 661 ;;;###autoload
 662 (defun mml2015-verify-test (handle ctl)
 663   mml2015-use)
 664
 665 ;;;###autoload
 666 (defun mml2015-encrypt (cont &optional sign)
 667   (mml2015-clean-buffer)
 668   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
 669     (if func
 670         (funcall func cont sign)
 671       (error "Cannot find encrypt function"))))
 672
 673 ;;;###autoload
 674 (defun mml2015-sign (cont)
 675   (mml2015-clean-buffer)
 676   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
 677     (if func
 678         (funcall func cont)
 679       (error "Cannot find sign function"))))
 680
 681 ;;;###autoload
 682 (defun mml2015-self-encrypt ()
 683   (mml2015-encrypt nil))
 684
 685 (provide 'mml2015)
 686
 687 ;;; mml2015.el ends here