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 (require 'mm-util)
  35
  36 (defvar mml2015-use (or
  37                      (progn
  38                        (ignore-errors
  39                          (require 'pgg))
  40                        (and (fboundp 'pgg-sign-region)
  41                             'pgg))
  42                      (progn
  43                        (ignore-errors
  44                          (require 'gpg))
  45                        (and (fboundp 'gpg-sign-detached)
  46                             'gpg))
  47                      (progn (ignore-errors
  48                               (load "mc-toplev"))
  49                             (and (fboundp 'mc-encrypt-generic)
  50                                  (fboundp 'mc-sign-generic)
  51                                  (fboundp 'mc-cleanup-recipient-headers)
  52                                  'mailcrypt)))
  53   "The package used for PGP/MIME.")
  54
  55 ;; Something is not RFC2015.
  56 (defvar mml2015-function-alist
  57   '((mailcrypt mml2015-mailcrypt-sign
  58                mml2015-mailcrypt-encrypt
  59                mml2015-mailcrypt-verify
  60                mml2015-mailcrypt-decrypt
  61                mml2015-mailcrypt-clear-verify
  62                mml2015-mailcrypt-clear-decrypt)
  63     (gpg mml2015-gpg-sign
  64          mml2015-gpg-encrypt
  65          mml2015-gpg-verify
  66          mml2015-gpg-decrypt
  67          mml2015-gpg-clear-verify
  68          mml2015-gpg-clear-decrypt)
  69   (pgg mml2015-pgg-sign
  70        mml2015-pgg-encrypt
  71        mml2015-pgg-verify
  72        mml2015-pgg-decrypt
  73        mml2015-pgg-clear-verify
  74        mml2015-pgg-clear-decrypt))
  75   "Alist of PGP/MIME functions.")
  76
  77 (defvar mml2015-result-buffer nil)
  78
  79 (defvar mml2015-trust-boundaries-alist
  80   '((trust-undefined . nil)
  81     (trust-none      . nil)
  82     (trust-marginal  . t)
  83     (trust-full      . t)
  84     (trust-ultimate  . t))
  85   "Trust boundaries for a signer's GnuPG key.
  86 This alist contains pairs of the form (trust-symbol . boolean), with
  87 symbols that are contained in `gpg-unabbrev-trust-alist'. The boolean
  88 specifies whether the given trust value is good enough to be trusted
  89 by you.")
  90
  91 ;;; mailcrypt wrapper
  92
  93 (eval-and-compile
  94   (autoload 'mailcrypt-decrypt "mailcrypt")
  95   (autoload 'mailcrypt-verify "mailcrypt")
  96   (autoload 'mc-pgp-always-sign "mailcrypt")
  97   (autoload 'mc-encrypt-generic "mc-toplev")
  98   (autoload 'mc-cleanup-recipient-headers "mc-toplev")
  99   (autoload 'mc-sign-generic "mc-toplev"))
 100
 101 (eval-when-compile
 102   (defvar mc-default-scheme)
 103   (defvar mc-schemes))
 104
 105 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
 106 (defvar mml2015-verify-function 'mailcrypt-verify)
 107
 108 (defun mml2015-format-error (err)
 109   (if (stringp (cadr err))
 110       (cadr err)
 111     (format "%S" (cdr err))))
 112
 113 (defun mml2015-mailcrypt-decrypt (handle ctl)
 114   (catch 'error
 115     (let (child handles result)
 116       (unless (setq child (mm-find-part-by-type
 117                            (cdr handle)
 118                            "application/octet-stream" nil t))
 119         (mm-set-handle-multipart-parameter
 120          mm-security-handle 'gnus-info "Corrupted")
 121         (throw 'error handle))
 122       (with-temp-buffer
 123         (mm-insert-part child)
 124         (setq result
 125               (condition-case err
 126                   (funcall mml2015-decrypt-function)
 127                 (error
 128                  (mm-set-handle-multipart-parameter
 129                   mm-security-handle 'gnus-details (mml2015-format-error err))
 130                  nil)
 131                 (quit
 132                  (mm-set-handle-multipart-parameter
 133                   mm-security-handle 'gnus-details "Quit.")
 134                  nil)))
 135         (unless (car result)
 136           (mm-set-handle-multipart-parameter
 137            mm-security-handle 'gnus-info "Failed")
 138           (throw 'error handle))
 139         (setq handles (mm-dissect-buffer t)))
 140       (mm-destroy-parts handle)
 141       (mm-set-handle-multipart-parameter
 142        mm-security-handle 'gnus-info
 143        (concat "OK"
 144                (let ((sig (with-current-buffer mml2015-result-buffer
 145                             (mml2015-gpg-extract-signature-details))))
 146                  (concat ", Signer: " sig))))
 147       (if (listp (car handles))
 148           handles
 149         (list handles)))))
 150
 151 (defun mml2015-mailcrypt-clear-decrypt ()
 152   (let (result)
 153     (setq result
 154           (condition-case err
 155               (funcall mml2015-decrypt-function)
 156             (error
 157              (mm-set-handle-multipart-parameter
 158               mm-security-handle 'gnus-details (mml2015-format-error err))
 159              nil)
 160             (quit
 161              (mm-set-handle-multipart-parameter
 162               mm-security-handle 'gnus-details "Quit.")
 163              nil)))
 164     (if (car result)
 165         (mm-set-handle-multipart-parameter
 166          mm-security-handle 'gnus-info "OK")
 167       (mm-set-handle-multipart-parameter
 168        mm-security-handle 'gnus-info "Failed"))))
 169
 170 (defun mml2015-fix-micalg (alg)
 171   (and alg
 172        ;; Mutt/1.2.5i has seen sending micalg=php-sha1
 173        (upcase (if (string-match "^p[gh]p-" alg)
 174                    (substring alg (match-end 0))
 175                  alg))))
 176
 177 (defun mml2015-mailcrypt-verify (handle ctl)
 178   (catch 'error
 179     (let (part)
 180       (unless (setq part (mm-find-raw-part-by-type
 181                           ctl (or (mm-handle-multipart-ctl-parameter
 182                                    ctl 'protocol)
 183                                   "application/pgp-signature")
 184                           t))
 185         (mm-set-handle-multipart-parameter
 186          mm-security-handle 'gnus-info "Corrupted")
 187         (throw 'error handle))
 188       (with-temp-buffer
 189         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
 190         (insert (format "Hash: %s\n\n"
 191                         (or (mml2015-fix-micalg
 192                              (mm-handle-multipart-ctl-parameter
 193                               ctl 'micalg))
 194                             "SHA1")))
 195         (save-restriction
 196           (narrow-to-region (point) (point))
 197           (insert part "\n")
 198           (goto-char (point-min))
 199           (while (not (eobp))
 200             (if (looking-at "^-")
 201                 (insert "- "))
 202             (forward-line)))
 203         (unless (setq part (mm-find-part-by-type
 204                             (cdr handle) "application/pgp-signature" nil t))
 205           (mm-set-handle-multipart-parameter
 206            mm-security-handle 'gnus-info "Corrupted")
 207           (throw 'error handle))
 208         (save-restriction
 209           (narrow-to-region (point) (point))
 210           (mm-insert-part part)
 211           (goto-char (point-min))
 212           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
 213               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
 214           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
 215               (replace-match "-----END PGP SIGNATURE-----" t t)))
 216         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 217           (unless (condition-case err
 218                       (prog1
 219                           (funcall mml2015-verify-function)
 220                         (if (get-buffer " *mailcrypt stderr temp")
 221                             (mm-set-handle-multipart-parameter
 222                              mm-security-handle 'gnus-details
 223                              (with-current-buffer " *mailcrypt stderr temp"
 224                                (buffer-string))))
 225                         (if (get-buffer " *mailcrypt stdout temp")
 226                             (kill-buffer " *mailcrypt stdout temp"))
 227                         (if (get-buffer " *mailcrypt stderr temp")
 228                             (kill-buffer " *mailcrypt stderr temp"))
 229                         (if (get-buffer " *mailcrypt status temp")
 230                             (kill-buffer " *mailcrypt status temp"))
 231                         (if (get-buffer mc-gpg-debug-buffer)
 232                             (kill-buffer mc-gpg-debug-buffer)))
 233                     (error
 234                      (mm-set-handle-multipart-parameter
 235                       mm-security-handle 'gnus-details (mml2015-format-error err))
 236                      nil)
 237                     (quit
 238                      (mm-set-handle-multipart-parameter
 239                       mm-security-handle 'gnus-details "Quit.")
 240                      nil))
 241             (mm-set-handle-multipart-parameter
 242              mm-security-handle 'gnus-info "Failed")
 243             (throw 'error handle))))
 244       (mm-set-handle-multipart-parameter
 245        mm-security-handle 'gnus-info "OK")
 246       handle)))
 247
 248 (defun mml2015-mailcrypt-clear-verify ()
 249   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 250     (if (condition-case err
 251             (prog1
 252                 (funcall mml2015-verify-function)
 253               (if (get-buffer " *mailcrypt stderr temp")
 254                   (mm-set-handle-multipart-parameter
 255                    mm-security-handle 'gnus-details
 256                    (with-current-buffer " *mailcrypt stderr temp"
 257                      (buffer-string))))
 258               (if (get-buffer " *mailcrypt stdout temp")
 259                   (kill-buffer " *mailcrypt stdout temp"))
 260               (if (get-buffer " *mailcrypt stderr temp")
 261                   (kill-buffer " *mailcrypt stderr temp"))
 262               (if (get-buffer " *mailcrypt status temp")
 263                   (kill-buffer " *mailcrypt status temp"))
 264               (if (get-buffer mc-gpg-debug-buffer)
 265                   (kill-buffer mc-gpg-debug-buffer)))
 266           (error
 267            (mm-set-handle-multipart-parameter
 268             mm-security-handle 'gnus-details (mml2015-format-error err))
 269            nil)
 270           (quit
 271            (mm-set-handle-multipart-parameter
 272             mm-security-handle 'gnus-details "Quit.")
 273            nil))
 274         (mm-set-handle-multipart-parameter
 275          mm-security-handle 'gnus-info "OK")
 276       (mm-set-handle-multipart-parameter
 277        mm-security-handle 'gnus-info "Failed"))))
 278
 279 (defun mml2015-mailcrypt-sign (cont)
 280   (mc-sign-generic (message-options-get 'message-sender)
 281                    nil nil nil nil)
 282   (let ((boundary
 283          (funcall mml-boundary-function (incf mml-multipart-number)))
 284         hash point)
 285     (goto-char (point-min))
 286     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
 287       (error "Cannot find signed begin line"))
 288     (goto-char (match-beginning 0))
 289     (forward-line 1)
 290     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 291       (error "Cannot not find PGP hash"))
 292     (setq hash (match-string 1))
 293     (unless (re-search-forward "^$" nil t)
 294       (error "Cannot not find PGP message"))
 295     (forward-line 1)
 296     (delete-region (point-min) (point))
 297     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 298                     boundary))
 299     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 300                     (downcase hash)))
 301     (insert (format "\n--%s\n" boundary))
 302     (setq point (point))
 303     (goto-char (point-max))
 304     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
 305       (error "Cannot find signature part"))
 306     (replace-match "-----END PGP MESSAGE-----" t t)
 307     (goto-char (match-beginning 0))
 308     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
 309                                 nil t)
 310       (error "Cannot find signature part"))
 311     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
 312     (goto-char (match-beginning 0))
 313     (save-restriction
 314       (narrow-to-region point (point))
 315       (goto-char point)
 316       (while (re-search-forward "^- -" nil t)
 317         (replace-match "-" t t))
 318       (goto-char (point-max)))
 319     (insert (format "--%s\n" boundary))
 320     (insert "Content-Type: application/pgp-signature\n\n")
 321     (goto-char (point-max))
 322     (insert (format "--%s--\n" boundary))
 323     (goto-char (point-max))))
 324
 325 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
 326   (let ((mc-pgp-always-sign
 327          (or mc-pgp-always-sign
 328              sign
 329              (eq t (or (message-options-get 'message-sign-encrypt)
 330                        (message-options-set
 331                         'message-sign-encrypt
 332                         (or (y-or-n-p "Sign the message? ")
 333                             'not))))
 334              'never)))
 335     (mm-with-unibyte-current-buffer-mule4
 336       (mc-encrypt-generic
 337        (or (message-options-get 'message-recipients)
 338            (message-options-set 'message-recipients
 339                                 (mc-cleanup-recipient-headers
 340                                  (read-string "Recipients: "))))
 341        nil nil nil
 342        (message-options-get 'message-sender))))
 343   (goto-char (point-min))
 344   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
 345     (error "Fail to encrypt the message"))
 346   (let ((boundary
 347          (funcall mml-boundary-function (incf mml-multipart-number))))
 348     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 349                     boundary))
 350     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 351     (insert (format "--%s\n" boundary))
 352     (insert "Content-Type: application/pgp-encrypted\n\n")
 353     (insert "Version: 1\n\n")
 354     (insert (format "--%s\n" boundary))
 355     (insert "Content-Type: application/octet-stream\n\n")
 356     (goto-char (point-max))
 357     (insert (format "--%s--\n" boundary))
 358     (goto-char (point-max))))
 359
 360 ;;; gpg wrapper
 361
 362 (eval-and-compile
 363   (autoload 'gpg-decrypt "gpg")
 364   (autoload 'gpg-verify "gpg")
 365   (autoload 'gpg-verify-cleartext "gpg")
 366   (autoload 'gpg-sign-detached "gpg")
 367   (autoload 'gpg-sign-encrypt "gpg")
 368   (autoload 'gpg-encrypt "gpg")
 369   (autoload 'gpg-passphrase-read "gpg"))
 370
 371 (defun mml2015-gpg-passphrase ()
 372   (or (message-options-get 'gpg-passphrase)
 373       (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
 374
 375 (defun mml2015-gpg-decrypt-1 ()
 376   (let ((cipher (current-buffer)) plain result)
 377     (if (with-temp-buffer
 378           (prog1
 379               (gpg-decrypt cipher (setq plain (current-buffer))
 380                            mml2015-result-buffer nil)
 381             (mm-set-handle-multipart-parameter
 382              mm-security-handle 'gnus-details
 383              (with-current-buffer mml2015-result-buffer
 384                (buffer-string)))
 385             (set-buffer cipher)
 386             (erase-buffer)
 387             (insert-buffer plain)
 388             (goto-char (point-min))
 389             (while (search-forward "\r\n" nil t)
 390               (replace-match "\n" t t))))
 391         '(t)
 392       ;; Some wrong with the return value, check plain text buffer.
 393       (if (> (point-max) (point-min))
 394           '(t)
 395         nil))))
 396
 397 (defun mml2015-gpg-decrypt (handle ctl)
 398   (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
 399     (mml2015-mailcrypt-decrypt handle ctl)))
 400
 401 (defun mml2015-gpg-clear-decrypt ()
 402   (let (result)
 403     (setq result (mml2015-gpg-decrypt-1))
 404     (if (car result)
 405         (mm-set-handle-multipart-parameter
 406          mm-security-handle 'gnus-info "OK")
 407       (mm-set-handle-multipart-parameter
 408        mm-security-handle 'gnus-info "Failed"))))
 409
 410 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
 411   (let* ((result "")
 412          (fpr-length (string-width fingerprint))
 413          (n-slice 0)
 414          slice)
 415     (setq fingerprint (string-to-list fingerprint))
 416     (while fingerprint
 417       (setq fpr-length (- fpr-length 4))
 418       (setq slice (butlast fingerprint fpr-length))
 419       (setq fingerprint (nthcdr 4 fingerprint))
 420       (setq n-slice (1+ n-slice))
 421       (setq result
 422             (concat
 423              result
 424              (case n-slice
 425                (1  slice)
 426                (otherwise (concat " " slice))))))
 427     result))
 428
 429 (defun mml2015-gpg-extract-signature-details ()
 430   (goto-char (point-min))
 431   (if (boundp 'gpg-unabbrev-trust-alist)
 432       (let* ((expired (re-search-forward
 433                        "^\\[GNUPG:\\] SIGEXPIRED$"
 434                        nil t))
 435              (signer (and (re-search-forward
 436                            "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
 437                            nil t)
 438                           (cons (match-string 1) (match-string 2))))
 439              (fprint (and (re-search-forward
 440                            "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
 441                        nil t)
 442                           (match-string 1)))
 443              (trust  (and (re-search-forward "^\\[GNUPG:\\] \\(TRUST_.*\\)$" nil t)
 444                           (match-string 1)))
 445              (trust-good-enough-p
 446               (cdr (assoc (cdr (assoc trust gpg-unabbrev-trust-alist))
 447                       mml2015-trust-boundaries-alist))))
 448         (cond ((and signer fprint)
 449                (concat (cdr signer)
 450                        (unless trust-good-enough-p
 451                          (concat "\nUntrusted, Fingerprint: "
 452                                  (mml2015-gpg-pretty-print-fpr fprint)))
 453                        (when expired
 454                          (format "\nWARNING: Signature from expired key (%s)"
 455                                  (car signer)))))
 456               (t
 457                "From unknown user")))
 458     (if (re-search-forward "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
 459         (match-string 2)
 460       "From unknown user")))
 461
 462 (defun mml2015-gpg-verify (handle ctl)
 463   (catch 'error
 464     (let (part message signature info-is-set-p)
 465       (unless (setq part (mm-find-raw-part-by-type
 466                           ctl (or (mm-handle-multipart-ctl-parameter
 467                                    ctl 'protocol)
 468                                   "application/pgp-signature")
 469                           t))
 470         (mm-set-handle-multipart-parameter
 471          mm-security-handle 'gnus-info "Corrupted")
 472         (throw 'error handle))
 473       (with-temp-buffer
 474         (setq message (current-buffer))
 475         (insert part)
 476         ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
 477         ;; clearsign use --textmode. The conversion is not necessary.
 478         ;; In clearverify, the conversion is not necessary either.
 479         (goto-char (point-min))
 480         (end-of-line)
 481         (while (not (eobp))
 482           (unless (eq (char-before) ?\r)
 483             (insert "\r"))
 484           (forward-line)
 485           (end-of-line))
 486         (with-temp-buffer
 487           (setq signature (current-buffer))
 488           (unless (setq part (mm-find-part-by-type
 489                               (cdr handle) "application/pgp-signature" nil t))
 490             (mm-set-handle-multipart-parameter
 491              mm-security-handle 'gnus-info "Corrupted")
 492             (throw 'error handle))
 493           (mm-insert-part part)
 494           (unless (condition-case err
 495                       (prog1
 496                           (gpg-verify message signature mml2015-result-buffer)
 497                         (mm-set-handle-multipart-parameter
 498                          mm-security-handle 'gnus-details
 499                          (with-current-buffer mml2015-result-buffer
 500                            (buffer-string))))
 501                     (error
 502                      (mm-set-handle-multipart-parameter
 503                       mm-security-handle 'gnus-details (mml2015-format-error err))
 504                      (mm-set-handle-multipart-parameter
 505                       mm-security-handle 'gnus-info "Error.")
 506                      (setq info-is-set-p t)
 507                      nil)
 508                     (quit
 509                      (mm-set-handle-multipart-parameter
 510                       mm-security-handle 'gnus-details "Quit.")
 511                      (mm-set-handle-multipart-parameter
 512                       mm-security-handle 'gnus-info "Quit.")
 513                      (setq info-is-set-p t)
 514                      nil))
 515             (unless info-is-set-p
 516               (mm-set-handle-multipart-parameter
 517                mm-security-handle 'gnus-info "Failed"))
 518             (throw 'error handle)))
 519         (mm-set-handle-multipart-parameter
 520          mm-security-handle 'gnus-info
 521          (with-current-buffer mml2015-result-buffer
 522            (mml2015-gpg-extract-signature-details))))
 523       handle)))
 524
 525 (defun mml2015-gpg-clear-verify ()
 526   (if (condition-case err
 527           (prog1
 528               (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
 529             (mm-set-handle-multipart-parameter
 530              mm-security-handle 'gnus-details
 531              (with-current-buffer mml2015-result-buffer
 532                (buffer-string))))
 533         (error
 534          (mm-set-handle-multipart-parameter
 535           mm-security-handle 'gnus-details (mml2015-format-error err))
 536          nil)
 537         (quit
 538          (mm-set-handle-multipart-parameter
 539           mm-security-handle 'gnus-details "Quit.")
 540          nil))
 541       (mm-set-handle-multipart-parameter
 542        mm-security-handle 'gnus-info
 543        (with-current-buffer mml2015-result-buffer
 544          (mml2015-gpg-extract-signature-details)))
 545     (mm-set-handle-multipart-parameter
 546      mm-security-handle 'gnus-info "Failed")))
 547
 548 (defun mml2015-gpg-sign (cont)
 549   (let ((boundary
 550          (funcall mml-boundary-function (incf mml-multipart-number)))
 551         (text (current-buffer)) signature)
 552     (goto-char (point-max))
 553     (unless (bolp)
 554       (insert "\n"))
 555     (with-temp-buffer
 556       (unless (gpg-sign-detached text (setq signature (current-buffer))
 557                                  mml2015-result-buffer
 558                                  nil
 559                                  (message-options-get 'message-sender)
 560                                  t t) ; armor & textmode
 561         (unless (> (point-max) (point-min))
 562           (pop-to-buffer mml2015-result-buffer)
 563           (error "Sign error")))
 564       (goto-char (point-min))
 565       (while (re-search-forward "\r+$" nil t)
 566         (replace-match "" t t))
 567       (set-buffer text)
 568       (goto-char (point-min))
 569       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 570                       boundary))
 571       ;;; FIXME: what is the micalg?
 572       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 573       (insert (format "\n--%s\n" boundary))
 574       (goto-char (point-max))
 575       (insert (format "\n--%s\n" boundary))
 576       (insert "Content-Type: application/pgp-signature\n\n")
 577       (insert-buffer signature)
 578       (goto-char (point-max))
 579       (insert (format "--%s--\n" boundary))
 580       (goto-char (point-max)))))
 581
 582 (defun mml2015-gpg-encrypt (cont &optional sign)
 583   (let ((boundary
 584          (funcall mml-boundary-function (incf mml-multipart-number)))
 585         (text (current-buffer))
 586         cipher)
 587     (mm-with-unibyte-current-buffer-mule4
 588       (with-temp-buffer
 589         ;; set up a function to call the correct gpg encrypt routine
 590         ;; with the right arguments. (FIXME: this should be done
 591         ;; differently.)
 592         (flet ((gpg-encrypt-func
 593                  (sign plaintext ciphertext result recipients &optional
 594                        passphrase sign-with-key armor textmode)
 595                  (if sign
 596                      (gpg-sign-encrypt
 597                       plaintext ciphertext result recipients passphrase
 598                       sign-with-key armor textmode)
 599                    (gpg-encrypt
 600                     plaintext ciphertext result recipients passphrase
 601                     armor textmode))))
 602           (unless (gpg-encrypt-func
 603                     sign ; passed in when using signencrypt
 604                     text (setq cipher (current-buffer))
 605                     mml2015-result-buffer
 606                     (split-string
 607                      (or
 608                       (message-options-get 'message-recipients)
 609                       (message-options-set 'message-recipients
 610                                            (read-string "Recipients: ")))
 611                      "[ \f\t\n\r\v,]+")
 612                     nil
 613                     (message-options-get 'message-sender)
 614                     t t) ; armor & textmode
 615             (unless (> (point-max) (point-min))
 616               (pop-to-buffer mml2015-result-buffer)
 617               (error "Encrypt error"))))
 618         (goto-char (point-min))
 619         (while (re-search-forward "\r+$" nil t)
 620           (replace-match "" t t))
 621         (set-buffer text)
 622         (delete-region (point-min) (point-max))
 623         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 624                         boundary))
 625         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 626         (insert (format "--%s\n" boundary))
 627         (insert "Content-Type: application/pgp-encrypted\n\n")
 628         (insert "Version: 1\n\n")
 629         (insert (format "--%s\n" boundary))
 630         (insert "Content-Type: application/octet-stream\n\n")
 631         (insert-buffer cipher)
 632         (goto-char (point-max))
 633         (insert (format "--%s--\n" boundary))
 634         (goto-char (point-max))))))
 635
 636 ;;; pgg wrapper
 637
 638 (eval-when-compile
 639   (defvar pgg-errors-buffer)
 640   (defvar pgg-output-buffer))
 641
 642 (eval-and-compile
 643   (autoload 'pgg-decrypt-region "pgg")
 644   (autoload 'pgg-verify-region "pgg")
 645   (autoload 'pgg-sign-region "pgg")
 646   (autoload 'pgg-encrypt-region "pgg"))
 647
 648 (defun mml2015-pgg-decrypt (handle ctl)
 649   (catch 'error
 650     (let ((pgg-errors-buffer mml2015-result-buffer)
 651           child handles result decrypt-status)
 652       (unless (setq child (mm-find-part-by-type
 653                            (cdr handle)
 654                            "application/octet-stream" nil t))
 655         (mm-set-handle-multipart-parameter
 656          mm-security-handle 'gnus-info "Corrupted")
 657         (throw 'error handle))
 658       (with-temp-buffer
 659         (mm-insert-part child)
 660         (if (condition-case err
 661                 (prog1
 662                     (pgg-decrypt-region (point-min) (point-max))
 663                   (setq decrypt-status
 664                         (with-current-buffer mml2015-result-buffer
 665                           (buffer-string))))
 666               (error
 667                (mm-set-handle-multipart-parameter
 668                 mm-security-handle 'gnus-details (mml2015-format-error err))
 669                nil)
 670               (quit
 671                (mm-set-handle-multipart-parameter
 672                 mm-security-handle 'gnus-details "Quit.")
 673                nil))
 674             (with-current-buffer pgg-output-buffer
 675               (setq handles (mm-dissect-buffer t))
 676               (mm-destroy-parts handle)
 677               (mm-set-handle-multipart-parameter
 678                mm-security-handle 'gnus-info "OK")
 679               (mm-set-handle-multipart-parameter
 680                mm-security-handle 'gnus-details
 681                (concat decrypt-status
 682                        (when (stringp (car handles))
 683                          "\n" (mm-handle-multipart-ctl-parameter
 684                                handles 'gnus-details))))
 685               (if (listp (car handles))
 686                   handles
 687                 (list handles)))
 688           (mm-set-handle-multipart-parameter
 689            mm-security-handle 'gnus-info "Failed")
 690           (throw 'error handle))))))
 691
 692 (defun mml2015-pgg-clear-decrypt ()
 693   (let ((pgg-errors-buffer mml2015-result-buffer))
 694     (if (prog1
 695             (pgg-decrypt-region (point-min) (point-max))
 696           (mm-set-handle-multipart-parameter
 697            mm-security-handle 'gnus-details
 698            (with-current-buffer mml2015-result-buffer
 699              (buffer-string))))
 700         (progn
 701           (erase-buffer)
 702           (insert-buffer pgg-output-buffer)
 703           (mm-set-handle-multipart-parameter
 704            mm-security-handle 'gnus-info "OK"))
 705       (mm-set-handle-multipart-parameter
 706        mm-security-handle 'gnus-info "Failed"))))
 707
 708 (defun mml2015-pgg-verify (handle ctl)
 709   (let ((pgg-errors-buffer mml2015-result-buffer)
 710         signature-file part signature)
 711     (if (or (null (setq part (mm-find-raw-part-by-type
 712                               ctl (or (mm-handle-multipart-ctl-parameter
 713                                        ctl 'protocol)
 714                                       "application/pgp-signature")
 715                               t)))
 716             (null (setq signature (mm-find-part-by-type
 717                                    (cdr handle) "application/pgp-signature" nil t))))
 718         (progn
 719           (mm-set-handle-multipart-parameter
 720            mm-security-handle 'gnus-info "Corrupted")
 721           handle)
 722       (with-temp-buffer
 723         (insert part)
 724         ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
 725         ;; clearsign use --textmode. The conversion is not necessary.
 726         ;; In clearverify, the conversion is not necessary either.
 727         (goto-char (point-min))
 728         (end-of-line)
 729         (while (not (eobp))
 730           (unless (eq (char-before) ?\r)
 731             (insert "\r"))
 732           (forward-line)
 733           (end-of-line))
 734         (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
 735           (mm-insert-part signature))
 736         (if (condition-case err
 737                 (prog1
 738                     (pgg-verify-region (point-min) (point-max)
 739                                        signature-file t)
 740                   (mm-set-handle-multipart-parameter
 741                    mm-security-handle 'gnus-details
 742                    (concat (with-current-buffer pgg-output-buffer
 743                              (buffer-string))
 744                            (with-current-buffer pgg-errors-buffer
 745                              (buffer-string)))))
 746               (error
 747                (mm-set-handle-multipart-parameter
 748                 mm-security-handle 'gnus-details (mml2015-format-error err))
 749                nil)
 750               (quit
 751                (mm-set-handle-multipart-parameter
 752                 mm-security-handle 'gnus-details "Quit.")
 753                nil))
 754             (progn
 755               (delete-file signature-file)
 756               (mm-set-handle-multipart-parameter
 757                mm-security-handle 'gnus-info
 758                (with-current-buffer pgg-errors-buffer
 759                  (mml2015-gpg-extract-signature-details))))
 760           (delete-file signature-file)
 761           (mm-set-handle-multipart-parameter
 762            mm-security-handle 'gnus-info "Failed")))))
 763   handle)
 764
 765 (defun mml2015-pgg-clear-verify ()
 766   (let ((pgg-errors-buffer mml2015-result-buffer)
 767         (text (current-buffer)))
 768     (if (condition-case err
 769             (prog1
 770                 (mm-with-unibyte-buffer
 771                   (insert-buffer text)
 772                   (pgg-verify-region (point-min) (point-max) nil t))
 773               (mm-set-handle-multipart-parameter
 774                mm-security-handle 'gnus-details
 775                (concat (with-current-buffer pgg-output-buffer
 776                          (buffer-string))
 777                        (with-current-buffer pgg-errors-buffer
 778                          (buffer-string)))))
 779           (error
 780            (mm-set-handle-multipart-parameter
 781             mm-security-handle 'gnus-details (mml2015-format-error err))
 782            nil)
 783           (quit
 784            (mm-set-handle-multipart-parameter
 785             mm-security-handle 'gnus-details "Quit.")
 786            nil))
 787         (mm-set-handle-multipart-parameter
 788          mm-security-handle 'gnus-info
 789          (with-current-buffer pgg-errors-buffer
 790            (mml2015-gpg-extract-signature-details)))
 791       (mm-set-handle-multipart-parameter
 792        mm-security-handle 'gnus-info "Failed"))))
 793
 794 (defun mml2015-pgg-sign (cont)
 795   (let ((pgg-errors-buffer mml2015-result-buffer)
 796         (boundary (funcall mml-boundary-function (incf mml-multipart-number))))
 797     (unless (pgg-sign-region (point-min) (point-max))
 798       (pop-to-buffer mml2015-result-buffer)
 799       (error "Sign error"))
 800     (goto-char (point-min))
 801     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 802                     boundary))
 803       ;;; FIXME: what is the micalg?
 804     (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 805     (insert (format "\n--%s\n" boundary))
 806     (goto-char (point-max))
 807     (insert (format "\n--%s\n" boundary))
 808     (insert "Content-Type: application/pgp-signature\n\n")
 809     (insert-buffer pgg-output-buffer)
 810     (goto-char (point-max))
 811     (insert (format "--%s--\n" boundary))
 812     (goto-char (point-max))))
 813
 814 (defun mml2015-pgg-encrypt (cont &optional sign)
 815   (let ((pgg-errors-buffer mml2015-result-buffer)
 816         (boundary (funcall mml-boundary-function (incf mml-multipart-number))))
 817     (unless (pgg-encrypt-region (point-min) (point-max)
 818                                 (split-string
 819                                  (or
 820                                   (message-options-get 'message-recipients)
 821                                   (message-options-set 'message-recipients
 822                                                        (read-string "Recipients: ")))
 823                                  "[ \f\t\n\r\v,]+")
 824                                 sign)
 825       (pop-to-buffer mml2015-result-buffer)
 826       (error "Encrypt error"))
 827     (delete-region (point-min) (point-max))
 828     (goto-char (point-min))
 829     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 830                     boundary))
 831     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 832     (insert (format "--%s\n" boundary))
 833     (insert "Content-Type: application/pgp-encrypted\n\n")
 834     (insert "Version: 1\n\n")
 835     (insert (format "--%s\n" boundary))
 836     (insert "Content-Type: application/octet-stream\n\n")
 837     (insert-buffer pgg-output-buffer)
 838     (goto-char (point-max))
 839     (insert (format "--%s--\n" boundary))
 840     (goto-char (point-max))))
 841
 842 ;;; General wrapper
 843
 844 (defun mml2015-clean-buffer ()
 845   (if (gnus-buffer-live-p mml2015-result-buffer)
 846       (with-current-buffer mml2015-result-buffer
 847         (erase-buffer)
 848         t)
 849     (setq mml2015-result-buffer
 850           (gnus-get-buffer-create "*MML2015 Result*"))
 851     nil))
 852
 853 (defsubst mml2015-clear-decrypt-function ()
 854   (nth 6 (assq mml2015-use mml2015-function-alist)))
 855
 856 (defsubst mml2015-clear-verify-function ()
 857   (nth 5 (assq mml2015-use mml2015-function-alist)))
 858
 859 ;;;###autoload
 860 (defun mml2015-decrypt (handle ctl)
 861   (mml2015-clean-buffer)
 862   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
 863     (if func
 864         (funcall func handle ctl)
 865       handle)))
 866
 867 ;;;###autoload
 868 (defun mml2015-decrypt-test (handle ctl)
 869   mml2015-use)
 870
 871 ;;;###autoload
 872 (defun mml2015-verify (handle ctl)
 873   (mml2015-clean-buffer)
 874   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
 875     (if func
 876         (funcall func handle ctl)
 877       handle)))
 878
 879 ;;;###autoload
 880 (defun mml2015-verify-test (handle ctl)
 881   mml2015-use)
 882
 883 ;;;###autoload
 884 (defun mml2015-encrypt (cont &optional sign)
 885   (mml2015-clean-buffer)
 886   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
 887     (if func
 888         (funcall func cont sign)
 889       (error "Cannot find encrypt function"))))
 890
 891 ;;;###autoload
 892 (defun mml2015-sign (cont)
 893   (mml2015-clean-buffer)
 894   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
 895     (if func
 896         (funcall func cont)
 897       (error "Cannot find sign function"))))
 898
 899 ;;;###autoload
 900 (defun mml2015-self-encrypt ()
 901   (mml2015-encrypt nil))
 902
 903 (provide 'mml2015)
 904
 905 ;;; mml2015.el ends here