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