1 ;;; rfc2015.el --- MIME Security with Pretty Good Privacy (PGP)
2 ;; Copyright (c) 2000 Free Software Foundation, Inc.
4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
7 ;; This file is a part of GNU Emacs.
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.
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.
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.
29 ;; Insert an attribute, postprocess=pgp-sign (or pgp-encrypt), into
30 ;; the mml tag to be signed (or encrypted).
34 (defvar rfc2015-decrypt-function 'mailcrypt-decrypt)
35 (defvar rfc2015-verify-function 'mailcrypt-verify)
37 (defun rfc2015-decrypt (handle)
40 ((setq child (mm-find-part-by-type (cdr handle)
41 "application/octet-stream"))
44 (mm-insert-part child)
45 (setq result (funcall rfc2015-decrypt-function))
47 (error "Decrypting error."))
48 (setq handles (mm-dissect-buffer t)))
49 (setq gnus-article-mime-handles
50 (append (if (listp (car gnus-article-mime-handles))
51 gnus-article-mime-handles
52 (list gnus-article-mime-handles))
53 (if (listp (car handles))
56 (gnus-mime-display-part handles)))
58 (if (y-or-n-p "Corrupted pgp-encrypted part. Abort?" )
59 (error "Corrupted pgp-encrypted part.")
60 (gnus-mime-display-mixed (cdr handle)))))))
62 ;; FIXME: mm-dissect-buffer loses information of micalg and the
63 ;; original header of signed part.
65 (defun rfc2015-verify (handle)
66 (if (y-or-n-p "Verify signed part?" )
67 (let (child result hash)
69 (unless (setq child (mm-find-part-by-type
70 (cdr handle) "application/pgp-signature" t))
71 (error "Corrupted pgp-signature part."))
72 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
73 (insert (format "Hash: %s\n\n" (read-string "Hash: " "SHA1")))
74 (mm-insert-part child)
75 (goto-char (point-max))
78 (unless (setq child (mm-find-part-by-type
79 (cdr handle) "application/pgp-signature"))
80 (error "Corrupted pgp-signature part."))
81 (mm-insert-part child)
82 (setq result (funcall rfc2015-verify-function))
84 (error "Verify error.")))))
85 (gnus-mime-display-part
87 (cdr handle) "application/pgp-signature" t)))
89 (defvar rfc2015-mailcrypt-prefix 0)
91 (defun rfc2015-mailcrypt-sign (cont)
92 (mailcrypt-sign rfc2015-mailcrypt-prefix)
94 (funcall mml-boundary-function (incf mml-multipart-number)))
95 (scheme-alist (funcall (or mc-default-scheme
96 (cdr (car mc-schemes)))))
98 (goto-char (point-min))
99 (unless (re-search-forward (cdr (assq 'signed-begin-line scheme-alist)))
100 (error "Cannot find signed begin line." ))
101 (goto-char (match-beginning 0))
103 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
104 (error "Cannot not find PGP hash." ))
105 (setq hash (match-string 1))
106 (unless (re-search-forward "^$" nil t)
107 (error "Cannot not find PGP message." ))
109 (delete-region (point-min) (point))
110 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
112 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
115 (insert (format "--%s\n" boundary))
116 (unless (re-search-forward (cdr (assq 'signed-end-line scheme-alist)))
117 (error "Cannot find signature part." ))
118 (goto-char (match-beginning 0))
119 (unless (re-search-backward "^-+BEGIN" nil t)
120 (error "Cannot find signature part." ))
121 (goto-char (match-beginning 0))
122 (insert (format "--%s\n" boundary))
123 (insert "Content-Type: application/pgp-signature\n\n")
124 (goto-char (point-max))
125 (insert (format "--%s--\n" boundary))
126 (goto-char (point-max))))
128 (defun rfc2015-mailcrypt-encrypt (cont)
130 ;; You have to input the receiptant.
131 (mailcrypt-encrypt rfc2015-mailcrypt-prefix)
133 (funcall mml-boundary-function (incf mml-multipart-number))))
134 (goto-char (point-min))
135 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
137 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
138 (insert (format "--%s\n" boundary))
139 (insert "Content-Type: application/pgp-encrypted\n\n")
140 (insert "Version: 1\n\n")
141 (insert (format "--%s\n" boundary))
142 (insert "Content-Type: application/octet-stream\n\n")
143 (goto-char (point-max))
144 (insert (format "--%s--\n" boundary))
145 (goto-char (point-max))))
147 ;; The following code might be moved into mml.el or gnus-art.el.
149 (defvar mml-postprocess-alist
150 '(("pgp-sign" . rfc2015-mailcrypt-sign)
151 ("pgp-encrypt" . rfc2015-mailcrypt-encrypt))
152 "Alist of postprocess functions.")
154 (defun mml-postprocess (cont)
155 (let ((pp (cdr (or (assq 'postprocess cont)
158 (if (and pp (setq item (assoc pp mml-postprocess-alist)))
159 (funcall (cdr item) cont))))
161 (defun rfc2015-setup ()
162 (setq mml-generate-mime-postprocess-function 'mml-postprocess)
163 ; (push '("multipart/signed" . rfc2015-verify)
164 ; gnus-mime-multipart-functions)
165 (push '("multipart/encrypted" . rfc2015-decrypt)
166 gnus-mime-multipart-functions))
168 ;; The following code might be moved into mm-decode.el.
170 (defun mm-find-part-by-type (handles type &optional notp)
174 (not (equal (mm-handle-media-type (car handles)) type))
175 (equal (mm-handle-media-type (car handles)) type))
176 (setq handle (car handles)
178 (setq handles (cdr handles)))
183 ;;; rfc2015.el ends here