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