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)
 314   (let ((mc-pgp-always-sign
 315          (or mc-pgp-always-sign
 316              (eq t (or (message-options-get 'message-sign-encrypt)
 317                        (message-options-set
 318                         'message-sign-encrypt
 319                         (or (y-or-n-p "Sign the message? ")
 320                             'not))))
 321              'never)))
 322     (mm-with-unibyte-current-buffer-mule4
 323       (mc-encrypt-generic
 324        (or (message-options-get 'message-recipients)
 325            (message-options-set 'message-recipients
 326                                 (mc-cleanup-recipient-headers
 327                                  (read-string "Recipients: "))))
 328        nil nil nil
 329        (message-options-get 'message-sender))))
 330   (goto-char (point-min))
 331   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
 332     (error "Fail to encrypt the message"))
 333   (let ((boundary
 334          (funcall mml-boundary-function (incf mml-multipart-number))))
 335     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 336                     boundary))
 337     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 338     (insert (format "--%s\n" boundary))
 339     (insert "Content-Type: application/pgp-encrypted\n\n")
 340     (insert "Version: 1\n\n")
 341     (insert (format "--%s\n" boundary))
 342     (insert "Content-Type: application/octet-stream\n\n")
 343     (goto-char (point-max))
 344     (insert (format "--%s--\n" boundary))
 345     (goto-char (point-max))))
 346
 347 ;;; gpg wrapper
 348
 349 (eval-and-compile
 350   (autoload 'gpg-decrypt "gpg")
 351   (autoload 'gpg-verify "gpg")
 352   (autoload 'gpg-verify-cleartext "gpg")
 353   (autoload 'gpg-sign-detached "gpg")
 354   (autoload 'gpg-sign-encrypt "gpg")
 355   (autoload 'gpg-encrypt "gpg")
 356   (autoload 'gpg-passphrase-read "gpg"))
 357
 358 (defun mml2015-gpg-passphrase ()
 359   (or (message-options-get 'gpg-passphrase)
 360       (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
 361
 362 (defun mml2015-gpg-decrypt-1 ()
 363   (let ((cipher (current-buffer)) plain result)
 364     (if (with-temp-buffer
 365           (prog1
 366               (gpg-decrypt cipher (setq plain (current-buffer))
 367                            mml2015-result-buffer nil)
 368             (mm-set-handle-multipart-parameter
 369              mm-security-handle 'gnus-details
 370              (with-current-buffer mml2015-result-buffer
 371                (buffer-string)))
 372             (set-buffer cipher)
 373             (erase-buffer)
 374             (insert-buffer plain)
 375             (goto-char (point-min))
 376             (while (search-forward "\r\n" nil t)
 377               (replace-match "\n" t t))))
 378         '(t)
 379       ;; Some wrong with the return value, check plain text buffer.
 380       (if (> (point-max) (point-min))
 381           '(t)
 382         nil))))
 383
 384 (defun mml2015-gpg-decrypt (handle ctl)
 385   (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
 386     (mml2015-mailcrypt-decrypt handle ctl)))
 387
 388 (defun mml2015-gpg-clear-decrypt ()
 389   (let (result)
 390     (setq result (mml2015-gpg-decrypt-1))
 391     (if (car result)
 392         (mm-set-handle-multipart-parameter
 393          mm-security-handle 'gnus-info "OK")
 394       (mm-set-handle-multipart-parameter
 395        mm-security-handle 'gnus-info "Failed"))))
 396
 397 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
 398   (let* ((result "")
 399          (fpr-length (string-width fingerprint))
 400          (n-slice 0)
 401          slice)
 402     (setq fingerprint (string-to-list fingerprint))
 403     (while fingerprint
 404       (setq fpr-length (- fpr-length 4))
 405       (setq slice (butlast fingerprint fpr-length))
 406       (setq fingerprint (nthcdr 4 fingerprint))
 407       (setq n-slice (1+ n-slice))
 408       (setq result
 409             (concat
 410              result
 411              (case n-slice
 412                (1  slice)
 413                (otherwise (concat " " slice))))))
 414     result))
 415
 416 (defun mml2015-gpg-extract-signature-details ()
 417   (goto-char (point-min))
 418   (if (boundp 'gpg-unabbrev-trust-alist)
 419       (let* ((expired (re-search-forward
 420                        "^\\[GNUPG:\\] SIGEXPIRED$"
 421                        nil t))
 422              (signer (and (re-search-forward
 423                            "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
 424                            nil t)
 425                           (cons (match-string 1) (match-string 2))))
 426              (fprint (and (re-search-forward
 427                            "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
 428                        nil t)
 429                           (match-string 1)))
 430              (trust  (and (re-search-forward "^\\[GNUPG:\\] \\(TRUST_.*\\)$" nil t)
 431                           (match-string 1)))
 432              (trust-good-enough-p
 433               (cdr (assoc (cdr (assoc trust gpg-unabbrev-trust-alist))
 434                       mml2015-trust-boundaries-alist))))
 435         (cond ((and signer fprint)
 436                (concat (cdr signer)
 437                        (unless trust-good-enough-p
 438                          (concat "\nUntrusted, Fingerprint: "
 439                                  (mml2015-gpg-pretty-print-fpr fprint)))
 440                        (when expired
 441                          (format "\nWARNING: Signature from expired key (%s)"
 442                                  (car signer)))))
 443               (t
 444                "From unknown user")))
 445     (if (re-search-forward "^gpg: Good signature from \"\\(.*\\)\"$" nil t)
 446         (match-string 1)
 447       "From unknown user")))
 448
 449 (defun mml2015-gpg-verify (handle ctl)
 450   (catch 'error
 451     (let (part message signature info-is-set-p)
 452       (unless (setq part (mm-find-raw-part-by-type
 453                           ctl (or (mm-handle-multipart-ctl-parameter
 454                                    ctl 'protocol)
 455                                   "application/pgp-signature")
 456                           t))
 457         (mm-set-handle-multipart-parameter
 458          mm-security-handle 'gnus-info "Corrupted")
 459         (throw 'error handle))
 460       (with-temp-buffer
 461         (setq message (current-buffer))
 462         (insert part)
 463         ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
 464         ;; clearsign use --textmode. The conversion is not necessary.
 465         ;; In clearverify, the conversion is not necessary either.
 466         (goto-char (point-min))
 467         (end-of-line)
 468         (while (not (eobp))
 469           (unless (eq (char-before) ?\r)
 470             (insert "\r"))
 471           (forward-line)
 472           (end-of-line))
 473         (with-temp-buffer
 474           (setq signature (current-buffer))
 475           (unless (setq part (mm-find-part-by-type
 476                               (cdr handle) "application/pgp-signature" nil t))
 477             (mm-set-handle-multipart-parameter
 478              mm-security-handle 'gnus-info "Corrupted")
 479             (throw 'error handle))
 480           (mm-insert-part part)
 481           (unless (condition-case err
 482                       (prog1
 483                           (gpg-verify message signature mml2015-result-buffer)
 484                         (mm-set-handle-multipart-parameter
 485                          mm-security-handle 'gnus-details
 486                          (with-current-buffer mml2015-result-buffer
 487                            (buffer-string))))
 488                     (error
 489                      (mm-set-handle-multipart-parameter
 490                       mm-security-handle 'gnus-details (mml2015-format-error err))
 491                      (mm-set-handle-multipart-parameter
 492                       mm-security-handle 'gnus-info "Error.")
 493                      (setq info-is-set-p t)
 494                      nil)
 495                     (quit
 496                      (mm-set-handle-multipart-parameter
 497                       mm-security-handle 'gnus-details "Quit.")
 498                      (mm-set-handle-multipart-parameter
 499                       mm-security-handle 'gnus-info "Quit.")
 500                      (setq info-is-set-p t)
 501                      nil))
 502             (unless info-is-set-p
 503               (mm-set-handle-multipart-parameter
 504                mm-security-handle 'gnus-info "Failed"))
 505             (throw 'error handle)))
 506         (mm-set-handle-multipart-parameter
 507          mm-security-handle 'gnus-info
 508          (with-current-buffer mml2015-result-buffer
 509            (mml2015-gpg-extract-signature-details))))
 510       handle)))
 511
 512 (defun mml2015-gpg-clear-verify ()
 513   (if (condition-case err
 514           (prog1
 515               (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
 516             (mm-set-handle-multipart-parameter
 517              mm-security-handle 'gnus-details
 518              (with-current-buffer mml2015-result-buffer
 519                (buffer-string))))
 520         (error
 521          (mm-set-handle-multipart-parameter
 522           mm-security-handle 'gnus-details (mml2015-format-error err))
 523          nil)
 524         (quit
 525          (mm-set-handle-multipart-parameter
 526           mm-security-handle 'gnus-details "Quit.")
 527          nil))
 528       (mm-set-handle-multipart-parameter
 529        mm-security-handle 'gnus-info
 530        (with-current-buffer mml2015-result-buffer
 531          (mml2015-gpg-extract-signature-details)))
 532     (mm-set-handle-multipart-parameter
 533      mm-security-handle 'gnus-info "Failed")))
 534
 535 (defun mml2015-gpg-sign (cont)
 536   (let ((boundary
 537          (funcall mml-boundary-function (incf mml-multipart-number)))
 538         (text (current-buffer)) signature)
 539     (goto-char (point-max))
 540     (unless (bolp)
 541       (insert "\n"))
 542     (with-temp-buffer
 543       (unless (gpg-sign-detached text (setq signature (current-buffer))
 544                                  mml2015-result-buffer
 545                                  nil
 546                                  (message-options-get 'message-sender)
 547                                  t t) ; armor & textmode
 548         (unless (> (point-max) (point-min))
 549           (pop-to-buffer mml2015-result-buffer)
 550           (error "Sign error")))
 551       (goto-char (point-min))
 552       (while (re-search-forward "\r+$" nil t)
 553         (replace-match "" t t))
 554       (set-buffer text)
 555       (goto-char (point-min))
 556       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 557                       boundary))
 558       ;;; FIXME: what is the micalg?
 559       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 560       (insert (format "\n--%s\n" boundary))
 561       (goto-char (point-max))
 562       (insert (format "\n--%s\n" boundary))
 563       (insert "Content-Type: application/pgp-signature\n\n")
 564       (insert-buffer signature)
 565       (goto-char (point-max))
 566       (insert (format "--%s--\n" boundary))
 567       (goto-char (point-max)))))
 568
 569 (defun mml2015-gpg-encrypt (cont &optional sign)
 570   (let ((boundary
 571          (funcall mml-boundary-function (incf mml-multipart-number)))
 572         (text (current-buffer))
 573         cipher)
 574     (mm-with-unibyte-current-buffer-mule4
 575       (with-temp-buffer
 576         ;; set up a function to call the correct gpg encrypt routine
 577         ;; with the right arguments. (FIXME: this should be done
 578         ;; differently.)
 579         (flet ((gpg-encrypt-func
 580                  (sign plaintext ciphertext result recipients &optional
 581                        passphrase sign-with-key armor textmode)
 582                  (if sign
 583                      (gpg-sign-encrypt
 584                       plaintext ciphertext result recipients passphrase
 585                       sign-with-key armor textmode)
 586                    (gpg-encrypt
 587                     plaintext ciphertext result recipients passphrase
 588                     armor textmode))))
 589           (unless (gpg-encrypt-func
 590                     sign ; passed in when using signencrypt
 591                     text (setq cipher (current-buffer))
 592                     mml2015-result-buffer
 593                     (split-string
 594                      (or
 595                       (message-options-get 'message-recipients)
 596                       (message-options-set 'message-recipients
 597                                            (read-string "Recipients: ")))
 598                      "[ \f\t\n\r\v,]+")
 599                     nil
 600                     (message-options-get 'message-sender)
 601                     t t) ; armor & textmode
 602             (unless (> (point-max) (point-min))
 603               (pop-to-buffer mml2015-result-buffer)
 604               (error "Encrypt error"))))
 605         (goto-char (point-min))
 606         (while (re-search-forward "\r+$" nil t)
 607           (replace-match "" t t))
 608         (set-buffer text)
 609         (delete-region (point-min) (point-max))
 610         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 611                         boundary))
 612         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 613         (insert (format "--%s\n" boundary))
 614         (insert "Content-Type: application/pgp-encrypted\n\n")
 615         (insert "Version: 1\n\n")
 616         (insert (format "--%s\n" boundary))
 617         (insert "Content-Type: application/octet-stream\n\n")
 618         (insert-buffer cipher)
 619         (goto-char (point-max))
 620         (insert (format "--%s--\n" boundary))
 621         (goto-char (point-max))))))
 622
 623 ;;; General wrapper
 624
 625 (defun mml2015-clean-buffer ()
 626   (if (gnus-buffer-live-p mml2015-result-buffer)
 627       (with-current-buffer mml2015-result-buffer
 628         (erase-buffer)
 629         t)
 630     (setq mml2015-result-buffer
 631           (gnus-get-buffer-create "*MML2015 Result*"))
 632     nil))
 633
 634 (defsubst mml2015-clear-decrypt-function ()
 635   (nth 6 (assq mml2015-use mml2015-function-alist)))
 636
 637 (defsubst mml2015-clear-verify-function ()
 638   (nth 5 (assq mml2015-use mml2015-function-alist)))
 639
 640 ;;;###autoload
 641 (defun mml2015-decrypt (handle ctl)
 642   (mml2015-clean-buffer)
 643   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
 644     (if func
 645         (funcall func handle ctl)
 646       handle)))
 647
 648 ;;;###autoload
 649 (defun mml2015-decrypt-test (handle ctl)
 650   mml2015-use)
 651
 652 ;;;###autoload
 653 (defun mml2015-verify (handle ctl)
 654   (mml2015-clean-buffer)
 655   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
 656     (if func
 657         (funcall func handle ctl)
 658       handle)))
 659
 660 ;;;###autoload
 661 (defun mml2015-verify-test (handle ctl)
 662   mml2015-use)
 663
 664 ;;;###autoload
 665 (defun mml2015-encrypt (cont &optional sign)
 666   (mml2015-clean-buffer)
 667   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
 668     (if func
 669         (funcall func cont sign)
 670       (error "Cannot find encrypt function"))))
 671
 672 ;;;###autoload
 673 (defun mml2015-sign (cont)
 674   (mml2015-clean-buffer)
 675   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
 676     (if func
 677         (funcall func cont)
 678       (error "Cannot find sign function"))))
 679
 680 ;;;###autoload
 681 (defun mml2015-self-encrypt ()
 682   (mml2015-encrypt nil))
 683
 684 (provide 'mml2015)
 685
 686 ;;; mml2015.el ends here