epa.el

   1 ;;; epa.el --- EasyPG Assistant, GUI of EasyPG
   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
  29 (defgroup epa nil
  30   "EasyPG Assistant, GUI of EasyPG."
  31   :group 'epg)
  32
  33 (defgroup epa-faces nil
  34   "Faces for epa-mode."
  35   :group 'epa)
  36
  37 (defvar epa-buffer nil)
  38
  39 (defface epa-validity-full-face
  40   '((((class color) (background dark))
  41      (:foreground "PaleTurquoise" :bold t))
  42     (t
  43      (:bold t)))
  44   "Face used for displaying the validity-full addon."
  45   :group 'epa-faces)
  46 (defvar epa-validity-full-face 'epa-validity-full-face)
  47
  48 (defface epa-validity-disabled-face
  49   '((((class color) (background dark))
  50      (:foreground "PaleTurquoise" :italic t))
  51     (t
  52      ()))
  53   "Face used for displaying the disabled validity."
  54   :group 'epa-faces)
  55 (defvar epa-validity-disabled-face 'epa-validity-disabled-face)
  56
  57 (defface epa-validity-unknown-face
  58   '((t
  59      (:italic t)))
  60   "Face used for displaying the validity-unknown addon."
  61   :group 'epa-faces)
  62 (defvar epa-validity-unknown-face 'epa-validity-unknown-face)
  63
  64 (defface epa-validity-marginal-face
  65   '((t
  66      (:italic t :inverse-video t)))
  67   "Face used for displaying the validity-marginal addon."
  68   :group 'epa-faces)
  69 (defvar epa-validity-marginal-face 'epa-validity-marginal-face)
  70
  71 (defface epa-user-id-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 user-id addon."
  81   :group 'epa-faces)
  82 (defvar epa-user-id-face 'epa-user-id-face)
  83
  84 (defcustom epa-validity-face-alist
  85   '((?o . epa-validity-unknown-face)
  86     (?i . epa-validity-disabled-face)
  87     (?d . epa-validity-disabled-face)
  88     (?r . epa-validity-disabled-face)
  89     (?e . epa-validity-disabled-face)
  90     (?- . epa-validity-unknown-face)
  91     (?q . epa-validity-unknown-face)
  92     (?n . epa-validity-disabled-face)
  93     (?m . epa-validity-marginal-face)
  94     (?f . epa-validity-full-face)
  95     (?u . epa-validity-full-face)
  96     (?  . epa-validity-full-face))
  97   "An alist mapping marks on epa-buffer to faces."
  98   :type 'list
  99   :group 'epa)
 100
 101 (defcustom epa-font-lock-keywords
 102   '(("^[* ]\\([-oidreqnmfu ]\\)\\s-+\\(\\S-+\\)\\s-+\\(.*\\)"
 103      (2 (cdr (assq (aref (match-string 1) 0)
 104                    epa-validity-face-alist)))
 105      (3 epa-user-id-face)))
 106   "Default expressions to addon in epa-mode."
 107   :type '(repeat (list string))
 108   :group 'epa)
 109
 110 (defvar epa-mode-map
 111   (let ((keymap (make-sparse-keymap)))
 112     (define-key keymap "m" 'epa-command-mark-key)
 113     (define-key keymap "u" 'epa-command-unmark-key)
 114     (define-key keymap "n" 'epa-command-next-line)
 115     (define-key keymap "p" 'previous-line)
 116     (define-key keymap "e" 'epa-command-encrypt-file)
 117     (define-key keymap "s" 'epa-command-sign-file)
 118     (define-key keymap " " 'scroll-up)
 119     (define-key keymap [delete] 'scroll-down)
 120     (define-key keymap "q" 'bury-buffer)
 121     keymap))
 122
 123 (defun epa-mode ()
 124   "Major mode for EasyPG Assistant.
 125 All normal editing commands are turned off."
 126   (kill-all-local-variables)
 127   (buffer-disable-undo)
 128   (setq major-mode 'epa-mode
 129         mode-name "EPA"
 130         truncate-lines t
 131         buffer-read-only t)
 132   (use-local-map epa-mode-map)
 133   (make-local-variable 'font-lock-defaults)
 134   (setq font-lock-defaults '(epa-font-lock-keywords t))
 135   ;; In XEmacs, auto-initialization of font-lock is not effective
 136   ;; if buffer-file-name is not set.
 137   (font-lock-set-defaults)
 138   (make-local-variable 'epa-marked-keys)
 139   (run-hooks 'epa-mode-hook))
 140
 141 (defun epa ()
 142   "EasyPG Assistant."
 143   (interactive)
 144   (unless epa-buffer
 145     (setq epa-buffer (generate-new-buffer "*EPA*")))
 146   (set-buffer epa-buffer)
 147   (epa-mode)
 148   (let ((inhibit-read-only t)
 149         buffer-read-only
 150         configuration pointer entry point)
 151     (erase-buffer)
 152     (insert "EasyPG Assistant\n\n")
 153     (setq configuration (epg-configuration))
 154     (if (setq entry (assq 'version configuration))
 155         (insert (format "GnuPG %s\n" (cdr entry))))
 156     (if (setq entry (assq 'pubkey configuration))
 157         (insert (format "Pubkey: %s\n"
 158                         (mapconcat
 159                          (lambda (algorithm)
 160                            (if (setq entry
 161                                      (assq algorithm
 162                                            epg-pubkey-algorithm-alist))
 163                                (cdr entry)
 164                              (format "(unknown: %d)" algorithm)))
 165                          (cdr entry) ", "))))
 166     (if (setq entry (assq 'cipher configuration))
 167         (insert (format "Cipher: %s\n"
 168                         (mapconcat
 169                          (lambda (algorithm)
 170                            (if (setq entry
 171                                      (assq algorithm
 172                                            epg-cipher-algorithm-alist))
 173                                (cdr entry)
 174                              (format "(unknown: %d)" algorithm)))
 175                          (cdr entry) ", "))))
 176     (if (setq entry (assq 'digest configuration))
 177         (insert (format "Hash: %s\n"
 178                         (mapconcat
 179                          (lambda (algorithm)
 180                            (if (setq entry
 181                                      (assq algorithm
 182                                            epg-digest-algorithm-alist))
 183                                (cdr entry)
 184                              (format "(unknown: %d)" algorithm)))
 185                          (cdr entry) ", "))))
 186     (if (setq entry (assq 'compress configuration))
 187         (insert (format "Compression: %s\n"
 188                         (mapconcat
 189                          (lambda (algorithm)
 190                            (if (setq entry
 191                                      (assq algorithm
 192                                            epg-compress-algorithm-alist))
 193                                (cdr entry)
 194                              (format "(unknown: %d)" algorithm)))
 195                          (cdr entry) ", "))))
 196     (insert "\nSecret keys:\n\n")
 197     (setq pointer (epg-list-keys nil t))
 198     (while pointer
 199       (setq point (point))
 200       (setq entry (cdr (assq 'sec (car pointer))))
 201       (setq key-id (cdr (assq 'key-id entry)))
 202       (insert (format "   %s %s\n"
 203                       key-id
 204                       (cdr (assq 'user-id (assq 'uid (car pointer))))))
 205       (put-text-property point (point) 'epa-key-id key-id)
 206       (put-text-property point (point) 'epa-key-secret t)
 207       (setq pointer (cdr pointer)))
 208     (insert "\nPublic keys:\n\n")
 209     (setq pointer (epg-list-keys nil))
 210     (while pointer
 211       (setq point (point))
 212       (setq entry (cdr (assq 'pub (car pointer))))
 213       (setq key-id (cdr (assq 'key-id entry)))
 214       (insert (format " %s %s %s\n"
 215                       (or (cdr (assq 'validity entry)) ? )
 216                       key-id
 217                       (cdr (assq 'user-id (assq 'uid (car pointer))))))
 218       (put-text-property point (point) 'epa-key-id key-id)
 219       (setq pointer (cdr pointer)))
 220     (goto-char (point-min))
 221     (pop-to-buffer (current-buffer))
 222     (delete-other-windows)))
 223
 224 (defun epa-key-id (point)
 225   (let ((key-id (get-text-property point 'epa-key-id)))
 226     (unless key-id
 227       (setq point (next-single-property-change point 'epa-key-id))
 228       (when point
 229         (goto-char point)
 230         (setq key-id (get-text-property point 'epa-key-id))))
 231     key-id))
 232
 233 (defun epa-command-mark-key (key-id)
 234   "Mark a key on the current line."
 235   (interactive
 236    (progn
 237      (unless (eq major-mode 'epa-mode)
 238        (error "Not in `epa-mode'"))
 239      (list (epa-key-id (point)))))
 240   (let ((point (point))
 241         (inhibit-read-only t)
 242         buffer-read-only)
 243     (while (and point
 244                 (not (equal (get-text-property point 'epa-key-id) key-id)))
 245       (setq point (next-single-property-change point)))
 246     (unless point
 247       (error "Key %s not found" key-id))
 248     (goto-char point)
 249     (beginning-of-line)
 250     (delete-char)
 251     (setq point (point))
 252     (insert "*")
 253     (put-text-property point (point) 'epa-key-id key-id)
 254     (forward-line)))
 255
 256 (defun epa-command-unmark-key (key-id)
 257   "Unmark a key on the current line."
 258   (interactive
 259    (progn
 260      (unless (eq major-mode 'epa-mode)
 261        (error "Not in `epa-mode'"))
 262      (list (epa-key-id (point)))))
 263   (let ((point (point))
 264         (inhibit-read-only t)
 265         buffer-read-only)
 266     (while (and point
 267                 (not (equal (get-text-property point 'epa-key-id) key-id)))
 268       (setq point (next-single-property-change point)))
 269     (unless point
 270       (error "Key %s not found" key-id))
 271     (goto-char point)
 272     (beginning-of-line)
 273     (delete-char)
 274     (setq point (point))
 275     (insert " ")
 276     (put-text-property point (point) 'epa-key-id key-id)
 277     (forward-line)))
 278
 279 (defun epa-command-next-line (count)
 280   "Same as next-line except that if you are at the beginning of buffer,
 281 you will be jumped to the first secret key."
 282   (interactive "p")
 283   (if (get-text-property (point) 'epa-key-id)
 284       (next-line count)
 285     (let ((point (next-single-property-change (point) 'epa-key-id)))
 286       (if (and point
 287                (get-text-property point 'epa-key-id))
 288           (goto-char point)))))
 289
 290 (defun epa-command-encrypt-file (plain cipher recipients sign)
 291   "Encrypt a file PLAIN for RECIPIENTS."
 292   (interactive
 293    (save-excursion
 294      (set-buffer epa-buffer)
 295      (goto-char (point-min))
 296      (let (plain recipients)
 297        (while (re-search-forward "^\\*" nil t)
 298          (unless (get-text-property (point) 'epa-key-secret)
 299            (setq recipients (cons (get-text-property (point) 'epa-key-id)
 300                                   recipients))))
 301        (list (setq plain (expand-file-name (read-file-name "Plain file: ")))
 302              (expand-file-name
 303               (read-file-name (format "Cipher file (default %s.gpg) "
 304                                       (file-name-nondirectory plain))
 305                               (file-name-directory plain)
 306                               (concat plain ".gpg")))
 307              recipients
 308              current-prefix-arg))))
 309   (message "Encrypting %s..." (file-name-nondirectory plain))
 310   (epg-encrypt-file (epg-make-context)
 311                     plain
 312                     recipients
 313                     (expand-file-name cipher)
 314                     sign)
 315   (message "Encrypting %s...done" (file-name-nondirectory plain)))
 316
 317 (defun epa-command-sign-file (plain signature detached signers)
 318   "Sign a file PLAIN."
 319   (interactive
 320    (save-excursion
 321      (set-buffer epa-buffer)
 322      (goto-char (point-min))
 323      (let ((extension (if current-prefix-arg ".sig" ".gpg"))
 324            plain signers)
 325        (while (re-search-forward "^\\*" nil t)
 326          (if (get-text-property (point) 'epa-key-secret)
 327              (setq signers (cons (get-text-property (point) 'epa-key-id)
 328                                  signers))))
 329
 330        (list (setq plain (expand-file-name (read-file-name "Plain file: ")))
 331              (expand-file-name
 332               (read-file-name (format "Signature file (default %s%s) "
 333                                       (file-name-nondirectory plain)
 334                                       extension)
 335                               (file-name-directory plain)
 336                               (concat plain extension)))
 337              current-prefix-arg
 338              signers))))
 339   (let ((context (epg-make-context)))
 340     (epg-context-set-signers context signers)
 341     (message "Signing %s..." (file-name-nondirectory plain))
 342     (epg-sign-file context
 343                    plain
 344                    signature
 345                    (if detached 'detached))
 346     (message "Signing %s...done" (file-name-nondirectory plain))))
 347
 348 (provide 'epa)
 349
 350 ;;; epa.el ends here