Mercurial > hg > xemacs-beta

comparison lisp/tm/tm-pgp.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents
children 4b173ad71786
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1 ;;; tm-pgp.el --- tm-view internal methods for PGP.
2
3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
7 ;; Created: 1995/12/7
8 ;; Version: $Id: tm-pgp.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $
9 ;; Keywords: mail, news, MIME, multimedia, PGP, security
10
11 ;; This file is part of tm (Tools for MIME).
12
13 ;; This program is free software; you can redistribute it and/or
14 ;; modify it under the terms of the GNU General Public License as
15 ;; published by the Free Software Foundation; either version 2, or (at
16 ;; your option) any later version.
17
18 ;; This program is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;; General Public License for more details.
22
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
27
28 ;;; Commentary:
29
30 ;; This module is based on 2 drafts about PGP MIME integration:
31
32 ;; - draft-elkins-pem-pgp-04.txt
33 ;; ``MIME Security with Pretty Good Privacy (PGP)''
34 ;; by Michael Elkins <elkins@aero.org> (1996/6)
35 ;;
36 ;; - draft-kazu-pgp-mime-00.txt
37 ;; ``PGP MIME Integration''
38 ;; by Kazuhiko Yamamoto <kazu@is.aist-nara.ac.jp> (1995/10)
39 ;;
40 ;; These drafts may be contrary to each other. You should decide
41 ;; which you support.
42
43 ;;; Code:
44
45 (require 'mailcrypt)
46 (require 'tm-play)
47
48
49 ;;; @ internal method for application/pgp
50 ;;;
51 ;;; It is based on draft-kazu-pgp-mime-00.txt
52
53 (defun mime-article/view-application/pgp (beg end cal)
54 (let* ((cnum (mime-article/point-content-number beg))
55 (cur-buf (current-buffer))
56 (new-name (format "%s-%s" (buffer-name) cnum))
57 (mother mime::article/preview-buffer)
58 (mode major-mode)
59 code-converter str)
60 (setq str (buffer-substring beg end))
61 (switch-to-buffer new-name)
62 (erase-buffer)
63 (insert str)
64 (cond ((progn
65 (goto-char (point-min))
66 (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t)
67 )
68 (mc-verify)
69 (goto-char (point-min))
70 (delete-region
71 (point-min)
72 (and
73 (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+\n\n")
74 (match-end 0))
75 )
76 (delete-region
77 (and (re-search-forward "^-+BEGIN PGP SIGNATURE-+")
78 (match-beginning 0))
79 (point-max)
80 )
81 (goto-char (point-min))
82 (while (re-search-forward "^- -" nil t)
83 (replace-match "-")
84 )
85 (setq code-converter
86 (or
87 (cdr (assq mode mime-viewer/code-converter-alist))
88 (function mime-viewer/default-code-convert-region)))
89 )
90 ((progn
91 (goto-char (point-min))
92 (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t)
93 )
94 (as-binary-process (mc-decrypt))
95 (goto-char (point-min))
96 (delete-region (point-min)
97 (and
98 (search-forward "\n\n")
99 (match-end 0)))
100 (setq code-converter (function mime-charset/decode-buffer))
101 ))
102 (setq major-mode 'mime/show-message-mode)
103 (setq mime::article/code-converter code-converter)
104 (mime/viewer-mode mother)
105 ))
106
107 (set-atype 'mime/content-decoding-condition
108 '((type . "application/pgp")
109 (method . mime-article/view-application/pgp)
110 ))
111
112 (set-atype 'mime/content-decoding-condition
113 '((type . "text/x-pgp")
114 (method . mime-article/view-application/pgp)
115 ))
116
117
118 ;;; @ Internal method for application/pgp-signature
119 ;;;
120 ;;; It is based on draft-elkins-pem-pgp-02.txt
121
122 (defvar tm-pgp::default-language 'en
123 "*Symbol of language for pgp.
124 It should be ISO 639 2 letter language code such as en, ja, ...")
125
126 (defvar tm-pgp::good-signature-regexp-alist
127 '((en . "Good signature from user.*$"))
128 "Alist of language vs regexp to detect ``Good signature''.")
129
130 (defvar tm-pgp::key-expected-regexp-alist
131 '((en . "Key matching expected Key ID \\(\\S +\\) not found"))
132 "Alist of language vs regexp to detect ``Key expected''.")
133
134 (defun mime::article/call-pgp-to-check-signature (output-buffer orig-file)
135 (save-excursion
136 (set-buffer output-buffer)
137 (erase-buffer)
138 )
139 (let* ((lang (or tm-pgp::default-language 'en))
140 (status
141 (call-process-region (point-min)(point-max)
142 "pgp" nil output-buffer nil orig-file
143 (format "+language=%s" lang)
144 ))
145 (regexp (cdr (assq lang tm-pgp::good-signature-regexp-alist)))
146 )
147 (if (= status 0)
148 (save-excursion
149 (set-buffer output-buffer)
150 (goto-char (point-min))
151 (message
152 (cond ((not (stringp regexp))
153 "Please specify right regexp for specified language")
154 ((re-search-forward regexp nil t)
155 (buffer-substring (match-beginning 0) (match-end 0))
156 )
157 (t
158 "Bad signature"
159 )))
160 ))))
161
162 (defun mime-article/check-pgp-signature (beg end cal)
163 (let* ((encoding (cdr (assq 'encoding cal)))
164 (cnum (mime-article/point-content-number beg))
165 (rcnum (reverse cnum))
166 (rmcnum (cdr rcnum))
167 (knum (car rcnum))
168 (onum (if (> knum 0)
169 (1- knum)
170 (1+ knum)))
171 (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum)
172 mime::article/content-info))
173 status str kbuf
174 (basename (expand-file-name "tm" mime/tmp-dir))
175 (orig-file (make-temp-name basename))
176 (sig-file (concat orig-file ".sig"))
177 )
178 (save-excursion
179 (setq str (buffer-substring
180 (mime::content-info/point-min oinfo)
181 (mime::content-info/point-max oinfo)
182 ))
183 (set-buffer (get-buffer-create mime/temp-buffer-name))
184 (insert str)
185 (goto-char (point-min))
186 (while (re-search-forward "\n" nil t)
187 (replace-match "\r\n")
188 )
189 (let ((mc-flag nil) ; for Mule
190 (file-coding-system *noconv*)
191 kanji-flag ; for NEmacs
192 (emx-binary-mode t) ; for OS/2
193 jka-compr-compression-info-list ; for jka-compr
194 jam-zcat-filename-list ; for jam-zcat
195 require-final-newline)
196 (write-file orig-file)
197 )
198 (kill-buffer (current-buffer))
199 )
200 (save-excursion
201 (mime-article/show-output-buffer)
202 )
203 (save-excursion
204 (setq str (buffer-substring
205 (save-excursion
206 (goto-char beg)
207 (and (search-forward "\n\n")
208 (match-end 0)))
209 end))
210 (set-buffer (setq kbuf (get-buffer-create mime/temp-buffer-name)))
211 (insert str)
212 (mime-decode-region (point-min)(point-max) encoding)
213 (let ((mc-flag nil) ; for Mule
214 (file-coding-system *noconv*)
215 kanji-flag ; for NEmacs
216 (emx-binary-mode t) ; for OS/2
217 jka-compr-compression-info-list ; for jka-compr
218 jam-zcat-filename-list ; for jam-zcat
219 require-final-newline)
220 (write-file sig-file)
221 )
222 ;;(get-buffer-create mime/output-buffer-name)
223 (or (mime::article/call-pgp-to-check-signature
224 mime/output-buffer-name orig-file)
225 (let (pgp-id)
226 (save-excursion
227 (set-buffer mime/output-buffer-name)
228 (goto-char (point-min))
229 (let ((regexp (cdr (assq (or tm-pgp::default-language 'en)
230 tm-pgp::key-expected-regexp-alist))))
231 (cond ((not (stringp regexp))
232 (message
233 "Please specify right regexp for specified language")
234 )
235 ((re-search-forward regexp nil t)
236 (setq pgp-id
237 (concat "0x" (buffer-substring-no-properties
238 (match-beginning 1)
239 (match-end 1))))
240 ))))
241 (if (and pgp-id
242 (y-or-n-p
243 (format "Key %s not found; attempt to fetch? " pgp-id))
244 )
245 (progn
246 (mc-pgp-fetch-key (cons nil pgp-id))
247 (mime::article/call-pgp-to-check-signature
248 mime/output-buffer-name orig-file)
249 ))
250 ))
251 (let ((other-window-scroll-buffer mime/output-buffer-name))
252 (scroll-other-window 8)
253 )
254 (kill-buffer kbuf)
255 (delete-file orig-file)
256 (delete-file sig-file)
257 )))
258
259 (set-atype 'mime/content-decoding-condition
260 '((type . "application/pgp-signature")
261 (method . mime-article/check-pgp-signature)
262 ))
263
264
265 ;;; @ Internal method for application/pgp-encrypted
266 ;;;
267 ;;; It is based on draft-elkins-pem-pgp-02.txt
268
269 (defun mime-article/decrypt-pgp (beg end cal)
270 (let* ((cnum (mime-article/point-content-number beg))
271 (rcnum (reverse cnum))
272 (rmcnum (cdr rcnum))
273 (knum (car rcnum))
274 (onum (if (> knum 0)
275 (1- knum)
276 (1+ knum)))
277 (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum)
278 mime::article/content-info))
279 (obeg (mime::content-info/point-min oinfo))
280 (oend (mime::content-info/point-max oinfo))
281 )
282 (mime-article/view-application/pgp obeg oend cal)
283 ))
284
285 (set-atype 'mime/content-decoding-condition
286 '((type . "application/pgp-encrypted")
287 (method . mime-article/decrypt-pgp)
288 ))
289
290
291 ;;; @ Internal method for application/pgp-keys
292 ;;;
293 ;;; It is based on draft-elkins-pem-pgp-02.txt
294
295 (autoload 'mc-snarf-keys "mc-toplev")
296
297 (defun mime-article/add-pgp-keys (beg end cal)
298 (let* ((cnum (mime-article/point-content-number beg))
299 (cur-buf (current-buffer))
300 (new-name (format "%s-%s" (buffer-name) cnum))
301 (mother mime::article/preview-buffer)
302 (charset (cdr (assoc "charset" cal)))
303 (encoding (cdr (assq 'encoding cal)))
304 (mode major-mode)
305 str)
306 (setq str (buffer-substring beg end))
307 (switch-to-buffer new-name)
308 (setq buffer-read-only nil)
309 (erase-buffer)
310 (insert str)
311 (goto-char (point-min))
312 (if (re-search-forward "^\n" nil t)
313 (delete-region (point-min) (match-end 0))
314 )
315 (mime-decode-region (point-min)(point-max) encoding)
316 (mc-snarf-keys)
317 (kill-buffer (current-buffer))
318 ))
319
320 (set-atype 'mime/content-decoding-condition
321 '((type . "application/pgp-keys")
322 (method . mime-article/add-pgp-keys)
323 ))
324
325
326 ;;; @ end
327 ;;;
328
329 (provide 'tm-pgp)
330
331 (run-hooks 'tm-pgp-load-hook)
332
333 ;;; tm-pgp.el ends here