Mercurial > emacs
comparison lisp/pgg-gpg.el @ 66383:c82982d6cbc4
Moved pgg*.el files from lisp/gnus to lisp.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Mon, 24 Oct 2005 09:46:27 +0000 |
parents | |
children | 67afcf271a8f |
comparison
equal
deleted
inserted
replaced
66382:9e9e3aac0fda | 66383:c82982d6cbc4 |
---|---|
1 ;;; pgg-gpg.el --- GnuPG support for PGG. | |
2 | |
3 ;; Copyright (C) 1999, 2000, 2002, 2003, 2004, | |
4 ;; 2005 Free Software Foundation, Inc. | |
5 | |
6 ;; Author: Daiki Ueno <ueno@unixuser.org> | |
7 ;; Created: 1999/10/28 | |
8 ;; Keywords: PGP, OpenPGP, GnuPG | |
9 | |
10 ;; This file is part of GNU Emacs. | |
11 | |
12 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
13 ;; it under the terms of the GNU General Public License as published by | |
14 ;; the Free Software Foundation; either version 2, or (at your option) | |
15 ;; any later version. | |
16 | |
17 ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 ;; GNU General Public License for more details. | |
21 | |
22 ;; You should have received a copy of the GNU General Public License | |
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
25 ;; Boston, MA 02110-1301, USA. | |
26 | |
27 ;;; Code: | |
28 | |
29 (eval-when-compile | |
30 (require 'cl) ; for gpg macros | |
31 (require 'pgg)) | |
32 | |
33 (defgroup pgg-gpg () | |
34 "GnuPG interface." | |
35 :group 'pgg) | |
36 | |
37 (defcustom pgg-gpg-program "gpg" | |
38 "The GnuPG executable." | |
39 :group 'pgg-gpg | |
40 :type 'string) | |
41 | |
42 (defcustom pgg-gpg-extra-args nil | |
43 "Extra arguments for every GnuPG invocation." | |
44 :group 'pgg-gpg | |
45 :type '(repeat (string :tag "Argument"))) | |
46 | |
47 (defcustom pgg-gpg-recipient-argument "--recipient" | |
48 "GnuPG option to specify recipient." | |
49 :group 'pgg-gpg | |
50 :type '(choice (const :tag "New `--recipient' option" "--recipient") | |
51 (const :tag "Old `--remote-user' option" "--remote-user"))) | |
52 | |
53 (defvar pgg-gpg-user-id nil | |
54 "GnuPG ID of your default identity.") | |
55 | |
56 (defun pgg-gpg-process-region (start end passphrase program args) | |
57 (let* ((output-file-name (pgg-make-temp-file "pgg-output")) | |
58 (args | |
59 `("--status-fd" "2" | |
60 ,@(if passphrase '("--passphrase-fd" "0")) | |
61 "--yes" ; overwrite | |
62 "--output" ,output-file-name | |
63 ,@pgg-gpg-extra-args ,@args)) | |
64 (output-buffer pgg-output-buffer) | |
65 (errors-buffer pgg-errors-buffer) | |
66 (orig-mode (default-file-modes)) | |
67 (process-connection-type nil) | |
68 exit-status) | |
69 (with-current-buffer (get-buffer-create errors-buffer) | |
70 (buffer-disable-undo) | |
71 (erase-buffer)) | |
72 (unwind-protect | |
73 (progn | |
74 (set-default-file-modes 448) | |
75 (let ((coding-system-for-write 'binary) | |
76 (input (buffer-substring-no-properties start end)) | |
77 (default-enable-multibyte-characters nil)) | |
78 (with-temp-buffer | |
79 (when passphrase | |
80 (insert passphrase "\n")) | |
81 (insert input) | |
82 (setq exit-status | |
83 (apply #'call-process-region (point-min) (point-max) program | |
84 nil errors-buffer nil args)))) | |
85 (with-current-buffer (get-buffer-create output-buffer) | |
86 (buffer-disable-undo) | |
87 (erase-buffer) | |
88 (if (file-exists-p output-file-name) | |
89 (let ((coding-system-for-read 'raw-text-dos)) | |
90 (insert-file-contents output-file-name))) | |
91 (set-buffer errors-buffer) | |
92 (if (not (equal exit-status 0)) | |
93 (insert (format "\n%s exited abnormally: '%s'\n" | |
94 program exit-status))))) | |
95 (if (file-exists-p output-file-name) | |
96 (delete-file output-file-name)) | |
97 (set-default-file-modes orig-mode)))) | |
98 | |
99 (defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key) | |
100 (if (and pgg-cache-passphrase | |
101 (progn | |
102 (goto-char (point-min)) | |
103 (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t))) | |
104 (pgg-add-passphrase-cache | |
105 (or key | |
106 (progn | |
107 (goto-char (point-min)) | |
108 (if (re-search-forward | |
109 "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t) | |
110 (substring (match-string 0) -8)))) | |
111 passphrase))) | |
112 | |
113 (defvar pgg-gpg-all-secret-keys 'unknown) | |
114 | |
115 (defun pgg-gpg-lookup-all-secret-keys () | |
116 "Return all secret keys present in secret key ring." | |
117 (when (eq pgg-gpg-all-secret-keys 'unknown) | |
118 (setq pgg-gpg-all-secret-keys '()) | |
119 (let ((args (list "--with-colons" "--no-greeting" "--batch" | |
120 "--list-secret-keys"))) | |
121 (with-temp-buffer | |
122 (apply #'call-process pgg-gpg-program nil t nil args) | |
123 (goto-char (point-min)) | |
124 (while (re-search-forward | |
125 "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t) | |
126 (push (substring (match-string 2) 8) | |
127 pgg-gpg-all-secret-keys))))) | |
128 pgg-gpg-all-secret-keys) | |
129 | |
130 (defun pgg-gpg-lookup-key (string &optional type) | |
131 "Search keys associated with STRING." | |
132 (let ((args (list "--with-colons" "--no-greeting" "--batch" | |
133 (if type "--list-secret-keys" "--list-keys") | |
134 string))) | |
135 (with-temp-buffer | |
136 (apply #'call-process pgg-gpg-program nil t nil args) | |
137 (goto-char (point-min)) | |
138 (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" | |
139 nil t) | |
140 (substring (match-string 2) 8))))) | |
141 | |
142 (defun pgg-gpg-encrypt-region (start end recipients &optional sign) | |
143 "Encrypt the current region between START and END. | |
144 If optional argument SIGN is non-nil, do a combined sign and encrypt." | |
145 (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) | |
146 (passphrase | |
147 (when sign | |
148 (pgg-read-passphrase | |
149 (format "GnuPG passphrase for %s: " pgg-gpg-user-id) | |
150 pgg-gpg-user-id))) | |
151 (args | |
152 (append | |
153 (list "--batch" "--armor" "--always-trust" "--encrypt") | |
154 (if sign (list "--sign" "--local-user" pgg-gpg-user-id)) | |
155 (if recipients | |
156 (apply #'nconc | |
157 (mapcar (lambda (rcpt) | |
158 (list pgg-gpg-recipient-argument rcpt)) | |
159 (append recipients | |
160 (if pgg-encrypt-for-me | |
161 (list pgg-gpg-user-id))))))))) | |
162 (pgg-as-lbt start end 'CRLF | |
163 (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) | |
164 (when sign | |
165 (with-current-buffer pgg-errors-buffer | |
166 ;; Possibly cache passphrase under, e.g. "jas", for future sign. | |
167 (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) | |
168 ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. | |
169 (pgg-gpg-possibly-cache-passphrase passphrase))) | |
170 (pgg-process-when-success))) | |
171 | |
172 (defun pgg-gpg-decrypt-region (start end) | |
173 "Decrypt the current region between START and END." | |
174 (let* ((current-buffer (current-buffer)) | |
175 (message-keys (with-temp-buffer | |
176 (insert-buffer-substring current-buffer) | |
177 (pgg-decode-armor-region (point-min) (point-max)))) | |
178 (secret-keys (pgg-gpg-lookup-all-secret-keys)) | |
179 (key (pgg-gpg-select-matching-key message-keys secret-keys)) | |
180 (pgg-gpg-user-id (or key pgg-gpg-user-id pgg-default-user-id)) | |
181 (passphrase | |
182 (pgg-read-passphrase | |
183 (format "GnuPG passphrase for %s: " pgg-gpg-user-id) | |
184 pgg-gpg-user-id)) | |
185 (args '("--batch" "--decrypt"))) | |
186 (pgg-gpg-process-region start end passphrase pgg-gpg-program args) | |
187 (with-current-buffer pgg-errors-buffer | |
188 (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) | |
189 (goto-char (point-min)) | |
190 (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t)))) | |
191 | |
192 (defun pgg-gpg-select-matching-key (message-keys secret-keys) | |
193 "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS." | |
194 (loop for message-key in message-keys | |
195 for message-key-id = (and (equal (car message-key) 1) | |
196 (cdr (assq 'key-identifier message-key))) | |
197 for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt)) | |
198 when (and key (member key secret-keys)) return key)) | |
199 | |
200 (defun pgg-gpg-sign-region (start end &optional cleartext) | |
201 "Make detached signature from text between START and END." | |
202 (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) | |
203 (passphrase | |
204 (pgg-read-passphrase | |
205 (format "GnuPG passphrase for %s: " pgg-gpg-user-id) | |
206 pgg-gpg-user-id)) | |
207 (args | |
208 (list (if cleartext "--clearsign" "--detach-sign") | |
209 "--armor" "--batch" "--verbose" | |
210 "--local-user" pgg-gpg-user-id)) | |
211 (inhibit-read-only t) | |
212 buffer-read-only) | |
213 (pgg-as-lbt start end 'CRLF | |
214 (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) | |
215 (with-current-buffer pgg-errors-buffer | |
216 ;; Possibly cache passphrase under, e.g. "jas", for future sign. | |
217 (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) | |
218 ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. | |
219 (pgg-gpg-possibly-cache-passphrase passphrase)) | |
220 (pgg-process-when-success))) | |
221 | |
222 (defun pgg-gpg-verify-region (start end &optional signature) | |
223 "Verify region between START and END as the detached signature SIGNATURE." | |
224 (let ((args '("--batch" "--verify"))) | |
225 (when (stringp signature) | |
226 (setq args (append args (list signature)))) | |
227 (setq args (append args '("-"))) | |
228 (pgg-gpg-process-region start end nil pgg-gpg-program args) | |
229 (with-current-buffer pgg-errors-buffer | |
230 (goto-char (point-min)) | |
231 (while (re-search-forward "^gpg: \\(.*\\)\n" nil t) | |
232 (with-current-buffer pgg-output-buffer | |
233 (insert-buffer-substring pgg-errors-buffer | |
234 (match-beginning 1) (match-end 0))) | |
235 (delete-region (match-beginning 0) (match-end 0))) | |
236 (goto-char (point-min)) | |
237 (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t)))) | |
238 | |
239 (defun pgg-gpg-insert-key () | |
240 "Insert public key at point." | |
241 (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) | |
242 (args (list "--batch" "--export" "--armor" | |
243 pgg-gpg-user-id))) | |
244 (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) | |
245 (insert-buffer-substring pgg-output-buffer))) | |
246 | |
247 (defun pgg-gpg-snarf-keys-region (start end) | |
248 "Add all public keys in region between START and END to the keyring." | |
249 (let ((args '("--import" "--batch" "-")) status) | |
250 (pgg-gpg-process-region start end nil pgg-gpg-program args) | |
251 (set-buffer pgg-errors-buffer) | |
252 (goto-char (point-min)) | |
253 (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t) | |
254 (setq status (buffer-substring (match-end 0) | |
255 (progn (end-of-line)(point))) | |
256 status (vconcat (mapcar #'string-to-number (split-string status)))) | |
257 (erase-buffer) | |
258 (insert (format "Imported %d key(s). | |
259 \tArmor contains %d key(s) [%d bad, %d old].\n" | |
260 (+ (aref status 2) | |
261 (aref status 10)) | |
262 (aref status 0) | |
263 (aref status 1) | |
264 (+ (aref status 4) | |
265 (aref status 11))) | |
266 (if (zerop (aref status 9)) | |
267 "" | |
268 "\tSecret keys are imported.\n"))) | |
269 (append-to-buffer pgg-output-buffer (point-min)(point-max)) | |
270 (pgg-process-when-success))) | |
271 | |
272 (provide 'pgg-gpg) | |
273 | |
274 ;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000 | |
275 ;;; pgg-gpg.el ends here |