epa.el

   1 ;;; epa.el --- the EasyPG Assistant
   2 ;; Copyright (C) 2006 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Keywords: PGP, GnuPG
   6
   7 ;; This file is part of EasyPG.
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23
  24 ;;; Code:
  25
  26 (require 'epg)
  27 (require 'font-lock)
  28 (require 'widget)
  29 (eval-when-compile (require 'wid-edit))
  30
  31 (defgroup epa nil
  32   "The EasyPG Assistant"
  33   :group 'epg)
  34
  35 (defgroup epa-faces nil
  36   "Faces for epa-mode."
  37   :group 'epa)
  38
  39 (defface epa-validity-high-face
  40   '((((class color) (background dark))
  41      (:foreground "PaleTurquoise" :bold t))
  42     (t
  43      (:bold t)))
  44   "Face used for displaying the high validity."
  45   :group 'epa-faces)
  46 (defvar epa-validity-high-face 'epa-validity-high-face)
  47
  48 (defface epa-validity-medium-face
  49   '((((class color) (background dark))
  50      (:foreground "PaleTurquoise" :italic t))
  51     (t
  52      ()))
  53   "Face used for displaying the medium validity."
  54   :group 'epa-faces)
  55 (defvar epa-validity-medium-face 'epa-validity-medium-face)
  56
  57 (defface epa-validity-low-face
  58   '((t
  59      (:italic t)))
  60   "Face used for displaying the low validity."
  61   :group 'epa-faces)
  62 (defvar epa-validity-low-face 'epa-validity-low-face)
  63
  64 (defface epa-validity-disabled-face
  65   '((t
  66      (:italic t :inverse-video t)))
  67   "Face used for displaying the disabled validity."
  68   :group 'epa-faces)
  69 (defvar epa-validity-disabled-face 'epa-validity-disabled-face)
  70
  71 (defface epa-string-face
  72   '((((class color)
  73       (background dark))
  74      (:foreground "lightyellow"))
  75     (((class color)
  76       (background light))
  77      (:foreground "blue4"))
  78     (t
  79      ()))
  80   "Face used for displaying the string."
  81   :group 'epa-faces)
  82 (defvar epa-string-face 'epa-string-face)
  83
  84 (defface epa-mark-face
  85   '((((class color) (background dark))
  86      (:foreground "orange" :bold t))
  87     (t
  88      (:foreground "red" :bold t)))
  89   "Face used for displaying the high validity."
  90   :group 'epa-faces)
  91 (defvar epa-mark-face 'epa-mark-face)
  92
  93 (defface epa-field-name-face
  94   '((((class color) (background dark))
  95      (:foreground "PaleTurquoise" :bold t))
  96     (t (:bold t)))
  97   "Face for the name of the attribute field."
  98   :group 'epa)
  99 (defvar epa-field-name-face 'epa-field-name-face)
 100
 101 (defface epa-field-body-face
 102   '((((class color) (background dark))
 103      (:foreground "turquoise" :italic t))
 104     (t (:italic t)))
 105   "Face for the body of the attribute field."
 106   :group 'epa)
 107 (defvar epa-field-body-face 'epa-field-body-face)
 108
 109 (defcustom epa-validity-face-alist
 110   '((unknown . epa-validity-disabled-face)
 111     (invalid . epa-validity-disabled-face)
 112     (disabled . epa-validity-disabled-face)
 113     (revoked . epa-validity-disabled-face)
 114     (expired . epa-validity-disabled-face)
 115     (none . epa-validity-low-face)
 116     (undefined . epa-validity-low-face)
 117     (never . epa-validity-low-face)
 118     (marginal . epa-validity-medium-face)
 119     (full . epa-validity-high-face)
 120     (ultimate . epa-validity-high-face))
 121   "An alist mapping validity values to faces."
 122   :type 'list
 123   :group 'epa)
 124
 125 (defcustom epa-font-lock-keywords
 126   '(("^\\*"
 127      (0 epa-mark-face))
 128     ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
 129      (1 epa-field-name-face)
 130      (2 epa-field-body-face)))
 131   "Default expressions to addon in epa-mode."
 132   :type '(repeat (list string))
 133   :group 'epa)
 134
 135 (defconst epa-pubkey-algorithm-letter-alist
 136   '((1 . ?R)
 137     (2 . ?r)
 138     (3 . ?s)
 139     (16 . ?g)
 140     (17 . ?D)
 141     (20 . ?G)))
 142
 143 (defvar epa-keys-buffer nil)
 144 (defvar epa-key-buffer-alist nil)
 145 (defvar epa-key nil)
 146 (defvar epa-list-keys-arguments nil)
 147
 148 (defvar epa-keys-mode-map
 149   (let ((keymap (make-sparse-keymap)))
 150     (define-key keymap "m" 'epa-mark)
 151     (define-key keymap "u" 'epa-unmark)
 152     (define-key keymap "d" 'epa-decrypt-file)
 153     (define-key keymap "v" 'epa-verify-file)
 154     (define-key keymap "s" 'epa-sign-file)
 155     (define-key keymap "e" 'epa-encrypt-file)
 156     (define-key keymap "r" 'epa-delete-key)
 157     (define-key keymap "i" 'epa-import-key)
 158     (define-key keymap "g" 'epa-list-keys)
 159     (define-key keymap "n" 'next-line)
 160     (define-key keymap "p" 'previous-line)
 161     (define-key keymap " " 'scroll-up)
 162     (define-key keymap [delete] 'scroll-down)
 163     (define-key keymap "q" 'bury-buffer)
 164     keymap))
 165
 166 (define-widget 'epa-key 'push-button
 167   "Button for representing a epg-key object."
 168   :format "%[%v%]"
 169   :button-face-get 'epa-key-widget-button-face-get
 170   :value-create 'epa-key-widget-value-create
 171   :action 'epa-key-widget-action
 172   :help-echo 'epa-key-widget-help-echo)
 173
 174 (defun epa-key-widget-action (widget &optional event)
 175   (epa-show-key (widget-get widget :value)))
 176
 177 (defun epa-key-widget-value-create (widget)
 178   (let* ((key (widget-get widget :value))
 179          (primary-sub-key (car (epg-key-sub-key-list key)))
 180          (primary-user-id (car (epg-key-user-id-list key))))
 181     (insert (format "%c "
 182                     (if (epg-sub-key-validity primary-sub-key)
 183                         (car (rassq (epg-sub-key-validity primary-sub-key)
 184                                     epg-key-validity-alist))
 185                       ? ))
 186             (epg-sub-key-id primary-sub-key)
 187             " "
 188             (epg-user-id-name primary-user-id))))
 189
 190 (defun epa-key-widget-button-face-get (widget)
 191   (let ((validity (epg-sub-key-validity (car (epg-key-sub-key-list
 192                                               (widget-get widget :value))))))
 193     (if validity
 194         (cdr (assq validity epa-validity-face-alist))
 195       'default)))
 196
 197 (defun epa-key-widget-help-echo (widget)
 198   (format "Show %s"
 199           (epg-sub-key-id (car (epg-key-sub-key-list
 200                                 (widget-get widget :value))))))
 201
 202 (defun epa-keys-mode ()
 203   "Major mode for `epa-list-keys'."
 204   (kill-all-local-variables)
 205   (buffer-disable-undo)
 206   (setq major-mode 'epa-keys-mode
 207         mode-name "Keys"
 208         truncate-lines t
 209         buffer-read-only t)
 210   (use-local-map epa-keys-mode-map)
 211   (set-keymap-parent (current-local-map) widget-keymap)
 212   (make-local-variable 'font-lock-defaults)
 213   (setq font-lock-defaults '(epa-font-lock-keywords t))
 214   ;; In XEmacs, auto-initialization of font-lock is not effective
 215   ;; if buffer-file-name is not set.
 216   (font-lock-set-defaults)
 217   (widget-setup)
 218   (run-hooks 'epa-keys-mode-hook))
 219
 220 (defvar epa-key-mode-map
 221   (let ((keymap (make-sparse-keymap)))
 222     (define-key keymap "q" 'bury-buffer)
 223     keymap))
 224
 225 (defun epa-key-mode ()
 226   "Major mode for `epa-show-key'."
 227   (kill-all-local-variables)
 228   (buffer-disable-undo)
 229   (setq major-mode 'epa-key-mode
 230         mode-name "Key"
 231         truncate-lines t
 232         buffer-read-only t)
 233   (use-local-map epa-key-mode-map)
 234   (make-local-variable 'font-lock-defaults)
 235   (setq font-lock-defaults '(epa-font-lock-keywords t))
 236   ;; In XEmacs, auto-initialization of font-lock is not effective
 237   ;; if buffer-file-name is not set.
 238   (font-lock-set-defaults)
 239   (run-hooks 'epa-key-mode-hook))
 240
 241 ;;;###autoload
 242 (defun epa-list-keys (&optional name mode)
 243   (interactive
 244    (if current-prefix-arg
 245        (let ((name (read-string "Pattern: "
 246                                 (if epa-list-keys-arguments
 247                                     (car epa-list-keys-arguments)))))
 248          (list (if (equal name "") nil name)
 249                (y-or-n-p "Secret keys? ")))
 250      (or epa-list-keys-arguments (list nil nil))))
 251   (unless (and epa-keys-buffer
 252                (buffer-live-p epa-keys-buffer))
 253     (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 254   (set-buffer epa-keys-buffer)
 255   (let ((inhibit-read-only t)
 256         buffer-read-only)
 257     (erase-buffer)
 258     (epa-list-keys-1 name mode)
 259     (epa-keys-mode))
 260   (make-local-variable 'epa-list-keys-arguments)
 261   (setq epa-list-keys-arguments (list name mode))
 262   (goto-char (point-min))
 263   (pop-to-buffer (current-buffer)))
 264
 265 (defun epa-list-keys-1 (name mode)
 266   (let ((inhibit-read-only t)
 267         buffer-read-only
 268         (keys (epg-list-keys name mode))
 269         point)
 270     (while keys
 271       (setq point (point))
 272       (insert "  ")
 273       (put-text-property point (point) 'epa-key (car keys))
 274       (widget-create 'epa-key :value (car keys))
 275       (insert "\n")
 276       (setq keys (cdr keys)))))
 277
 278 (defun epa-select-keys (prompt &optional names)
 279   (save-excursion
 280     (unless (and epa-keys-buffer
 281                  (buffer-live-p epa-keys-buffer))
 282       (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 283     (let ((inhibit-read-only t)
 284           buffer-read-only
 285           point)
 286       (set-buffer epa-keys-buffer)
 287       (erase-buffer)
 288       (insert prompt "\n")
 289       (widget-create 'link
 290                      :notify (lambda (&rest ignore) (exit-recursive-edit))
 291                      :help-echo
 292                      (substitute-command-keys
 293                       "Click here or \\[exit-recursive-edit] to finish")
 294                      "OK")
 295       (insert "\n\n")
 296       (if names
 297           (while names
 298             (setq point (point))
 299             (epa-list-keys-1 (car names) nil)
 300             (goto-char point)
 301             (epa-mark)
 302             (goto-char (point-max))
 303             (setq names (cdr names)))
 304         (epa-list-keys-1 nil nil))
 305       (epa-keys-mode)
 306       (goto-char (point-min))
 307       (pop-to-buffer (current-buffer))
 308       (unwind-protect
 309           (progn
 310             (recursive-edit)
 311             (save-excursion
 312               (set-buffer epa-keys-buffer)
 313               (goto-char (point-min))
 314               (let (keys key)
 315                 (while (re-search-forward "^\\*" nil t)
 316                   (if (setq key (get-text-property (match-beginning 0)
 317                                                    'epa-key))
 318                       (setq keys (cons key keys))))
 319                 (nreverse keys))))
 320         (if (get-buffer-window epa-keys-buffer)
 321             (delete-window (get-buffer-window epa-keys-buffer)))
 322         (kill-buffer epa-keys-buffer)))))
 323
 324 (defun epa-show-key (key)
 325   (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
 326          (entry (assoc (epg-sub-key-id primary-sub-key)
 327                        epa-key-buffer-alist))
 328          (inhibit-read-only t)
 329          buffer-read-only
 330          pointer)
 331     (unless entry
 332       (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
 333             epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
 334     (unless (and (cdr entry)
 335                  (buffer-live-p (cdr entry)))
 336       (setcdr entry (generate-new-buffer
 337                      (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
 338     (set-buffer (cdr entry))
 339     (make-local-variable 'epa-key)
 340     (setq epa-key key)
 341     (erase-buffer)
 342     (setq pointer (epg-key-user-id-list key))
 343     (while pointer
 344       (insert " "
 345               (if (epg-user-id-validity (car pointer))
 346                   (char-to-string
 347                    (car (rassq (epg-user-id-validity (car pointer))
 348                                epg-key-validity-alist)))
 349                 " ")
 350               " "
 351               (epg-user-id-name (car pointer))
 352               "\n")
 353       (setq pointer (cdr pointer)))
 354     (setq pointer (epg-key-sub-key-list key))
 355     (while pointer
 356       (insert " "
 357               (if (epg-sub-key-validity (car pointer))
 358                   (char-to-string
 359                    (car (rassq (epg-sub-key-validity (car pointer))
 360                                epg-key-validity-alist)))
 361                 " ")
 362               " "
 363               (epg-sub-key-id (car pointer))
 364               " "
 365               (format "%dbits"
 366                       (epg-sub-key-length (car pointer)))
 367               " "
 368               (cdr (assq (epg-sub-key-algorithm (car pointer))
 369                          epg-pubkey-algorithm-alist))
 370               "\n\tCreated: "
 371               (epg-sub-key-creation-time (car pointer))
 372               (if (epg-sub-key-expiration-time (car pointer))
 373                   (format "\n\tExpires: %s" (epg-sub-key-expiration-time
 374                                              (car pointer)))
 375                 "")
 376               "\n\tCapabilities: "
 377               (mapconcat #'symbol-name
 378                          (epg-sub-key-capability (car pointer))
 379                          " ")
 380               "\n\tFingerprint: "
 381               (epg-sub-key-fingerprint (car pointer))
 382               "\n")
 383       (setq pointer (cdr pointer)))
 384     (goto-char (point-min))
 385     (pop-to-buffer (current-buffer))
 386     (epa-key-mode)))
 387
 388 (defun epa-show-key-notify (widget &rest ignore)
 389   (epa-show-key (widget-get widget :value)))
 390
 391 (defun epa-mark (&optional arg)
 392   "Mark the current line."
 393   (interactive "P")
 394   (let ((inhibit-read-only t)
 395         buffer-read-only
 396         properties)
 397     (beginning-of-line)
 398     (setq properties (text-properties-at (point)))
 399     (delete-char 1)
 400     (insert (if arg " " "*"))
 401     (set-text-properties (1- (point)) (point) properties)
 402     (forward-line)))
 403
 404 (defun epa-unmark (&optional arg)
 405   "Unmark the current line."
 406   (interactive "P")
 407   (epa-mark (not arg)))
 408
 409 (defun epa-decrypt-file (file)
 410   (interactive "fFile: ")
 411   (let* ((default-name (file-name-sans-extension file))
 412          (plain (expand-file-name
 413                  (read-file-name
 414                   (concat "To file (default "
 415                           (file-name-nondirectory default-name)
 416                           ") ")
 417                   (file-name-directory default-name)
 418                   default-name)))
 419          (context (epg-make-context)))
 420     (message "Decrypting %s..." (file-name-nondirectory file))
 421     (epg-decrypt-file context file plain)
 422     (message "Decrypting %s...done" (file-name-nondirectory file))))
 423
 424 (defun epa-verify-file (file)
 425   (interactive "fFile: ")
 426   (let* ((context (epg-make-context))
 427          (plain (if (equal (file-name-extension file) "sig")
 428                     (file-name-sans-extension file)))
 429          signature)
 430     (message "Verifying %s..." (file-name-nondirectory file))
 431     (epg-verify-file context file plain)
 432     (setq signature (reverse (epg-context-result-for context 'verify)))
 433     (with-output-to-temp-buffer "*epa-verify-file*"
 434       (set-buffer standard-output)
 435       (while signature
 436         (insert (format "%s: %s %s %s\n"
 437                         (epg-signature-status (car signature))
 438                         (epg-signature-key-id (car signature))
 439                         (epg-signature-user-id (car signature))
 440                         (epg-signature-validity (car signature))))
 441         (setq signature (cdr signature))))
 442     (shrink-window-if-larger-than-buffer
 443      (get-buffer-window "*epa-verify-file*"))
 444     (message "Verifying %s...done" (file-name-nondirectory file))))
 445
 446 (defun epa-sign-file (file detached)
 447   (interactive
 448    (list (expand-file-name (read-file-name "File: "))
 449          (y-or-n-p "Make a detached signature? ")))
 450   (let ((signature (concat file (if detached ".sig" ".gpg")))
 451         (context (epg-make-context)))
 452     (message "Signing %s..." (file-name-nondirectory file))
 453     (epg-sign-file context file signature (not (null detached)))
 454     (message "Signing %s...done" (file-name-nondirectory file))))
 455
 456 (defun epa-encrypt-file (file recipients)
 457   (interactive
 458    (list (expand-file-name (read-file-name "File: "))
 459          (mapcar (lambda (key)
 460                  (epg-sub-key-id
 461                   (car (epg-key-sub-key-list key))))
 462                  (epa-select-keys "Select recipents for encryption.
 463 If no one is selected, symmetric encryption will be performed.  "))))
 464   (let ((cipher (concat file ".gpg"))
 465         (context (epg-make-context)))
 466     (message "Encrypting %s..." (file-name-nondirectory file))
 467     (epg-encrypt-file context
 468                       file
 469                       recipients
 470                       cipher)
 471     (message "Encrypting %s...done" (file-name-nondirectory file))))
 472
 473 (defun epa-delete-key (key)
 474   (interactive
 475    (list
 476     (save-excursion
 477       (beginning-of-line)
 478       (get-text-property (point) 'epa-key))))
 479   (let ((context (epg-make-context)))
 480     (message "Deleting %s..."
 481              (epg-sub-key-id (car (epg-key-sub-key-list key))))
 482     (epg-delete-key context key)
 483     (apply #'epa-list-keys epa-list-keys-arguments)
 484     (message "Deleting %s...done"
 485              (epg-sub-key-id (car (epg-key-sub-key-list key))))))
 486
 487 (defun epa-import-key (file)
 488   (interactive "sFile: ")
 489   (let ((context (epg-make-context)))
 490     (message "Importing %s..." (file-name-nondirectory file))
 491     (epg-import-key context file)
 492     (apply #'epa-list-keys epa-list-keys-arguments)
 493     (message "Importing %s...done" (file-name-nondirectory file))))
 494
 495 (provide 'epa)
 496
 497 ;;; epa.el ends here