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 (and (eq mml2015-use 'gpg)
 432            (boundp 'gpg-unabbrev-trust-alist))
 433       (let* ((expired (re-search-forward
 434                        "^\\[GNUPG:\\] SIGEXPIRED$"
 435                        nil t))
 436              (signer (and (re-search-forward
 437                            "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
 438                            nil t)
 439                           (cons (match-string 1) (match-string 2))))
 440              (fprint (and (re-search-forward
 441                            "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
 442                        nil t)
 443                           (match-string 1)))
 444              (trust  (and (re-search-forward "^\\[GNUPG:\\] \\(TRUST_.*\\)$" nil t)
 445                           (match-string 1)))
 446              (trust-good-enough-p
 447               (cdr (assoc (cdr (assoc trust gpg-unabbrev-trust-alist))
 448                       mml2015-trust-boundaries-alist))))
 449         (cond ((and signer fprint)
 450                (concat (cdr signer)
 451                        (unless trust-good-enough-p
 452                          (concat "\nUntrusted, Fingerprint: "
 453                                  (mml2015-gpg-pretty-print-fpr fprint)))
 454                        (when expired
 455                          (format "\nWARNING: Signature from expired key (%s)"
 456                                  (car signer)))))
 457               (t
 458                "From unknown user")))
 459     (if (re-search-forward "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
 460         (match-string 2)
 461       "From unknown user")))
 462
 463 (defun mml2015-gpg-verify (handle ctl)
 464   (catch 'error
 465     (let (part message signature info-is-set-p)
 466       (unless (setq part (mm-find-raw-part-by-type
 467                           ctl (or (mm-handle-multipart-ctl-parameter
 468                                    ctl 'protocol)
 469                                   "application/pgp-signature")
 470                           t))
 471         (mm-set-handle-multipart-parameter
 472          mm-security-handle 'gnus-info "Corrupted")
 473         (throw 'error handle))
 474       (with-temp-buffer
 475         (setq message (current-buffer))
 476         (insert part)
 477         ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
 478         ;; clearsign use --textmode. The conversion is not necessary.
 479         ;; In clearverify, the conversion is not necessary either.
 480         (goto-char (point-min))
 481         (end-of-line)
 482         (while (not (eobp))
 483           (unless (eq (char-before) ?\r)
 484             (insert "\r"))
 485           (forward-line)
 486           (end-of-line))
 487         (with-temp-buffer
 488           (setq signature (current-buffer))
 489           (unless (setq part (mm-find-part-by-type
 490                               (cdr handle) "application/pgp-signature" nil t))
 491             (mm-set-handle-multipart-parameter
 492              mm-security-handle 'gnus-info "Corrupted")
 493             (throw 'error handle))
 494           (mm-insert-part part)
 495           (unless (condition-case err
 496                       (prog1
 497                           (gpg-verify message signature mml2015-result-buffer)
 498                         (mm-set-handle-multipart-parameter
 499                          mm-security-handle 'gnus-details
 500                          (with-current-buffer mml2015-result-buffer
 501                            (buffer-string))))
 502                     (error
 503                      (mm-set-handle-multipart-parameter
 504                       mm-security-handle 'gnus-details (mml2015-format-error err))
 505                      (mm-set-handle-multipart-parameter
 506                       mm-security-handle 'gnus-info "Error.")
 507                      (setq info-is-set-p t)
 508                      nil)
 509                     (quit
 510                      (mm-set-handle-multipart-parameter
 511                       mm-security-handle 'gnus-details "Quit.")
 512                      (mm-set-handle-multipart-parameter
 513                       mm-security-handle 'gnus-info "Quit.")
 514                      (setq info-is-set-p t)
 515                      nil))
 516             (unless info-is-set-p
 517               (mm-set-handle-multipart-parameter
 518                mm-security-handle 'gnus-info "Failed"))
 519             (throw 'error handle)))
 520         (mm-set-handle-multipart-parameter
 521          mm-security-handle 'gnus-info
 522          (with-current-buffer mml2015-result-buffer
 523            (mml2015-gpg-extract-signature-details))))
 524       handle)))
 525
 526 (defun mml2015-gpg-clear-verify ()
 527   (if (condition-case err
 528           (prog1
 529               (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
 530             (mm-set-handle-multipart-parameter
 531              mm-security-handle 'gnus-details
 532              (with-current-buffer mml2015-result-buffer
 533                (buffer-string))))
 534         (error
 535          (mm-set-handle-multipart-parameter
 536           mm-security-handle 'gnus-details (mml2015-format-error err))
 537          nil)
 538         (quit
 539          (mm-set-handle-multipart-parameter
 540           mm-security-handle 'gnus-details "Quit.")
 541          nil))
 542       (mm-set-handle-multipart-parameter
 543        mm-security-handle 'gnus-info
 544        (with-current-buffer mml2015-result-buffer
 545          (mml2015-gpg-extract-signature-details)))
 546     (mm-set-handle-multipart-parameter
 547      mm-security-handle 'gnus-info "Failed")))
 548
 549 (defun mml2015-gpg-sign (cont)
 550   (let ((boundary
 551          (funcall mml-boundary-function (incf mml-multipart-number)))
 552         (text (current-buffer)) signature)
 553     (goto-char (point-max))
 554     (unless (bolp)
 555       (insert "\n"))
 556     (with-temp-buffer
 557       (unless (gpg-sign-detached text (setq signature (current-buffer))
 558                                  mml2015-result-buffer
 559                                  nil
 560                                  (message-options-get 'message-sender)
 561                                  t t) ; armor & textmode
 562         (unless (> (point-max) (point-min))
 563           (pop-to-buffer mml2015-result-buffer)
 564           (error "Sign error")))
 565       (goto-char (point-min))
 566       (while (re-search-forward "\r+$" nil t)
 567         (replace-match "" t t))
 568       (set-buffer text)
 569       (goto-char (point-min))
 570       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 571                       boundary))
 572       ;;; FIXME: what is the micalg?
 573       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 574       (insert (format "\n--%s\n" boundary))
 575       (goto-char (point-max))
 576       (insert (format "\n--%s\n" boundary))
 577       (insert "Content-Type: application/pgp-signature\n\n")
 578       (insert-buffer signature)
 579       (goto-char (point-max))
 580       (insert (format "--%s--\n" boundary))
 581       (goto-char (point-max)))))
 582
 583 (defun mml2015-gpg-encrypt (cont &optional sign)
 584   (let ((boundary
 585          (funcall mml-boundary-function (incf mml-multipart-number)))
 586         (text (current-buffer))
 587         cipher)
 588     (mm-with-unibyte-current-buffer-mule4
 589       (with-temp-buffer
 590         ;; set up a function to call the correct gpg encrypt routine
 591         ;; with the right arguments. (FIXME: this should be done
 592         ;; differently.)
 593         (flet ((gpg-encrypt-func
 594                  (sign plaintext ciphertext result recipients &optional
 595                        passphrase sign-with-key armor textmode)
 596                  (if sign
 597                      (gpg-sign-encrypt
 598                       plaintext ciphertext result recipients passphrase
 599                       sign-with-key armor textmode)
 600                    (gpg-encrypt
 601                     plaintext ciphertext result recipients passphrase
 602                     armor textmode))))
 603           (unless (gpg-encrypt-func
 604                     sign ; passed in when using signencrypt
 605                     text (setq cipher (current-buffer))
 606                     mml2015-result-buffer
 607                     (split-string
 608                      (or
 609                       (message-options-get 'message-recipients)
 610                       (message-options-set 'message-recipients
 611                                            (read-string "Recipients: ")))
 612                      "[ \f\t\n\r\v,]+")
 613                     nil
 614                     (message-options-get 'message-sender)
 615                     t t) ; armor & textmode
 616             (unless (> (point-max) (point-min))
 617               (pop-to-buffer mml2015-result-buffer)
 618               (error "Encrypt error"))))
 619         (goto-char (point-min))
 620         (while (re-search-forward "\r+$" nil t)
 621           (replace-match "" t t))
 622         (set-buffer text)
 623         (delete-region (point-min) (point-max))
 624         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 625                         boundary))
 626         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 627         (insert (format "--%s\n" boundary))
 628         (insert "Content-Type: application/pgp-encrypted\n\n")
 629         (insert "Version: 1\n\n")
 630         (insert (format "--%s\n" boundary))
 631         (insert "Content-Type: application/octet-stream\n\n")
 632         (insert-buffer cipher)
 633         (goto-char (point-max))
 634         (insert (format "--%s--\n" boundary))
 635         (goto-char (point-max))))))
 636
 637 ;;; pgg wrapper
 638
 639 (eval-when-compile
 640   (defvar pgg-errors-buffer)
 641   (defvar pgg-output-buffer))
 642
 643 (eval-and-compile
 644   (autoload 'pgg-decrypt-region "pgg")
 645   (autoload 'pgg-verify-region "pgg")
 646   (autoload 'pgg-sign-region "pgg")
 647   (autoload 'pgg-encrypt-region "pgg"))
 648
 649 (defun mml2015-pgg-decrypt (handle ctl)
 650   (catch 'error
 651     (let ((pgg-errors-buffer mml2015-result-buffer)
 652           child handles result decrypt-status)
 653       (unless (setq child (mm-find-part-by-type
 654                            (cdr handle)
 655                            "application/octet-stream" nil t))
 656         (mm-set-handle-multipart-parameter
 657          mm-security-handle 'gnus-info "Corrupted")
 658         (throw 'error handle))
 659       (with-temp-buffer
 660         (mm-insert-part child)
 661         (if (condition-case err
 662                 (prog1
 663                     (pgg-decrypt-region (point-min) (point-max))
 664                   (setq decrypt-status
 665                         (with-current-buffer mml2015-result-buffer
 666                           (buffer-string))))
 667               (error
 668                (mm-set-handle-multipart-parameter
 669                 mm-security-handle 'gnus-details (mml2015-format-error err))
 670                nil)
 671               (quit
 672                (mm-set-handle-multipart-parameter
 673                 mm-security-handle 'gnus-details "Quit.")
 674                nil))
 675             (with-current-buffer pgg-output-buffer
 676               (setq handles (mm-dissect-buffer t))
 677               (mm-destroy-parts handle)
 678               (mm-set-handle-multipart-parameter
 679                mm-security-handle 'gnus-info "OK")
 680               (mm-set-handle-multipart-parameter
 681                mm-security-handle 'gnus-details
 682                (concat decrypt-status
 683                        (when (stringp (car handles))
 684                          "\n" (mm-handle-multipart-ctl-parameter
 685                                handles 'gnus-details))))
 686               (if (listp (car handles))
 687                   handles
 688                 (list handles)))
 689           (mm-set-handle-multipart-parameter
 690            mm-security-handle 'gnus-info "Failed"))))))
 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) signature-file t)
 739                   (mm-set-handle-multipart-parameter
 740                    mm-security-handle 'gnus-details
 741                    (with-current-buffer pgg-output-buffer
 742                      (buffer-string))))
 743               (error
 744                (mm-set-handle-multipart-parameter
 745                 mm-security-handle 'gnus-details (mml2015-format-error err))
 746                nil)
 747               (quit
 748                (mm-set-handle-multipart-parameter
 749                 mm-security-handle 'gnus-details "Quit.")
 750                nil))
 751             (progn
 752               (delete-file signature-file)
 753               (mm-set-handle-multipart-parameter
 754                mm-security-handle 'gnus-info
 755                (with-current-buffer pgg-output-buffer
 756                  (mml2015-gpg-extract-signature-details))))
 757           (delete-file signature-file)
 758           (mm-set-handle-multipart-parameter
 759            mm-security-handle 'gnus-info "Failed"))))))
 760
 761 (defun mml2015-pgg-clear-verify ()
 762   (let ((pgg-errors-buffer mml2015-result-buffer))
 763     (if (condition-case err
 764             (prog1
 765                 (pgg-verify-region (point-min) (point-max) nil t)
 766               (mm-set-handle-multipart-parameter
 767                mm-security-handle 'gnus-details
 768                (with-current-buffer mml2015-result-buffer
 769                  (buffer-string))))
 770           (error
 771            (mm-set-handle-multipart-parameter
 772             mm-security-handle 'gnus-details (mml2015-format-error err))
 773            nil)
 774           (quit
 775            (mm-set-handle-multipart-parameter
 776             mm-security-handle 'gnus-details "Quit.")
 777            nil))
 778         (mm-set-handle-multipart-parameter
 779          mm-security-handle 'gnus-info
 780          (with-current-buffer pgg-output-buffer
 781            (mml2015-gpg-extract-signature-details)))
 782       (mm-set-handle-multipart-parameter
 783        mm-security-handle 'gnus-info "Failed"))))
 784
 785 (defun mml2015-pgg-sign (cont)
 786   (let ((pgg-errors-buffer mml2015-result-buffer)
 787         (boundary (funcall mml-boundary-function (incf mml-multipart-number))))
 788     (unless (pgg-sign-region (point-min) (point-max))
 789       (pop-to-buffer mml2015-result-buffer)
 790       (error "Sign error"))
 791     (goto-char (point-min))
 792     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 793                     boundary))
 794       ;;; FIXME: what is the micalg?
 795     (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 796     (insert (format "\n--%s\n" boundary))
 797     (goto-char (point-max))
 798     (insert (format "\n--%s\n" boundary))
 799     (insert "Content-Type: application/pgp-signature\n\n")
 800     (insert-buffer pgg-output-buffer)
 801     (goto-char (point-max))
 802     (insert (format "--%s--\n" boundary))
 803     (goto-char (point-max))))
 804
 805 (defun mml2015-pgg-encrypt (cont &optional sign)
 806   (let ((pgg-errors-buffer mml2015-result-buffer)
 807         (boundary (funcall mml-boundary-function (incf mml-multipart-number))))
 808     (unless (pgg-encrypt-region (point-min) (point-max)
 809                                 (split-string
 810                                  (or
 811                                   (message-options-get 'message-recipients)
 812                                   (message-options-set 'message-recipients
 813                                                        (read-string "Recipients: ")))
 814                                  "[ \f\t\n\r\v,]+"))
 815       (pop-to-buffer mml2015-result-buffer)
 816       (error "Encrypt error"))
 817     (delete-region (point-min) (point-max))
 818     (goto-char (point-min))
 819     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 820                     boundary))
 821     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 822     (insert (format "--%s\n" boundary))
 823     (insert "Content-Type: application/pgp-encrypted\n\n")
 824     (insert "Version: 1\n\n")
 825     (insert (format "--%s\n" boundary))
 826     (insert "Content-Type: application/octet-stream\n\n")
 827     (insert-buffer pgg-output-buffer)
 828     (goto-char (point-max))
 829     (insert (format "--%s--\n" boundary))
 830     (goto-char (point-max))))
 831
 832 ;;; General wrapper
 833
 834 (defun mml2015-clean-buffer ()
 835   (if (gnus-buffer-live-p mml2015-result-buffer)
 836       (with-current-buffer mml2015-result-buffer
 837         (erase-buffer)
 838         t)
 839     (setq mml2015-result-buffer
 840           (gnus-get-buffer-create "*MML2015 Result*"))
 841     nil))
 842
 843 (defsubst mml2015-clear-decrypt-function ()
 844   (nth 6 (assq mml2015-use mml2015-function-alist)))
 845
 846 (defsubst mml2015-clear-verify-function ()
 847   (nth 5 (assq mml2015-use mml2015-function-alist)))
 848
 849 ;;;###autoload
 850 (defun mml2015-decrypt (handle ctl)
 851   (mml2015-clean-buffer)
 852   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
 853     (if func
 854         (funcall func handle ctl)
 855       handle)))
 856
 857 ;;;###autoload
 858 (defun mml2015-decrypt-test (handle ctl)
 859   mml2015-use)
 860
 861 ;;;###autoload
 862 (defun mml2015-verify (handle ctl)
 863   (mml2015-clean-buffer)
 864   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
 865     (if func
 866         (funcall func handle ctl)
 867       handle)))
 868
 869 ;;;###autoload
 870 (defun mml2015-verify-test (handle ctl)
 871   mml2015-use)
 872
 873 ;;;###autoload
 874 (defun mml2015-encrypt (cont &optional sign)
 875   (mml2015-clean-buffer)
 876   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
 877     (if func
 878         (funcall func cont sign)
 879       (error "Cannot find encrypt function"))))
 880
 881 ;;;###autoload
 882 (defun mml2015-sign (cont)
 883   (mml2015-clean-buffer)
 884   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
 885     (if func
 886         (funcall func cont)
 887       (error "Cannot find sign function"))))
 888
 889 ;;;###autoload
 890 (defun mml2015-self-encrypt ()
 891   (mml2015-encrypt nil))
 892
 893 (provide 'mml2015)
 894
 895 ;;; mml2015.el ends here