Importing Oort Gnus v0.06.
[elisp/gnus.git-] / contrib / rfc2015.el
1 ;;; rfc2015.el --- MIME Security with Pretty Good Privacy (PGP)
2 ;; Copyright (c) 2000 Shenghuo Zhu
3
4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
5 ;; Keywords: PGP MIME
6
7 ;; This file is not (yet) a part of GNU Emacs. Hope it 
8 ;; will be a part of oGnus distribution, then GNU Emacs.
9
10 ;; This file 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 ;; This file 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., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Commentary:
26
27 ;; Installation: put the following statements in ~/.gnus:
28 ;;    (require 'rfc2015)
29 ;;    (require 'gnus-art)
30 ;;    (rfc2015-setup)
31 ;; You may have to make sure that the directory where this file lives
32 ;; is mentioned in `load-path'.
33 ;; 
34 ;; Insert an attribute, postprocess=pgp-sign (or pgp-encrypt), into
35 ;; the mml tag to be signed (or encrypted).
36
37 ;;; Code:
38
39 (defvar rfc2015-decrypt-function 'mailcrypt-decrypt)
40 (defvar rfc2015-verify-function 'mailcrypt-verify)
41
42 (defun rfc2015-decrypt (handle)
43   (let (child)
44     (cond 
45      ((setq child (mm-find-part-by-type (cdr handle) 
46                                         "application/octet-stream"))
47       (let (handles result)
48         (with-temp-buffer
49           (mm-insert-part child)
50           (setq result (funcall rfc2015-decrypt-function))
51           (unless (car result)
52             (error "Decrypting error."))
53           (setq handles (mm-dissect-buffer t)))
54         (setq gnus-article-mime-handles
55               (append (if (listp (car gnus-article-mime-handles))
56                           gnus-article-mime-handles
57                         (list gnus-article-mime-handles))
58                       (if (listp (car handles))
59                           handles
60                         (list handles))))
61         (gnus-mime-display-part handles)))
62      (t
63       (if (y-or-n-p "Corrupted pgp-encrypted part. Abort?" )
64           (error "Corrupted pgp-encrypted part.")
65         (gnus-mime-display-mixed (cdr handle)))))))
66
67 ;; FIXME: mm-dissect-buffer loses information of micalg and the
68 ;; original header of signed part.
69
70 (defun rfc2015-verify (handle)
71   (if (y-or-n-p "Verify signed part?" )
72       (let (child result hash)
73         (with-temp-buffer
74           (unless (setq child (mm-find-part-by-type 
75                                (cdr handle) "application/pgp-signature" t))
76             (error "Corrupted pgp-signature part."))
77           (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
78           (insert (format "Hash: %s\n\n" (read-string "Hash: " "SHA1")))
79           (mm-insert-part child)
80           (goto-char (point-max))
81           (unless (bolp)
82             (insert "\n"))
83           (unless (setq child (mm-find-part-by-type 
84                                (cdr handle) "application/pgp-signature"))
85             (error "Corrupted pgp-signature part."))
86           (mm-insert-part child)
87           (setq result (funcall rfc2015-verify-function))
88           (unless result
89             (error "Verify error.")))))
90   (gnus-mime-display-part 
91    (mm-find-part-by-type 
92     (cdr handle) "application/pgp-signature" t)))
93
94 (defvar rfc2015-mailcrypt-prefix 0)
95
96 (defun rfc2015-mailcrypt-sign (cont)
97   (mailcrypt-sign rfc2015-mailcrypt-prefix)
98   (let ((boundary 
99          (funcall mml-boundary-function (incf mml-multipart-number)))
100         (scheme-alist (funcall (or mc-default-scheme 
101                                    (cdr (car mc-schemes)))))
102         hash)
103     (goto-char (point-min))
104     (unless (re-search-forward (cdr (assq 'signed-begin-line scheme-alist)))
105       (error "Cannot find signed begin line." ))
106     (goto-char (match-beginning 0))
107     (forward-line 1)
108     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
109       (error "Cannot not find PGP hash." ))
110     (setq hash (match-string 1))
111     (unless (re-search-forward "^$" nil t)
112       (error "Cannot not find PGP message." ))
113     (forward-line 1)
114     (delete-region (point-min) (point))
115     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
116                     boundary))
117     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
118                     hash))
119     (insert "\n")
120     (insert (format "--%s\n" boundary))
121     (unless (re-search-forward (cdr (assq 'signed-end-line scheme-alist)))
122       (error "Cannot find signature part." ))
123     (goto-char (match-beginning 0))
124     (unless (re-search-backward "^-+BEGIN" nil t)
125       (error "Cannot find signature part." ))
126     (goto-char (match-beginning 0))
127     (insert (format "--%s\n" boundary))
128     (insert "Content-Type: application/pgp-signature\n\n")
129     (goto-char (point-max))
130     (insert (format "--%s--\n" boundary))
131     (goto-char (point-max))))
132
133 (defun rfc2015-mailcrypt-encrypt (cont)
134   ;; FIXME:
135   ;; You have to input the receiptant.
136   (mailcrypt-encrypt rfc2015-mailcrypt-prefix)
137   (let ((boundary 
138          (funcall mml-boundary-function (incf mml-multipart-number))))
139     (goto-char (point-min))
140     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
141                     boundary))
142     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
143     (insert (format "--%s\n" boundary))
144     (insert "Content-Type: application/pgp-encrypted\n\n")
145     (insert "Version: 1\n\n")
146     (insert (format "--%s\n" boundary))
147     (insert "Content-Type: application/octet-stream\n\n")
148     (goto-char (point-max))
149     (insert (format "--%s--\n" boundary))
150     (goto-char (point-max))))
151
152 ;; The following code might be moved into mml.el or gnus-art.el.
153
154 (defvar mml-postprocess-alist
155   '(("pgp-sign" . rfc2015-mailcrypt-sign)
156     ("pgp-encrypt" . rfc2015-mailcrypt-encrypt))
157   "Alist of postprocess functions.")
158
159 (defun mml-postprocess (cont)
160   (let ((pp (cdr (or (assq 'postprocess cont)
161                      (assq 'pp cont))))
162         item)
163     (if (and pp (setq item (assoc pp mml-postprocess-alist)))
164         (funcall (cdr item) cont))))
165
166 (defun rfc2015-setup ()
167   (setq mml-generate-mime-postprocess-function 'mml-postprocess)
168 ;  (push '("multipart/signed" . rfc2015-verify)
169 ;       gnus-mime-multipart-functions)
170   (push '("multipart/encrypted" . rfc2015-decrypt)
171         gnus-mime-multipart-functions))
172
173 ;; The following code might be moved into mm-decode.el.
174
175 (defun mm-find-part-by-type (handles type &optional notp) 
176   (let (handle)
177     (while handles
178       (if (if notp
179               (not (equal (mm-handle-media-type (car handles)) type))
180             (equal (mm-handle-media-type (car handles)) type))
181           (setq handle (car handles)
182                 handles nil))
183       (setq handles (cdr handles)))
184     handle))
185
186 (provide 'rfc2015)
187
188 ;;; rfc2015.el ends here