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
 693 (defun mml2015-pgg-clear-decrypt ()
 694   (let ((pgg-errors-buffer mml2015-result-buffer))
 695     (if (prog1
 696             (pgg-decrypt-region (point-min) (point-max))
 697           (mm-set-handle-multipart-parameter
 698            mm-security-handle 'gnus-details
 699            (with-current-buffer mml2015-result-buffer
 700              (buffer-string))))
 701         (progn
 702           (erase-buffer)
 703           (insert-buffer pgg-output-buffer)
 704           (mm-set-handle-multipart-parameter
 705            mm-security-handle 'gnus-info "OK"))
 706       (mm-set-handle-multipart-parameter
 707        mm-security-handle 'gnus-info "Failed"))))
 708
 709 (defun mml2015-pgg-verify (handle ctl)
 710   (let ((pgg-errors-buffer mml2015-result-buffer)
 711         signature-file part signature)
 712     (if (or (null (setq part (mm-find-raw-part-by-type
 713                               ctl (or (mm-handle-multipart-ctl-parameter
 714                                        ctl 'protocol)
 715                                       "application/pgp-signature")
 716                               t)))
 717             (null (setq signature (mm-find-part-by-type
 718                                    (cdr handle) "application/pgp-signature" nil t))))
 719         (progn
 720           (mm-set-handle-multipart-parameter
 721            mm-security-handle 'gnus-info "Corrupted")
 722           handle)
 723       (with-temp-buffer
 724         (insert part)
 725         ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
 726         ;; clearsign use --textmode. The conversion is not necessary.
 727         ;; In clearverify, the conversion is not necessary either.
 728         (goto-char (point-min))
 729         (end-of-line)
 730         (while (not (eobp))
 731           (unless (eq (char-before) ?\r)
 732             (insert "\r"))
 733           (forward-line)
 734           (end-of-line))
 735         (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
 736           (mm-insert-part signature))
 737         (if (condition-case err
 738                 (prog1
 739                     (pgg-verify-region (point-min) (point-max) signature-file t)
 740                   (mm-set-handle-multipart-parameter
 741                    mm-security-handle 'gnus-details
 742                    (with-current-buffer pgg-output-buffer
 743                      (buffer-string))))
 744               (error
 745                (mm-set-handle-multipart-parameter
 746                 mm-security-handle 'gnus-details (mml2015-format-error err))
 747                nil)
 748               (quit
 749                (mm-set-handle-multipart-parameter
 750                 mm-security-handle 'gnus-details "Quit.")
 751                nil))
 752             (progn
 753               (delete-file signature-file)
 754               (mm-set-handle-multipart-parameter
 755                mm-security-handle 'gnus-info
 756                (with-current-buffer pgg-output-buffer
 757                  (mml2015-gpg-extract-signature-details))))
 758           (delete-file signature-file)
 759           (mm-set-handle-multipart-parameter
 760            mm-security-handle 'gnus-info "Failed"))))))
 761
 762 (defun mml2015-pgg-clear-verify ()
 763   (let ((pgg-errors-buffer mml2015-result-buffer))
 764     (if (condition-case err
 765             (prog1
 766                 (pgg-verify-region (point-min) (point-max) nil t)
 767               (mm-set-handle-multipart-parameter
 768                mm-security-handle 'gnus-details
 769                (with-current-buffer mml2015-result-buffer
 770                  (buffer-string))))
 771           (error
 772            (mm-set-handle-multipart-parameter
 773             mm-security-handle 'gnus-details (mml2015-format-error err))
 774            nil)
 775           (quit
 776            (mm-set-handle-multipart-parameter
 777             mm-security-handle 'gnus-details "Quit.")
 778            nil))
 779         (mm-set-handle-multipart-parameter
 780          mm-security-handle 'gnus-info
 781          (with-current-buffer pgg-output-buffer
 782            (mml2015-gpg-extract-signature-details)))
 783       (mm-set-handle-multipart-parameter
 784        mm-security-handle 'gnus-info "Failed"))))
 785
 786 (defun mml2015-pgg-sign (cont)
 787   (let ((pgg-errors-buffer mml2015-result-buffer)
 788         (boundary (funcall mml-boundary-function (incf mml-multipart-number))))
 789     (unless (pgg-sign-region (point-min) (point-max))
 790       (pop-to-buffer mml2015-result-buffer)
 791       (error "Sign error"))
 792     (goto-char (point-min))
 793     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 794                     boundary))
 795       ;;; FIXME: what is the micalg?
 796     (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 797     (insert (format "\n--%s\n" boundary))
 798     (goto-char (point-max))
 799     (insert (format "\n--%s\n" boundary))
 800     (insert "Content-Type: application/pgp-signature\n\n")
 801     (insert-buffer pgg-output-buffer)
 802     (goto-char (point-max))
 803     (insert (format "--%s--\n" boundary))
 804     (goto-char (point-max))))
 805
 806 (defun mml2015-pgg-encrypt (cont &optional sign)
 807   (let ((pgg-errors-buffer mml2015-result-buffer)
 808         (boundary (funcall mml-boundary-function (incf mml-multipart-number))))
 809     (unless (pgg-encrypt-region (point-min) (point-max)
 810                                 (split-string
 811                                  (or
 812                                   (message-options-get 'message-recipients)
 813                                   (message-options-set 'message-recipients
 814                                                        (read-string "Recipients: ")))
 815                                  "[ \f\t\n\r\v,]+"))
 816       (pop-to-buffer mml2015-result-buffer)
 817       (error "Encrypt error"))
 818     (delete-region (point-min) (point-max))
 819     (goto-char (point-min))
 820     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 821                     boundary))
 822     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 823     (insert (format "--%s\n" boundary))
 824     (insert "Content-Type: application/pgp-encrypted\n\n")
 825     (insert "Version: 1\n\n")
 826     (insert (format "--%s\n" boundary))
 827     (insert "Content-Type: application/octet-stream\n\n")
 828     (insert-buffer pgg-output-buffer)
 829     (goto-char (point-max))
 830     (insert (format "--%s--\n" boundary))
 831     (goto-char (point-max))))
 832
 833 ;;; General wrapper
 834
 835 (defun mml2015-clean-buffer ()
 836   (if (gnus-buffer-live-p mml2015-result-buffer)
 837       (with-current-buffer mml2015-result-buffer
 838         (erase-buffer)
 839         t)
 840     (setq mml2015-result-buffer
 841           (gnus-get-buffer-create "*MML2015 Result*"))
 842     nil))
 843
 844 (defsubst mml2015-clear-decrypt-function ()
 845   (nth 6 (assq mml2015-use mml2015-function-alist)))
 846
 847 (defsubst mml2015-clear-verify-function ()
 848   (nth 5 (assq mml2015-use mml2015-function-alist)))
 849
 850 ;;;###autoload
 851 (defun mml2015-decrypt (handle ctl)
 852   (mml2015-clean-buffer)
 853   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
 854     (if func
 855         (funcall func handle ctl)
 856       handle)))
 857
 858 ;;;###autoload
 859 (defun mml2015-decrypt-test (handle ctl)
 860   mml2015-use)
 861
 862 ;;;###autoload
 863 (defun mml2015-verify (handle ctl)
 864   (mml2015-clean-buffer)
 865   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
 866     (if func
 867         (funcall func handle ctl)
 868       handle)))
 869
 870 ;;;###autoload
 871 (defun mml2015-verify-test (handle ctl)
 872   mml2015-use)
 873
 874 ;;;###autoload
 875 (defun mml2015-encrypt (cont &optional sign)
 876   (mml2015-clean-buffer)
 877   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
 878     (if func
 879         (funcall func cont sign)
 880       (error "Cannot find encrypt function"))))
 881
 882 ;;;###autoload
 883 (defun mml2015-sign (cont)
 884   (mml2015-clean-buffer)
 885   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
 886     (if func
 887         (funcall func cont)
 888       (error "Cannot find sign function"))))
 889
 890 ;;;###autoload
 891 (defun mml2015-self-encrypt ()
 892   (mml2015-encrypt nil))
 893
 894 (provide 'mml2015)
 895
 896 ;;; mml2015.el ends here