git.chise.org Git - elisp/gnus.git-/blob - contrib/gpg-ring.el

   1 ;;; gpg-ring.el --- Major mode for editing GnuPG key rings.
   2
   3 ;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart
   4
   5 ;; Author: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
   6 ;; Maintainer: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
   7 ;; Keywords: crypto
   8 ;; Created: 2000-04-28
   9
  10 ;; $Id: gpg-ring.el,v 1.1.1.1 2001-04-15 22:41:22 yamaoka Exp $
  11
  12 ;; This file is NOT (yet?) part of GNU Emacs.
  13
  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)
  17 ;; any later version.
  18
  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.
  23
  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.
  28
  29
  30 \f
  31 ;;;; Code:
  32
  33 (require 'gpg)
  34 (eval-when-compile
  35   (require 'cl))
  36
  37 ;;;; Customization:
  38
  39 ;;; Customization: Groups:
  40
  41 (defgroup gpg-ring nil
  42   "GNU Privacy Guard user interface."
  43   :tag "GnuPG user interface"
  44   :group 'gpg)
  45
  46 ;;; Customization: Variables:
  47
  48 (defface gpg-ring-key-invalid-face
  49   '((((class color))
  50      (:foreground "yellow" :background "red"))
  51     (t (:bold t :italic t :underline t)))
  52   "Face for strings indicating key invalidity."
  53   :group 'gpg-ring)
  54
  55 (defface gpg-ring-uncertain-validity-face
  56   '((((class color)) (:foreground "red"))
  57     (t (:bold t)))
  58   "Face for strings indicating uncertain validity."
  59   :group 'gpg-ring)
  60
  61 (defface gpg-ring-full-validity-face
  62   '((((class color)) (:foreground "ForestGreen" :bold t))
  63     (t (:bold t)))
  64   "Face for strings indicating key invalidity."
  65   :group 'gpg-ring)
  66
  67 (defvar gpg-ring-mode-hook nil
  68   "Normal hook run when entering GnuPG ring mode.")
  69
  70 ;;; Constants
  71
  72 (defconst gpg-ring-algo-alist
  73   '((rsa . "RSA")
  74     (rsa-encrypt-only . "RSA-E")
  75     (rsa-sign-only . "RSA-S")
  76     (elgamal-encrypt-only . "ELG-E")
  77     (dsa . "DSA")
  78     (elgamal . "ELG-E"))
  79   "Alist mapping algorithm IDs to algorithm abbreviations.")
  80
  81 (defconst gpg-ring-trust-alist
  82   '((not-known       "???" gpg-ring-uncertain-validity-face)
  83     (disabled        "DIS" gpg-ring-key-invalid-face)
  84     (revoked         "REV" gpg-ring-key-invalid-face)
  85     (expired         "EXP" gpg-ring-key-invalid-face)
  86     (trust-undefined "QES" gpg-ring-uncertain-validity-face)
  87     (trust-none      "NON" gpg-ring-uncertain-validity-face)
  88     (trust-marginal  "MAR")
  89     (trust-full      "FUL" gpg-ring-full-validity-face)
  90     (trust-ultimate  "ULT" gpg-ring-full-validity-face))
  91   "Alist mapping trust IDs to trust abbrevs and faces.")
  92
  93 (defvar gpg-ring-mode-map
  94   (let ((map (make-keymap)))
  95     (suppress-keymap map t)
  96     map)
  97   "Keymap for `gpg-ring-mode'.")
  98
  99 (define-key gpg-ring-mode-map "0" 'delete-window)
 100 (define-key gpg-ring-mode-map "1" 'delete-other-windows)
 101 (define-key gpg-ring-mode-map "M" 'gpg-ring-mark-process-all)
 102 (define-key gpg-ring-mode-map "U" 'gpg-ring-unmark-all)
 103 (define-key gpg-ring-mode-map "a" 'gpg-ring-toggle-show-unusable)
 104 (define-key gpg-ring-mode-map "d" 'gpg-ring-mark-delete)
 105 (define-key gpg-ring-mode-map "f" 'gpg-ring-update-key)
 106 (define-key gpg-ring-mode-map "g" 'gpg-ring-update)
 107 (define-key gpg-ring-mode-map "i" 'gpg-ring-show-key)
 108 (define-key gpg-ring-mode-map "l" 'gpg-ring-toggle-show-all-ids)
 109 (define-key gpg-ring-mode-map "m" 'gpg-ring-mark-process)
 110 (define-key gpg-ring-mode-map "n" 'gpg-ring-next-record)
 111 (define-key gpg-ring-mode-map "p" 'gpg-ring-previous-record)
 112 (define-key gpg-ring-mode-map "q" 'gpg-ring-quit)
 113 (define-key gpg-ring-mode-map "u" 'gpg-ring-unmark)
 114 (define-key gpg-ring-mode-map "x" 'gpg-ring-extract-keys)
 115 (define-key gpg-ring-mode-map "X" 'gpg-ring-extract-keys-to-kill)
 116
 117 (define-key gpg-ring-mode-map "\C-c\C-c" 'gpg-ring-action)
 118
 119 ;;; Internal functions:
 120
 121 (defvar gpg-ring-key-list
 122   nil
 123   "List of keys in the key list buffer.")
 124 (make-variable-buffer-local 'gpg-ring-key-list)
 125
 126 (defvar gpg-ring-update-funcs
 127   nil
 128   "List of functions called to obtain the key list.")
 129 (make-variable-buffer-local 'gpg-ring-update-funcs)
 130
 131 (defvar gpg-ring-show-unusable
 132   nil
 133   "If t, show expired, revoked and disabled keys, too.")
 134 (make-variable-buffer-local 'gpg-ring-show-unusable)
 135
 136 (defvar gpg-ring-show-all-ids
 137   nil
 138   "If t, show all user IDs.  If nil, show only the primary user ID.")
 139 (make-variable-buffer-local 'gpg-ring-show-all-ids)
 140
 141 (defvar gpg-ring-marks-alist
 142   nil
 143   "Alist of (UNIQUE-ID MARK KEY).
 144 UNIQUE-ID is a unique key ID from GnuPG.  MARK is either `?D'
 145 (marked for deletion), or `?*' (marked for processing).")
 146 (make-variable-buffer-local 'gpg-ring-marks-alist)
 147
 148 (defvar gpg-ring-action
 149   nil
 150   "Function to call when `gpg-ring-action' is invoked.
 151 A list of the keys which are marked for processing is passed as argument.")
 152 (make-variable-buffer-local 'gpg-ring-action)
 153
 154 (defun gpg-ring-mode ()
 155   "Mode for editing GnuPG key rings.
 156 \\{gpg-ring-mode-map}
 157 Turning on gpg-ring-mode runs `gpg-ring-mode-hook'."
 158   (interactive)
 159   (kill-all-local-variables)
 160   (buffer-disable-undo)
 161   (setq truncate-lines t)
 162   (setq buffer-read-only t)
 163   (use-local-map gpg-ring-mode-map)
 164   (setq mode-name "Key Ring")
 165   (setq major-mode 'gpg-ring-mode)
 166   (run-hooks 'gpg-ring-mode-hook))
 167
 168
 169 (defmacro gpg-ring-record-start (&optional pos)
 170   "Return buffer position of start of record containing POS."
 171   `(get-text-property (or ,pos (point)) 'gpg-record-start))
 172
 173 (defun gpg-ring-current-key (&optional pos)
 174   "Return GnuPG key at POS, or at point if ommitted."
 175   (or (get-text-property (or pos (point)) 'gpg-key)
 176       (error "No record on current line")))
 177
 178 (defun gpg-ring-goto-record (pos)
 179   "Go to record starting at POS.
 180 Position point after the marks at the beginning of a record."
 181   (goto-char pos)
 182   (forward-char 2))
 183
 184 (defun gpg-ring-next-record ()
 185   "Advances point to the start of the next record."
 186   (interactive)
 187   (let ((start (next-single-property-change
 188                 (point) 'gpg-record-start nil (point-max))))
 189     ;; Don't advance to the last line of the buffer.
 190     (when (/= start (point-max))
 191         (gpg-ring-goto-record start))))
 192
 193 (defun gpg-ring-previous-record ()
 194   "Advances point to the start of the previous record."
 195   (interactive)
 196   ;; The last line of the buffer doesn't contain a record.
 197   (let ((start (gpg-ring-record-start)))
 198     (if start
 199         (gpg-ring-goto-record (previous-single-property-change
 200                                     start 'gpg-record-start nil (point-min)))
 201       (gpg-ring-goto-record
 202        (gpg-ring-record-start (1- (point-max)))))))
 203
 204 (defun gpg-ring-set-mark (&optional pos mark)
 205   "Set MARK on record at POS, or at point if POS is omitted.
 206 If MARK is omitted, clear it."
 207   (save-excursion
 208     (let* ((start (gpg-ring-record-start pos))
 209            (key (gpg-ring-current-key start))
 210            (id (gpg-key-unique-id key))
 211            (entry (assoc id gpg-ring-marks-alist))
 212            buffer-read-only)
 213       (goto-char start)
 214       ;; Replace the mark character.
 215       (subst-char-in-region (point) (1+ (point)) (char-after)
 216                             (or mark ? ))
 217       ;; Store the mark in alist.
 218       (if entry
 219           (setcdr entry (if mark (list mark key)))
 220         (when mark
 221           (push (list id mark key) gpg-ring-marks-alist))))))
 222
 223 (defun gpg-ring-marked-keys (&optional only-marked mark)
 224   "Return list of key specs which have MARK.
 225 If no marks are present and ONLY-MARKED is not nil, return singleton
 226 list with key of the current record.  If MARK is omitted, `?*' is
 227 used."
 228   (let ((the-marker (or mark ?*))
 229         (marks gpg-ring-marks-alist)
 230         key-list)
 231     (while marks
 232       (let ((mark (pop marks)))
 233         ;; If this entry has got the right mark ...
 234         (when (equal (nth 1 mark) the-marker)
 235           ;; ... rember the key spec.
 236           (push (nth 2 mark) key-list))))
 237     (or key-list (if (not only-marked) (list (gpg-ring-current-key))))))
 238
 239 (defun gpg-ring-mark-process ()
 240   "Mark record at point for processing."
 241   (interactive)
 242   (gpg-ring-set-mark nil ?*)
 243   (gpg-ring-next-record))
 244
 245 (defun gpg-ring-mark-delete ()
 246   "Mark record at point for processing."
 247   (interactive)
 248   (gpg-ring-set-mark nil ?D)
 249   (gpg-ring-next-record))
 250
 251 (defun gpg-ring-unmark ()
 252   "Mark record at point for processing."
 253   (interactive)
 254   (gpg-ring-set-mark)
 255   (gpg-ring-next-record))
 256
 257 (defun gpg-ring-mark-process-all ()
 258   "Put process mark on all records."
 259   (interactive)
 260   (setq gpg-ring-marks-alist
 261         (mapcar (lambda (key)
 262                   (list (gpg-key-unique-id key) ?* key))
 263                 gpg-ring-key-list))
 264   (gpg-ring-regenerate))
 265
 266 (defun gpg-ring-unmark-all ()
 267   "Remove all record marks."
 268   (interactive)
 269   (setq gpg-ring-marks-alist nil)
 270   (gpg-ring-regenerate))
 271
 272 (defun gpg-ring-toggle-show-unusable ()
 273   "Toggle value if `gpg-ring-show-unusable'."
 274   (interactive)
 275   (setq gpg-ring-show-unusable (not gpg-ring-show-unusable))
 276   (gpg-ring-regenerate))
 277
 278 (defun gpg-ring-toggle-show-all-ids ()
 279   "Toggle value of `gpg-ring-show-all-ids'."
 280   (interactive)
 281   (setq gpg-ring-show-all-ids (not gpg-ring-show-all-ids))
 282   (gpg-ring-regenerate))
 283
 284 (defvar gpg-ring-output-buffer-name "*GnuPG Output*"
 285   "Name buffer to which output from GnuPG is sent.")
 286
 287 (defmacro gpg-ring-with-output-buffer (&rest body)
 288   "Erase GnuPG output buffer, evaluate BODY in it, and display it."
 289   `(with-current-buffer (get-buffer-create gpg-ring-output-buffer-name)
 290      (erase-buffer)
 291      (setq truncate-lines t)
 292      ,@body
 293      (goto-char (point-min))
 294      (display-buffer gpg-ring-output-buffer-name)))
 295
 296 (defun gpg-ring-quit ()
 297   "Bury key list buffer and kill GnuPG output buffer."
 298   (interactive)
 299   (let ((output (get-buffer gpg-ring-output-buffer-name)))
 300     (when output
 301       (kill-buffer output)))
 302   (when (eq 'gpg-ring-mode major-mode)
 303     (bury-buffer)))
 304
 305 (defun gpg-ring-show-key ()
 306   "Show information for current key."
 307   (interactive)
 308   (let ((keys (gpg-ring-marked-keys)))
 309     (gpg-ring-with-output-buffer
 310      (gpg-key-insert-information (gpg-key-unique-id-list keys)))))
 311
 312 (defun gpg-ring-extract-keys ()
 313   "Export currently selected public keys in ASCII armor."
 314   (interactive)
 315   (let ((keys (gpg-ring-marked-keys)))
 316     (gpg-ring-with-output-buffer
 317      (gpg-key-insert-public-key (gpg-key-unique-id-list keys)))))
 318
 319 (defun gpg-ring-extract-keys-to-kill ()
 320   "Export currently selected public keys in ASCII armor to kill ring."
 321   (interactive)
 322   (let ((keys (gpg-ring-marked-keys)))
 323     (with-temp-buffer
 324       (gpg-key-insert-public-key (gpg-key-unique-id-list keys))
 325       (copy-region-as-kill (point-min) (point-max)))))
 326
 327 (defun gpg-ring-update-key ()
 328   "Fetch key information from key server."
 329   (interactive)
 330   (let ((keys (gpg-ring-marked-keys)))
 331     (gpg-ring-with-output-buffer
 332      (gpg-key-retrieve (gpg-key-unique-id-list keys)))))
 333
 334 (defun gpg-ring-insert-key-stat (key)
 335   (let* ((validity (gpg-key-validity key))
 336          (validity-entry (assq validity gpg-ring-trust-alist))
 337          (trust (gpg-key-trust key))
 338          (trust-entry (assq trust gpg-ring-trust-alist)))
 339     ;; Insert abbrev for key status.
 340     (let ((start (point)))
 341       (insert (nth 1 validity-entry))
 342       ;; Change face if necessary.
 343       (when (nth 2 validity-entry)
 344         (add-text-properties start (point)
 345                              (list 'face (nth 2 validity-entry)))))
 346     ;; Trust, key ID, length, algorithm, creation date.
 347     (insert (format "/%s %-8s/%4d/%-5s created %s"
 348                     (nth 1 trust-entry)
 349                     (gpg-short-key-id key)
 350                     (gpg-key-length key)
 351                     (cdr (assq (gpg-key-algorithm key) gpg-ring-algo-alist))
 352                     (gpg-key-creation-date key)))
 353     ;; Expire date.
 354     (when (gpg-key-expire-date key)
 355       (insert ", ")
 356       (let ((start (point))
 357             (expired (eq 'expired validity))
 358             (notice (concat )))
 359         (insert (if expired "EXPIRED" "expires")
 360                 " " (gpg-key-expire-date key))
 361         (when expired
 362           (add-text-properties start (point)
 363                                '(face gpg-ring-key-invalid-face)))))))
 364
 365 (defun gpg-ring-insert-key (key &optional mark)
 366   "Inserts description for KEY into current buffer before point."
 367   (let ((start (point)))
 368     (insert (if mark mark " ")
 369             " " (gpg-key-primary-user-id key) "\n"
 370             "    ")
 371     (gpg-ring-insert-key-stat key)
 372     (insert "\n")
 373     (when gpg-ring-show-all-ids
 374       (let ((uids (gpg-key-user-ids key)))
 375         (while uids
 376           (insert "     ID " (pop uids) "\n"))))
 377     (add-text-properties start (point)
 378                          (list 'gpg-record-start start
 379                                'gpg-key key))))
 380
 381 (defun gpg-ring-regenerate ()
 382   "Regenerate the key list buffer from stored data."
 383   (interactive)
 384   (let* ((key-list gpg-ring-key-list)
 385          ;; Record position of point.
 386          (old-record (if (eobp)         ; No record on last line.
 387                          nil
 388                        (gpg-key-unique-id (gpg-ring-current-key))))
 389          (old-pos (if old-record (- (point) (gpg-ring-record-start))))
 390          found new-pos new-pos-offset buffer-read-only new-marks)
 391     ;; Replace buffer contents with new data.
 392     (erase-buffer)
 393     (while key-list
 394       (let* ((key (pop key-list))
 395              (id (gpg-key-unique-id key))
 396              (mark (assoc id gpg-ring-marks-alist)))
 397         (when (or gpg-ring-show-unusable
 398                   (not (memq (gpg-key-validity key)
 399                              '(disabled revoked expired))))
 400           ;; Check if point was in this record.
 401           (when (and old-record
 402                      (string-equal old-record id))
 403             (setq new-pos (point))
 404             (setq new-pos-offset (+ new-pos old-pos)))
 405           ;; Check if this record was marked.
 406           (if (nth 1 mark)
 407               (progn
 408                 (push mark new-marks)
 409                 (gpg-ring-insert-key key (nth 1 mark)))
 410             (gpg-ring-insert-key key)))))
 411     ;; Replace mark alist with the new one (which does not contain
 412     ;; marks for records which vanished during this update).
 413     (setq gpg-ring-marks-alist new-marks)
 414     ;; Restore point.
 415     (if (not old-record)
 416         ;; We were at the end of the buffer before.
 417         (goto-char (point-max))
 418       (if new-pos
 419           (if (and (< new-pos-offset (point-max))
 420                    (equal old-record (gpg-key-unique-id
 421                                       (gpg-ring-current-key new-pos-offset))))
 422               ;; Record is there, with offset.
 423               (goto-char new-pos-offset)
 424             ;; Record is there, but not offset.
 425             (goto-char new-pos))
 426         ;; Record is not there.
 427         (goto-char (point-min))))))
 428
 429 (defun gpg-ring-update ()
 430   "Update the key list buffer with new data."
 431   (interactive)
 432   (let ((funcs gpg-ring-update-funcs)
 433         old)
 434     ;; Merge the sorted lists obtained by calling elements of
 435     ;; `gpg-ring-update-funcs'.
 436     (while funcs
 437       (let ((additional (funcall (pop funcs)))
 438             new)
 439         (while (and additional old)
 440           (if (gpg-key-lessp (car additional) (car old))
 441               (push (pop additional) new)
 442             (if (gpg-key-lessp (car old) (car additional))
 443                 (push (pop old) new)
 444               ;; Keys are perhaps equal.  Always Add old key.
 445               (push (pop old) new)
 446               ;; If new key is equal, drop it, otherwise add it as well.
 447               (if (string-equal (gpg-key-unique-id (car old))
 448                                 (gpg-key-unique-id (car additional)))
 449                   (pop additional)
 450                 (push (pop additional) new)))))
 451         ;; Store new list as old one for next round.
 452         (setq old (nconc (nreverse new) old additional))))
 453     ;; Store the list in the buffer.
 454     (setq gpg-ring-key-list old))
 455   (gpg-ring-regenerate))
 456
 457 (defun gpg-ring-action ()
 458   "Perform the action associated with this buffer."
 459   (interactive)
 460   (if gpg-ring-action
 461       (funcall gpg-ring-action (gpg-ring-marked-keys))
 462     (error "No action for this buffer specified")))
 463
 464 ;;;###autoload
 465 (defun gpg-ring-keys (&optional key-list-funcs action)
 466   (interactive)
 467   (let ((buffer (get-buffer-create "*GnuPG Key List*")))
 468     (with-current-buffer buffer
 469       (gpg-ring-mode)
 470       (setq gpg-ring-action action)
 471       (setq gpg-ring-update-funcs key-list-funcs key-list-funcs)
 472       (gpg-ring-update)
 473       (goto-char (point-min)))
 474     (switch-to-buffer buffer)))
 475
 476 ;;;###autoload
 477 (defun gpg-ring-public (key-spec)
 478   "List public keys matching keys KEY-SPEC."
 479   (interactive "sList public keys containing: ")
 480   (gpg-ring-keys  `((lambda () (gpg-key-list-keys ,key-spec)))))
 481
 482 (provide 'gpg-ring)
 483
 484 ;;; gpg-ring.el ends here