1 ;;; pgg-gpg.el --- GnuPG support for PGG.
3 ;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Daiki Ueno <ueno@unixuser.org>
7 ;; Symmetric encryption and gpg-agent support added by:
8 ;; Sascha Wilde <wilde@sha-bang.de>
10 ;; Keywords: PGP, OpenPGP, GnuPG
12 ;; This file is part of GNU Emacs.
14 ;; GNU Emacs is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 2, or (at your option)
19 ;; GNU Emacs is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs; see the file COPYING. If not, write to the
26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
27 ;; Boston, MA 02110-1301, USA.
32 (require 'cl
) ; for gpg macros
39 (defcustom pgg-gpg-program
"gpg"
40 "The GnuPG executable."
44 (defcustom pgg-gpg-extra-args nil
45 "Extra arguments for every GnuPG invocation."
47 :type
'(repeat (string :tag
"Argument")))
49 (defcustom pgg-gpg-recipient-argument
"--recipient"
50 "GnuPG option to specify recipient."
52 :type
'(choice (const :tag
"New `--recipient' option" "--recipient")
53 (const :tag
"Old `--remote-user' option" "--remote-user")))
55 (defcustom pgg-gpg-use-agent nil
56 "Whether to use gnupg agent for key caching."
60 (defvar pgg-gpg-user-id nil
61 "GnuPG ID of your default identity.")
63 (defun pgg-gpg-process-region (start end passphrase program args
)
64 (let* ((use-agent (pgg-gpg-use-agent-p))
65 (output-file-name (pgg-make-temp-file "pgg-output"))
68 ,@(if use-agent
'("--use-agent")
69 (if passphrase
'("--passphrase-fd" "0")))
71 "--output" ,output-file-name
72 ,@pgg-gpg-extra-args
,@args
))
73 (output-buffer pgg-output-buffer
)
74 (errors-buffer pgg-errors-buffer
)
75 (orig-mode (default-file-modes))
76 (process-connection-type nil
)
78 (with-current-buffer (get-buffer-create errors-buffer
)
83 (set-default-file-modes 448)
84 (let ((coding-system-for-write 'binary
)
85 (input (buffer-substring-no-properties start end
))
86 (default-enable-multibyte-characters nil
))
89 (insert passphrase
"\n"))
92 (apply #'call-process-region
(point-min) (point-max) program
93 nil errors-buffer nil args
))))
94 (with-current-buffer (get-buffer-create output-buffer
)
97 (if (file-exists-p output-file-name
)
98 (let ((coding-system-for-read (if pgg-text-mode
101 (insert-file-contents output-file-name
)))
102 (set-buffer errors-buffer
)
103 (if (not (equal exit-status
0))
104 (insert (format "\n%s exited abnormally: '%s'\n"
105 program exit-status
)))))
106 (if (file-exists-p output-file-name
)
107 (delete-file output-file-name
))
108 (set-default-file-modes orig-mode
))))
110 (defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key notruncate
)
114 (goto-char (point-min))
115 (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t
)))
116 (pgg-add-passphrase-to-cache
119 (goto-char (point-min))
120 (if (re-search-forward
121 "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t
)
122 (substring (match-string 0) -
8))))
126 (defvar pgg-gpg-all-secret-keys
'unknown
)
128 (defun pgg-gpg-lookup-all-secret-keys ()
129 "Return all secret keys present in secret key ring."
130 (when (eq pgg-gpg-all-secret-keys
'unknown
)
131 (setq pgg-gpg-all-secret-keys
'())
132 (let ((args (list "--with-colons" "--no-greeting" "--batch"
133 "--list-secret-keys")))
135 (apply #'call-process pgg-gpg-program nil t nil args
)
136 (goto-char (point-min))
137 (while (re-search-forward
138 "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t
)
139 (push (substring (match-string 2) 8)
140 pgg-gpg-all-secret-keys
)))))
141 pgg-gpg-all-secret-keys
)
143 (defun pgg-gpg-lookup-key (string &optional type
)
144 "Search keys associated with STRING."
145 (let ((args (list "--with-colons" "--no-greeting" "--batch"
146 (if type
"--list-secret-keys" "--list-keys")
149 (apply #'call-process pgg-gpg-program nil t nil args
)
150 (goto-char (point-min))
151 (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)"
153 (substring (match-string 2) 8)))))
155 (defun pgg-gpg-lookup-key-owner (string &optional all
)
156 "Search keys associated with STRING and return owner of identified key.
158 The value may be just the bare key id, or it may be a combination of the
159 user name associated with the key and the key id, with the key id enclosed
160 in \"<...>\" angle brackets.
162 Optional ALL non-nil means search all keys, including secret keys."
163 (let ((args (list "--with-colons" "--no-greeting" "--batch"
164 (if all
"--list-secret-keys" "--list-keys")
166 (key-regexp (concat "^\\(sec\\|pub\\)"
167 ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):[^:]*"
168 ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):")))
170 (apply #'call-process pgg-gpg-program nil t nil args
)
171 (goto-char (point-min))
172 (if (re-search-forward key-regexp
176 (defun pgg-gpg-key-id-from-key-owner (key-owner)
177 (cond ((not key-owner
) nil
)
178 ;; Extract bare key id from outermost paired angle brackets, if any:
179 ((string-match "[^<]*<\\(.+\\)>[^>]*" key-owner
)
180 (substring key-owner
(match-beginning 1)(match-end 1)))
183 (defun pgg-gpg-encrypt-region (start end recipients
&optional sign passphrase
)
184 "Encrypt the current region between START and END.
186 If optional argument SIGN is non-nil, do a combined sign and encrypt.
188 If optional PASSPHRASE is not specified, it will be obtained from the
189 passphrase cache or user."
190 (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id
))
191 (passphrase (or passphrase
192 (when (and sign
(not (pgg-gpg-use-agent-p)))
194 (format "GnuPG passphrase for %s: "
199 (list "--batch" "--armor" "--always-trust" "--encrypt")
200 (if pgg-text-mode
(list "--textmode"))
201 (if sign
(list "--sign" "--local-user" pgg-gpg-user-id
))
204 (mapcar (lambda (rcpt)
205 (list pgg-gpg-recipient-argument rcpt
))
207 (if pgg-encrypt-for-me
208 (list pgg-gpg-user-id
)))))))))
209 (pgg-gpg-process-region start end passphrase pgg-gpg-program args
)
211 (with-current-buffer pgg-errors-buffer
212 ;; Possibly cache passphrase under, e.g. "jas", for future sign.
213 (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id
)
214 ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
215 (pgg-gpg-possibly-cache-passphrase passphrase
)))
216 (pgg-process-when-success)))
218 (defun pgg-gpg-encrypt-symmetric-region (start end
&optional passphrase
)
219 "Encrypt the current region between START and END with symmetric cipher.
221 If optional PASSPHRASE is not specified, it will be obtained from the
222 passphrase cache or user."
223 (let* ((passphrase (or passphrase
224 (when (not (pgg-gpg-use-agent-p))
226 "GnuPG passphrase for symmetric encryption: "))))
228 (append (list "--batch" "--armor" "--symmetric" )
229 (if pgg-text-mode
(list "--textmode")))))
230 (pgg-gpg-process-region start end passphrase pgg-gpg-program args
)
231 (pgg-process-when-success)))
233 (defun pgg-gpg-decrypt-region (start end
&optional passphrase
)
234 "Decrypt the current region between START and END.
236 If optional PASSPHRASE is not specified, it will be obtained from the
237 passphrase cache or user."
238 (let* ((current-buffer (current-buffer))
239 (message-keys (with-temp-buffer
240 (insert-buffer-substring current-buffer
)
241 (pgg-decode-armor-region (point-min) (point-max))))
242 (secret-keys (pgg-gpg-lookup-all-secret-keys))
243 ;; XXX the user is stuck if they need to use the passphrase for
244 ;; any but the first secret key for which the message is
245 ;; encrypted. ideally, we would incrementally give them a
246 ;; chance with subsequent keys each time they fail with one.
247 (key (pgg-gpg-select-matching-key message-keys secret-keys
))
248 (key-owner (and key
(pgg-gpg-lookup-key-owner key t
)))
249 (key-id (pgg-gpg-key-id-from-key-owner key-owner
))
250 (pgg-gpg-user-id (or key-id key
251 pgg-gpg-user-id pgg-default-user-id
))
252 (passphrase (or passphrase
253 (when (not (pgg-gpg-use-agent-p))
255 (format (if (pgg-gpg-symmetric-key-p message-keys
)
256 "Passphrase for symmetric decryption: "
257 "GnuPG passphrase for %s: ")
260 (args '("--batch" "--decrypt")))
261 (pgg-gpg-process-region start end passphrase pgg-gpg-program args
)
262 (with-current-buffer pgg-errors-buffer
263 (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id
)
264 (goto-char (point-min))
265 (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t
))))
268 (defun pgg-gpg-symmetric-key-p (message-keys)
269 "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator."
271 (dolist (key message-keys result
)
272 (when (and (eq (car key
) 3)
273 (member '(symmetric-key-algorithm) key
))
274 (setq result key
)))))
276 (defun pgg-gpg-select-matching-key (message-keys secret-keys
)
277 "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS."
278 (loop for message-key in message-keys
279 for message-key-id
= (and (equal (car message-key
) 1)
280 (cdr (assq 'key-identifier
282 for key
= (and message-key-id
(pgg-lookup-key message-key-id
'encrypt
))
283 when
(and key
(member key secret-keys
)) return key
))
285 (defun pgg-gpg-sign-region (start end
&optional cleartext passphrase
)
286 "Make detached signature from text between START and END."
287 (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id
))
288 (passphrase (or passphrase
289 (when (not (pgg-gpg-use-agent-p))
291 (format "GnuPG passphrase for %s: "
295 (append (list (if cleartext
"--clearsign" "--detach-sign")
296 "--armor" "--batch" "--verbose"
297 "--local-user" pgg-gpg-user-id
)
298 (if pgg-text-mode
(list "--textmode"))))
299 (inhibit-read-only t
)
301 (pgg-gpg-process-region start end passphrase pgg-gpg-program args
)
302 (with-current-buffer pgg-errors-buffer
303 ;; Possibly cache passphrase under, e.g. "jas", for future sign.
304 (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id
)
305 ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
306 (pgg-gpg-possibly-cache-passphrase passphrase
))
307 (pgg-process-when-success)))
309 (defun pgg-gpg-verify-region (start end
&optional signature
)
310 "Verify region between START and END as the detached signature SIGNATURE."
311 (let ((args '("--batch" "--verify")))
312 (when (stringp signature
)
313 (setq args
(append args
(list signature
))))
314 (setq args
(append args
'("-")))
315 (pgg-gpg-process-region start end nil pgg-gpg-program args
)
316 (with-current-buffer pgg-errors-buffer
317 (goto-char (point-min))
318 (while (re-search-forward "^gpg: \\(.*\\)\n" nil t
)
319 (with-current-buffer pgg-output-buffer
320 (insert-buffer-substring pgg-errors-buffer
321 (match-beginning 1) (match-end 0)))
322 (delete-region (match-beginning 0) (match-end 0)))
323 (goto-char (point-min))
324 (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t
))))
326 (defun pgg-gpg-insert-key ()
327 "Insert public key at point."
328 (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id
))
329 (args (list "--batch" "--export" "--armor"
331 (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args
)
332 (insert-buffer-substring pgg-output-buffer
)))
334 (defun pgg-gpg-snarf-keys-region (start end
)
335 "Add all public keys in region between START and END to the keyring."
336 (let ((args '("--import" "--batch" "-")) status
)
337 (pgg-gpg-process-region start end nil pgg-gpg-program args
)
338 (set-buffer pgg-errors-buffer
)
339 (goto-char (point-min))
340 (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t
)
341 (setq status
(buffer-substring (match-end 0)
342 (progn (end-of-line)(point)))
343 status
(vconcat (mapcar #'string-to-number
(split-string status
))))
345 (insert (format "Imported %d key(s).
346 \tArmor contains %d key(s) [%d bad, %d old].\n"
353 (if (zerop (aref status
9))
355 "\tSecret keys are imported.\n")))
356 (append-to-buffer pgg-output-buffer
(point-min)(point-max))
357 (pgg-process-when-success)))
359 (defun pgg-gpg-update-agent ()
360 "Try to connet to gpg-agent and send UPDATESTARTUPTTY."
361 (if (fboundp 'make-network-process
)
362 (let* ((agent-info (getenv "GPG_AGENT_INFO"))
363 (socket (and agent-info
364 (string-match "^\\([^:]*\\)" agent-info
)
365 (match-string 1 agent-info
)))
367 (make-network-process :name
"gpg-agent-process"
368 :host
'local
:family
'local
370 (when (and conn
(eq (process-status conn
) 'open
))
371 (process-send-string conn
"UPDATESTARTUPTTY\n")
372 (delete-process conn
)
374 ;; We can't check, so assume gpg-agent is up.
377 (defun pgg-gpg-use-agent-p ()
378 "Return t if `pgg-gpg-use-agent' is t and gpg-agent is available."
379 (and pgg-gpg-use-agent
(pgg-gpg-update-agent)))
383 ;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000
384 ;;; pgg-gpg.el ends here