epa.el

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