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     (mm-with-unibyte-current-buffer-mule4
 266       (mc-encrypt-generic
 267        (or (message-options-get 'message-recipients)
 268            (message-options-set 'message-recipients
 269                               (mc-cleanup-recipient-headers
 270                                (read-string "Recipients: "))))
 271        nil nil nil
 272        (message-options-get 'message-sender))))
 273   (goto-char (point-min))
 274   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
 275     (error "Fail to encrypt the message."))
 276   (let ((boundary
 277          (funcall mml-boundary-function (incf mml-multipart-number))))
 278     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 279                     boundary))
 280     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 281     (insert (format "--%s\n" boundary))
 282     (insert "Content-Type: application/pgp-encrypted\n\n")
 283     (insert "Version: 1\n\n")
 284     (insert (format "--%s\n" boundary))
 285     (insert "Content-Type: application/octet-stream\n\n")
 286     (goto-char (point-max))
 287     (insert (format "--%s--\n" boundary))
 288     (goto-char (point-max))))
 289
 290 ;;; gpg wrapper
 291
 292 (eval-and-compile
 293   (autoload 'gpg-decrypt "gpg")
 294   (autoload 'gpg-verify "gpg")
 295   (autoload 'gpg-sign-detached "gpg")
 296   (autoload 'gpg-sign-encrypt "gpg")
 297   (autoload 'gpg-passphrase-read "gpg"))
 298
 299 (defun mml2015-gpg-passphrase ()
 300   (or (message-options-get 'gpg-passphrase)
 301       (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
 302
 303 (defun mml2015-gpg-decrypt-1 ()
 304   (let ((cipher (current-buffer)) plain result)
 305     (if (with-temp-buffer
 306           (prog1
 307               (gpg-decrypt cipher (setq plain (current-buffer))
 308                            mml2015-result-buffer nil)
 309             (set-buffer cipher)
 310             (erase-buffer)
 311             (insert-buffer plain)))
 312         '(t)
 313       ;; Some wrong with the return value, check plain text buffer.
 314       (if (> (point-max) (point-min))
 315           '(t)
 316         (mm-set-handle-multipart-parameter
 317          mm-security-handle 'gnus-details
 318          (with-current-buffer mml2015-result-buffer
 319            (buffer-string)))
 320         nil))))
 321
 322 (defun mml2015-gpg-decrypt (handle ctl)
 323   (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
 324     (mml2015-mailcrypt-decrypt handle ctl)))
 325
 326 (defun mml2015-gpg-clear-decrypt ()
 327   (let (result)
 328     (setq result (mml2015-gpg-decrypt-1))
 329     (if (car result)
 330         (mm-set-handle-multipart-parameter
 331          mm-security-handle 'gnus-info "OK")
 332       (mm-set-handle-multipart-parameter
 333        mm-security-handle 'gnus-info "Failed"))))
 334
 335 (defun mml2015-gpg-verify (handle ctl)
 336   (catch 'error
 337     (let (part message signature)
 338       (unless (setq part (mm-find-raw-part-by-type
 339                           ctl (or (mm-handle-multipart-ctl-parameter
 340                                    ctl 'protocol)
 341                                   "application/pgp-signature")
 342                           t))
 343         (mm-set-handle-multipart-parameter
 344          mm-security-handle 'gnus-info "Corrupted")
 345         (throw 'error handle))
 346       (with-temp-buffer
 347         (setq message (current-buffer))
 348         (insert part)
 349         (with-temp-buffer
 350           (setq signature (current-buffer))
 351           (unless (setq part (mm-find-part-by-type
 352                               (cdr handle) "application/pgp-signature" nil t))
 353             (mm-set-handle-multipart-parameter
 354              mm-security-handle 'gnus-info "Corrupted")
 355             (throw 'error handle))
 356           (mm-insert-part part)
 357           (unless (condition-case err
 358                       (gpg-verify message signature mml2015-result-buffer)
 359                     (error
 360                      (mm-set-handle-multipart-parameter
 361                       mm-security-handle 'gnus-details (cadr err))
 362                      nil)
 363                     (quit
 364                      (mm-set-handle-multipart-parameter
 365                       mm-security-handle 'gnus-details "Quit.")
 366                      nil))
 367             (mm-set-handle-multipart-parameter
 368              mm-security-handle 'gnus-details
 369              (with-current-buffer mml2015-result-buffer
 370                (buffer-string)))
 371             (mm-set-handle-multipart-parameter
 372              mm-security-handle 'gnus-info "Failed")
 373             (throw 'error handle)))
 374         (mm-set-handle-multipart-parameter
 375          mm-security-handle 'gnus-info "OK"))
 376       handle)))
 377
 378 (defun mml2015-gpg-clear-verify ()
 379   (if (condition-case err
 380           (funcall mml2015-verify-function)
 381         (error
 382          (mm-set-handle-multipart-parameter
 383           mm-security-handle 'gnus-details (cadr err))
 384          nil)
 385         (quit
 386          (mm-set-handle-multipart-parameter
 387           mm-security-handle 'gnus-details "Quit.")
 388          nil))
 389       (mm-set-handle-multipart-parameter
 390        mm-security-handle 'gnus-info "OK")
 391     (mm-set-handle-multipart-parameter
 392      mm-security-handle 'gnus-info "Failed")))
 393
 394 (defun mml2015-gpg-sign (cont)
 395   (let ((boundary
 396          (funcall mml-boundary-function (incf mml-multipart-number)))
 397         (text (current-buffer)) signature)
 398     (goto-char (point-max))
 399     (unless (bolp)
 400       (insert "\n"))
 401     (with-temp-buffer
 402       (unless (gpg-sign-detached text (setq signature (current-buffer))
 403                                  mml2015-result-buffer
 404                                  nil
 405                                  (message-options-get 'message-sender)
 406                                  t t) ; armor & textmode
 407         (unless (> (point-max) (point-min))
 408           (pop-to-buffer mml2015-result-buffer)
 409           (error "Sign error.")))
 410       (set-buffer text)
 411       (goto-char (point-min))
 412       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
 413                       boundary))
 414       ;;; FIXME: what is the micalg?
 415       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
 416       (insert (format "\n--%s\n" boundary))
 417       (goto-char (point-max))
 418       (insert (format "\n--%s\n" boundary))
 419       (insert "Content-Type: application/pgp-signature\n\n")
 420       (insert-buffer signature)
 421       (goto-char (point-max))
 422       (insert (format "--%s--\n" boundary))
 423       (goto-char (point-max)))))
 424
 425 (defun mml2015-gpg-encrypt (cont)
 426   (let ((boundary
 427          (funcall mml-boundary-function (incf mml-multipart-number)))
 428         (text (current-buffer))
 429         cipher)
 430     (mm-with-unibyte-current-buffer-mule4
 431       (with-temp-buffer
 432         (unless (gpg-sign-encrypt
 433                  text (setq cipher (current-buffer))
 434                  mml2015-result-buffer
 435                  (split-string
 436                   (or
 437                    (message-options-get 'message-recipients)
 438                    (message-options-set 'message-recipients
 439                                         (read-string "Recipients: ")))
 440                   "[ \f\t\n\r\v,]+")
 441                  nil
 442                  (message-options-get 'message-sender)
 443                  t t) ; armor & textmode
 444           (unless (> (point-max) (point-min))
 445             (pop-to-buffer mml2015-result-buffer)
 446             (error "Encrypt error.")))
 447         (set-buffer text)
 448         (delete-region (point-min) (point-max))
 449         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
 450                         boundary))
 451         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
 452         (insert (format "--%s\n" boundary))
 453         (insert "Content-Type: application/pgp-encrypted\n\n")
 454         (insert "Version: 1\n\n")
 455         (insert (format "--%s\n" boundary))
 456         (insert "Content-Type: application/octet-stream\n\n")
 457         (insert-buffer cipher)
 458         (goto-char (point-max))
 459         (insert (format "--%s--\n" boundary))
 460         (goto-char (point-max))))))
 461
 462 ;;; General wrapper
 463
 464 (defun mml2015-clean-buffer ()
 465   (if (gnus-buffer-live-p mml2015-result-buffer)
 466       (with-current-buffer mml2015-result-buffer
 467         (erase-buffer)
 468         t)
 469     (setq mml2015-result-buffer
 470           (gnus-get-buffer-create "*MML2015 Result*"))
 471     nil))
 472
 473 (defsubst mml2015-clear-decrypt-function ()
 474   (nth 6 (assq mml2015-use mml2015-function-alist)))
 475
 476 (defsubst mml2015-clear-verify-function ()
 477   (nth 5 (assq mml2015-use mml2015-function-alist)))
 478
 479 ;;;###autoload
 480 (defun mml2015-decrypt (handle ctl)
 481   (mml2015-clean-buffer)
 482   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
 483     (if func
 484         (funcall func handle ctl)
 485       handle)))
 486
 487 ;;;###autoload
 488 (defun mml2015-decrypt-test (handle ctl)
 489   mml2015-use)
 490
 491 ;;;###autoload
 492 (defun mml2015-verify (handle ctl)
 493   (mml2015-clean-buffer)
 494   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
 495     (if func
 496         (funcall func handle ctl)
 497       handle)))
 498
 499 ;;;###autoload
 500 (defun mml2015-verify-test (handle ctl)
 501   mml2015-use)
 502
 503 ;;;###autoload
 504 (defun mml2015-encrypt (cont)
 505   (mml2015-clean-buffer)
 506   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
 507     (if func
 508         (funcall func cont)
 509       (error "Cannot find encrypt function."))))
 510
 511 ;;;###autoload
 512 (defun mml2015-sign (cont)
 513   (mml2015-clean-buffer)
 514   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
 515     (if func
 516         (funcall func cont)
 517       (error "Cannot find sign function."))))
 518
 519 ;;;###autoload
 520 (defun mml2015-self-encrypt ()
 521   (mml2015-encrypt nil))
 522
 523 (provide 'mml2015)
 524
 525 ;;; mml2015.el ends here