|
0
|
1 ;; mc-pgp.el, PGP support for Mailcrypt
|
|
|
2 ;; Copyright (C) 1995 Jin Choi <jin@atype.com>
|
|
|
3 ;; Patrick LoPresti <patl@lcs.mit.edu>
|
|
|
4
|
|
|
5 ;;{{{ Licensing
|
|
|
6 ;; This file is intended to be used with GNU Emacs.
|
|
|
7
|
|
|
8 ;; This program is free software; you can redistribute it and/or modify
|
|
|
9 ;; it under the terms of the GNU General Public License as published by
|
|
|
10 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
11 ;; any later version.
|
|
|
12
|
|
|
13 ;; This program is distributed in the hope that it will be useful,
|
|
|
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
16 ;; GNU General Public License for more details.
|
|
|
17
|
|
|
18 ;; You should have received a copy of the GNU General Public License
|
|
|
19 ;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
|
20 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
21 ;;}}}
|
|
|
22 (require 'mailcrypt)
|
|
|
23
|
|
|
24 (defvar mc-pgp-user-id (user-login-name)
|
|
|
25 "*PGP ID of your default identity.")
|
|
|
26 (defvar mc-pgp-always-sign nil
|
|
|
27 "*If t, always sign encrypted PGP messages, or never sign if 'never.")
|
|
|
28 (defvar mc-pgp-path "pgp" "*The PGP executable.")
|
|
|
29 (defvar mc-pgp-display-snarf-output nil
|
|
|
30 "*If t, pop up the PGP output window when snarfing keys.")
|
|
|
31 (defvar mc-pgp-alternate-keyring nil
|
|
|
32 "*Public keyring to use instead of default.")
|
|
|
33 (defvar mc-pgp-comment
|
|
|
34 (format "Processed by Mailcrypt %s, an Emacs/PGP interface" mc-version)
|
|
|
35 "*Comment field to appear in ASCII armor output. If nil, let PGP
|
|
|
36 use its default.")
|
|
|
37
|
|
|
38 (defconst mc-pgp-msg-begin-line "-----BEGIN PGP MESSAGE-----"
|
|
|
39 "Text for start of PGP message delimiter.")
|
|
|
40 (defconst mc-pgp-msg-end-line "-----END PGP MESSAGE-----\n?"
|
|
|
41 "Text for end of PGP message delimiter.")
|
|
|
42 (defconst mc-pgp-signed-begin-line "-----BEGIN PGP SIGNED MESSAGE-----"
|
|
|
43 "Text for start of PGP signed messages.")
|
|
|
44 (defconst mc-pgp-signed-end-line "-----END PGP SIGNATURE-----"
|
|
|
45 "Text for end of PGP signed messages.")
|
|
|
46 (defconst mc-pgp-key-begin-line "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
|
|
|
47 "Text for start of PGP public key.")
|
|
|
48 (defconst mc-pgp-key-end-line "^-----END PGP PUBLIC KEY BLOCK-----\r?$"
|
|
|
49 "Text for end of PGP public key.")
|
|
|
50 (defconst mc-pgp-error-re "^\\(ERROR:\\|WARNING:\\).*"
|
|
|
51 "Regular expression matching an error from PGP")
|
|
|
52 (defconst mc-pgp-sigok-re "^.*Good signature.*"
|
|
|
53 "Regular expression matching a PGP signature validation message")
|
|
|
54 (defconst mc-pgp-newkey-re "^[ \t]*\\(No\\|[0-9]+\\) +new [ku].*"
|
|
|
55 "Regular expression matching a PGP key snarf message")
|
|
|
56 (defconst mc-pgp-nokey-re
|
|
|
57 "Cannot find the public key matching userid '\\(.+\\)'$"
|
|
|
58 "Regular expression matching a PGP missing-key messsage")
|
|
|
59 (defconst mc-pgp-key-expected-re
|
|
|
60 "Key matching expected Key ID \\(\\S +\\) not found")
|
|
|
61
|
|
|
62 (defvar mc-pgp-keydir nil
|
|
|
63 "Directory in which keyrings are stored.")
|
|
|
64
|
|
|
65 (defun mc-get-pgp-keydir ()
|
|
|
66 (if (null mc-pgp-keydir)
|
|
|
67 (let ((buffer (generate-new-buffer " *mailcrypt temp*"))
|
|
|
68 (obuf (current-buffer)))
|
|
|
69 (unwind-protect
|
|
|
70 (progn
|
|
|
71 (call-process mc-pgp-path nil buffer nil "+verbose=1"
|
|
|
72 "+language=en" "-kv" "XXXXXXXXXX")
|
|
|
73 (set-buffer buffer)
|
|
|
74 (goto-char (point-min))
|
|
|
75 (re-search-forward "^Key ring:\\s *'\\(.*\\)'")
|
|
|
76 (setq mc-pgp-keydir
|
|
|
77 (file-name-directory
|
|
|
78 (buffer-substring-no-properties
|
|
|
79 (match-beginning 1) (match-end 1)))))
|
|
|
80 (set-buffer obuf)
|
|
|
81 (kill-buffer buffer))))
|
|
|
82 mc-pgp-keydir)
|
|
|
83
|
|
|
84 (defvar mc-pgp-key-cache nil
|
|
|
85 "Association list mapping PGP IDs to canonical \"keys\". A \"key\"
|
|
|
86 is a pair (USER-ID . KEY-ID) which identifies the canonical IDs of the
|
|
|
87 PGP ID.")
|
|
|
88
|
|
|
89 (defun mc-pgp-lookup-key (str)
|
|
|
90 ;; Look up the string STR in the user's secret key ring. Return a
|
|
|
91 ;; pair of strings (USER-ID . KEY-ID) which uniquely identifies the
|
|
|
92 ;; matching key, or nil if no key matches.
|
|
|
93 (if (equal str "***** CONVENTIONAL *****") nil
|
|
|
94 (let ((keyring (concat (mc-get-pgp-keydir) "secring"))
|
|
|
95 (result (cdr-safe (assoc str mc-pgp-key-cache)))
|
|
|
96 (key-regexp
|
|
|
97 "^\\(pub\\|sec\\)\\s +[^/]+/\\(\\S *\\)\\s +\\S +\\s +\\(.*\\)$")
|
|
|
98 (obuf (current-buffer))
|
|
|
99 buffer)
|
|
|
100 (if (null result)
|
|
|
101 (unwind-protect
|
|
|
102 (progn
|
|
|
103 (setq buffer (generate-new-buffer " *mailcrypt temp"))
|
|
|
104 (call-process mc-pgp-path nil buffer nil
|
|
|
105 "+language=en" "-kv" str keyring)
|
|
|
106 (set-buffer buffer)
|
|
|
107 (goto-char (point-min))
|
|
|
108 (if (re-search-forward key-regexp nil t)
|
|
|
109 (progn
|
|
|
110 (setq result
|
|
|
111 (cons (buffer-substring-no-properties
|
|
|
112 (match-beginning 3) (match-end 3))
|
|
|
113 (concat
|
|
|
114 "0x"
|
|
|
115 (buffer-substring-no-properties
|
|
|
116 (match-beginning 2) (match-end 2)))))
|
|
|
117 (setq mc-pgp-key-cache (cons (cons str result)
|
|
|
118 mc-pgp-key-cache)))))
|
|
|
119 (if buffer (kill-buffer buffer))
|
|
|
120 (set-buffer obuf)))
|
|
|
121 (if (null result)
|
|
|
122 (error "No PGP secret key for %s" str))
|
|
|
123 result)))
|
|
|
124
|
|
|
125 (defun mc-pgp-generic-parser (result)
|
|
|
126 (let (start)
|
|
|
127 (goto-char (point-min))
|
|
|
128 (cond ((not (eq result 0))
|
|
|
129 (prog1
|
|
|
130 nil
|
|
|
131 (if (mc-message "^\aError: +Bad pass phrase\\.$" (current-buffer))
|
|
|
132 (mc-deactivate-passwd t)
|
|
|
133 (mc-message mc-pgp-error-re (current-buffer)
|
|
|
134 (format "PGP exited with status %d" result)))))
|
|
|
135 ((re-search-forward mc-pgp-nokey-re nil t)
|
|
|
136 nil)
|
|
|
137 (t
|
|
|
138 (and
|
|
|
139 (goto-char (point-min))
|
|
|
140 (re-search-forward "-----BEGIN PGP.*-----$" nil t)
|
|
|
141 (setq start (match-beginning 0))
|
|
|
142 (goto-char (point-max))
|
|
|
143 (re-search-backward "^-----END PGP.*-----\n" nil t)
|
|
|
144 (cons start (match-end 0)))))))
|
|
|
145
|
|
|
146 (defun mc-pgp-encrypt-region (recipients start end &optional id sign)
|
|
|
147 (let ((process-environment process-environment)
|
|
|
148 (buffer (get-buffer-create mc-buffer-name))
|
|
|
149 ;; Crock. Rewrite someday.
|
|
|
150 (mc-pgp-always-sign mc-pgp-always-sign)
|
|
|
151 (obuf (current-buffer))
|
|
|
152 action msg args key passwd result pgp-id)
|
|
|
153 (setq args (list "+encrypttoself=off +verbose=1" "+batchmode"
|
|
|
154 "+language=en" "-fat"))
|
|
|
155 (setq action (if recipients "Encrypting" "Armoring"))
|
|
|
156 (setq msg (format "%s..." action)) ; May get overridden below
|
|
|
157 (if recipients (setq args (cons "-e" args)))
|
|
|
158 (if mc-pgp-comment
|
|
|
159 (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
|
|
|
160 (if mc-pgp-alternate-keyring
|
|
|
161 (setq args (append args (list (format "+pubring=%s"
|
|
|
162 mc-pgp-alternate-keyring)))))
|
|
|
163 (if (and (not (eq mc-pgp-always-sign 'never))
|
|
|
164 (or mc-pgp-always-sign sign (y-or-n-p "Sign the message? ")))
|
|
|
165 (progn
|
|
|
166 (setq mc-pgp-always-sign t)
|
|
|
167 (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
|
|
|
168 (setq passwd
|
|
|
169 (mc-activate-passwd
|
|
|
170 (cdr key)
|
|
|
171 (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
|
|
|
172 (setq args
|
|
|
173 (nconc args (list "-s" "-u" (cdr key))))
|
|
|
174 (setenv "PGPPASSFD" "0")
|
|
|
175 (setq msg (format "%s+signing as %s ..." action (car key))))
|
|
|
176 (setq mc-pgp-always-sign 'never))
|
|
|
177
|
|
|
178 (or key
|
|
|
179 (setq key (mc-pgp-lookup-key mc-pgp-user-id)))
|
|
|
180
|
|
|
181 (if (and recipients mc-encrypt-for-me)
|
|
|
182 (setq recipients (cons (cdr key) recipients)))
|
|
|
183
|
|
|
184 (setq args (append args recipients))
|
|
|
185
|
|
|
186 (message "%s" msg)
|
|
|
187 (setq result (mc-process-region start end passwd mc-pgp-path args
|
|
|
188 'mc-pgp-generic-parser buffer))
|
|
|
189 (save-excursion
|
|
|
190 (set-buffer buffer)
|
|
|
191 (goto-char (point-min))
|
|
|
192 (if (re-search-forward mc-pgp-nokey-re nil t)
|
|
|
193 (progn
|
|
|
194 (if result (error "This should never happen."))
|
|
|
195 (setq pgp-id (buffer-substring-no-properties
|
|
|
196 (match-beginning 1) (match-end 1)))
|
|
|
197 (if (and (not (eq mc-pgp-always-fetch 'never))
|
|
|
198 (or mc-pgp-always-fetch
|
|
|
199 (y-or-n-p
|
|
|
200 (format "Key for '%s' not found; try to fetch? "
|
|
|
201 pgp-id))))
|
|
|
202 (progn
|
|
|
203 (mc-pgp-fetch-key (cons pgp-id nil))
|
|
|
204 (set-buffer obuf)
|
|
|
205 (mc-pgp-encrypt-region recipients start end id))
|
|
|
206 (mc-message mc-pgp-nokey-re buffer)
|
|
|
207 nil))
|
|
|
208 (if (not result)
|
|
|
209 nil
|
|
|
210 (message "%s Done." msg)
|
|
|
211 t)))))
|
|
|
212
|
|
|
213 (defun mc-pgp-decrypt-parser (result)
|
|
|
214 (goto-char (point-min))
|
|
|
215 (cond ((eq result 0)
|
|
|
216 ;; Valid signature
|
|
|
217 (re-search-forward "^Signature made.*\n")
|
|
|
218 (if (looking-at
|
|
|
219 "\a\nWARNING: Because this public key.*\n.*\n.*\n")
|
|
|
220 (goto-char (match-end 0)))
|
|
|
221 (cons (point) (point-max)))
|
|
|
222 ((eq result 1)
|
|
|
223 (re-search-forward
|
|
|
224 "\\(\\(^File is conven.*\\)?Just a moment\\.+\\)\\|\\(^\\.\\)")
|
|
|
225 (if (eq (match-beginning 2) (match-end 2))
|
|
|
226 (if (looking-at
|
|
|
227 "\nFile has signature.*\\(\n\a.*\n\\)*\nWARNING:.*\n")
|
|
|
228 (goto-char (match-end 0)))
|
|
|
229 (if (looking-at "Pass phrase appears good\\. \\.")
|
|
|
230 (goto-char (match-end 0))))
|
|
|
231 (cons (point) (point-max)))
|
|
|
232 (t nil)))
|
|
|
233
|
|
|
234 (defun mc-pgp-decrypt-region (start end &optional id)
|
|
|
235 ;; returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if
|
|
|
236 ;; the decryption succeeded and verified is t if there was a valid signature
|
|
|
237 (let ((process-environment process-environment)
|
|
|
238 (buffer (get-buffer-create mc-buffer-name))
|
|
|
239 args key new-key passwd result pgp-id)
|
|
|
240 (undo-boundary)
|
|
|
241 (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
|
|
|
242 (setq
|
|
|
243 passwd
|
|
|
244 (if key
|
|
|
245 (mc-activate-passwd (cdr key)
|
|
|
246 (and id
|
|
|
247 (format "PGP passphrase for %s (%s): "
|
|
|
248 (car key) (cdr key))))
|
|
|
249 (mc-activate-passwd id "PGP passphrase for conventional decryption: ")))
|
|
|
250 (if passwd
|
|
|
251 (setenv "PGPPASSFD" "0"))
|
|
|
252 (setq args '("+verbose=1" "+batchmode" "+language=en" "-f"))
|
|
|
253 (if mc-pgp-alternate-keyring
|
|
|
254 (setq args (append args (list (format "+pubring=%s"
|
|
|
255 mc-pgp-alternate-keyring)))))
|
|
|
256 (message "Decrypting...")
|
|
|
257 (setq result
|
|
|
258 (mc-process-region
|
|
|
259 start end passwd mc-pgp-path args 'mc-pgp-decrypt-parser buffer))
|
|
|
260 (cond
|
|
|
261 (result
|
|
|
262 (message "Decrypting... Done.")
|
|
|
263 ;; If verification failed due to missing key, offer to fetch it.
|
|
|
264 (save-excursion
|
|
|
265 (set-buffer buffer)
|
|
|
266 (goto-char (point-min))
|
|
|
267 (if (re-search-forward mc-pgp-key-expected-re nil t)
|
|
|
268 (setq pgp-id (concat "0x" (buffer-substring-no-properties
|
|
|
269 (match-beginning 1)
|
|
|
270 (match-end 1))))))
|
|
|
271 (if (and pgp-id
|
|
|
272 (not (eq mc-pgp-always-fetch 'never))
|
|
|
273 (or mc-pgp-always-fetch
|
|
|
274 (y-or-n-p
|
|
|
275 (format "Key %s not found; attempt to fetch? " pgp-id)))
|
|
|
276 (mc-pgp-fetch-key (cons nil pgp-id)))
|
|
|
277 (progn
|
|
|
278 (undo-start)
|
|
|
279 (undo-more 1)
|
|
|
280 (mc-pgp-decrypt-region start end id))
|
|
|
281 (mc-message mc-pgp-key-expected-re buffer)
|
|
|
282 (cons t (eq result 0))))
|
|
|
283 ;; Decryption failed; maybe we need to use a different user-id
|
|
|
284 ((save-excursion
|
|
|
285 (and
|
|
|
286 (set-buffer buffer)
|
|
|
287 (goto-char (point-min))
|
|
|
288 (re-search-forward
|
|
|
289 "^Key for user ID:.*\n.*Key ID \\([0-9A-F]+\\)" nil t)
|
|
|
290 (setq new-key
|
|
|
291 (mc-pgp-lookup-key
|
|
|
292 (concat "0x" (buffer-substring-no-properties
|
|
|
293 (match-beginning 1)
|
|
|
294 (match-end 1)))))
|
|
|
295 (not (and id (equal key new-key)))))
|
|
|
296 (mc-pgp-decrypt-region start end (cdr new-key)))
|
|
|
297 ;; Or maybe it is conventionally encrypted
|
|
|
298 ((save-excursion
|
|
|
299 (and
|
|
|
300 (set-buffer buffer)
|
|
|
301 (goto-char (point-min))
|
|
|
302 (re-search-forward "^File is conventionally encrypted" nil t)))
|
|
|
303 (if (null key) (mc-deactivate-passwd t))
|
|
|
304 (mc-pgp-decrypt-region start end "***** CONVENTIONAL *****"))
|
|
|
305 (t
|
|
|
306 (mc-display-buffer buffer)
|
|
|
307 (if (mc-message "^\aError: +Bad pass phrase\\.$" buffer)
|
|
|
308 (mc-deactivate-passwd t)
|
|
|
309 (mc-message mc-pgp-error-re buffer "Error decrypting buffer"))
|
|
|
310 (cons nil nil)))))
|
|
|
311
|
|
|
312 (defun mc-pgp-sign-region (start end &optional id unclear)
|
|
|
313 (let ((process-environment process-environment)
|
|
|
314 (buffer (get-buffer-create mc-buffer-name))
|
|
|
315 passwd args key)
|
|
|
316 (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
|
|
|
317 (setq passwd
|
|
|
318 (mc-activate-passwd
|
|
|
319 (cdr key)
|
|
|
320 (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
|
|
|
321 (setenv "PGPPASSFD" "0")
|
|
|
322 (setq args
|
|
|
323 (list
|
|
|
324 "-fast" "+verbose=1" "+language=en"
|
|
|
325 (format "+clearsig=%s" (if unclear "off" "on"))
|
|
|
326 "+batchmode" "-u" (cdr key)))
|
|
|
327 (if mc-pgp-comment
|
|
|
328 (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
|
|
|
329 (message "Signing as %s ..." (car key))
|
|
|
330 (if (mc-process-region start end passwd mc-pgp-path args
|
|
|
331 'mc-pgp-generic-parser buffer)
|
|
|
332 (progn
|
|
|
333 (message "Signing as %s ... Done." (car key))
|
|
|
334 t)
|
|
|
335 nil)))
|
|
|
336
|
|
|
337 (defun mc-pgp-verify-parser (result)
|
|
|
338 (cond ((eq result 0)
|
|
|
339 (mc-message mc-pgp-sigok-re (current-buffer) "Good signature")
|
|
|
340 t)
|
|
|
341 ((eq result 1)
|
|
|
342 (mc-message mc-pgp-error-re (current-buffer) "Bad signature")
|
|
|
343 nil)
|
|
|
344 (t
|
|
|
345 (mc-message mc-pgp-error-re (current-buffer)
|
|
|
346 (format "PGP exited with status %d" result))
|
|
|
347 nil)))
|
|
|
348
|
|
|
349 (defun mc-pgp-verify-region (start end &optional no-fetch)
|
|
|
350 (let ((buffer (get-buffer-create mc-buffer-name))
|
|
|
351 (obuf (current-buffer))
|
|
|
352 args pgp-id)
|
|
|
353 (setq args '("+verbose=1" "+batchmode" "+language=en" "-f"))
|
|
|
354 (if mc-pgp-alternate-keyring
|
|
|
355 (setq args (append args (list (format "+pubring=%s"
|
|
|
356 mc-pgp-alternate-keyring)))))
|
|
|
357 (message "Verifying...")
|
|
|
358 (if (mc-process-region
|
|
|
359 start end nil mc-pgp-path args 'mc-pgp-verify-parser buffer)
|
|
|
360 t
|
|
|
361 (save-excursion
|
|
|
362 (set-buffer buffer)
|
|
|
363 (goto-char (point-min))
|
|
|
364 (if (and
|
|
|
365 (not no-fetch)
|
|
|
366 (re-search-forward mc-pgp-key-expected-re nil t)
|
|
|
367 (setq pgp-id
|
|
|
368 (concat "0x" (buffer-substring-no-properties
|
|
|
369 (match-beginning 1)
|
|
|
370 (match-end 1))))
|
|
|
371 (not (eq mc-pgp-always-fetch 'never))
|
|
|
372 (or mc-pgp-always-fetch
|
|
|
373 (y-or-n-p
|
|
|
374 (format "Key %s not found; attempt to fetch? " pgp-id)))
|
|
|
375 (mc-pgp-fetch-key (cons nil pgp-id))
|
|
|
376 (set-buffer obuf))
|
|
|
377 (mc-pgp-verify-region start end t)
|
|
|
378 (mc-message mc-pgp-error-re buffer)
|
|
|
379 nil)))))
|
|
|
380
|
|
|
381 (defun mc-pgp-insert-public-key (&optional id)
|
|
|
382 (let ((buffer (get-buffer-create mc-buffer-name))
|
|
|
383 args)
|
|
|
384 (setq id (or id mc-pgp-user-id))
|
|
|
385 (setq args (list "+verbose=1" "+batchmode" "+language=en" "-kxaf" id))
|
|
|
386 (if mc-pgp-comment
|
|
|
387 (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
|
|
|
388 (if mc-pgp-alternate-keyring
|
|
|
389 (setq args (append args (list (format "+pubring=%s"
|
|
|
390 mc-pgp-alternate-keyring)))))
|
|
|
391
|
|
|
392 (if (mc-process-region (point) (point) nil mc-pgp-path
|
|
|
393 args 'mc-pgp-generic-parser buffer)
|
|
|
394 (progn
|
|
|
395 (mc-message "Key for user ID: .*" buffer)
|
|
|
396 t))))
|
|
|
397
|
|
|
398 (defun mc-pgp-snarf-parser (result)
|
|
|
399 (eq result 0))
|
|
|
400
|
|
|
401 (defun mc-pgp-snarf-keys (start end)
|
|
|
402 ;; Returns number of keys found.
|
|
|
403 (let ((buffer (get-buffer-create mc-buffer-name)) tmpstr args)
|
|
|
404 (setq args '("+verbose=1" "+batchmode" "+language=en" "-kaf"))
|
|
|
405 (if mc-pgp-alternate-keyring
|
|
|
406 (setq args (append args (list (format "+pubring=%s"
|
|
|
407 mc-pgp-alternate-keyring)))))
|
|
|
408 (message "Snarfing...")
|
|
|
409 (if (mc-process-region start end nil mc-pgp-path args
|
|
|
410 'mc-pgp-snarf-parser buffer)
|
|
|
411 (save-excursion
|
|
|
412 (set-buffer buffer)
|
|
|
413 (goto-char (point-min))
|
|
|
414 (if (re-search-forward mc-pgp-newkey-re nil t)
|
|
|
415 (progn
|
|
|
416 (if mc-pgp-display-snarf-output (mc-display-buffer buffer))
|
|
|
417 (setq tmpstr (buffer-substring-no-properties
|
|
|
418 (match-beginning 1)
|
|
|
419 (match-end 1)))
|
|
|
420 (if (equal tmpstr "No")
|
|
|
421 0
|
|
|
422 (car (read-from-string tmpstr))))))
|
|
|
423 (mc-display-buffer buffer)
|
|
|
424 (mc-message mc-pgp-error-re buffer "Error snarfing PGP keys")
|
|
|
425 0)))
|
|
|
426
|
|
|
427 ;;;###autoload
|
|
|
428 (defun mc-scheme-pgp ()
|
|
|
429 (list
|
|
|
430 (cons 'encryption-func 'mc-pgp-encrypt-region)
|
|
|
431 (cons 'decryption-func 'mc-pgp-decrypt-region)
|
|
|
432 (cons 'signing-func 'mc-pgp-sign-region)
|
|
|
433 (cons 'verification-func 'mc-pgp-verify-region)
|
|
|
434 (cons 'key-insertion-func 'mc-pgp-insert-public-key)
|
|
|
435 (cons 'snarf-func 'mc-pgp-snarf-keys)
|
|
|
436 (cons 'msg-begin-line mc-pgp-msg-begin-line)
|
|
|
437 (cons 'msg-end-line mc-pgp-msg-end-line)
|
|
|
438 (cons 'signed-begin-line mc-pgp-signed-begin-line)
|
|
|
439 (cons 'signed-end-line mc-pgp-signed-end-line)
|
|
|
440 (cons 'key-begin-line mc-pgp-key-begin-line)
|
|
|
441 (cons 'key-end-line mc-pgp-key-end-line)
|
|
|
442 (cons 'user-id mc-pgp-user-id)))
|
|
|
443
|
|
|
444 ;;{{{ Key fetching
|
|
|
445
|
|
|
446 (defvar mc-pgp-always-fetch nil
|
|
|
447 "*If t, always attempt to fetch missing keys, or never fetch if
|
|
|
448 'never.")
|
|
|
449
|
|
|
450 (defvar mc-pgp-keyserver-url-template
|
|
|
451 "/htbin/pks-extract-key.pl?op=get&search=%s"
|
|
|
452 "The URL to pass to the keyserver.")
|
|
|
453
|
|
|
454 (defvar mc-pgp-keyserver-address "pgp.ai.mit.edu"
|
|
|
455 "Host name of keyserver.")
|
|
|
456
|
|
|
457 (defvar mc-pgp-keyserver-port 80
|
|
|
458 "Port on which the keyserver's HTTP daemon lives.")
|
|
|
459
|
|
|
460 (defvar mc-pgp-fetch-timeout 20
|
|
|
461 "*Timeout, in seconds, for any particular key fetch operation.")
|
|
|
462
|
|
|
463 (defvar mc-pgp-fetch-keyring-list nil
|
|
|
464 "*List of strings which are filenames of public keyrings to search
|
|
|
465 when fetching keys.")
|
|
|
466
|
|
|
467 (defsubst mc-pgp-buffer-get-key (buf)
|
|
|
468 "Return the first key block in BUF as a string, or nil if none found."
|
|
|
469 (save-excursion
|
|
|
470 (let (start)
|
|
|
471 (set-buffer buf)
|
|
|
472 (goto-char (point-min))
|
|
|
473 (and (re-search-forward mc-pgp-key-begin-line nil t)
|
|
|
474 (setq start (match-beginning 0))
|
|
|
475 (re-search-forward mc-pgp-key-end-line nil t)
|
|
|
476 (buffer-substring-no-properties start (match-end 0))))))
|
|
|
477
|
|
|
478 (defun mc-pgp-fetch-from-keyrings (id)
|
|
|
479 (let ((keyring-list mc-pgp-fetch-keyring-list)
|
|
|
480 buf proc key)
|
|
|
481 (unwind-protect
|
|
|
482 (progn
|
|
|
483 (message "Fetching %s from keyrings..." (or (cdr id) (car id)))
|
|
|
484 (while (and (not key) keyring-list)
|
|
|
485 (setq buf (generate-new-buffer " *mailcrypt temp*"))
|
|
|
486 (setq proc
|
|
|
487 (start-process "*PGP*" buf mc-pgp-path "-kxaf"
|
|
|
488 "+verbose=0" "+batchmode"
|
|
|
489 (format "+pubring=%s" (car keyring-list))
|
|
|
490 (or (cdr id) (car id))))
|
|
|
491 ;; Because PGPPASSFD might be set
|
|
|
492 (process-send-string proc "\r\n")
|
|
|
493 (while (eq 'run (process-status proc))
|
|
|
494 (accept-process-output proc 5))
|
|
|
495 (setq key (mc-pgp-buffer-get-key buf))
|
|
|
496 (setq keyring-list (cdr keyring-list)))
|
|
|
497 key)
|
|
|
498 (if buf (kill-buffer buf))
|
|
|
499 (if (and proc (eq 'run (process-status proc)))
|
|
|
500 (interrupt-process proc)))))
|
|
|
501
|
|
|
502 (defun mc-pgp-fetch-from-http (id)
|
|
|
503 (let (buf connection)
|
|
|
504 (unwind-protect
|
|
|
505 (progn
|
|
|
506 (message "Fetching %s via HTTP to %s..."
|
|
|
507 (or (cdr id) (car id)) mc-pgp-keyserver-address)
|
|
|
508 (setq buf (generate-new-buffer " *mailcrypt temp*"))
|
|
|
509 (setq connection
|
|
|
510 (open-network-stream "*key fetch*" buf mc-pgp-keyserver-address
|
|
|
511 mc-pgp-keyserver-port))
|
|
|
512 (process-send-string
|
|
|
513 connection
|
|
|
514 (concat "GET " (format mc-pgp-keyserver-url-template
|
|
|
515 (or (cdr id) (car id))) "\r\n"))
|
|
|
516 (while (and (eq 'open (process-status connection))
|
|
|
517 (accept-process-output connection mc-pgp-fetch-timeout)))
|
|
|
518 (mc-pgp-buffer-get-key buf))
|
|
|
519 (if buf (kill-buffer buf))
|
|
|
520 (if connection (delete-process connection)))))
|
|
|
521
|
|
|
522 (defun mc-pgp-fetch-from-finger (id)
|
|
|
523 (let (buf connection user host)
|
|
|
524 (unwind-protect
|
|
|
525 (and (car id)
|
|
|
526 (string-match "^\\(.+\\)@\\([^@]+\\)$" (car id))
|
|
|
527 (progn
|
|
|
528 (message "Trying finger %s..." (car id))
|
|
|
529 (setq user (substring (car id)
|
|
|
530 (match-beginning 1) (match-end 1)))
|
|
|
531 (setq host (substring (car id)
|
|
|
532 (match-beginning 2) (match-end 2)))
|
|
|
533 (setq buf (generate-new-buffer " *mailcrypt temp*"))
|
|
|
534 (condition-case nil
|
|
|
535 (progn
|
|
|
536 (setq connection
|
|
|
537 (open-network-stream "*key fetch*" buf host 79))
|
|
|
538 (process-send-string connection
|
|
|
539 (concat "/W " user "\r\n"))
|
|
|
540 (while
|
|
|
541 (and (eq 'open (process-status connection))
|
|
|
542 (accept-process-output connection
|
|
|
543 mc-pgp-fetch-timeout)))
|
|
|
544 (mc-pgp-buffer-get-key buf))
|
|
|
545 (error nil))))
|
|
|
546 (if buf (kill-buffer buf))
|
|
|
547 (if connection (delete-process connection)))))
|
|
|
548
|
|
|
549 (defvar mc-pgp-fetch-methods '(mc-pgp-fetch-from-keyrings
|
|
|
550 mc-pgp-fetch-from-finger
|
|
|
551 mc-pgp-fetch-from-http)
|
|
|
552 "List of methods to try when attempting to fetch a key. Each
|
|
|
553 element is a function to call with an ID as argument. See the
|
|
|
554 documentation for the function mc-pgp-fetch-key for a description of
|
|
|
555 the ID.")
|
|
|
556
|
|
|
557 ;;;###autoload
|
|
|
558 (defun mc-pgp-fetch-key (&optional id)
|
|
|
559 "Attempt to fetch a key for addition to PGP keyring. Interactively,
|
|
|
560 prompt for string matching key to fetch.
|
|
|
561
|
|
|
562 Non-interactively, ID must be a pair. The CAR must be a bare Email
|
|
|
563 address and the CDR a keyID (with \"0x\" prefix). Either, but not
|
|
|
564 both, may be nil.
|
|
|
565
|
|
|
566 Return t if we think we were successful; nil otherwise. Note that nil
|
|
|
567 is not necessarily an error, since we may have merely fired off an Email
|
|
|
568 request for the key."
|
|
|
569 (interactive)
|
|
|
570 (let ((methods mc-pgp-fetch-methods)
|
|
|
571 (process-connection-type nil) key proc buf args)
|
|
|
572 (if (null id)
|
|
|
573 (setq id (cons (read-string "Fetch key for: ") nil)))
|
|
|
574 (while (and (not key) methods)
|
|
|
575 (setq key (funcall (car methods) id))
|
|
|
576 (setq methods (cdr methods)))
|
|
|
577 (if (not (stringp key))
|
|
|
578 (progn
|
|
|
579 (message "Key not found.")
|
|
|
580 nil)
|
|
|
581 ;; Maybe I'll do this right someday.
|
|
|
582 (unwind-protect
|
|
|
583 (save-window-excursion
|
|
|
584 (setq buf (generate-new-buffer " *PGP Key Info*"))
|
|
|
585 (pop-to-buffer buf)
|
|
|
586 (if (< (window-height) (/ (frame-height) 2))
|
|
|
587 (enlarge-window (- (/ (frame-height) 2)
|
|
|
588 (window-height))))
|
|
|
589 (setq args '("-f" "+verbose=0" "+batchmode"))
|
|
|
590 (if mc-pgp-alternate-keyring
|
|
|
591 (setq args
|
|
|
592 (append args (list (format "+pubring=%s"
|
|
|
593 mc-pgp-alternate-keyring)))))
|
|
|
594
|
|
|
595 (setq proc (apply 'start-process "*PGP*" buf mc-pgp-path args))
|
|
|
596 ;; Because PGPPASSFD might be set
|
|
|
597 (process-send-string proc "\r\n")
|
|
|
598 (process-send-string proc key)
|
|
|
599 (process-send-string proc "\r\n")
|
|
|
600 (process-send-eof proc)
|
|
|
601 (set-buffer buf)
|
|
|
602 (while (eq 'run (process-status proc))
|
|
|
603 (accept-process-output proc 5)
|
|
|
604 (goto-char (point-min)))
|
|
|
605 (if (y-or-n-p "Add this key to keyring? ")
|
|
|
606 (progn
|
|
|
607 (setq args (append args '("-ka")))
|
|
|
608 (setq proc
|
|
|
609 (apply 'start-process "*PGP*" buf mc-pgp-path args))
|
|
|
610 ;; Because PGPPASSFD might be set
|
|
|
611 (process-send-string proc "\r\n")
|
|
|
612 (process-send-string proc key)
|
|
|
613 (process-send-string proc "\r\n")
|
|
|
614 (process-send-eof proc)
|
|
|
615 (while (eq 'run (process-status proc))
|
|
|
616 (accept-process-output proc 5))
|
|
|
617 t)))
|
|
|
618 (if buf (kill-buffer buf))))))
|
|
|
619
|
|
|
620 ;;}}}
|
