1 ;;; gpg-ring.el --- Major mode for editing GnuPG key rings.
3 ;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart
5 ;; Author: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
6 ;; Maintainer: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
10 ;; $Id: gpg-ring.el,v 1.1 2000/11/04 12:22:17 zsh Exp $
12 ;; This file is NOT (yet?) 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., 59 Temple Place - Suite 330,
27 ;; Boston, MA 02111-1307, USA.
34 (eval-when-compile (require 'cl))
38 ;;; Customization: Groups:
40 (defgroup gpg-ring nil
41 "GNU Privacy Guard user interface."
42 :tag "GnuPG user interface"
45 ;;; Customization: Variables:
47 (defface gpg-ring-key-invalid-face
49 (:foreground "yellow" :background "red"))
50 (t (:bold t :italic t :underline t)))
51 "Face for strings indicating key invalidity."
54 (defface gpg-ring-uncertain-validity-face
55 '((((class color)) (:foreground "red"))
57 "Face for strings indicating uncertain validity."
60 (defface gpg-ring-full-validity-face
61 '((((class color)) (:foreground "ForestGreen" :bold t))
63 "Face for strings indicating key invalidity."
66 (defvar gpg-ring-mode-hook nil
67 "Normal hook run when entering GnuPG ring mode.")
71 (defconst gpg-ring-algo-alist
73 (rsa-encrypt-only . "RSA-E")
74 (rsa-sign-only . "RSA-S")
75 (elgamal-encrypt-only . "ELG-E")
78 "Alist mapping algorithm IDs to algorithm abbreviations.")
80 (defconst gpg-ring-trust-alist
81 '((not-known "???" gpg-ring-uncertain-validity-face)
82 (disabled "DIS" gpg-ring-key-invalid-face)
83 (revoked "REV" gpg-ring-key-invalid-face)
84 (expired "EXP" gpg-ring-key-invalid-face)
85 (trust-undefined "QES" gpg-ring-uncertain-validity-face)
86 (trust-none "NON" gpg-ring-uncertain-validity-face)
87 (trust-marginal "MAR")
88 (trust-full "FUL" gpg-ring-full-validity-face)
89 (trust-ultimate "ULT" gpg-ring-full-validity-face))
90 "Alist mapping trust IDs to trust abbrevs and faces.")
92 (defvar gpg-ring-mode-map
93 (let ((map (make-keymap)))
94 (suppress-keymap map t)
96 "Keymap for `gpg-ring-mode'.")
98 (define-key gpg-ring-mode-map "0" 'delete-window)
99 (define-key gpg-ring-mode-map "1" 'delete-other-windows)
100 (define-key gpg-ring-mode-map "M" 'gpg-ring-mark-process-all)
101 (define-key gpg-ring-mode-map "U" 'gpg-ring-unmark-all)
102 (define-key gpg-ring-mode-map "a" 'gpg-ring-toggle-show-unusable)
103 (define-key gpg-ring-mode-map "d" 'gpg-ring-mark-delete)
104 (define-key gpg-ring-mode-map "f" 'gpg-ring-update-key)
105 (define-key gpg-ring-mode-map "g" 'gpg-ring-update)
106 (define-key gpg-ring-mode-map "i" 'gpg-ring-show-key)
107 (define-key gpg-ring-mode-map "l" 'gpg-ring-toggle-show-all-ids)
108 (define-key gpg-ring-mode-map "m" 'gpg-ring-mark-process)
109 (define-key gpg-ring-mode-map "n" 'gpg-ring-next-record)
110 (define-key gpg-ring-mode-map "p" 'gpg-ring-previous-record)
111 (define-key gpg-ring-mode-map "q" 'gpg-ring-quit)
112 (define-key gpg-ring-mode-map "u" 'gpg-ring-unmark)
113 (define-key gpg-ring-mode-map "x" 'gpg-ring-extract-keys)
114 (define-key gpg-ring-mode-map "X" 'gpg-ring-extract-keys-to-kill)
116 (define-key gpg-ring-mode-map "\C-c\C-c" 'gpg-ring-action)
118 ;;; Internal functions:
120 (defvar gpg-ring-key-list
122 "List of keys in the key list buffer.")
123 (make-variable-buffer-local 'gpg-ring-key-list)
125 (defvar gpg-ring-update-funcs
127 "List of functions called to obtain the key list.")
128 (make-variable-buffer-local 'gpg-ring-update-funcs)
130 (defvar gpg-ring-show-unusable
132 "If t, show expired, revoked and disabled keys, too.")
133 (make-variable-buffer-local 'gpg-ring-show-unusable)
135 (defvar gpg-ring-show-all-ids
137 "If t, show all user IDs. If nil, show only the primary user ID.")
138 (make-variable-buffer-local 'gpg-ring-show-all-ids)
140 (defvar gpg-ring-marks-alist
142 "Alist of (UNIQUE-ID MARK KEY).
143 UNIQUE-ID is a unique key ID from GnuPG. MARK is either `?D'
144 (marked for deletion), or `?*' (marked for processing).")
145 (make-variable-buffer-local 'gpg-ring-marks-alist)
147 (defvar gpg-ring-action
149 "Function to call when `gpg-ring-action' is invoked.
150 A list of the keys which are marked for processing is passed as argument.")
151 (make-variable-buffer-local 'gpg-ring-action)
153 (defun gpg-ring-mode ()
154 "Mode for editing GnuPG key rings.
155 \\{gpg-ring-mode-map}
156 Turning on gpg-ring-mode runs `gpg-ring-mode-hook'."
158 (kill-all-local-variables)
159 (buffer-disable-undo)
160 (setq truncate-lines t)
161 (setq buffer-read-only t)
162 (use-local-map gpg-ring-mode-map)
163 (setq mode-name "Key Ring")
164 (setq major-mode 'gpg-ring-mode)
165 (run-hooks 'gpg-ring-mode-hook))
168 (defmacro gpg-ring-record-start (&optional pos)
169 "Return buffer position of start of record containing POS."
170 `(get-text-property (or ,pos (point)) 'gpg-record-start))
172 (defun gpg-ring-current-key (&optional pos)
173 "Return GnuPG key at POS, or at point if ommitted."
174 (or (get-text-property (or pos (point)) 'gpg-key)
175 (error "No record on current line")))
177 (defun gpg-ring-goto-record (pos)
178 "Go to record starting at POS.
179 Position point after the marks at the beginning of a record."
183 (defun gpg-ring-next-record ()
184 "Advances point to the start of the next record."
186 (let ((start (next-single-property-change
187 (point) 'gpg-record-start nil (point-max))))
188 ;; Don't advance to the last line of the buffer.
189 (when (/= start (point-max))
190 (gpg-ring-goto-record start))))
192 (defun gpg-ring-previous-record ()
193 "Advances point to the start of the previous record."
195 ;; The last line of the buffer doesn't contain a record.
196 (let ((start (gpg-ring-record-start)))
198 (gpg-ring-goto-record (previous-single-property-change
199 start 'gpg-record-start nil (point-min)))
200 (gpg-ring-goto-record
201 (gpg-ring-record-start (1- (point-max)))))))
203 (defun gpg-ring-set-mark (&optional pos mark)
204 "Set MARK on record at POS, or at point if POS is omitted.
205 If MARK is omitted, clear it."
207 (let* ((start (gpg-ring-record-start pos))
208 (key (gpg-ring-current-key start))
209 (id (gpg-key-unique-id key))
210 (entry (assoc id gpg-ring-marks-alist))
213 ;; Replace the mark character.
214 (subst-char-in-region (point) (1+ (point)) (char-after)
216 ;; Store the mark in alist.
218 (setcdr entry (if mark (list mark key)))
220 (push (list id mark key) gpg-ring-marks-alist))))))
222 (defun gpg-ring-marked-keys (&optional only-marked mark)
223 "Return list of key specs which have MARK.
224 If no marks are present and ONLY-MARKED is not nil, return singleton
225 list with key of the current record. If MARK is omitted, `?*' is
227 (let ((the-marker (or mark ?*))
228 (marks gpg-ring-marks-alist)
231 (let ((mark (pop marks)))
232 ;; If this entry has got the right mark ...
233 (when (equal (nth 1 mark) the-marker)
234 ;; ... rember the key spec.
235 (push (nth 2 mark) key-list))))
236 (or key-list (if (not only-marked) (list (gpg-ring-current-key))))))
238 (defun gpg-ring-mark-process ()
239 "Mark record at point for processing."
241 (gpg-ring-set-mark nil ?*)
242 (gpg-ring-next-record))
244 (defun gpg-ring-mark-delete ()
245 "Mark record at point for processing."
247 (gpg-ring-set-mark nil ?D)
248 (gpg-ring-next-record))
250 (defun gpg-ring-unmark ()
251 "Mark record at point for processing."
254 (gpg-ring-next-record))
256 (defun gpg-ring-mark-process-all ()
257 "Put process mark on all records."
259 (setq gpg-ring-marks-alist
260 (mapcar (lambda (key)
261 (list (gpg-key-unique-id key) ?* key))
263 (gpg-ring-regenerate))
265 (defun gpg-ring-unmark-all ()
266 "Remove all record marks."
268 (setq gpg-ring-marks-alist nil)
269 (gpg-ring-regenerate))
271 (defun gpg-ring-toggle-show-unusable ()
272 "Toggle value if `gpg-ring-show-unusable'."
274 (setq gpg-ring-show-unusable (not gpg-ring-show-unusable))
275 (gpg-ring-regenerate))
277 (defun gpg-ring-toggle-show-all-ids ()
278 "Toggle value of `gpg-ring-show-all-ids'."
280 (setq gpg-ring-show-all-ids (not gpg-ring-show-all-ids))
281 (gpg-ring-regenerate))
283 (defvar gpg-ring-output-buffer-name "*GnuPG Output*"
284 "Name buffer to which output from GnuPG is sent.")
286 (defmacro gpg-ring-with-output-buffer (&rest body)
287 "Erase GnuPG output buffer, evaluate BODY in it, and display it."
288 `(with-current-buffer (get-buffer-create gpg-ring-output-buffer-name)
290 (setq truncate-lines t)
292 (goto-char (point-min))
293 (display-buffer gpg-ring-output-buffer-name)))
295 (defun gpg-ring-quit ()
296 "Bury key list buffer and kill GnuPG output buffer."
298 (let ((output (get-buffer gpg-ring-output-buffer-name)))
300 (kill-buffer output)))
301 (when (eq 'gpg-ring-mode major-mode)
304 (defun gpg-ring-show-key ()
305 "Show information for current key."
307 (let ((keys (gpg-ring-marked-keys)))
308 (gpg-ring-with-output-buffer
309 (gpg-key-insert-information (gpg-key-unique-id-list keys)))))
311 (defun gpg-ring-extract-keys ()
312 "Export currently selected public keys in ASCII armor."
314 (let ((keys (gpg-ring-marked-keys)))
315 (gpg-ring-with-output-buffer
316 (gpg-key-insert-public-key (gpg-key-unique-id-list keys)))))
318 (defun gpg-ring-extract-keys-to-kill ()
319 "Export currently selected public keys in ASCII armor to kill ring."
321 (let ((keys (gpg-ring-marked-keys)))
323 (gpg-key-insert-public-key (gpg-key-unique-id-list keys))
324 (copy-region-as-kill (point-min) (point-max)))))
326 (defun gpg-ring-update-key ()
327 "Fetch key information from key server."
329 (let ((keys (gpg-ring-marked-keys)))
330 (gpg-ring-with-output-buffer
331 (gpg-key-retrieve (gpg-key-unique-id-list keys)))))
333 (defun gpg-ring-insert-key-stat (key)
334 (let* ((validity (gpg-key-validity key))
335 (validity-entry (assq validity gpg-ring-trust-alist))
336 (trust (gpg-key-trust key))
337 (trust-entry (assq trust gpg-ring-trust-alist)))
338 ;; Insert abbrev for key status.
339 (let ((start (point)))
340 (insert (nth 1 validity-entry))
341 ;; Change face if necessary.
342 (when (nth 2 validity-entry)
343 (add-text-properties start (point)
344 (list 'face (nth 2 validity-entry)))))
345 ;; Trust, key ID, length, algorithm, creation date.
346 (insert (format "/%s %-8s/%4d/%-5s created %s"
348 (gpg-short-key-id key)
350 (cdr (assq (gpg-key-algorithm key) gpg-ring-algo-alist))
351 (gpg-key-creation-date key)))
353 (when (gpg-key-expire-date key)
355 (let ((start (point))
356 (expired (eq 'expired validity))
358 (insert (if expired "EXPIRED" "expires")
359 " " (gpg-key-expire-date key))
361 (add-text-properties start (point)
362 '(face gpg-ring-key-invalid-face)))))))
364 (defun gpg-ring-insert-key (key &optional mark)
365 "Inserts description for KEY into current buffer before point."
366 (let ((start (point)))
367 (insert (if mark mark " ")
368 " " (gpg-key-primary-user-id key) "\n"
370 (gpg-ring-insert-key-stat key)
372 (when gpg-ring-show-all-ids
373 (let ((uids (gpg-key-user-ids key)))
375 (insert " ID " (pop uids) "\n"))))
376 (add-text-properties start (point)
377 (list 'gpg-record-start start
380 (defun gpg-ring-regenerate ()
381 "Regenerate the key list buffer from stored data."
383 (let* ((key-list gpg-ring-key-list)
384 ;; Record position of point.
385 (old-record (if (eobp) ; No record on last line.
387 (gpg-key-unique-id (gpg-ring-current-key))))
388 (old-pos (if old-record (- (point) (gpg-ring-record-start))))
389 found new-pos new-pos-offset buffer-read-only new-marks)
390 ;; Replace buffer contents with new data.
393 (let* ((key (pop key-list))
394 (id (gpg-key-unique-id key))
395 (mark (assoc id gpg-ring-marks-alist)))
396 (when (or gpg-ring-show-unusable
397 (not (memq (gpg-key-validity key)
398 '(disabled revoked expired))))
399 ;; Check if point was in this record.
400 (when (and old-record
401 (string-equal old-record id))
402 (setq new-pos (point))
403 (setq new-pos-offset (+ new-pos old-pos)))
404 ;; Check if this record was marked.
407 (push mark new-marks)
408 (gpg-ring-insert-key key (nth 1 mark)))
409 (gpg-ring-insert-key key)))))
410 ;; Replace mark alist with the new one (which does not contain
411 ;; marks for records which vanished during this update).
412 (setq gpg-ring-marks-alist new-marks)
415 ;; We were at the end of the buffer before.
416 (goto-char (point-max))
418 (if (and (< new-pos-offset (point-max))
419 (equal old-record (gpg-key-unique-id
420 (gpg-ring-current-key new-pos-offset))))
421 ;; Record is there, with offset.
422 (goto-char new-pos-offset)
423 ;; Record is there, but not offset.
425 ;; Record is not there.
426 (goto-char (point-min))))))
428 (defun gpg-ring-update ()
429 "Update the key list buffer with new data."
431 (let ((funcs gpg-ring-update-funcs)
433 ;; Merge the sorted lists obtained by calling elements of
434 ;; `gpg-ring-update-funcs'.
436 (let ((additional (funcall (pop funcs)))
438 (while (and additional old)
439 (if (gpg-key-lessp (car additional) (car old))
440 (push (pop additional) new)
441 (if (gpg-key-lessp (car old) (car additional))
443 ;; Keys are perhaps equal. Always Add old key.
445 ;; If new key is equal, drop it, otherwise add it as well.
446 (if (string-equal (gpg-key-unique-id (car old))
447 (gpg-key-unique-id (car additional)))
449 (push (pop additional) new)))))
450 ;; Store new list as old one for next round.
451 (setq old (nconc (nreverse new) old additional))))
452 ;; Store the list in the buffer.
453 (setq gpg-ring-key-list old))
454 (gpg-ring-regenerate))
456 (defun gpg-ring-action ()
457 "Perform the action associated with this buffer."
460 (funcall gpg-ring-action (gpg-ring-marked-keys))
461 (error "No action for this buffer specified")))
464 (defun gpg-ring-keys (&optional key-list-funcs action)
466 (let ((buffer (get-buffer-create "*GnuPG Key List*")))
467 (with-current-buffer buffer
469 (setq gpg-ring-action action)
470 (setq gpg-ring-update-funcs key-list-funcs key-list-funcs)
472 (goto-char (point-min)))
473 (switch-to-buffer buffer)))
476 (defun gpg-ring-public (key-spec)
477 "List public keys matching keys KEY-SPEC."
478 (interactive "sList public keys containing: ")
479 (gpg-ring-keys `((lambda () (gpg-key-list-keys ,key-spec)))))
483 ;;; gpg-ring.el ends here