88155
|
1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
|
|
2
|
|
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
|
|
4 ;; 2005 Free Software Foundation, Inc.
|
|
5
|
|
6 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
|
|
7 ;; Keywords: PGP MIME MML
|
|
8
|
|
9 ;; This file is part of GNU Emacs.
|
|
10
|
|
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
12 ;; it under the terms of the GNU General Public License as published
|
|
13 ;; by the Free Software Foundation; either version 2, or (at your
|
|
14 ;; option) any later version.
|
|
15
|
|
16 ;; GNU Emacs is distributed in the hope that it will be useful, but
|
|
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
19 ;; General Public License for more details.
|
|
20
|
|
21 ;; You should have received a copy of the GNU General Public License
|
|
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
24 ;; Boston, MA 02110-1301, USA.
|
|
25
|
|
26 ;;; Commentary:
|
|
27
|
|
28 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
|
|
29 ;; with both.
|
|
30
|
|
31 ;;; Code:
|
|
32
|
|
33 (eval-when-compile (require 'cl))
|
|
34 (require 'mm-decode)
|
|
35 (require 'mm-util)
|
|
36 (require 'mml)
|
|
37
|
|
38 (defvar mc-pgp-always-sign)
|
|
39
|
|
40 (defvar mml2015-use (or
|
|
41 (progn
|
|
42 (ignore-errors
|
|
43 (require 'pgg))
|
|
44 (and (fboundp 'pgg-sign-region)
|
|
45 'pgg))
|
|
46 (progn
|
|
47 (ignore-errors
|
|
48 (require 'gpg))
|
|
49 (and (fboundp 'gpg-sign-detached)
|
|
50 'gpg))
|
|
51 (progn (ignore-errors
|
|
52 (load "mc-toplev"))
|
|
53 (and (fboundp 'mc-encrypt-generic)
|
|
54 (fboundp 'mc-sign-generic)
|
|
55 (fboundp 'mc-cleanup-recipient-headers)
|
|
56 'mailcrypt)))
|
|
57 "The package used for PGP/MIME.")
|
|
58
|
|
59 ;; Something is not RFC2015.
|
|
60 (defvar mml2015-function-alist
|
|
61 '((mailcrypt mml2015-mailcrypt-sign
|
|
62 mml2015-mailcrypt-encrypt
|
|
63 mml2015-mailcrypt-verify
|
|
64 mml2015-mailcrypt-decrypt
|
|
65 mml2015-mailcrypt-clear-verify
|
|
66 mml2015-mailcrypt-clear-decrypt)
|
|
67 (gpg mml2015-gpg-sign
|
|
68 mml2015-gpg-encrypt
|
|
69 mml2015-gpg-verify
|
|
70 mml2015-gpg-decrypt
|
|
71 mml2015-gpg-clear-verify
|
|
72 mml2015-gpg-clear-decrypt)
|
|
73 (pgg mml2015-pgg-sign
|
|
74 mml2015-pgg-encrypt
|
|
75 mml2015-pgg-verify
|
|
76 mml2015-pgg-decrypt
|
|
77 mml2015-pgg-clear-verify
|
|
78 mml2015-pgg-clear-decrypt))
|
|
79 "Alist of PGP/MIME functions.")
|
|
80
|
|
81 (defvar mml2015-result-buffer nil)
|
|
82
|
|
83 (defcustom mml2015-unabbrev-trust-alist
|
|
84 '(("TRUST_UNDEFINED" . nil)
|
|
85 ("TRUST_NEVER" . nil)
|
|
86 ("TRUST_MARGINAL" . t)
|
|
87 ("TRUST_FULLY" . t)
|
|
88 ("TRUST_ULTIMATE" . t))
|
|
89 "Map GnuPG trust output values to a boolean saying if you trust the key."
|
|
90 :version "22.1"
|
|
91 :group 'mime-security
|
|
92 :type '(repeat (cons (regexp :tag "GnuPG output regexp")
|
|
93 (boolean :tag "Trust key"))))
|
|
94
|
|
95 ;;; mailcrypt wrapper
|
|
96
|
|
97 (eval-and-compile
|
|
98 (autoload 'mailcrypt-decrypt "mailcrypt")
|
|
99 (autoload 'mailcrypt-verify "mailcrypt")
|
|
100 (autoload 'mc-pgp-always-sign "mailcrypt")
|
|
101 (autoload 'mc-encrypt-generic "mc-toplev")
|
|
102 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
|
|
103 (autoload 'mc-sign-generic "mc-toplev"))
|
|
104
|
|
105 (eval-when-compile
|
|
106 (defvar mc-default-scheme)
|
|
107 (defvar mc-schemes))
|
|
108
|
|
109 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
|
|
110 (defvar mml2015-verify-function 'mailcrypt-verify)
|
|
111
|
|
112 (defun mml2015-format-error (err)
|
|
113 (if (stringp (cadr err))
|
|
114 (cadr err)
|
|
115 (format "%S" (cdr err))))
|
|
116
|
|
117 (defun mml2015-mailcrypt-decrypt (handle ctl)
|
|
118 (catch 'error
|
|
119 (let (child handles result)
|
|
120 (unless (setq child (mm-find-part-by-type
|
|
121 (cdr handle)
|
|
122 "application/octet-stream" nil t))
|
|
123 (mm-set-handle-multipart-parameter
|
|
124 mm-security-handle 'gnus-info "Corrupted")
|
|
125 (throw 'error handle))
|
|
126 (with-temp-buffer
|
|
127 (mm-insert-part child)
|
|
128 (setq result
|
|
129 (condition-case err
|
|
130 (funcall mml2015-decrypt-function)
|
|
131 (error
|
|
132 (mm-set-handle-multipart-parameter
|
|
133 mm-security-handle 'gnus-details (mml2015-format-error err))
|
|
134 nil)
|
|
135 (quit
|
|
136 (mm-set-handle-multipart-parameter
|
|
137 mm-security-handle 'gnus-details "Quit.")
|
|
138 nil)))
|
|
139 (unless (car result)
|
|
140 (mm-set-handle-multipart-parameter
|
|
141 mm-security-handle 'gnus-info "Failed")
|
|
142 (throw 'error handle))
|
|
143 (setq handles (mm-dissect-buffer t)))
|
|
144 (mm-destroy-parts handle)
|
|
145 (mm-set-handle-multipart-parameter
|
|
146 mm-security-handle 'gnus-info
|
|
147 (concat "OK"
|
|
148 (let ((sig (with-current-buffer mml2015-result-buffer
|
|
149 (mml2015-gpg-extract-signature-details))))
|
|
150 (concat ", Signer: " sig))))
|
|
151 (if (listp (car handles))
|
|
152 handles
|
|
153 (list handles)))))
|
|
154
|
|
155 (defun mml2015-mailcrypt-clear-decrypt ()
|
|
156 (let (result)
|
|
157 (setq result
|
|
158 (condition-case err
|
|
159 (funcall mml2015-decrypt-function)
|
|
160 (error
|
|
161 (mm-set-handle-multipart-parameter
|
|
162 mm-security-handle 'gnus-details (mml2015-format-error err))
|
|
163 nil)
|
|
164 (quit
|
|
165 (mm-set-handle-multipart-parameter
|
|
166 mm-security-handle 'gnus-details "Quit.")
|
|
167 nil)))
|
|
168 (if (car result)
|
|
169 (mm-set-handle-multipart-parameter
|
|
170 mm-security-handle 'gnus-info "OK")
|
|
171 (mm-set-handle-multipart-parameter
|
|
172 mm-security-handle 'gnus-info "Failed"))))
|
|
173
|
|
174 (defun mml2015-fix-micalg (alg)
|
|
175 (and alg
|
|
176 ;; Mutt/1.2.5i has seen sending micalg=php-sha1
|
|
177 (upcase (if (string-match "^p[gh]p-" alg)
|
|
178 (substring alg (match-end 0))
|
|
179 alg))))
|
|
180
|
|
181 (defun mml2015-mailcrypt-verify (handle ctl)
|
|
182 (catch 'error
|
|
183 (let (part)
|
|
184 (unless (setq part (mm-find-raw-part-by-type
|
|
185 ctl (or (mm-handle-multipart-ctl-parameter
|
|
186 ctl 'protocol)
|
|
187 "application/pgp-signature")
|
|
188 t))
|
|
189 (mm-set-handle-multipart-parameter
|
|
190 mm-security-handle 'gnus-info "Corrupted")
|
|
191 (throw 'error handle))
|
|
192 (with-temp-buffer
|
|
193 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
|
|
194 (insert (format "Hash: %s\n\n"
|
|
195 (or (mml2015-fix-micalg
|
|
196 (mm-handle-multipart-ctl-parameter
|
|
197 ctl 'micalg))
|
|
198 "SHA1")))
|
|
199 (save-restriction
|
|
200 (narrow-to-region (point) (point))
|
|
201 (insert part "\n")
|
|
202 (goto-char (point-min))
|
|
203 (while (not (eobp))
|
|
204 (if (looking-at "^-")
|
|
205 (insert "- "))
|
|
206 (forward-line)))
|
|
207 (unless (setq part (mm-find-part-by-type
|
|
208 (cdr handle) "application/pgp-signature" nil t))
|
|
209 (mm-set-handle-multipart-parameter
|
|
210 mm-security-handle 'gnus-info "Corrupted")
|
|
211 (throw 'error handle))
|
|
212 (save-restriction
|
|
213 (narrow-to-region (point) (point))
|
|
214 (mm-insert-part part)
|
|
215 (goto-char (point-min))
|
|
216 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
|
|
217 (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
|
|
218 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
|
|
219 (replace-match "-----END PGP SIGNATURE-----" t t)))
|
|
220 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
|
|
221 (unless (condition-case err
|
|
222 (prog1
|
|
223 (funcall mml2015-verify-function)
|
|
224 (if (get-buffer " *mailcrypt stderr temp")
|
|
225 (mm-set-handle-multipart-parameter
|
|
226 mm-security-handle 'gnus-details
|
|
227 (with-current-buffer " *mailcrypt stderr temp"
|
|
228 (buffer-string))))
|
|
229 (if (get-buffer " *mailcrypt stdout temp")
|
|
230 (kill-buffer " *mailcrypt stdout temp"))
|
|
231 (if (get-buffer " *mailcrypt stderr temp")
|
|
232 (kill-buffer " *mailcrypt stderr temp"))
|
|
233 (if (get-buffer " *mailcrypt status temp")
|
|
234 (kill-buffer " *mailcrypt status temp"))
|
|
235 (if (get-buffer mc-gpg-debug-buffer)
|
|
236 (kill-buffer mc-gpg-debug-buffer)))
|
|
237 (error
|
|
238 (mm-set-handle-multipart-parameter
|
|
239 mm-security-handle 'gnus-details (mml2015-format-error err))
|
|
240 nil)
|
|
241 (quit
|
|
242 (mm-set-handle-multipart-parameter
|
|
243 mm-security-handle 'gnus-details "Quit.")
|
|
244 nil))
|
|
245 (mm-set-handle-multipart-parameter
|
|
246 mm-security-handle 'gnus-info "Failed")
|
|
247 (throw 'error handle))))
|
|
248 (mm-set-handle-multipart-parameter
|
|
249 mm-security-handle 'gnus-info "OK")
|
|
250 handle)))
|
|
251
|
|
252 (defun mml2015-mailcrypt-clear-verify ()
|
|
253 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
|
|
254 (if (condition-case err
|
|
255 (prog1
|
|
256 (funcall mml2015-verify-function)
|
|
257 (if (get-buffer " *mailcrypt stderr temp")
|
|
258 (mm-set-handle-multipart-parameter
|
|
259 mm-security-handle 'gnus-details
|
|
260 (with-current-buffer " *mailcrypt stderr temp"
|
|
261 (buffer-string))))
|
|
262 (if (get-buffer " *mailcrypt stdout temp")
|
|
263 (kill-buffer " *mailcrypt stdout temp"))
|
|
264 (if (get-buffer " *mailcrypt stderr temp")
|
|
265 (kill-buffer " *mailcrypt stderr temp"))
|
|
266 (if (get-buffer " *mailcrypt status temp")
|
|
267 (kill-buffer " *mailcrypt status temp"))
|
|
268 (if (get-buffer mc-gpg-debug-buffer)
|
|
269 (kill-buffer mc-gpg-debug-buffer)))
|
|
270 (error
|
|
271 (mm-set-handle-multipart-parameter
|
|
272 mm-security-handle 'gnus-details (mml2015-format-error err))
|
|
273 nil)
|
|
274 (quit
|
|
275 (mm-set-handle-multipart-parameter
|
|
276 mm-security-handle 'gnus-details "Quit.")
|
|
277 nil))
|
|
278 (mm-set-handle-multipart-parameter
|
|
279 mm-security-handle 'gnus-info "OK")
|
|
280 (mm-set-handle-multipart-parameter
|
|
281 mm-security-handle 'gnus-info "Failed"))))
|
|
282
|
|
283 (defun mml2015-mailcrypt-sign (cont)
|
|
284 (mc-sign-generic (message-options-get 'message-sender)
|
|
285 nil nil nil nil)
|
|
286 (let ((boundary (mml-compute-boundary cont))
|
|
287 hash point)
|
|
288 (goto-char (point-min))
|
|
289 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
|
|
290 (error "Cannot find signed begin line"))
|
|
291 (goto-char (match-beginning 0))
|
|
292 (forward-line 1)
|
|
293 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
|
|
294 (error "Cannot not find PGP hash"))
|
|
295 (setq hash (match-string 1))
|
|
296 (unless (re-search-forward "^$" nil t)
|
|
297 (error "Cannot not find PGP message"))
|
|
298 (forward-line 1)
|
|
299 (delete-region (point-min) (point))
|
|
300 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
|
|
301 boundary))
|
|
302 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
|
|
303 (downcase hash)))
|
|
304 (insert (format "\n--%s\n" boundary))
|
|
305 (setq point (point))
|
|
306 (goto-char (point-max))
|
|
307 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
|
|
308 (error "Cannot find signature part"))
|
|
309 (replace-match "-----END PGP MESSAGE-----" t t)
|
|
310 (goto-char (match-beginning 0))
|
|
311 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
|
|
312 nil t)
|
|
313 (error "Cannot find signature part"))
|
|
314 (replace-match "-----BEGIN PGP MESSAGE-----" t t)
|
|
315 (goto-char (match-beginning 0))
|
|
316 (save-restriction
|
|
317 (narrow-to-region point (point))
|
|
318 (goto-char point)
|
|
319 (while (re-search-forward "^- -" nil t)
|
|
320 (replace-match "-" t t))
|
|
321 (goto-char (point-max)))
|
|
322 (insert (format "--%s\n" boundary))
|
|
323 (insert "Content-Type: application/pgp-signature\n\n")
|
|
324 (goto-char (point-max))
|
|
325 (insert (format "--%s--\n" boundary))
|
|
326 (goto-char (point-max))))
|
|
327
|
|
328 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
|
|
329 (let ((mc-pgp-always-sign
|
|
330 (or mc-pgp-always-sign
|
|
331 sign
|
|
332 (eq t (or (message-options-get 'message-sign-encrypt)
|
|
333 (message-options-set
|
|
334 'message-sign-encrypt
|
|
335 (or (y-or-n-p "Sign the message? ")
|
|
336 'not))))
|
|
337 'never)))
|
|
338 (mm-with-unibyte-current-buffer
|
|
339 (mc-encrypt-generic
|
|
340 (or (message-options-get 'message-recipients)
|
|
341 (message-options-set 'message-recipients
|
|
342 (mc-cleanup-recipient-headers
|
|
343 (read-string "Recipients: "))))
|
|
344 nil nil nil
|
|
345 (message-options-get 'message-sender))))
|
|
346 (goto-char (point-min))
|
|
347 (unless (looking-at "-----BEGIN PGP MESSAGE-----")
|
|
348 (error "Fail to encrypt the message"))
|
|
349 (let ((boundary (mml-compute-boundary cont)))
|
|
350 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
|
|
351 boundary))
|
|
352 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
|
|
353 (insert (format "--%s\n" boundary))
|
|
354 (insert "Content-Type: application/pgp-encrypted\n\n")
|
|
355 (insert "Version: 1\n\n")
|
|
356 (insert (format "--%s\n" boundary))
|
|
357 (insert "Content-Type: application/octet-stream\n\n")
|
|
358 (goto-char (point-max))
|
|
359 (insert (format "--%s--\n" boundary))
|
|
360 (goto-char (point-max))))
|
|
361
|
|
362 ;;; gpg wrapper
|
|
363
|
|
364 (eval-and-compile
|
|
365 (autoload 'gpg-decrypt "gpg")
|
|
366 (autoload 'gpg-verify "gpg")
|
|
367 (autoload 'gpg-verify-cleartext "gpg")
|
|
368 (autoload 'gpg-sign-detached "gpg")
|
|
369 (autoload 'gpg-sign-encrypt "gpg")
|
|
370 (autoload 'gpg-encrypt "gpg")
|
|
371 (autoload 'gpg-passphrase-read "gpg"))
|
|
372
|
|
373 (defun mml2015-gpg-passphrase ()
|
|
374 (or (message-options-get 'gpg-passphrase)
|
|
375 (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
|
|
376
|
|
377 (defun mml2015-gpg-decrypt-1 ()
|
|
378 (let ((cipher (current-buffer)) plain result)
|
|
379 (if (with-temp-buffer
|
|
380 (prog1
|
|
381 (gpg-decrypt cipher (setq plain (current-buffer))
|
|
382 mml2015-result-buffer nil)
|
|
383 (mm-set-handle-multipart-parameter
|
|
384 mm-security-handle 'gnus-details
|
|
385 (with-current-buffer mml2015-result-buffer
|
|
386 (buffer-string)))
|
|
387 (set-buffer cipher)
|
|
388 (erase-buffer)
|
|
389 (insert-buffer-substring plain)
|
|
390 (goto-char (point-min))
|
|
391 (while (search-forward "\r\n" nil t)
|
|
392 (replace-match "\n" t t))))
|
|
393 '(t)
|
|
394 ;; Some wrong with the return value, check plain text buffer.
|
|
395 (if (> (point-max) (point-min))
|
|
396 '(t)
|
|
397 nil))))
|
|
398
|
|
399 (defun mml2015-gpg-decrypt (handle ctl)
|
|
400 (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
|
|
401 (mml2015-mailcrypt-decrypt handle ctl)))
|
|
402
|
|
403 (defun mml2015-gpg-clear-decrypt ()
|
|
404 (let (result)
|
|
405 (setq result (mml2015-gpg-decrypt-1))
|
|
406 (if (car result)
|
|
407 (mm-set-handle-multipart-parameter
|
|
408 mm-security-handle 'gnus-info "OK")
|
|
409 (mm-set-handle-multipart-parameter
|
|
410 mm-security-handle 'gnus-info "Failed"))))
|
|
411
|
|
412 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
|
|
413 (let* ((result "")
|
|
414 (fpr-length (string-width fingerprint))
|
|
415 (n-slice 0)
|
|
416 slice)
|
|
417 (setq fingerprint (string-to-list fingerprint))
|
|
418 (while fingerprint
|
|
419 (setq fpr-length (- fpr-length 4))
|
|
420 (setq slice (butlast fingerprint fpr-length))
|
|
421 (setq fingerprint (nthcdr 4 fingerprint))
|
|
422 (setq n-slice (1+ n-slice))
|
|
423 (setq result
|
|
424 (concat
|
|
425 result
|
|
426 (case n-slice
|
|
427 (1 slice)
|
|
428 (otherwise (concat " " slice))))))
|
|
429 result))
|
|
430
|
|
431 (defun mml2015-gpg-extract-signature-details ()
|
|
432 (goto-char (point-min))
|
|
433 (let* ((expired (re-search-forward
|
|
434 "^\\[GNUPG:\\] SIGEXPIRED$"
|
|
435 nil t))
|
|
436 (signer (and (re-search-forward
|
|
437 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
|
|
438 nil t)
|
|
439 (cons (match-string 1) (match-string 2))))
|
|
440 (fprint (and (re-search-forward
|
|
441 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
|
|
442 nil t)
|
|
443 (match-string 1)))
|
|
444 (trust (and (re-search-forward
|
|
445 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
|
|
446 nil t)
|
|
447 (match-string 1)))
|
|
448 (trust-good-enough-p
|
|
449 (cdr (assoc trust mml2015-unabbrev-trust-alist))))
|
|
450 (cond ((and signer fprint)
|
|
451 (concat (cdr signer)
|
|
452 (unless trust-good-enough-p
|
|
453 (concat "\nUntrusted, Fingerprint: "
|
|
454 (mml2015-gpg-pretty-print-fpr fprint)))
|
|
455 (when expired
|
|
456 (format "\nWARNING: Signature from expired key (%s)"
|
|
457 (car signer)))))
|
|
458 ((re-search-forward
|
|
459 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
|
|
460 (match-string 2))
|
|
461 (t
|
|
462 "From unknown user"))))
|
|
463
|
|
464 (defun mml2015-gpg-verify (handle ctl)
|
|
465 (catch 'error
|
|
466 (let (part message signature info-is-set-p)
|
|
467 (unless (setq part (mm-find-raw-part-by-type
|
|
468 ctl (or (mm-handle-multipart-ctl-parameter
|
|
469 ctl 'protocol)
|
|
470 "application/pgp-signature")
|
|
471 t))
|
|
472 (mm-set-handle-multipart-parameter
|
|
473 mm-security-handle 'gnus-info "Corrupted")
|
|
474 (throw 'error handle))
|
|
475 (with-temp-buffer
|
|
476 (setq message (current-buffer))
|
|
477 (insert part)
|
|
478 ;; Convert <LF> to <CR><LF> in verify mode. Sign and
|
|
479 ;; clearsign use --textmode. The conversion is not necessary.
|
|
480 ;; In clearverify, the conversion is not necessary either.
|
|
481 (goto-char (point-min))
|
|
482 (end-of-line)
|
|
483 (while (not (eobp))
|
|
484 (unless (eq (char-before) ?\r)
|
|
485 (insert "\r"))
|
|
486 (forward-line)
|
|
487 (end-of-line))
|
|
488 (with-temp-buffer
|
|
489 (setq signature (current-buffer))
|
|
490 (unless (setq part (mm-find-part-by-type
|
|
491 (cdr handle) "application/pgp-signature" nil t))
|
|
492 (mm-set-handle-multipart-parameter
|
|
493 mm-security-handle 'gnus-info "Corrupted")
|
|
494 (throw 'error handle))
|
|
495 (mm-insert-part part)
|
|
496 (unless (condition-case err
|
|
497 (prog1
|
|
498 (gpg-verify message signature mml2015-result-buffer)
|
|
499 (mm-set-handle-multipart-parameter
|
|
500 mm-security-handle 'gnus-details
|
|
501 (with-current-buffer mml2015-result-buffer
|
|
502 (buffer-string))))
|
|
503 (error
|
|
504 (mm-set-handle-multipart-parameter
|
|
505 mm-security-handle 'gnus-details (mml2015-format-error err))
|
|
506 (mm-set-handle-multipart-parameter
|
|
507 mm-security-handle 'gnus-info "Error.")
|
|
508 (setq info-is-set-p t)
|
|
509 nil)
|
|
510 (quit
|
|
511 (mm-set-handle-multipart-parameter
|
|
512 mm-security-handle 'gnus-details "Quit.")
|
|
513 (mm-set-handle-multipart-parameter
|
|
514 mm-security-handle 'gnus-info "Quit.")
|
|
515 (setq info-is-set-p t)
|
|
516 nil))
|
|
517 (unless info-is-set-p
|
|
518 (mm-set-handle-multipart-parameter
|
|
519 mm-security-handle 'gnus-info "Failed"))
|
|
520 (throw 'error handle)))
|
|
521 (mm-set-handle-multipart-parameter
|
|
522 mm-security-handle 'gnus-info
|
|
523 (with-current-buffer mml2015-result-buffer
|
|
524 (mml2015-gpg-extract-signature-details))))
|
|
525 handle)))
|
|
526
|
|
527 (defun mml2015-gpg-clear-verify ()
|
|
528 (if (condition-case err
|
|
529 (prog1
|
|
530 (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
|
|
531 (mm-set-handle-multipart-parameter
|
|
532 mm-security-handle 'gnus-details
|
|
533 (with-current-buffer mml2015-result-buffer
|
|
534 (buffer-string))))
|
|
535 (error
|
|
536 (mm-set-handle-multipart-parameter
|
|
537 mm-security-handle 'gnus-details (mml2015-format-error err))
|
|
538 nil)
|
|
539 (quit
|
|
540 (mm-set-handle-multipart-parameter
|
|
541 mm-security-handle 'gnus-details "Quit.")
|
|
542 nil))
|
|
543 (mm-set-handle-multipart-parameter
|
|
544 mm-security-handle 'gnus-info
|
|
545 (with-current-buffer mml2015-result-buffer
|
|
546 (mml2015-gpg-extract-signature-details)))
|
|
547 (mm-set-handle-multipart-parameter
|
|
548 mm-security-handle 'gnus-info "Failed")))
|
|
549
|
|
550 (defun mml2015-gpg-sign (cont)
|
|
551 (let ((boundary (mml-compute-boundary cont))
|
|
552 (text (current-buffer)) signature)
|
|
553 (goto-char (point-max))
|
|
554 (unless (bolp)
|
|
555 (insert "\n"))
|
|
556 (with-temp-buffer
|
|
557 (unless (gpg-sign-detached text (setq signature (current-buffer))
|
|
558 mml2015-result-buffer
|
|
559 nil
|
|
560 (message-options-get 'message-sender)
|
|
561 t t) ; armor & textmode
|
|
562 (unless (> (point-max) (point-min))
|
|
563 (pop-to-buffer mml2015-result-buffer)
|
|
564 (error "Sign error")))
|
|
565 (goto-char (point-min))
|
|
566 (while (re-search-forward "\r+$" nil t)
|
|
567 (replace-match "" t t))
|
|
568 (set-buffer text)
|
|
569 (goto-char (point-min))
|
|
570 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
|
|
571 boundary))
|
|
572 ;;; FIXME: what is the micalg?
|
|
573 (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
|
|
574 (insert (format "\n--%s\n" boundary))
|
|
575 (goto-char (point-max))
|
|
576 (insert (format "\n--%s\n" boundary))
|
|
577 (insert "Content-Type: application/pgp-signature\n\n")
|
|
578 (insert-buffer-substring signature)
|
|
579 (goto-char (point-max))
|
|
580 (insert (format "--%s--\n" boundary))
|
|
581 (goto-char (point-max)))))
|
|
582
|
|
583 (defun mml2015-gpg-encrypt (cont &optional sign)
|
|
584 (let ((boundary (mml-compute-boundary cont))
|
|
585 (text (current-buffer))
|
|
586 cipher)
|
|
587 (mm-with-unibyte-current-buffer
|
|
588 (with-temp-buffer
|
|
589 ;; set up a function to call the correct gpg encrypt routine
|
|
590 ;; with the right arguments. (FIXME: this should be done
|
|
591 ;; differently.)
|
|
592 (flet ((gpg-encrypt-func
|
|
593 (sign plaintext ciphertext result recipients &optional
|
|
594 passphrase sign-with-key armor textmode)
|
|
595 (if sign
|
|
596 (gpg-sign-encrypt
|
|
597 plaintext ciphertext result recipients passphrase
|
|
598 sign-with-key armor textmode)
|
|
599 (gpg-encrypt
|
|
600 plaintext ciphertext result recipients passphrase
|
|
601 armor textmode))))
|
|
602 (unless (gpg-encrypt-func
|
|
603 sign ; passed in when using signencrypt
|
|
604 text (setq cipher (current-buffer))
|
|
605 mml2015-result-buffer
|
|
606 (split-string
|
|
607 (or
|
|
608 (message-options-get 'message-recipients)
|
|
609 (message-options-set 'message-recipients
|
|
610 (read-string "Recipients: ")))
|
|
611 "[ \f\t\n\r\v,]+")
|
|
612 nil
|
|
613 (message-options-get 'message-sender)
|
|
614 t t) ; armor & textmode
|
|
615 (unless (> (point-max) (point-min))
|
|
616 (pop-to-buffer mml2015-result-buffer)
|
|
617 (error "Encrypt error"))))
|
|
618 (goto-char (point-min))
|
|
619 (while (re-search-forward "\r+$" nil t)
|
|
620 (replace-match "" t t))
|
|
621 (set-buffer text)
|
|
622 (delete-region (point-min) (point-max))
|
|
623 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
|
|
624 boundary))
|
|
625 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
|
|
626 (insert (format "--%s\n" boundary))
|
|
627 (insert "Content-Type: application/pgp-encrypted\n\n")
|
|
628 (insert "Version: 1\n\n")
|
|
629 (insert (format "--%s\n" boundary))
|
|
630 (insert "Content-Type: application/octet-stream\n\n")
|
|
631 (insert-buffer-substring cipher)
|
|
632 (goto-char (point-max))
|
|
633 (insert (format "--%s--\n" boundary))
|
|
634 (goto-char (point-max))))))
|
|
635
|
|
636 ;;; pgg wrapper
|
|
637
|
|
638 (eval-when-compile
|
|
639 (defvar pgg-default-user-id)
|
|
640 (defvar pgg-errors-buffer)
|
|
641 (defvar pgg-output-buffer))
|
|
642
|
|
643 (eval-and-compile
|
|
644 (autoload 'pgg-decrypt-region "pgg")
|
|
645 (autoload 'pgg-verify-region "pgg")
|
|
646 (autoload 'pgg-sign-region "pgg")
|
|
647 (autoload 'pgg-encrypt-region "pgg")
|
|
648 (autoload 'pgg-parse-armor "pgg-parse"))
|
|
649
|
|
650 (defun mml2015-pgg-decrypt (handle ctl)
|
|
651 (catch 'error
|
|
652 (let ((pgg-errors-buffer mml2015-result-buffer)
|
|
653 child handles result decrypt-status)
|
|
654 (unless (setq child (mm-find-part-by-type
|
|
655 (cdr handle)
|
|
656 "application/octet-stream" nil t))
|
|
657 (mm-set-handle-multipart-parameter
|
|
658 mm-security-handle 'gnus-info "Corrupted")
|
|
659 (throw 'error handle))
|
|
660 (with-temp-buffer
|
|
661 (mm-insert-part child)
|
|
662 (if (condition-case err
|
|
663 (prog1
|
|
664 (pgg-decrypt-region (point-min) (point-max))
|
|
665 (setq decrypt-status
|
|
666 (with-current-buffer mml2015-result-buffer
|
|
667 (buffer-string)))
|
|
668 (mm-set-handle-multipart-parameter
|
|
669 mm-security-handle 'gnus-details
|
|
670 decrypt-status))
|
|
671 (error
|
|
672 (mm-set-handle-multipart-parameter
|
|
673 mm-security-handle 'gnus-details (mml2015-format-error err))
|
|
674 nil)
|
|
675 (quit
|
|
676 (mm-set-handle-multipart-parameter
|
|
677 mm-security-handle 'gnus-details "Quit.")
|
|
678 nil))
|
|
679 (with-current-buffer pgg-output-buffer
|
|
680 (goto-char (point-min))
|
|
681 (while (search-forward "\r\n" nil t)
|
|
682 (replace-match "\n" t t))
|
|
683 (setq handles (mm-dissect-buffer t))
|
|
684 (mm-destroy-parts handle)
|
|
685 (mm-set-handle-multipart-parameter
|
|
686 mm-security-handle 'gnus-info "OK")
|
|
687 (mm-set-handle-multipart-parameter
|
|
688 mm-security-handle 'gnus-details
|
|
689 (concat decrypt-status
|
|
690 (when (stringp (car handles))
|
|
691 "\n" (mm-handle-multipart-ctl-parameter
|
|
692 handles 'gnus-details))))
|
|
693 (if (listp (car handles))
|
|
694 handles
|
|
695 (list handles)))
|
|
696 (mm-set-handle-multipart-parameter
|
|
697 mm-security-handle 'gnus-info "Failed")
|
|
698 (throw 'error handle))))))
|
|
699
|
|
700 (defun mml2015-pgg-clear-decrypt ()
|
|
701 (let ((pgg-errors-buffer mml2015-result-buffer))
|
|
702 (if (prog1
|
|
703 (pgg-decrypt-region (point-min) (point-max))
|
|
704 (mm-set-handle-multipart-parameter
|
|
705 mm-security-handle 'gnus-details
|
|
706 (with-current-buffer mml2015-result-buffer
|
|
707 (buffer-string))))
|
|
708 (progn
|
|
709 (erase-buffer)
|
|
710 (insert-buffer-substring pgg-output-buffer)
|
|
711 (goto-char (point-min))
|
|
712 (while (search-forward "\r\n" nil t)
|
|
713 (replace-match "\n" t t))
|
|
714 (mm-set-handle-multipart-parameter
|
|
715 mm-security-handle 'gnus-info "OK"))
|
|
716 (mm-set-handle-multipart-parameter
|
|
717 mm-security-handle 'gnus-info "Failed"))))
|
|
718
|
|
719 (defun mml2015-pgg-verify (handle ctl)
|
|
720 (let ((pgg-errors-buffer mml2015-result-buffer)
|
|
721 signature-file part signature)
|
|
722 (if (or (null (setq part (mm-find-raw-part-by-type
|
|
723 ctl (or (mm-handle-multipart-ctl-parameter
|
|
724 ctl 'protocol)
|
|
725 "application/pgp-signature")
|
|
726 t)))
|
|
727 (null (setq signature (mm-find-part-by-type
|
|
728 (cdr handle) "application/pgp-signature" nil t))))
|
|
729 (progn
|
|
730 (mm-set-handle-multipart-parameter
|
|
731 mm-security-handle 'gnus-info "Corrupted")
|
|
732 handle)
|
|
733 (with-temp-buffer
|
|
734 (insert part)
|
|
735 ;; Convert <LF> to <CR><LF> in verify mode. Sign and
|
|
736 ;; clearsign use --textmode. The conversion is not necessary.
|
|
737 ;; In clearverify, the conversion is not necessary either.
|
|
738 (goto-char (point-min))
|
|
739 (end-of-line)
|
|
740 (while (not (eobp))
|
|
741 (unless (eq (char-before) ?\r)
|
|
742 (insert "\r"))
|
|
743 (forward-line)
|
|
744 (end-of-line))
|
|
745 (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
|
|
746 (mm-insert-part signature))
|
|
747 (if (condition-case err
|
|
748 (prog1
|
|
749 (pgg-verify-region (point-min) (point-max)
|
|
750 signature-file t)
|
|
751 (goto-char (point-min))
|
|
752 (while (search-forward "\r\n" nil t)
|
|
753 (replace-match "\n" t t))
|
|
754 (mm-set-handle-multipart-parameter
|
|
755 mm-security-handle 'gnus-details
|
|
756 (concat (with-current-buffer pgg-output-buffer
|
|
757 (buffer-string))
|
|
758 (with-current-buffer pgg-errors-buffer
|
|
759 (buffer-string)))))
|
|
760 (error
|
|
761 (mm-set-handle-multipart-parameter
|
|
762 mm-security-handle 'gnus-details (mml2015-format-error err))
|
|
763 nil)
|
|
764 (quit
|
|
765 (mm-set-handle-multipart-parameter
|
|
766 mm-security-handle 'gnus-details "Quit.")
|
|
767 nil))
|
|
768 (progn
|
|
769 (delete-file signature-file)
|
|
770 (mm-set-handle-multipart-parameter
|
|
771 mm-security-handle 'gnus-info
|
|
772 (with-current-buffer pgg-errors-buffer
|
|
773 (mml2015-gpg-extract-signature-details))))
|
|
774 (delete-file signature-file)
|
|
775 (mm-set-handle-multipart-parameter
|
|
776 mm-security-handle 'gnus-info "Failed")))))
|
|
777 handle)
|
|
778
|
|
779 (defun mml2015-pgg-clear-verify ()
|
|
780 (let ((pgg-errors-buffer mml2015-result-buffer)
|
|
781 (text (buffer-string))
|
|
782 (coding-system buffer-file-coding-system))
|
|
783 (if (condition-case err
|
|
784 (prog1
|
|
785 (mm-with-unibyte-buffer
|
|
786 (insert (encode-coding-string text coding-system))
|
|
787 (pgg-verify-region (point-min) (point-max) nil t))
|
|
788 (goto-char (point-min))
|
|
789 (while (search-forward "\r\n" nil t)
|
|
790 (replace-match "\n" t t))
|
|
791 (mm-set-handle-multipart-parameter
|
|
792 mm-security-handle 'gnus-details
|
|
793 (concat (with-current-buffer pgg-output-buffer
|
|
794 (buffer-string))
|
|
795 (with-current-buffer pgg-errors-buffer
|
|
796 (buffer-string)))))
|
|
797 (error
|
|
798 (mm-set-handle-multipart-parameter
|
|
799 mm-security-handle 'gnus-details (mml2015-format-error err))
|
|
800 nil)
|
|
801 (quit
|
|
802 (mm-set-handle-multipart-parameter
|
|
803 mm-security-handle 'gnus-details "Quit.")
|
|
804 nil))
|
|
805 (mm-set-handle-multipart-parameter
|
|
806 mm-security-handle 'gnus-info
|
|
807 (with-current-buffer pgg-errors-buffer
|
|
808 (mml2015-gpg-extract-signature-details)))
|
|
809 (mm-set-handle-multipart-parameter
|
|
810 mm-security-handle 'gnus-info "Failed"))))
|
|
811
|
|
812 (defun mml2015-pgg-sign (cont)
|
|
813 (let ((pgg-errors-buffer mml2015-result-buffer)
|
|
814 (boundary (mml-compute-boundary cont))
|
|
815 (pgg-default-user-id (or (message-options-get 'mml-sender)
|
|
816 pgg-default-user-id))
|
|
817 entry)
|
|
818 (unless (pgg-sign-region (point-min) (point-max))
|
|
819 (pop-to-buffer mml2015-result-buffer)
|
|
820 (error "Sign error"))
|
|
821 (goto-char (point-min))
|
|
822 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
|
|
823 boundary))
|
|
824 (if (setq entry (assq 2 (pgg-parse-armor
|
|
825 (with-current-buffer pgg-output-buffer
|
|
826 (buffer-string)))))
|
|
827 (setq entry (assq 'hash-algorithm (cdr entry))))
|
|
828 (insert (format "\tmicalg=%s; "
|
|
829 (if (cdr entry)
|
|
830 (downcase (format "pgp-%s" (cdr entry)))
|
|
831 "pgp-sha1")))
|
|
832 (insert "protocol=\"application/pgp-signature\"\n")
|
|
833 (insert (format "\n--%s\n" boundary))
|
|
834 (goto-char (point-max))
|
|
835 (insert (format "\n--%s\n" boundary))
|
|
836 (insert "Content-Type: application/pgp-signature\n\n")
|
|
837 (insert-buffer-substring pgg-output-buffer)
|
|
838 (goto-char (point-max))
|
|
839 (insert (format "--%s--\n" boundary))
|
|
840 (goto-char (point-max))))
|
|
841
|
|
842 (defun mml2015-pgg-encrypt (cont &optional sign)
|
|
843 (let ((pgg-errors-buffer mml2015-result-buffer)
|
|
844 (boundary (mml-compute-boundary cont)))
|
|
845 (unless (pgg-encrypt-region (point-min) (point-max)
|
|
846 (split-string
|
|
847 (or
|
|
848 (message-options-get 'message-recipients)
|
|
849 (message-options-set 'message-recipients
|
|
850 (read-string "Recipients: ")))
|
|
851 "[ \f\t\n\r\v,]+")
|
|
852 sign)
|
|
853 (pop-to-buffer mml2015-result-buffer)
|
|
854 (error "Encrypt error"))
|
|
855 (delete-region (point-min) (point-max))
|
|
856 (goto-char (point-min))
|
|
857 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
|
|
858 boundary))
|
|
859 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
|
|
860 (insert (format "--%s\n" boundary))
|
|
861 (insert "Content-Type: application/pgp-encrypted\n\n")
|
|
862 (insert "Version: 1\n\n")
|
|
863 (insert (format "--%s\n" boundary))
|
|
864 (insert "Content-Type: application/octet-stream\n\n")
|
|
865 (insert-buffer-substring pgg-output-buffer)
|
|
866 (goto-char (point-max))
|
|
867 (insert (format "--%s--\n" boundary))
|
|
868 (goto-char (point-max))))
|
|
869
|
|
870 ;;; General wrapper
|
|
871
|
|
872 (defun mml2015-clean-buffer ()
|
|
873 (if (gnus-buffer-live-p mml2015-result-buffer)
|
|
874 (with-current-buffer mml2015-result-buffer
|
|
875 (erase-buffer)
|
|
876 t)
|
|
877 (setq mml2015-result-buffer
|
|
878 (gnus-get-buffer-create "*MML2015 Result*"))
|
|
879 nil))
|
|
880
|
|
881 (defsubst mml2015-clear-decrypt-function ()
|
|
882 (nth 6 (assq mml2015-use mml2015-function-alist)))
|
|
883
|
|
884 (defsubst mml2015-clear-verify-function ()
|
|
885 (nth 5 (assq mml2015-use mml2015-function-alist)))
|
|
886
|
|
887 ;;;###autoload
|
|
888 (defun mml2015-decrypt (handle ctl)
|
|
889 (mml2015-clean-buffer)
|
|
890 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
|
|
891 (if func
|
|
892 (funcall func handle ctl)
|
|
893 handle)))
|
|
894
|
|
895 ;;;###autoload
|
|
896 (defun mml2015-decrypt-test (handle ctl)
|
|
897 mml2015-use)
|
|
898
|
|
899 ;;;###autoload
|
|
900 (defun mml2015-verify (handle ctl)
|
|
901 (mml2015-clean-buffer)
|
|
902 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
|
|
903 (if func
|
|
904 (funcall func handle ctl)
|
|
905 handle)))
|
|
906
|
|
907 ;;;###autoload
|
|
908 (defun mml2015-verify-test (handle ctl)
|
|
909 mml2015-use)
|
|
910
|
|
911 ;;;###autoload
|
|
912 (defun mml2015-encrypt (cont &optional sign)
|
|
913 (mml2015-clean-buffer)
|
|
914 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
|
|
915 (if func
|
|
916 (funcall func cont sign)
|
|
917 (error "Cannot find encrypt function"))))
|
|
918
|
|
919 ;;;###autoload
|
|
920 (defun mml2015-sign (cont)
|
|
921 (mml2015-clean-buffer)
|
|
922 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
|
|
923 (if func
|
|
924 (funcall func cont)
|
|
925 (error "Cannot find sign function"))))
|
|
926
|
|
927 ;;;###autoload
|
|
928 (defun mml2015-self-encrypt ()
|
|
929 (mml2015-encrypt nil))
|
|
930
|
|
931 (provide 'mml2015)
|
|
932
|
|
933 ;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
|
|
934 ;;; mml2015.el ends here
|