cgit.sxemacs.org Git - gnus/blob - lisp/mml2015.el

   1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
   2 ;; Copyright (C) 2000 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 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29 (require 'mm-decode)
  30
  31 (defvar mml2015-use (or (progn (ignore-errors
  32                                  (load "mc-toplev"))
  33                                (and (fboundp 'mc-encrypt-generic)
  34                                     (fboundp 'mc-sign-generic)
  35                                     (fboundp 'mc-cleanup-recipient-headers)
  36                                     'mailcrypt))
  37                         (progn
  38                           (ignore-errors
  39                             (require 'gpg))
  40                           (and (fboundp 'gpg-sign-detached)
  41                                'gpg)))
  42   "The package used for PGP/MIME.")
  43
  44 ;; Something is not RFC2015.
  45 (defvar mml2015-function-alist
  46   '((mailcrypt mml2015-mailcrypt-sign
  47                mml2015-mailcrypt-encrypt
  48                mml2015-mailcrypt-verify
  49                mml2015-mailcrypt-decrypt
  50                mml2015-mailcrypt-clear-verify
  51                mml2015-mailcrypt-clear-decrypt)
  52     (gpg mml2015-gpg-sign
  53          mml2015-gpg-encrypt
  54          mml2015-gpg-verify
  55          mml2015-gpg-decrypt
  56          mml2015-gpg-clear-verify
  57          mml2015-gpg-clear-decrypt))
  58   "Alist of PGP/MIME functions.")
  59
  60 (defvar mml2015-result-buffer nil)
  61
  62 ;;; mailcrypt wrapper
  63
  64 (eval-and-compile
  65   (autoload 'mailcrypt-decrypt "mailcrypt")
  66   (autoload 'mailcrypt-verify "mailcrypt")
  67   (autoload 'mc-pgp-always-sign "mailcrypt")
  68   (autoload 'mc-encrypt-generic "mc-toplev")
  69   (autoload 'mc-cleanup-recipient-headers "mc-toplev")
  70   (autoload 'mc-sign-generic "mc-toplev"))
  71
  72 (eval-when-compile
  73   (defvar mc-default-scheme)
  74   (defvar mc-schemes))
  75
  76 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
  77 (defvar mml2015-verify-function 'mailcrypt-verify)
  78
  79 (defun mml2015-mailcrypt-decrypt (handle ctl)
  80   (catch 'error
  81     (let (child handles result)
  82       (unless (setq child (mm-find-part-by-type
  83                            (cdr handle)
  84                            "application/octet-stream" nil t))
  85         (mm-set-handle-multipart-parameter
  86          mm-security-handle 'gnus-info "Corrupted")
  87         (throw 'error handle))
  88       (with-temp-buffer
  89         (mm-insert-part child)
  90         (setq result
  91               (condition-case err
  92                   (funcall mml2015-decrypt-function)
  93                 (error
  94                  (mm-set-handle-multipart-parameter
  95                   mm-security-handle 'gnus-details (cadr err))
  96                  nil)
  97                 (quit
  98                  (mm-set-handle-multipart-parameter
  99                   mm-security-handle 'gnus-details "Quit.")
 100                  nil)))
 101         (unless (car result)
 102           (mm-set-handle-multipart-parameter
 103            mm-security-handle 'gnus-info "Failed")
 104           (throw 'error handle))
 105         (setq handles (mm-dissect-buffer t)))
 106       (mm-destroy-parts handle)
 107       (mm-set-handle-multipart-parameter
 108        mm-security-handle 'gnus-info "OK")
 109       (if (listp (car handles))
 110           handles
 111         (list handles)))))
 112
 113 (defun mml2015-mailcrypt-clear-decrypt ()
 114   (let (result)
 115     (setq result
 116           (condition-case err
 117               (funcall mml2015-decrypt-function)
 118             (error
 119              (mm-set-handle-multipart-parameter
 120               mm-security-handle 'gnus-details (cadr err))
 121              nil)
 122             (quit
 123              (mm-set-handle-multipart-parameter
 124               mm-security-handle 'gnus-details "Quit.")
 125              nil)))
 126     (if (car result)
 127         (mm-set-handle-multipart-parameter
 128          mm-security-handle 'gnus-info "OK")
 129       (mm-set-handle-multipart-parameter
 130        mm-security-handle 'gnus-info "Failed"))))
 131
 132 (defun mml2015-fix-micalg (alg)
 133   (upcase
 134    (if (and alg (string-match "^pgp-" alg))
 135        (substring alg (match-end 0))
 136      alg)))
 137
 138 (defun mml2015-mailcrypt-verify (handle ctl)
 139   (catch 'error
 140     (let (part)
 141       (unless (setq part (mm-find-raw-part-by-type
 142                           ctl (or (mm-handle-multipart-ctl-parameter
 143                                    ctl 'protocol)
 144                                   "application/pgp-signature")
 145                           t))
 146         (mm-set-handle-multipart-parameter
 147          mm-security-handle 'gnus-info "Corrupted")
 148         (throw 'error handle))
 149       (with-temp-buffer
 150         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
 151         (insert (format "Hash: %s\n\n"
 152                         (or (mml2015-fix-micalg
 153                              (mm-handle-multipart-ctl-parameter
 154                               ctl 'micalg))
 155                             "SHA1")))
 156         (save-restriction
 157           (narrow-to-region (point) (point))
 158           (insert part "\n")
 159           (goto-char (point-min))
 160           (while (not (eobp))
 161             (if (looking-at "^-")
 162                 (insert "- "))
 163             (forward-line)))
 164         (unless (setq part (mm-find-part-by-type
 165                             (cdr handle) "application/pgp-signature" nil t))
 166           (mm-set-handle-multipart-parameter
 167            mm-security-handle 'gnus-info "Corrupted")
 168           (throw 'error handle))
 169         (save-restriction
 170           (narrow-to-region (point) (point))
 171           (mm-insert-part part)
 172           (goto-char (point-min))
 173           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
 174               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
 175           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
 176               (replace-match "-----END PGP SIGNATURE-----" t t)))
 177         (unless (condition-case err
 178                     (funcall mml2015-verify-function)
 179                   (error
 180                    (mm-set-handle-multipart-parameter
 181                     mm-security-handle 'gnus-details (cadr err))
 182                    nil)
 183                   (quit
 184                    (mm-set-handle-multipart-parameter
 185                     mm-security-handle 'gnus-details "Quit.")
 186                    nil))
 187           (mm-set-handle-multipart-parameter
 188            mm-security-handle 'gnus-info "Failed")
 189           (throw 'error handle)))
 190       (mm-set-handle-multipart-parameter
 191        mm-security-handle 'gnus-info "OK")
 192       handle)))
 193
 194 (defun mml2015-mailcrypt-clear-verify ()
 195   (if (condition-case err
 196           (funcall mml2015-verify-function)
 197         (error
 198          (mm-set-handle-multipart-parameter
 199           mm-security-handle 'gnus-details (cadr err))
 200          nil)
 201         (quit
 202          (mm-set-handle-multipart-parameter
 203           mm-security-handle 'gnus-details "Quit.")
 204          nil))
 205       (mm-set-handle-multipart-parameter
 206        mm-security-handle 'gnus-info "OK")
 207     (mm-set-handle-multipart-parameter
 208      mm-security-handle 'gnus-info "Failed")))
 209
 210 (defun mml2015-mailcrypt-sign (cont)
 211   (mc-sign-generic (message-options-get 'message-sender)
 212                    nil nil nil nil)
 213   (let ((boundary
 214          (funcall mml-boundary-function (incf mml-multipart-number)))
 215         hash point)
 216     (goto-char (point-min))
 217     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
 218       (error "Cannot find signed begin line." ))
 219     (goto-char (match-beginning 0))
 220     (forward-line 1)
 221     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
 222       (error "Cannot not find PGP hash." ))
 223     (setq hash (match-string 1))
 224     (unless (re-search-forward "^$" nil t)
 225       (error "Cannot not find PGP message." ))
 226     (forward-line 1)
 227     (delete-region (point-min) (point))
 228     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 229                     boundary))
 230     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
 231                     (downcase hash)))
 232     (insert (format "\n--%s\n" boundary))
 233     (setq point (point))
 234     (goto-char (point-max))
 235     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
 236       (error "Cannot find signature part." ))
 237     (replace-match "-----END PGP MESSAGE-----" t t)
 238     (goto-char (match-beginning 0))
 239     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
 240                                 nil t)
 241       (error "Cannot find signature part." ))
 242     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
 243     (goto-char (match-beginning 0))
 244     (save-restriction
 245       (narrow-to-region point (point))
 246       (goto-char point)
 247       (while (re-search-forward "^- -" nil t)
 248         (replace-match "-" t t))
 249       (goto-char (point-max)))
 250     (insert (format "--%s\n" boundary))
 251     (insert "Content-Type: application/pgp-signature\n\n")
 252     (goto-char (point-max))
 253     (insert (format "--%s--\n" boundary))
 254     (goto-char (point-max))))
 255
 256 (defun mml2015-mailcrypt-encrypt (cont)
 257   (let ((mc-pgp-always-sign
 258          (or mc-pgp-always-sign
 259              (eq t (or (message-options-get 'message-sign-encrypt)
 260                        (message-options-set
 261                         'message-sign-encrypt
 262                         (or (y-or-n-p "Sign the message? ")
 263                             'not))))
 264              'never)))
 265     (mc-encrypt-generic
 266      (or (message-options-get 'message-recipients)
 267          (message-options-set 'message-recipients
 268                               (mc-cleanup-recipient-headers
 269                                (read-string "Recipients: "))))
 270      nil nil nil
 271      (message-options-get 'message-sender)))
 272   (let ((boundary
 273          (funcall mml-boundary-function (incf mml-multipart-number))))
 274     (goto-char (point-min))
 275     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 276                     boundary))
 277     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 278     (insert (format "--%s\n" boundary))
 279     (insert "Content-Type: application/pgp-encrypted\n\n")
 280     (insert "Version: 1\n\n")
 281     (insert (format "--%s\n" boundary))
 282     (insert "Content-Type: application/octet-stream\n\n")
 283     (goto-char (point-max))
 284     (insert (format "--%s--\n" boundary))
 285     (goto-char (point-max))))
 286
 287 ;;; gpg wrapper
 288
 289 (eval-and-compile
 290   (autoload 'gpg-decrypt "gpg")
 291   (autoload 'gpg-verify "gpg")
 292   (autoload 'gpg-sign-detached "gpg")
 293   (autoload 'gpg-sign-encrypt "gpg")
 294   (autoload 'gpg-passphrase-read "gpg"))
 295
 296 (defun mml2015-gpg-passphrase ()
 297   (or (message-options-get 'gpg-passphrase)
 298       (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
 299
 300 (defun mml2015-gpg-decrypt-1 ()
 301   (let ((cipher (current-buffer)) plain result)
 302     (if (with-temp-buffer
 303           (prog1
 304               (gpg-decrypt cipher (setq plain (current-buffer))
 305                            mml2015-result-buffer nil)
 306             (set-buffer cipher)
 307             (erase-buffer)
 308             (insert-buffer plain)))
 309         '(t)
 310       ;; Some wrong with the return value, check plain text buffer.
 311       (if (> (point-max) (point-min))
 312           '(t)
 313         (mm-set-handle-multipart-parameter
 314          mm-security-handle 'gnus-details
 315          (with-current-buffer mml2015-result-buffer
 316            (buffer-string)))
 317         nil))))
 318
 319 (defun mml2015-gpg-decrypt (handle ctl)
 320   (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
 321     (mml2015-mailcrypt-decrypt handle ctl)))
 322
 323 (defun mml2015-gpg-clear-decrypt ()
 324   (let (result)
 325     (setq result (mml2015-gpg-decrypt-1))
 326     (if (car result)
 327         (mm-set-handle-multipart-parameter
 328          mm-security-handle 'gnus-info "OK")
 329       (mm-set-handle-multipart-parameter
 330        mm-security-handle 'gnus-info "Failed"))))
 331
 332 (defun mml2015-gpg-verify (handle ctl)
 333   (catch 'error
 334     (let (part message signature)
 335       (unless (setq part (mm-find-raw-part-by-type
 336                           ctl (or (mm-handle-multipart-ctl-parameter
 337                                    ctl 'protocol)
 338                                   "application/pgp-signature")
 339                           t))
 340         (mm-set-handle-multipart-parameter
 341          mm-security-handle 'gnus-info "Corrupted")
 342         (throw 'error handle))
 343       (with-temp-buffer
 344         (setq message (current-buffer))
 345         (insert part)
 346         (with-temp-buffer
 347           (setq signature (current-buffer))
 348           (unless (setq part (mm-find-part-by-type
 349                               (cdr handle) "application/pgp-signature" nil t))
 350             (mm-set-handle-multipart-parameter
 351              mm-security-handle 'gnus-info "Corrupted")
 352             (throw 'error handle))
 353           (mm-insert-part part)
 354           (unless (condition-case err
 355                       (gpg-verify message signature mml2015-result-buffer)
 356                     (error
 357                      (mm-set-handle-multipart-parameter
 358                       mm-security-handle 'gnus-details (cadr err))
 359                      nil)
 360                     (quit
 361                      (mm-set-handle-multipart-parameter
 362                       mm-security-handle 'gnus-details "Quit.")
 363                      nil))
 364             (mm-set-handle-multipart-parameter
 365              mm-security-handle 'gnus-details
 366              (with-current-buffer mml2015-result-buffer
 367                (buffer-string)))
 368             (mm-set-handle-multipart-parameter
 369              mm-security-handle 'gnus-info "Failed")
 370             (throw 'error handle)))
 371         (mm-set-handle-multipart-parameter
 372          mm-security-handle 'gnus-info "OK"))
 373       handle)))
 374
 375 (defun mml2015-gpg-clear-verify ()
 376   (if (condition-case err
 377           (funcall mml2015-verify-function)
 378         (error
 379          (mm-set-handle-multipart-parameter
 380           mm-security-handle 'gnus-details (cadr err))
 381          nil)
 382         (quit
 383          (mm-set-handle-multipart-parameter
 384           mm-security-handle 'gnus-details "Quit.")
 385          nil))
 386       (mm-set-handle-multipart-parameter
 387        mm-security-handle 'gnus-info "OK")
 388     (mm-set-handle-multipart-parameter
 389      mm-security-handle 'gnus-info "Failed")))
 390
 391 (defun mml2015-gpg-sign (cont)
 392   (let ((boundary
 393          (funcall mml-boundary-function (incf mml-multipart-number)))
 394         (text (current-buffer)) signature)
 395     (goto-char (point-max))
 396     (unless (bolp)
 397       (insert "\n"))
 398     (with-temp-buffer
 399       (unless (gpg-sign-detached text (setq signature (current-buffer))
 400                                  mml2015-result-buffer
 401                                  nil
 402                                  (message-options-get 'message-sender)
 403                                  t t) ; armor & textmode
 404         (unless (> (point-max) (point-min))
 405           (pop-to-buffer mml2015-result-buffer)
 406           (error "Sign error.")))
 407       (set-buffer text)
 408       (goto-char (point-min))
 409       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 410                       boundary))
 411       ;;; FIXME: what is the micalg?
 412       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 413       (insert (format "\n--%s\n" boundary))
 414       (goto-char (point-max))
 415       (insert (format "\n--%s\n" boundary))
 416       (insert "Content-Type: application/pgp-signature\n\n")
 417       (insert-buffer signature)
 418       (goto-char (point-max))
 419       (insert (format "--%s--\n" boundary))
 420       (goto-char (point-max)))))
 421
 422 (defun mml2015-gpg-encrypt (cont)
 423   (let ((boundary
 424          (funcall mml-boundary-function (incf mml-multipart-number)))
 425         (text (current-buffer))
 426         cipher)
 427     (with-temp-buffer
 428       (unless (gpg-sign-encrypt
 429                text (setq cipher (current-buffer))
 430                mml2015-result-buffer
 431                (split-string
 432                 (or
 433                  (message-options-get 'message-recipients)
 434                  (message-options-set 'message-recipients
 435                                       (read-string "Recipients: ")))
 436                 "[ \f\t\n\r\v,]+")
 437                nil
 438                (message-options-get 'message-sender)
 439                t t) ; armor & textmode
 440         (unless (> (point-max) (point-min))
 441           (pop-to-buffer mml2015-result-buffer)
 442           (error "Encrypt error.")))
 443       (set-buffer text)
 444       (delete-region (point-min) (point-max))
 445       (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 446                       boundary))
 447       (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 448       (insert (format "--%s\n" boundary))
 449       (insert "Content-Type: application/pgp-encrypted\n\n")
 450       (insert "Version: 1\n\n")
 451       (insert (format "--%s\n" boundary))
 452       (insert "Content-Type: application/octet-stream\n\n")
 453       (insert-buffer cipher)
 454       (goto-char (point-max))
 455       (insert (format "--%s--\n" boundary))
 456       (goto-char (point-max)))))
 457
 458 ;;; General wrapper
 459
 460 (defun mml2015-clean-buffer ()
 461   (if (gnus-buffer-live-p mml2015-result-buffer)
 462       (with-current-buffer mml2015-result-buffer
 463         (erase-buffer)
 464         t)
 465     (setq mml2015-result-buffer
 466           (gnus-get-buffer-create "*MML2015 Result*"))
 467     nil))
 468
 469 (defsubst mml2015-clear-decrypt-function ()
 470   (nth 6 (assq mml2015-use mml2015-function-alist)))
 471
 472 (defsubst mml2015-clear-verify-function ()
 473   (nth 5 (assq mml2015-use mml2015-function-alist)))
 474
 475 ;;;###autoload
 476 (defun mml2015-decrypt (handle ctl)
 477   (mml2015-clean-buffer)
 478   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
 479     (if func
 480         (funcall func handle ctl)
 481       handle)))
 482
 483 ;;;###autoload
 484 (defun mml2015-decrypt-test (handle ctl)
 485   mml2015-use)
 486
 487 ;;;###autoload
 488 (defun mml2015-verify (handle ctl)
 489   (mml2015-clean-buffer)
 490   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
 491     (if func
 492         (funcall func handle ctl)
 493       handle)))
 494
 495 ;;;###autoload
 496 (defun mml2015-verify-test (handle ctl)
 497   mml2015-use)
 498
 499 ;;;###autoload
 500 (defun mml2015-encrypt (cont)
 501   (mml2015-clean-buffer)
 502   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
 503     (if func
 504         (funcall func cont)
 505       (error "Cannot find encrypt function."))))
 506
 507 ;;;###autoload
 508 (defun mml2015-sign (cont)
 509   (mml2015-clean-buffer)
 510   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
 511     (if func
 512         (funcall func cont)
 513       (error "Cannot find sign function."))))
 514
 515 ;;;###autoload
 516 (defun mml2015-self-encrypt ()
 517   (mml2015-encrypt nil))
 518
 519 (provide 'mml2015)
 520
 521 ;;; mml2015.el ends here