+++ /dev/null
-;;; rfc2015.el --- MIME Security with Pretty Good Privacy (PGP)
-;; Copyright (c) 2000 Shenghuo Zhu
-
-;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
-;; Keywords: PGP MIME
-
-;; This file is not (yet) a part of GNU Emacs. Hope it
-;; will be a part of oGnus distribution, then GNU Emacs.
-
-;; This file is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published
-;; by the Free Software Foundation; either version 2, or (at your
-;; option) any later version.
-
-;; This file is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; Installation: put the following statements in ~/.gnus:
-;; (require 'rfc2015)
-;; (require 'gnus-art)
-;; (rfc2015-setup)
-;; You may have to make sure that the directory where this file lives
-;; is mentioned in `load-path'.
-;;
-;; Insert an attribute, postprocess=pgp-sign (or pgp-encrypt), into
-;; the mml tag to be signed (or encrypted).
-
-;;; Code:
-
-(defvar rfc2015-decrypt-function 'mailcrypt-decrypt)
-(defvar rfc2015-verify-function 'mailcrypt-verify)
-
-(defun rfc2015-decrypt (handle)
- (let (child)
- (cond
- ((setq child (mm-find-part-by-type (cdr handle)
- "application/octet-stream"))
- (let (handles result)
- (with-temp-buffer
- (mm-insert-part child)
- (setq result (funcall rfc2015-decrypt-function))
- (unless (car result)
- (error "Decrypting error."))
- (setq handles (mm-dissect-buffer t)))
- (setq gnus-article-mime-handles
- (append (if (listp (car gnus-article-mime-handles))
- gnus-article-mime-handles
- (list gnus-article-mime-handles))
- (if (listp (car handles))
- handles
- (list handles))))
- (gnus-mime-display-part handles)))
- (t
- (if (y-or-n-p "Corrupted pgp-encrypted part. Abort?" )
- (error "Corrupted pgp-encrypted part.")
- (gnus-mime-display-mixed (cdr handle)))))))
-
-;; FIXME: mm-dissect-buffer loses information of micalg and the
-;; original header of signed part.
-
-(defun rfc2015-verify (handle)
- (if (y-or-n-p "Verify signed part?" )
- (let (child result hash)
- (with-temp-buffer
- (unless (setq child (mm-find-part-by-type
- (cdr handle) "application/pgp-signature" t))
- (error "Corrupted pgp-signature part."))
- (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
- (insert (format "Hash: %s\n\n" (read-string "Hash: " "SHA1")))
- (mm-insert-part child)
- (goto-char (point-max))
- (unless (bolp)
- (insert "\n"))
- (unless (setq child (mm-find-part-by-type
- (cdr handle) "application/pgp-signature"))
- (error "Corrupted pgp-signature part."))
- (mm-insert-part child)
- (setq result (funcall rfc2015-verify-function))
- (unless result
- (error "Verify error.")))))
- (gnus-mime-display-part
- (mm-find-part-by-type
- (cdr handle) "application/pgp-signature" t)))
-
-(defvar rfc2015-mailcrypt-prefix 0)
-
-(defun rfc2015-mailcrypt-sign (cont)
- (mailcrypt-sign rfc2015-mailcrypt-prefix)
- (let ((boundary
- (funcall mml-boundary-function (incf mml-multipart-number)))
- (scheme-alist (funcall (or mc-default-scheme
- (cdr (car mc-schemes)))))
- hash)
- (goto-char (point-min))
- (unless (re-search-forward (cdr (assq 'signed-begin-line scheme-alist)))
- (error "Cannot find signed begin line." ))
- (goto-char (match-beginning 0))
- (forward-line 1)
- (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
- (error "Cannot not find PGP hash." ))
- (setq hash (match-string 1))
- (unless (re-search-forward "^$" nil t)
- (error "Cannot not find PGP message." ))
- (forward-line 1)
- (delete-region (point-min) (point))
- (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
- boundary))
- (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
- hash))
- (insert "\n")
- (insert (format "--%s\n" boundary))
- (unless (re-search-forward (cdr (assq 'signed-end-line scheme-alist)))
- (error "Cannot find signature part." ))
- (goto-char (match-beginning 0))
- (unless (re-search-backward "^-+BEGIN" nil t)
- (error "Cannot find signature part." ))
- (goto-char (match-beginning 0))
- (insert (format "--%s\n" boundary))
- (insert "Content-Type: application/pgp-signature\n\n")
- (goto-char (point-max))
- (insert (format "--%s--\n" boundary))
- (goto-char (point-max))))
-
-(defun rfc2015-mailcrypt-encrypt (cont)
- ;; FIXME:
- ;; You have to input the receiptant.
- (mailcrypt-encrypt rfc2015-mailcrypt-prefix)
- (let ((boundary
- (funcall mml-boundary-function (incf mml-multipart-number))))
- (goto-char (point-min))
- (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
- boundary))
- (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
- (insert (format "--%s\n" boundary))
- (insert "Content-Type: application/pgp-encrypted\n\n")
- (insert "Version: 1\n\n")
- (insert (format "--%s\n" boundary))
- (insert "Content-Type: application/octet-stream\n\n")
- (goto-char (point-max))
- (insert (format "--%s--\n" boundary))
- (goto-char (point-max))))
-
-;; The following code might be moved into mml.el or gnus-art.el.
-
-(defvar mml-postprocess-alist
- '(("pgp-sign" . rfc2015-mailcrypt-sign)
- ("pgp-encrypt" . rfc2015-mailcrypt-encrypt))
- "Alist of postprocess functions.")
-
-(defun mml-postprocess (cont)
- (let ((pp (cdr (or (assq 'postprocess cont)
- (assq 'pp cont))))
- item)
- (if (and pp (setq item (assoc pp mml-postprocess-alist)))
- (funcall (cdr item) cont))))
-
-(defun rfc2015-setup ()
- (setq mml-generate-mime-postprocess-function 'mml-postprocess)
-; (push '("multipart/signed" . rfc2015-verify)
-; gnus-mime-multipart-functions)
- (push '("multipart/encrypted" . rfc2015-decrypt)
- gnus-mime-multipart-functions))
-
-;; The following code might be moved into mm-decode.el.
-
-(defun mm-find-part-by-type (handles type &optional notp)
- (let (handle)
- (while handles
- (if (if notp
- (not (equal (mm-handle-media-type (car handles)) type))
- (equal (mm-handle-media-type (car handles)) type))
- (setq handle (car handles)
- handles nil))
- (setq handles (cdr handles)))
- handle))
-
-(provide 'rfc2015)
-
-;;; rfc2015.el ends here
projects / gnus / blobdiff