lisp/gnus/mml2015.el

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