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, 2003, 2004, 2005
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   6 ;; Keywords: PGP MIME MML
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published
  12 ;; by the Free Software Foundation; either version 2, or (at your
  13 ;; option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
  28 ;; with both.
  29
  30 ;;; Code:
  31
  32 (eval-when-compile (require 'cl))
  33 (require 'mm-decode)
  34 (require 'mm-util)
  35 (require 'mml)
  36
  37 (defvar mml2015-use (or
  38                      (progn
  39                        (ignore-errors
  40                         ;; Avoid the "Recursive load suspected" error
  41                         ;; in Emacs 21.1.
  42                         (let ((recursive-load-depth-limit 100))
  43                           (require 'pgg)))
  44                        (and (fboundp 'pgg-sign-region)
  45                             'pgg))
  46                      (progn
  47                        (ignore-errors
  48                          (require 'gpg))
  49                        (and (fboundp 'gpg-sign-detached)
  50                             'gpg))
  51                      (progn (ignore-errors
  52                               (load "mc-toplev"))
  53                             (and (fboundp 'mc-encrypt-generic)
  54                                  (fboundp 'mc-sign-generic)
  55                                  (fboundp 'mc-cleanup-recipient-headers)
  56                                  'mailcrypt)))
  57   "The package used for PGP/MIME.
  58 Valid packages include `pgg', `gpg' and `mailcrypt'.")
  59
  60 ;; Something is not RFC2015.
  61 (defvar mml2015-function-alist
  62   '((mailcrypt mml2015-mailcrypt-sign
  63                mml2015-mailcrypt-encrypt
  64                mml2015-mailcrypt-verify
  65                mml2015-mailcrypt-decrypt
  66                mml2015-mailcrypt-clear-verify
  67                mml2015-mailcrypt-clear-decrypt)
  68     (gpg mml2015-gpg-sign
  69          mml2015-gpg-encrypt
  70          mml2015-gpg-verify
  71          mml2015-gpg-decrypt
  72          mml2015-gpg-clear-verify
  73          mml2015-gpg-clear-decrypt)
  74   (pgg mml2015-pgg-sign
  75        mml2015-pgg-encrypt
  76        mml2015-pgg-verify
  77        mml2015-pgg-decrypt
  78        mml2015-pgg-clear-verify
  79        mml2015-pgg-clear-decrypt))
  80   "Alist of PGP/MIME functions.")
  81
  82 (defvar mml2015-result-buffer nil)
  83
  84 (defcustom mml2015-unabbrev-trust-alist
  85   '(("TRUST_UNDEFINED" . nil)
  86     ("TRUST_NEVER"     . nil)
  87     ("TRUST_MARGINAL"  . t)
  88     ("TRUST_FULLY"     . t)
  89     ("TRUST_ULTIMATE"  . t))
  90   "Map GnuPG trust output values to a boolean saying if you trust the key."
  91   :version "22.1"
  92   :group 'mime-security
  93   :type '(repeat (cons (regexp :tag "GnuPG output regexp")
  94                        (boolean :tag "Trust key"))))
  95
  96 ;;; mailcrypt wrapper
  97
  98 (eval-and-compile
  99   (autoload 'mailcrypt-decrypt "mailcrypt")
 100   (autoload 'mailcrypt-verify "mailcrypt")
 101   (autoload 'mc-pgp-always-sign "mailcrypt")
 102   (autoload 'mc-encrypt-generic "mc-toplev")
 103   (autoload 'mc-cleanup-recipient-headers "mc-toplev")
 104   (autoload 'mc-sign-generic "mc-toplev"))
 105
 106 (eval-when-compile
 107   (defvar mc-default-scheme)
 108   (defvar mc-schemes))
 109
 110 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
 111 (defvar mml2015-verify-function 'mailcrypt-verify)
 112
 113 (defun mml2015-format-error (err)
 114   (if (stringp (cadr err))
 115       (cadr err)
 116     (format "%S" (cdr err))))
 117
 118 (defun mml2015-mailcrypt-decrypt (handle ctl)
 119   (catch 'error
 120     (let (child handles result)
 121       (unless (setq child (mm-find-part-by-type
 122                            (cdr handle)
 123                            "application/octet-stream" nil t))
 124         (mm-set-handle-multipart-parameter
 125          mm-security-handle 'gnus-info "Corrupted")
 126         (throw 'error handle))
 127       (with-temp-buffer
 128         (mm-insert-part child)
 129         (setq result
 130               (condition-case err
 131                   (funcall mml2015-decrypt-function)
 132                 (error
 133                  (mm-set-handle-multipart-parameter
 134                   mm-security-handle 'gnus-details (mml2015-format-error err))
 135                  nil)
 136                 (quit
 137                  (mm-set-handle-multipart-parameter
 138                   mm-security-handle 'gnus-details "Quit.")
 139                  nil)))
 140         (unless (car result)
 141           (mm-set-handle-multipart-parameter
 142            mm-security-handle 'gnus-info "Failed")
 143           (throw 'error handle))
 144         (setq handles (mm-dissect-buffer t)))
 145       (mm-destroy-parts handle)
 146       (mm-set-handle-multipart-parameter
 147        mm-security-handle 'gnus-info
 148        (concat "OK"
 149                (let ((sig (with-current-buffer mml2015-result-buffer
 150                             (mml2015-gpg-extract-signature-details))))
 151                  (concat ", Signer: " sig))))
 152       (if (listp (car handles))
 153           handles
 154         (list handles)))))
 155
 156 (defun mml2015-mailcrypt-clear-decrypt ()
 157   (let (result)
 158     (setq result
 159           (condition-case err
 160               (funcall mml2015-decrypt-function)
 161             (error
 162              (mm-set-handle-multipart-parameter
 163               mm-security-handle 'gnus-details (mml2015-format-error err))
 164              nil)
 165             (quit
 166              (mm-set-handle-multipart-parameter
 167               mm-security-handle 'gnus-details "Quit.")
 168              nil)))
 169     (if (car result)
 170         (mm-set-handle-multipart-parameter
 171          mm-security-handle 'gnus-info "OK")
 172       (mm-set-handle-multipart-parameter
 173        mm-security-handle 'gnus-info "Failed"))))
 174
 175 (defun mml2015-fix-micalg (alg)
 176   (and alg
 177        ;; Mutt/1.2.5i has seen sending micalg=php-sha1
 178        (upcase (if (string-match "^p[gh]p-" alg)
 179                    (substring alg (match-end 0))
 180                  alg))))
 181
 182 (defun mml2015-mailcrypt-verify (handle ctl)
 183   (catch 'error
 184     (let (part)
 185       (unless (setq part (mm-find-raw-part-by-type
 186                           ctl (or (mm-handle-multipart-ctl-parameter
 187                                    ctl 'protocol)
 188                                   "application/pgp-signature")
 189                           t))
 190         (mm-set-handle-multipart-parameter
 191          mm-security-handle 'gnus-info "Corrupted")
 192         (throw 'error handle))
 193       (with-temp-buffer
 194         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
 195         (insert (format "Hash: %s\n\n"
 196                         (or (mml2015-fix-micalg
 197                              (mm-handle-multipart-ctl-parameter
 198                               ctl 'micalg))
 199                             "SHA1")))
 200         (save-restriction
 201           (narrow-to-region (point) (point))
 202           (insert part "\n")
 203           (goto-char (point-min))
 204           (while (not (eobp))
 205             (if (looking-at "^-")
 206                 (insert "- "))
 207             (forward-line)))
 208         (unless (setq part (mm-find-part-by-type
 209                             (cdr handle) "application/pgp-signature" nil t))
 210           (mm-set-handle-multipart-parameter
 211            mm-security-handle 'gnus-info "Corrupted")
 212           (throw 'error handle))
 213         (save-restriction
 214           (narrow-to-region (point) (point))
 215           (mm-insert-part part)
 216           (goto-char (point-min))
 217           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
 218               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
 219           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
 220               (replace-match "-----END PGP SIGNATURE-----" t t)))
 221         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 222           (unless (condition-case err
 223                       (prog1
 224                           (funcall mml2015-verify-function)
 225                         (if (get-buffer " *mailcrypt stderr temp")
 226                             (mm-set-handle-multipart-parameter
 227                              mm-security-handle 'gnus-details
 228                              (with-current-buffer " *mailcrypt stderr temp"
 229                                (buffer-string))))
 230                         (if (get-buffer " *mailcrypt stdout temp")
 231                             (kill-buffer " *mailcrypt stdout temp"))
 232                         (if (get-buffer " *mailcrypt stderr temp")
 233                             (kill-buffer " *mailcrypt stderr temp"))
 234                         (if (get-buffer " *mailcrypt status temp")
 235                             (kill-buffer " *mailcrypt status temp"))
 236                         (if (get-buffer mc-gpg-debug-buffer)
 237                             (kill-buffer mc-gpg-debug-buffer)))
 238                     (error
 239                      (mm-set-handle-multipart-parameter
 240                       mm-security-handle 'gnus-details (mml2015-format-error err))
 241                      nil)
 242                     (quit
 243                      (mm-set-handle-multipart-parameter
 244                       mm-security-handle 'gnus-details "Quit.")
 245                      nil))
 246             (mm-set-handle-multipart-parameter
 247              mm-security-handle 'gnus-info "Failed")
 248             (throw 'error handle))))
 249       (mm-set-handle-multipart-parameter
 250        mm-security-handle 'gnus-info "OK")
 251       handle)))
 252
 253 (defun mml2015-mailcrypt-clear-verify ()
 254   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
 255     (if (condition-case err
 256             (prog1
 257                 (funcall mml2015-verify-function)
 258               (if (get-buffer " *mailcrypt stderr temp")
 259                   (mm-set-handle-multipart-parameter
 260                    mm-security-handle 'gnus-details
 261                    (with-current-buffer " *mailcrypt stderr temp"
 262                      (buffer-string))))
 263               (if (get-buffer " *mailcrypt stdout temp")
 264                   (kill-buffer " *mailcrypt stdout temp"))
 265               (if (get-buffer " *mailcrypt stderr temp")
 266                   (kill-buffer " *mailcrypt stderr temp"))
 267               (if (get-buffer " *mailcrypt status temp")
 268                   (kill-buffer " *mailcrypt status temp"))
 269               (if (get-buffer mc-gpg-debug-buffer)
 270                   (kill-buffer mc-gpg-debug-buffer)))
 271           (error
 272            (mm-set-handle-multipart-parameter
 273             mm-security-handle 'gnus-details (mml2015-format-error err))
 274            nil)
 275           (quit
 276            (mm-set-handle-multipart-parameter
 277             mm-security-handle 'gnus-details "Quit.")
 278            nil))
 279         (mm-set-handle-multipart-parameter
 280          mm-security-handle 'gnus-info "OK")
 281       (mm-set-handle-multipart-parameter
 282        mm-security-handle 'gnus-info "Failed"))))
 283
 284 (defun mml2015-mailcrypt-sign (cont)
 285   (mc-sign-generic (message-options-get 'message-sender)
 286                    nil nil nil nil)
 287   (let ((boundary (mml-compute-boundary cont))
 288         hash point)
 289     (goto-char (point-min))
 290     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
 291       (error "Cannot find signed begin line"))
 292     (goto-char (match-beginning 0))
 293     (forward-line 1)
 294     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 295       (error "Cannot not find PGP hash"))
 296     (setq hash (match-string 1))
 297     (unless (re-search-forward "^$" nil t)
 298       (error "Cannot not find PGP message"))
 299     (forward-line 1)
 300     (delete-region (point-min) (point))
 301     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 302                     boundary))
 303     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 304                     (downcase hash)))
 305     (insert (format "\n--%s\n" boundary))
 306     (setq point (point))
 307     (goto-char (point-max))
 308     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
 309       (error "Cannot find signature part"))
 310     (replace-match "-----END PGP MESSAGE-----" t t)
 311     (goto-char (match-beginning 0))
 312     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
 313                                 nil t)
 314       (error "Cannot find signature part"))
 315     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
 316     (goto-char (match-beginning 0))
 317     (save-restriction
 318       (narrow-to-region point (point))
 319       (goto-char point)
 320       (while (re-search-forward "^- -" nil t)
 321         (replace-match "-" t t))
 322       (goto-char (point-max)))
 323     (insert (format "--%s\n" boundary))
 324     (insert "Content-Type: application/pgp-signature\n\n")
 325     (goto-char (point-max))
 326     (insert (format "--%s--\n" boundary))
 327     (goto-char (point-max))))
 328
 329 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
 330   (let ((mc-pgp-always-sign
 331          (or mc-pgp-always-sign
 332              sign
 333              (eq t (or (message-options-get 'message-sign-encrypt)
 334                        (message-options-set
 335                         'message-sign-encrypt
 336                         (or (y-or-n-p "Sign the message? ")
 337                             'not))))
 338              'never)))
 339     (mm-with-unibyte-current-buffer
 340       (mc-encrypt-generic
 341        (or (message-options-get 'message-recipients)
 342            (message-options-set 'message-recipients
 343                               (mc-cleanup-recipient-headers
 344                                (read-string "Recipients: "))))
 345        nil nil nil
 346        (message-options-get 'message-sender))))
 347   (goto-char (point-min))
 348   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
 349     (error "Fail to encrypt the message"))
 350   (let ((boundary (mml-compute-boundary cont)))
 351     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 352                     boundary))
 353     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 354     (insert (format "--%s\n" boundary))
 355     (insert "Content-Type: application/pgp-encrypted\n\n")
 356     (insert "Version: 1\n\n")
 357     (insert (format "--%s\n" boundary))
 358     (insert "Content-Type: application/octet-stream\n\n")
 359     (goto-char (point-max))
 360     (insert (format "--%s--\n" boundary))
 361     (goto-char (point-max))))
 362
 363 ;;; gpg wrapper
 364
 365 (eval-and-compile
 366   (autoload 'gpg-decrypt "gpg")
 367   (autoload 'gpg-verify "gpg")
 368   (autoload 'gpg-verify-cleartext "gpg")
 369   (autoload 'gpg-sign-detached "gpg")
 370   (autoload 'gpg-sign-encrypt "gpg")
 371   (autoload 'gpg-encrypt "gpg")
 372   (autoload 'gpg-passphrase-read "gpg"))
 373
 374 (defun mml2015-gpg-passphrase ()
 375   (or (message-options-get 'gpg-passphrase)
 376       (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
 377
 378 (defun mml2015-gpg-decrypt-1 ()
 379   (let ((cipher (current-buffer)) plain result)
 380     (if (with-temp-buffer
 381           (prog1
 382               (gpg-decrypt cipher (setq plain (current-buffer))
 383                            mml2015-result-buffer nil)
 384             (mm-set-handle-multipart-parameter
 385              mm-security-handle 'gnus-details
 386              (with-current-buffer mml2015-result-buffer
 387                (buffer-string)))
 388             (set-buffer cipher)
 389             (erase-buffer)
 390             (insert-buffer-substring plain)
 391             (goto-char (point-min))
 392             (while (search-forward "\r\n" nil t)
 393               (replace-match "\n" t t))))
 394         '(t)
 395       ;; Some wrong with the return value, check plain text buffer.
 396       (if (> (point-max) (point-min))
 397           '(t)
 398         nil))))
 399
 400 (defun mml2015-gpg-decrypt (handle ctl)
 401   (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
 402     (mml2015-mailcrypt-decrypt handle ctl)))
 403
 404 (defun mml2015-gpg-clear-decrypt ()
 405   (let (result)
 406     (setq result (mml2015-gpg-decrypt-1))
 407     (if (car result)
 408         (mm-set-handle-multipart-parameter
 409          mm-security-handle 'gnus-info "OK")
 410       (mm-set-handle-multipart-parameter
 411        mm-security-handle 'gnus-info "Failed"))))
 412
 413 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
 414   (let* ((result "")
 415          (fpr-length (string-width fingerprint))
 416          (n-slice 0)
 417          slice)
 418     (setq fingerprint (string-to-list fingerprint))
 419     (while fingerprint
 420       (setq fpr-length (- fpr-length 4))
 421       (setq slice (butlast fingerprint fpr-length))
 422       (setq fingerprint (nthcdr 4 fingerprint))
 423       (setq n-slice (1+ n-slice))
 424       (setq result
 425             (concat
 426              result
 427              (case n-slice
 428                (1  slice)
 429                (otherwise (concat " " slice))))))
 430     result))
 431
 432 (defun mml2015-gpg-extract-signature-details ()
 433   (goto-char (point-min))
 434   (let* ((expired (re-search-forward
 435                    "^\\[GNUPG:\\] SIGEXPIRED$"
 436                    nil t))
 437          (signer (and (re-search-forward
 438                        "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
 439                        nil t)
 440                       (cons (match-string 1) (match-string 2))))
 441          (fprint (and (re-search-forward
 442                        "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
 443                        nil t)
 444                       (match-string 1)))
 445          (trust  (and (re-search-forward
 446                        "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
 447                        nil t)
 448                       (match-string 1)))
 449          (trust-good-enough-p
 450           (cdr (assoc trust mml2015-unabbrev-trust-alist))))
 451     (cond ((and signer fprint)
 452            (concat (cdr signer)
 453                    (unless trust-good-enough-p
 454                      (concat "\nUntrusted, Fingerprint: "
 455                              (mml2015-gpg-pretty-print-fpr fprint)))
 456                    (when expired
 457                      (format "\nWARNING: Signature from expired key (%s)"
 458                              (car signer)))))
 459           ((re-search-forward
 460             "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
 461            (match-string 2))
 462           (t
 463            "From unknown user"))))
 464
 465 (defun mml2015-gpg-verify (handle ctl)
 466   (catch 'error
 467     (let (part message signature info-is-set-p)
 468       (unless (setq part (mm-find-raw-part-by-type
 469                           ctl (or (mm-handle-multipart-ctl-parameter
 470                                    ctl 'protocol)
 471                                   "application/pgp-signature")
 472                           t))
 473         (mm-set-handle-multipart-parameter
 474          mm-security-handle 'gnus-info "Corrupted")
 475         (throw 'error handle))
 476       (with-temp-buffer
 477         (setq message (current-buffer))
 478         (insert part)
 479         ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
 480         ;; clearsign use --textmode. The conversion is not necessary.
 481         ;; In clearverify, the conversion is not necessary either.
 482         (goto-char (point-min))
 483         (end-of-line)
 484         (while (not (eobp))
 485           (unless (eq (char-before) ?\r)
 486             (insert "\r"))
 487           (forward-line)
 488           (end-of-line))
 489         (with-temp-buffer
 490           (setq signature (current-buffer))
 491           (unless (setq part (mm-find-part-by-type
 492                               (cdr handle) "application/pgp-signature" nil t))
 493             (mm-set-handle-multipart-parameter
 494              mm-security-handle 'gnus-info "Corrupted")
 495             (throw 'error handle))
 496           (mm-insert-part part)
 497           (unless (condition-case err
 498                       (prog1
 499                           (gpg-verify message signature mml2015-result-buffer)
 500                         (mm-set-handle-multipart-parameter
 501                          mm-security-handle 'gnus-details
 502                          (with-current-buffer mml2015-result-buffer
 503                            (buffer-string))))
 504                     (error
 505                      (mm-set-handle-multipart-parameter
 506                       mm-security-handle 'gnus-details (mml2015-format-error err))
 507                      (mm-set-handle-multipart-parameter
 508                       mm-security-handle 'gnus-info "Error.")
 509                      (setq info-is-set-p t)
 510                      nil)
 511                     (quit
 512                      (mm-set-handle-multipart-parameter
 513                       mm-security-handle 'gnus-details "Quit.")
 514                      (mm-set-handle-multipart-parameter
 515                       mm-security-handle 'gnus-info "Quit.")
 516                      (setq info-is-set-p t)
 517                      nil))
 518             (unless info-is-set-p
 519               (mm-set-handle-multipart-parameter
 520                mm-security-handle 'gnus-info "Failed"))
 521             (throw 'error handle)))
 522         (mm-set-handle-multipart-parameter
 523          mm-security-handle 'gnus-info
 524          (with-current-buffer mml2015-result-buffer
 525            (mml2015-gpg-extract-signature-details))))
 526       handle)))
 527
 528 (defun mml2015-gpg-clear-verify ()
 529   (if (condition-case err
 530           (prog1
 531               (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
 532             (mm-set-handle-multipart-parameter
 533              mm-security-handle 'gnus-details
 534              (with-current-buffer mml2015-result-buffer
 535                (buffer-string))))
 536         (error
 537          (mm-set-handle-multipart-parameter
 538           mm-security-handle 'gnus-details (mml2015-format-error err))
 539          nil)
 540         (quit
 541          (mm-set-handle-multipart-parameter
 542           mm-security-handle 'gnus-details "Quit.")
 543          nil))
 544       (mm-set-handle-multipart-parameter
 545        mm-security-handle 'gnus-info
 546        (with-current-buffer mml2015-result-buffer
 547          (mml2015-gpg-extract-signature-details)))
 548     (mm-set-handle-multipart-parameter
 549      mm-security-handle 'gnus-info "Failed")))
 550
 551 (defun mml2015-gpg-sign (cont)
 552   (let ((boundary (mml-compute-boundary cont))
 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-substring 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 (mml-compute-boundary cont))
 586         (text (current-buffer))
 587         cipher)
 588     (mm-with-unibyte-current-buffer
 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-substring 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-default-user-id)
 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   (autoload 'pgg-parse-armor "pgg-parse"))
 650
 651 (defun mml2015-pgg-decrypt (handle ctl)
 652   (catch 'error
 653     (let ((pgg-errors-buffer mml2015-result-buffer)
 654           child handles result decrypt-status)
 655       (unless (setq child (mm-find-part-by-type
 656                            (cdr handle)
 657                            "application/octet-stream" nil t))
 658         (mm-set-handle-multipart-parameter
 659          mm-security-handle 'gnus-info "Corrupted")
 660         (throw 'error handle))
 661       (with-temp-buffer
 662         (mm-insert-part child)
 663         (if (condition-case err
 664                 (prog1
 665                     (pgg-decrypt-region (point-min) (point-max))
 666                   (setq decrypt-status
 667                         (with-current-buffer mml2015-result-buffer
 668                           (buffer-string)))
 669                   (mm-set-handle-multipart-parameter
 670                    mm-security-handle 'gnus-details
 671                    decrypt-status))
 672               (error
 673                (mm-set-handle-multipart-parameter
 674                 mm-security-handle 'gnus-details (mml2015-format-error err))
 675                nil)
 676               (quit
 677                (mm-set-handle-multipart-parameter
 678                 mm-security-handle 'gnus-details "Quit.")
 679                nil))
 680             (with-current-buffer pgg-output-buffer
 681               (goto-char (point-min))
 682               (while (search-forward "\r\n" nil t)
 683                 (replace-match "\n" t t))
 684               (setq handles (mm-dissect-buffer t))
 685               (mm-destroy-parts handle)
 686               (mm-set-handle-multipart-parameter
 687                mm-security-handle 'gnus-info "OK")
 688               (mm-set-handle-multipart-parameter
 689                mm-security-handle 'gnus-details
 690                (concat decrypt-status
 691                        (when (stringp (car handles))
 692                          "\n" (mm-handle-multipart-ctl-parameter
 693                                handles 'gnus-details))))
 694               (if (listp (car handles))
 695                   handles
 696                 (list handles)))
 697           (mm-set-handle-multipart-parameter
 698            mm-security-handle 'gnus-info "Failed")
 699           (throw 'error handle))))))
 700
 701 (defun mml2015-pgg-clear-decrypt ()
 702   (let ((pgg-errors-buffer mml2015-result-buffer))
 703     (if (prog1
 704             (pgg-decrypt-region (point-min) (point-max))
 705           (mm-set-handle-multipart-parameter
 706            mm-security-handle 'gnus-details
 707            (with-current-buffer mml2015-result-buffer
 708              (buffer-string))))
 709         (progn
 710           (erase-buffer)
 711           (insert-buffer-substring pgg-output-buffer)
 712           (goto-char (point-min))
 713           (while (search-forward "\r\n" nil t)
 714             (replace-match "\n" t t))
 715           (mm-set-handle-multipart-parameter
 716            mm-security-handle 'gnus-info "OK"))
 717       (mm-set-handle-multipart-parameter
 718        mm-security-handle 'gnus-info "Failed"))))
 719
 720 (defun mml2015-pgg-verify (handle ctl)
 721   (let ((pgg-errors-buffer mml2015-result-buffer)
 722         signature-file part signature)
 723     (if (or (null (setq part (mm-find-raw-part-by-type
 724                               ctl (or (mm-handle-multipart-ctl-parameter
 725                                        ctl 'protocol)
 726                                       "application/pgp-signature")
 727                               t)))
 728             (null (setq signature (mm-find-part-by-type
 729                                    (cdr handle) "application/pgp-signature" nil t))))
 730         (progn
 731           (mm-set-handle-multipart-parameter
 732            mm-security-handle 'gnus-info "Corrupted")
 733           handle)
 734       (with-temp-buffer
 735         (insert part)
 736         ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
 737         ;; clearsign use --textmode. The conversion is not necessary.
 738         ;; In clearverify, the conversion is not necessary either.
 739         (goto-char (point-min))
 740         (end-of-line)
 741         (while (not (eobp))
 742           (unless (eq (char-before) ?\r)
 743             (insert "\r"))
 744           (forward-line)
 745           (end-of-line))
 746         (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
 747           (mm-insert-part signature))
 748         (if (condition-case err
 749                 (prog1
 750                     (pgg-verify-region (point-min) (point-max)
 751                                        signature-file t)
 752                   (goto-char (point-min))
 753                   (while (search-forward "\r\n" nil t)
 754                     (replace-match "\n" t t))
 755                   (mm-set-handle-multipart-parameter
 756                    mm-security-handle 'gnus-details
 757                    (concat (with-current-buffer pgg-output-buffer
 758                              (buffer-string))
 759                            (with-current-buffer pgg-errors-buffer
 760                              (buffer-string)))))
 761               (error
 762                (mm-set-handle-multipart-parameter
 763                 mm-security-handle 'gnus-details (mml2015-format-error err))
 764                nil)
 765               (quit
 766                (mm-set-handle-multipart-parameter
 767                 mm-security-handle 'gnus-details "Quit.")
 768                nil))
 769             (progn
 770               (delete-file signature-file)
 771               (mm-set-handle-multipart-parameter
 772                mm-security-handle 'gnus-info
 773                (with-current-buffer pgg-errors-buffer
 774                  (mml2015-gpg-extract-signature-details))))
 775           (delete-file signature-file)
 776           (mm-set-handle-multipart-parameter
 777            mm-security-handle 'gnus-info "Failed")))))
 778   handle)
 779
 780 (defun mml2015-pgg-clear-verify ()
 781   (let ((pgg-errors-buffer mml2015-result-buffer)
 782         (text (buffer-string))
 783         (coding-system buffer-file-coding-system))
 784     (if (condition-case err
 785             (prog1
 786                 (mm-with-unibyte-buffer
 787                   (insert (encode-coding-string text coding-system))
 788                   (pgg-verify-region (point-min) (point-max) nil t))
 789               (goto-char (point-min))
 790               (while (search-forward "\r\n" nil t)
 791                 (replace-match "\n" t t))
 792               (mm-set-handle-multipart-parameter
 793                mm-security-handle 'gnus-details
 794                (concat (with-current-buffer pgg-output-buffer
 795                          (buffer-string))
 796                        (with-current-buffer pgg-errors-buffer
 797                          (buffer-string)))))
 798           (error
 799            (mm-set-handle-multipart-parameter
 800             mm-security-handle 'gnus-details (mml2015-format-error err))
 801            nil)
 802           (quit
 803            (mm-set-handle-multipart-parameter
 804             mm-security-handle 'gnus-details "Quit.")
 805            nil))
 806         (mm-set-handle-multipart-parameter
 807          mm-security-handle 'gnus-info
 808          (with-current-buffer pgg-errors-buffer
 809            (mml2015-gpg-extract-signature-details)))
 810       (mm-set-handle-multipart-parameter
 811        mm-security-handle 'gnus-info "Failed"))))
 812
 813 (defun mml2015-pgg-sign (cont)
 814   (let ((pgg-errors-buffer mml2015-result-buffer)
 815         (boundary (mml-compute-boundary cont))
 816         (pgg-default-user-id (or (message-options-get 'mml-sender)
 817                                  pgg-default-user-id))
 818         entry)
 819     (unless (pgg-sign-region (point-min) (point-max))
 820       (pop-to-buffer mml2015-result-buffer)
 821       (error "Sign error"))
 822     (goto-char (point-min))
 823     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 824                     boundary))
 825     (if (setq entry (assq 2 (pgg-parse-armor
 826                              (with-current-buffer pgg-output-buffer
 827                                (buffer-string)))))
 828         (setq entry (assq 'hash-algorithm (cdr entry))))
 829     (insert (format "\tmicalg=%s; "
 830                     (if (cdr entry)
 831                         (downcase (format "pgp-%s" (cdr entry)))
 832                       "pgp-sha1")))
 833     (insert "protocol=\"application/pgp-signature\"\n")
 834     (insert (format "\n--%s\n" boundary))
 835     (goto-char (point-max))
 836     (insert (format "\n--%s\n" boundary))
 837     (insert "Content-Type: application/pgp-signature\n\n")
 838     (insert-buffer-substring pgg-output-buffer)
 839     (goto-char (point-max))
 840     (insert (format "--%s--\n" boundary))
 841     (goto-char (point-max))))
 842
 843 (defun mml2015-pgg-encrypt (cont &optional sign)
 844   (let ((pgg-errors-buffer mml2015-result-buffer)
 845         (boundary (mml-compute-boundary cont)))
 846     (unless (pgg-encrypt-region (point-min) (point-max)
 847                                 (split-string
 848                                  (or
 849                                   (message-options-get 'message-recipients)
 850                                   (message-options-set 'message-recipients
 851                                                        (read-string "Recipients: ")))
 852                                  "[ \f\t\n\r\v,]+")
 853                                 sign)
 854       (pop-to-buffer mml2015-result-buffer)
 855       (error "Encrypt error"))
 856     (delete-region (point-min) (point-max))
 857     (goto-char (point-min))
 858     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 859                     boundary))
 860     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 861     (insert (format "--%s\n" boundary))
 862     (insert "Content-Type: application/pgp-encrypted\n\n")
 863     (insert "Version: 1\n\n")
 864     (insert (format "--%s\n" boundary))
 865     (insert "Content-Type: application/octet-stream\n\n")
 866     (insert-buffer-substring pgg-output-buffer)
 867     (goto-char (point-max))
 868     (insert (format "--%s--\n" boundary))
 869     (goto-char (point-max))))
 870
 871 ;;; General wrapper
 872
 873 (defun mml2015-clean-buffer ()
 874   (if (gnus-buffer-live-p mml2015-result-buffer)
 875       (with-current-buffer mml2015-result-buffer
 876         (erase-buffer)
 877         t)
 878     (setq mml2015-result-buffer
 879           (gnus-get-buffer-create " *MML2015 Result*"))
 880     nil))
 881
 882 (defsubst mml2015-clear-decrypt-function ()
 883   (nth 6 (assq mml2015-use mml2015-function-alist)))
 884
 885 (defsubst mml2015-clear-verify-function ()
 886   (nth 5 (assq mml2015-use mml2015-function-alist)))
 887
 888 ;;;###autoload
 889 (defun mml2015-decrypt (handle ctl)
 890   (mml2015-clean-buffer)
 891   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
 892     (if func
 893         (funcall func handle ctl)
 894       handle)))
 895
 896 ;;;###autoload
 897 (defun mml2015-decrypt-test (handle ctl)
 898   mml2015-use)
 899
 900 ;;;###autoload
 901 (defun mml2015-verify (handle ctl)
 902   (mml2015-clean-buffer)
 903   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
 904     (if func
 905         (funcall func handle ctl)
 906       handle)))
 907
 908 ;;;###autoload
 909 (defun mml2015-verify-test (handle ctl)
 910   mml2015-use)
 911
 912 ;;;###autoload
 913 (defun mml2015-encrypt (cont &optional sign)
 914   (mml2015-clean-buffer)
 915   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
 916     (if func
 917         (funcall func cont sign)
 918       (error "Cannot find encrypt function"))))
 919
 920 ;;;###autoload
 921 (defun mml2015-sign (cont)
 922   (mml2015-clean-buffer)
 923   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
 924     (if func
 925         (funcall func cont)
 926       (error "Cannot find sign function"))))
 927
 928 ;;;###autoload
 929 (defun mml2015-self-encrypt ()
 930   (mml2015-encrypt nil))
 931
 932 (provide 'mml2015)
 933
 934 ;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
 935 ;;; mml2015.el ends here