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 "S" 'epa-sign-keys)
 156     (define-key keymap "e" 'epa-encrypt-file)
 157     (define-key keymap "r" 'epa-delete-keys)
 158     (define-key keymap "i" 'epa-import-keys)
 159     (define-key keymap "o" 'epa-export-keys)
 160     (define-key keymap "g" 'epa-list-keys)
 161     (define-key keymap "n" 'next-line)
 162     (define-key keymap "p" 'previous-line)
 163     (define-key keymap " " 'scroll-up)
 164     (define-key keymap [delete] 'scroll-down)
 165     (define-key keymap "q" 'epa-exit-buffer)
 166     keymap))
 167
 168 (defvar epa-exit-buffer-function #'bury-buffer)
 169
 170 (define-widget 'epa-key 'push-button
 171   "Button for representing a epg-key object."
 172   :format "%[%v%]"
 173   :button-face-get 'epa-key-widget-button-face-get
 174   :value-create 'epa-key-widget-value-create
 175   :action 'epa-key-widget-action
 176   :help-echo 'epa-key-widget-help-echo)
 177
 178 (defun epa-key-widget-action (widget &optional event)
 179   (epa-show-key (widget-get widget :value)))
 180
 181 (defun epa-key-widget-value-create (widget)
 182   (let* ((key (widget-get widget :value))
 183          (primary-sub-key (car (epg-key-sub-key-list key)))
 184          (primary-user-id (car (epg-key-user-id-list key))))
 185     (insert (format "%c "
 186                     (if (epg-sub-key-validity primary-sub-key)
 187                         (car (rassq (epg-sub-key-validity primary-sub-key)
 188                                     epg-key-validity-alist))
 189                       ? ))
 190             (epg-sub-key-id primary-sub-key)
 191             " "
 192             (if (stringp (epg-user-id-string primary-user-id))
 193                 (epg-user-id-string primary-user-id)
 194               (epg-decode-dn (epg-user-id-string primary-user-id))))))
 195
 196 (defun epa-key-widget-button-face-get (widget)
 197   (let ((validity (epg-sub-key-validity (car (epg-key-sub-key-list
 198                                               (widget-get widget :value))))))
 199     (if validity
 200         (cdr (assq validity epa-validity-face-alist))
 201       'default)))
 202
 203 (defun epa-key-widget-help-echo (widget)
 204   (format "Show %s"
 205           (epg-sub-key-id (car (epg-key-sub-key-list
 206                                 (widget-get widget :value))))))
 207
 208 (defun epa-keys-mode ()
 209   "Major mode for `epa-list-keys'."
 210   (kill-all-local-variables)
 211   (buffer-disable-undo)
 212   (setq major-mode 'epa-keys-mode
 213         mode-name "Keys"
 214         truncate-lines t
 215         buffer-read-only t)
 216   (use-local-map epa-keys-mode-map)
 217   (set-keymap-parent (current-local-map) widget-keymap)
 218   (make-local-variable 'font-lock-defaults)
 219   (setq font-lock-defaults '(epa-font-lock-keywords t))
 220   ;; In XEmacs, auto-initialization of font-lock is not effective
 221   ;; if buffer-file-name is not set.
 222   (font-lock-set-defaults)
 223   (widget-setup)
 224   (make-local-variable 'epa-exit-buffer-function)
 225   (run-hooks 'epa-keys-mode-hook))
 226
 227 (defvar epa-key-mode-map
 228   (let ((keymap (make-sparse-keymap)))
 229     (define-key keymap "q" 'bury-buffer)
 230     keymap))
 231
 232 (defun epa-key-mode ()
 233   "Major mode for `epa-show-key'."
 234   (kill-all-local-variables)
 235   (buffer-disable-undo)
 236   (setq major-mode 'epa-key-mode
 237         mode-name "Key"
 238         truncate-lines t
 239         buffer-read-only t)
 240   (use-local-map epa-key-mode-map)
 241   (make-local-variable 'font-lock-defaults)
 242   (setq font-lock-defaults '(epa-font-lock-keywords t))
 243   ;; In XEmacs, auto-initialization of font-lock is not effective
 244   ;; if buffer-file-name is not set.
 245   (font-lock-set-defaults)
 246   (make-local-variable 'epa-exit-buffer-function)
 247   (run-hooks 'epa-key-mode-hook))
 248
 249 ;;;###autoload
 250 (defun epa-list-keys (&optional name mode protocol)
 251   (interactive
 252    (if current-prefix-arg
 253        (let ((name (read-string "Pattern: "
 254                                 (if epa-list-keys-arguments
 255                                     (car epa-list-keys-arguments)))))
 256          (list (if (equal name "") nil name)
 257                (y-or-n-p "Secret keys? ")
 258                (intern (completing-read "Protocol? "
 259                                         '(("OpenPGP") ("CMS"))
 260                                         nil t))))
 261      (or epa-list-keys-arguments (list nil nil nil))))
 262   (unless (and epa-keys-buffer
 263                (buffer-live-p epa-keys-buffer))
 264     (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 265   (set-buffer epa-keys-buffer)
 266   (let ((inhibit-read-only t)
 267         buffer-read-only
 268         (point (point-min))
 269         (context (epg-make-context protocol)))
 270     (unless (get-text-property point 'epa-list-keys)
 271       (setq point (next-single-property-change point 'epa-list-keys)))
 272     (when point
 273       (delete-region point
 274                      (or (next-single-property-change point 'epa-list-keys)
 275                          (point-max)))
 276       (goto-char point))
 277     (epa-list-keys-1 context name mode)
 278     (epa-keys-mode))
 279   (make-local-variable 'epa-list-keys-arguments)
 280   (setq epa-list-keys-arguments (list name mode protocol))
 281   (goto-char (point-min))
 282   (pop-to-buffer (current-buffer)))
 283
 284 (defun epa-list-keys-1 (context name mode)
 285   (save-restriction
 286     (narrow-to-region (point) (point))
 287     (let ((inhibit-read-only t)
 288           buffer-read-only
 289           (keys (epg-list-keys context name mode))
 290           point)
 291       (while keys
 292         (setq point (point))
 293         (insert "  ")
 294         (put-text-property point (point) 'epa-key (car keys))
 295         (widget-create 'epa-key :value (car keys))
 296         (insert "\n")
 297         (setq keys (cdr keys))))
 298     (put-text-property (point-min) (point-max) 'epa-list-keys t)))
 299
 300 (defun epa-marked-keys ()
 301   (or (save-excursion
 302         (set-buffer epa-keys-buffer)
 303         (goto-char (point-min))
 304         (let (keys key)
 305           (while (re-search-forward "^\\*" nil t)
 306             (if (setq key (get-text-property (match-beginning 0)
 307                                              'epa-key))
 308                 (setq keys (cons key keys))))
 309           (nreverse keys)))
 310       (save-excursion
 311         (beginning-of-line)
 312         (let ((key (get-text-property (point) 'epa-key)))
 313           (if key
 314               (list key))))))
 315
 316 ;;;###autoload
 317 (defun epa-select-keys (context prompt &optional names secret)
 318   "Display a user's keyring and ask him to select keys.
 319 CONTEXT is an epg-context.
 320 PROMPT is a string to prompt with.
 321 NAMES is a list of strings to be matched with keys.  If it is nil, all
 322 the keys are listed.
 323 If SECRET is non-nil, list secret keys instead of public keys."
 324   (save-excursion
 325     (unless (and epa-keys-buffer
 326                  (buffer-live-p epa-keys-buffer))
 327       (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 328     (let ((inhibit-read-only t)
 329           buffer-read-only
 330           point)
 331       (set-buffer epa-keys-buffer)
 332       (erase-buffer)
 333       (insert prompt "\n")
 334       (widget-create 'link
 335                      :notify (lambda (&rest ignore) (abort-recursive-edit))
 336                      :help-echo
 337                      (substitute-command-keys
 338                       "Click here or \\[abort-recursive-edit] to cancel")
 339                      "Cancel")
 340       (widget-create 'link
 341                      :notify (lambda (&rest ignore) (exit-recursive-edit))
 342                      :help-echo
 343                      (substitute-command-keys
 344                       "Click here or \\[exit-recursive-edit] to finish")
 345                      "OK")
 346       (insert "\n\n")
 347       (if names
 348           (while names
 349             (setq point (point))
 350             (epa-list-keys-1 context (car names) secret)
 351             (goto-char point)
 352             (epa-mark)
 353             (goto-char (point-max))
 354             (setq names (cdr names)))
 355         (epa-list-keys-1 context nil secret))
 356       (epa-keys-mode)
 357       (setq epa-exit-buffer-function #'abort-recursive-edit)
 358       (goto-char (point-min))
 359       (pop-to-buffer (current-buffer)))
 360     (unwind-protect
 361           (progn
 362             (recursive-edit)
 363             (epa-marked-keys))
 364         (if (get-buffer-window epa-keys-buffer)
 365             (delete-window (get-buffer-window epa-keys-buffer)))
 366         (kill-buffer epa-keys-buffer))))
 367
 368 (defun epa-show-key (key)
 369   (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
 370          (entry (assoc (epg-sub-key-id primary-sub-key)
 371                        epa-key-buffer-alist))
 372          (inhibit-read-only t)
 373          buffer-read-only
 374          pointer)
 375     (unless entry
 376       (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
 377             epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
 378     (unless (and (cdr entry)
 379                  (buffer-live-p (cdr entry)))
 380       (setcdr entry (generate-new-buffer
 381                      (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
 382     (set-buffer (cdr entry))
 383     (make-local-variable 'epa-key)
 384     (setq epa-key key)
 385     (erase-buffer)
 386     (setq pointer (epg-key-user-id-list key))
 387     (while pointer
 388       (insert " "
 389               (if (epg-user-id-validity (car pointer))
 390                   (char-to-string
 391                    (car (rassq (epg-user-id-validity (car pointer))
 392                                epg-key-validity-alist)))
 393                 " ")
 394               " "
 395               (if (stringp (epg-user-id-string (car pointer)))
 396                   (epg-user-id-string (car pointer))
 397                 (epg-decode-dn (epg-user-id-string (car pointer))))
 398               "\n")
 399       (setq pointer (cdr pointer)))
 400     (setq pointer (epg-key-sub-key-list key))
 401     (while pointer
 402       (insert " "
 403               (if (epg-sub-key-validity (car pointer))
 404                   (char-to-string
 405                    (car (rassq (epg-sub-key-validity (car pointer))
 406                                epg-key-validity-alist)))
 407                 " ")
 408               " "
 409               (epg-sub-key-id (car pointer))
 410               " "
 411               (format "%dbits"
 412                       (epg-sub-key-length (car pointer)))
 413               " "
 414               (cdr (assq (epg-sub-key-algorithm (car pointer))
 415                          epg-pubkey-algorithm-alist))
 416               "\n\tCreated: "
 417               (epg-sub-key-creation-time (car pointer))
 418               (if (epg-sub-key-expiration-time (car pointer))
 419                   (format "\n\tExpires: %s" (epg-sub-key-expiration-time
 420                                              (car pointer)))
 421                 "")
 422               "\n\tCapabilities: "
 423               (mapconcat #'symbol-name
 424                          (epg-sub-key-capability (car pointer))
 425                          " ")
 426               "\n\tFingerprint: "
 427               (epg-sub-key-fingerprint (car pointer))
 428               "\n")
 429       (setq pointer (cdr pointer)))
 430     (goto-char (point-min))
 431     (pop-to-buffer (current-buffer))
 432     (epa-key-mode)))
 433
 434 (defun epa-show-key-notify (widget &rest ignore)
 435   (epa-show-key (widget-get widget :value)))
 436
 437 (defun epa-mark (&optional arg)
 438   "Mark the current line.
 439 If ARG is non-nil, unmark the current line."
 440   (interactive "P")
 441   (let ((inhibit-read-only t)
 442         buffer-read-only
 443         properties)
 444     (beginning-of-line)
 445     (setq properties (text-properties-at (point)))
 446     (delete-char 1)
 447     (insert (if arg " " "*"))
 448     (set-text-properties (1- (point)) (point) properties)
 449     (forward-line)))
 450
 451 (defun epa-unmark (&optional arg)
 452   "Unmark the current line.
 453 If ARG is non-nil, mark the current line."
 454   (interactive "P")
 455   (epa-mark (not arg)))
 456
 457 (defun epa-exit-buffer ()
 458   "Exit the current buffer.
 459 `epa-exit-buffer-function' is called if it is set."
 460   (interactive)
 461   (funcall epa-exit-buffer-function))
 462
 463 ;;;###autoload
 464 (defun epa-decrypt-file (file)
 465   "Decrypt FILE."
 466   (interactive "fFile: ")
 467   (let* ((default-name (file-name-sans-extension file))
 468          (plain (expand-file-name
 469                  (read-file-name
 470                   (concat "To file (default "
 471                           (file-name-nondirectory default-name)
 472                           ") ")
 473                   (file-name-directory default-name)
 474                   default-name)))
 475          (context (epg-make-context)))
 476     (message "Decrypting %s..." (file-name-nondirectory file))
 477     (epg-decrypt-file context file plain)
 478     (message "Decrypting %s...done" (file-name-nondirectory file))))
 479
 480 ;;;###autoload
 481 (defun epa-verify-file (file)
 482   "Verify FILE."
 483   (interactive "fFile: ")
 484   (let* ((context (epg-make-context))
 485          (plain (if (equal (file-name-extension file) "sig")
 486                     (file-name-sans-extension file))))
 487     (message "Verifying %s..." (file-name-nondirectory file))
 488     (epg-verify-file context file plain)
 489     (message "Verifying %s...done" (file-name-nondirectory file))
 490     (message "%s"
 491              (epg-verify-result-to-string
 492               (epg-context-result-for context 'verify)))))
 493
 494 ;;;###autoload
 495 (defun epa-sign-file (file signers detached)
 496   "Sign FILE by selected SIGNERS keys.
 497 If DETACHED is non-nil, it creates a detached signature."
 498   (interactive
 499    (list (expand-file-name (read-file-name "File: "))
 500          (epa-select-keys (epg-make-context) "Select keys for signing.
 501 If no one is selected, default secret key is used.  "
 502                           nil t)
 503          (y-or-n-p "Make a detached signature? ")))
 504   (let ((signature (concat file (if detached ".sig" ".gpg")))
 505         (context (epg-make-context)))
 506     (message "Signing %s..." (file-name-nondirectory file))
 507     (epg-context-set-signers context signers)
 508     (epg-sign-file context file signature (not (null detached)))
 509     (message "Signing %s...done" (file-name-nondirectory file))))
 510
 511 ;;;###autoload
 512 (defun epa-encrypt-file (file recipients)
 513   "Encrypt FILE for RECIPIENTS."
 514   (interactive
 515    (list (expand-file-name (read-file-name "File: "))
 516          (epa-select-keys (epg-make-context) "Select recipents for encryption.
 517 If no one is selected, symmetric encryption will be performed.  ")))
 518   (let ((cipher (concat file ".gpg"))
 519         (context (epg-make-context)))
 520     (message "Encrypting %s..." (file-name-nondirectory file))
 521     (epg-encrypt-file context file recipients cipher)
 522     (message "Encrypting %s...done" (file-name-nondirectory file))))
 523
 524 ;;;###autoload
 525 (defun epa-delete-keys (keys &optional allow-secret)
 526   "Delete selected KEYS."
 527   (interactive
 528    (let ((keys (epa-marked-keys)))
 529      (unless keys
 530        (error "No keys selected"))
 531      (list keys
 532            (eq (nth 1 epa-list-keys-arguments) t))))
 533   (let ((context (epg-make-context)))
 534     (message "Deleting...")
 535     (epg-delete-keys context keys allow-secret)
 536     (apply #'epa-list-keys epa-list-keys-arguments)
 537     (message "Deleting...done")))
 538
 539 ;;;###autoload
 540 (defun epa-import-keys (file)
 541   "Import keys from FILE."
 542   (interactive "fFile: ")
 543   (let ((context (epg-make-context)))
 544     (message "Importing %s..." (file-name-nondirectory file))
 545     (epg-import-keys-from-file context (expand-file-name file))
 546     (apply #'epa-list-keys epa-list-keys-arguments)
 547     (message "Importing %s...done" (file-name-nondirectory file))))
 548
 549 ;;;###autoload
 550 (defun epa-export-keys (keys file)
 551   "Export selected KEYS to FILE."
 552   (interactive
 553    (let ((keys (epa-marked-keys))
 554          default-name)
 555      (unless keys
 556        (error "No keys selected"))
 557      (setq default-name
 558            (expand-file-name
 559             (concat (epg-sub-key-id (car (epg-key-sub-key-list (car keys))))
 560                     ".gpg")
 561             default-directory))
 562      (list keys
 563            (expand-file-name
 564             (read-file-name
 565              (concat "To file (default "
 566                      (file-name-nondirectory default-name)
 567                      ") ")
 568              (file-name-directory default-name)
 569              default-name)))))
 570   (let ((context (epg-make-context)))
 571     (message "Exporting to %s..." (file-name-nondirectory file))
 572     (epg-export-keys-to-file context keys file)
 573     (message "Exporting to %s...done" (file-name-nondirectory file))))
 574
 575 ;;;###autoload
 576 (defun epa-sign-keys (keys &optional local)
 577   "Sign selected KEYS.
 578 If LOCAL is non-nil, the signature is marked as non exportable."
 579   (interactive
 580    (let ((keys (epa-marked-keys)))
 581      (unless keys
 582        (error "No keys selected"))
 583      (list keys current-prefix-arg)))
 584   (let ((context (epg-make-context)))
 585     (message "Signing keys...")
 586     (epg-sign-keys context keys local)
 587     (message "Signing keys...done")))
 588
 589 (provide 'epa)
 590
 591 ;;; epa.el ends here