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 (require 'derived)
  31
  32 (defgroup epa nil
  33   "The EasyPG Assistant"
  34   :group 'epg)
  35
  36 (defcustom epa-protocol 'OpenPGP
  37   "The default protocol."
  38   :type '(choice (const :tag "OpenPGP" OpenPGP)
  39                  (const :tag "CMS" CMS))
  40   :group 'epa)
  41
  42 (defcustom epa-armor nil
  43   "If non-nil, epa commands create ASCII armored output."
  44   :type 'boolean
  45   :group 'epa)
  46
  47 (defcustom epa-textmode nil
  48   "If non-nil, epa commands treat input files as text."
  49   :type 'boolean
  50   :group 'epa)
  51
  52 (defcustom epa-popup-info-window t
  53   "If non-nil, status information from epa commands is displayed on
  54 the separate window."
  55   :type 'boolean
  56   :group 'epa)
  57
  58 (defcustom epa-info-window-height 5
  59   "Number of lines used to display status information."
  60   :type 'integer
  61   :group 'epa)
  62
  63 (defgroup epa-faces nil
  64   "Faces for epa-mode."
  65   :group 'epa)
  66
  67 (defface epa-validity-high-face
  68   '((((class color) (background dark))
  69      (:foreground "PaleTurquoise" :bold t))
  70     (t
  71      (:bold t)))
  72   "Face used for displaying the high validity."
  73   :group 'epa-faces)
  74 (defvar epa-validity-high-face 'epa-validity-high-face)
  75
  76 (defface epa-validity-medium-face
  77   '((((class color) (background dark))
  78      (:foreground "PaleTurquoise" :italic t))
  79     (t
  80      ()))
  81   "Face used for displaying the medium validity."
  82   :group 'epa-faces)
  83 (defvar epa-validity-medium-face 'epa-validity-medium-face)
  84
  85 (defface epa-validity-low-face
  86   '((t
  87      (:italic t)))
  88   "Face used for displaying the low validity."
  89   :group 'epa-faces)
  90 (defvar epa-validity-low-face 'epa-validity-low-face)
  91
  92 (defface epa-validity-disabled-face
  93   '((t
  94      (:italic t :inverse-video t)))
  95   "Face used for displaying the disabled validity."
  96   :group 'epa-faces)
  97 (defvar epa-validity-disabled-face 'epa-validity-disabled-face)
  98
  99 (defface epa-string-face
 100   '((((class color)
 101       (background dark))
 102      (:foreground "lightyellow"))
 103     (((class color)
 104       (background light))
 105      (:foreground "blue4"))
 106     (t
 107      ()))
 108   "Face used for displaying the string."
 109   :group 'epa-faces)
 110 (defvar epa-string-face 'epa-string-face)
 111
 112 (defface epa-mark-face
 113   '((((class color) (background dark))
 114      (:foreground "orange" :bold t))
 115     (t
 116      (:foreground "red" :bold t)))
 117   "Face used for displaying the high validity."
 118   :group 'epa-faces)
 119 (defvar epa-mark-face 'epa-mark-face)
 120
 121 (defface epa-field-name-face
 122   '((((class color) (background dark))
 123      (:foreground "PaleTurquoise" :bold t))
 124     (t (:bold t)))
 125   "Face for the name of the attribute field."
 126   :group 'epa)
 127 (defvar epa-field-name-face 'epa-field-name-face)
 128
 129 (defface epa-field-body-face
 130   '((((class color) (background dark))
 131      (:foreground "turquoise" :italic t))
 132     (t (:italic t)))
 133   "Face for the body of the attribute field."
 134   :group 'epa)
 135 (defvar epa-field-body-face 'epa-field-body-face)
 136
 137 (defcustom epa-validity-face-alist
 138   '((unknown . epa-validity-disabled-face)
 139     (invalid . epa-validity-disabled-face)
 140     (disabled . epa-validity-disabled-face)
 141     (revoked . epa-validity-disabled-face)
 142     (expired . epa-validity-disabled-face)
 143     (none . epa-validity-low-face)
 144     (undefined . epa-validity-low-face)
 145     (never . epa-validity-low-face)
 146     (marginal . epa-validity-medium-face)
 147     (full . epa-validity-high-face)
 148     (ultimate . epa-validity-high-face))
 149   "An alist mapping validity values to faces."
 150   :type 'list
 151   :group 'epa)
 152
 153 (defcustom epa-font-lock-keywords
 154   '(("^\\*"
 155      (0 epa-mark-face))
 156     ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
 157      (1 epa-field-name-face)
 158      (2 epa-field-body-face)))
 159   "Default expressions to addon in epa-mode."
 160   :type '(repeat (list string))
 161   :group 'epa)
 162
 163 (defconst epa-pubkey-algorithm-letter-alist
 164   '((1 . ?R)
 165     (2 . ?r)
 166     (3 . ?s)
 167     (16 . ?g)
 168     (17 . ?D)
 169     (20 . ?G)))
 170
 171 (defvar epa-keys-buffer nil)
 172 (defvar epa-key-buffer-alist nil)
 173 (defvar epa-key nil)
 174 (defvar epa-list-keys-arguments nil)
 175 (defvar epa-info-buffer nil)
 176 (defvar epa-last-coding-system-specified nil)
 177
 178 (defvar epa-key-list-mode-map
 179   (let ((keymap (make-sparse-keymap)))
 180     (define-key keymap "m" 'epa-mark)
 181     (define-key keymap "u" 'epa-unmark)
 182     (define-key keymap "d" 'epa-decrypt-file)
 183     (define-key keymap "v" 'epa-verify-file)
 184     (define-key keymap "s" 'epa-sign-file)
 185     (define-key keymap "e" 'epa-encrypt-file)
 186     (define-key keymap "r" 'epa-delete-keys)
 187     (define-key keymap "i" 'epa-import-keys)
 188     (define-key keymap "o" 'epa-export-keys)
 189     (define-key keymap "g" 'epa-list-keys)
 190     (define-key keymap "n" 'next-line)
 191     (define-key keymap "p" 'previous-line)
 192     (define-key keymap " " 'scroll-up)
 193     (define-key keymap [delete] 'scroll-down)
 194     (define-key keymap "q" 'epa-exit-buffer)
 195     keymap))
 196
 197 (defvar epa-key-mode-map
 198   (let ((keymap (make-sparse-keymap)))
 199     (define-key keymap "q" 'bury-buffer)
 200     keymap))
 201
 202 (defvar epa-info-mode-map
 203   (let ((keymap (make-sparse-keymap)))
 204     (define-key keymap "q" 'delete-window)
 205     keymap))
 206
 207 (defvar epa-exit-buffer-function #'bury-buffer)
 208
 209 (define-widget 'epa-key 'push-button
 210   "Button for representing a epg-key object."
 211   :format "%[%v%]"
 212   :button-face-get 'epa--key-widget-button-face-get
 213   :value-create 'epa--key-widget-value-create
 214   :action 'epa--key-widget-action
 215   :help-echo 'epa--key-widget-help-echo)
 216
 217 (defun epa--key-widget-action (widget &optional event)
 218   (epa--show-key (widget-get widget :value)))
 219
 220 (defun epa--key-widget-value-create (widget)
 221   (let* ((key (widget-get widget :value))
 222          (primary-sub-key (car (epg-key-sub-key-list key)))
 223          (primary-user-id (car (epg-key-user-id-list key))))
 224     (insert (format "%c "
 225                     (if (epg-sub-key-validity primary-sub-key)
 226                         (car (rassq (epg-sub-key-validity primary-sub-key)
 227                                     epg-key-validity-alist))
 228                       ? ))
 229             (epg-sub-key-id primary-sub-key)
 230             " "
 231             (if primary-user-id
 232                 (if (stringp (epg-user-id-string primary-user-id))
 233                     (epg-user-id-string primary-user-id)
 234                   (epg-decode-dn (epg-user-id-string primary-user-id)))
 235               ""))))
 236
 237 (defun epa--key-widget-button-face-get (widget)
 238   (let ((validity (epg-sub-key-validity (car (epg-key-sub-key-list
 239                                               (widget-get widget :value))))))
 240     (if validity
 241         (cdr (assq validity epa-validity-face-alist))
 242       'default)))
 243
 244 (defun epa--key-widget-help-echo (widget)
 245   (format "Show %s"
 246           (epg-sub-key-id (car (epg-key-sub-key-list
 247                                 (widget-get widget :value))))))
 248
 249 (if (fboundp 'encode-coding-string)
 250     (defalias 'epa--encode-coding-string 'encode-coding-string)
 251   (defalias 'epa--encode-coding-string 'identity))
 252
 253 (if (fboundp 'decode-coding-string)
 254     (defalias 'epa--decode-coding-string 'decode-coding-string)
 255   (defalias 'epa--decode-coding-string 'identity))
 256
 257 (defun epa-key-list-mode ()
 258   "Major mode for `epa-list-keys'."
 259   (kill-all-local-variables)
 260   (buffer-disable-undo)
 261   (setq major-mode 'epa-key-list-mode
 262         mode-name "Keys"
 263         truncate-lines t
 264         buffer-read-only t)
 265   (use-local-map epa-key-list-mode-map)
 266   (make-local-variable 'font-lock-defaults)
 267   (setq font-lock-defaults '(epa-font-lock-keywords t))
 268   ;; In XEmacs, auto-initialization of font-lock is not effective
 269   ;; if buffer-file-name is not set.
 270   (font-lock-set-defaults)
 271   (make-local-variable 'epa-exit-buffer-function)
 272   (run-hooks 'epa-key-list-mode-hook))
 273
 274 (defun epa-key-mode ()
 275   "Major mode for a key description."
 276   (kill-all-local-variables)
 277   (buffer-disable-undo)
 278   (setq major-mode 'epa-key-mode
 279         mode-name "Key"
 280         truncate-lines t
 281         buffer-read-only t)
 282   (use-local-map epa-key-mode-map)
 283   (make-local-variable 'font-lock-defaults)
 284   (setq font-lock-defaults '(epa-font-lock-keywords t))
 285   ;; In XEmacs, auto-initialization of font-lock is not effective
 286   ;; if buffer-file-name is not set.
 287   (font-lock-set-defaults)
 288   (make-local-variable 'epa-exit-buffer-function)
 289   (run-hooks 'epa-key-mode-hook))
 290
 291 (defun epa-info-mode ()
 292   "Major mode for `epa-info-buffer'."
 293   (kill-all-local-variables)
 294   (buffer-disable-undo)
 295   (setq major-mode 'epa-info-mode
 296         mode-name "Info"
 297         truncate-lines t
 298         buffer-read-only t)
 299   (use-local-map epa-info-mode-map)
 300   (run-hooks 'epa-info-mode-hook))
 301
 302 (defun epa-mark (&optional arg)
 303   "Mark the current line.
 304 If ARG is non-nil, unmark the current line."
 305   (interactive "P")
 306   (let ((inhibit-read-only t)
 307         buffer-read-only
 308         properties)
 309     (beginning-of-line)
 310     (setq properties (text-properties-at (point)))
 311     (delete-char 1)
 312     (insert (if arg " " "*"))
 313     (set-text-properties (1- (point)) (point) properties)
 314     (forward-line)))
 315
 316 (defun epa-unmark (&optional arg)
 317   "Unmark the current line.
 318 If ARG is non-nil, mark the current line."
 319   (interactive "P")
 320   (epa-mark (not arg)))
 321
 322 (defun epa-toggle-mark ()
 323   "Toggle the mark the current line."
 324   (interactive)
 325   (epa-mark (eq (char-after (save-excursion (beginning-of-line) (point))) ?*)))
 326
 327 (defun epa-exit-buffer ()
 328   "Exit the current buffer.
 329 `epa-exit-buffer-function' is called if it is set."
 330   (interactive)
 331   (funcall epa-exit-buffer-function))
 332
 333 (defun epa--insert-keys (context name mode)
 334   (save-excursion
 335     (save-restriction
 336       (narrow-to-region (point) (point))
 337       (let ((keys (epg-list-keys context name mode))
 338             point)
 339         (while keys
 340           (setq point (point))
 341           (insert "  ")
 342           (add-text-properties point (point)
 343                                (list 'epa-key (car keys)
 344                                      'front-sticky nil
 345                                      'rear-nonsticky t
 346                                      'start-open t
 347                                      'end-open t))
 348           (widget-create 'epa-key :value (car keys))
 349           (insert "\n")
 350           (setq keys (cdr keys))))
 351       (add-text-properties (point-min) (point-max)
 352                            (list 'epa-list-keys t
 353                                  'front-sticky nil
 354                                  'rear-nonsticky t
 355                                  'start-open t
 356                                  'end-open t)))))
 357
 358 (defun epa--list-keys (name secret)
 359   (unless (and epa-keys-buffer
 360                (buffer-live-p epa-keys-buffer))
 361     (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 362   (set-buffer epa-keys-buffer)
 363   (epa-key-list-mode)
 364   (let ((inhibit-read-only t)
 365         buffer-read-only
 366         (point (point-min))
 367         (context (epg-make-context epa-protocol)))
 368     (unless (get-text-property point 'epa-list-keys)
 369       (setq point (next-single-property-change point 'epa-list-keys)))
 370     (when point
 371       (delete-region point
 372                      (or (next-single-property-change point 'epa-list-keys)
 373                          (point-max)))
 374       (goto-char point))
 375     (epa--insert-keys context name secret)
 376     (widget-setup)
 377     (set-keymap-parent (current-local-map) widget-keymap))
 378   (make-local-variable 'epa-list-keys-arguments)
 379   (setq epa-list-keys-arguments (list name secret))
 380   (goto-char (point-min))
 381   (pop-to-buffer (current-buffer)))
 382
 383 ;;;###autoload
 384 (defun epa-list-keys (&optional name)
 385   "List all keys matched with NAME from the public keyring."
 386   (interactive
 387    (if current-prefix-arg
 388        (let ((name (read-string "Pattern: "
 389                                 (if epa-list-keys-arguments
 390                                     (car epa-list-keys-arguments)))))
 391          (list (if (equal name "") nil name)))
 392      (or epa-list-keys-arguments (list nil nil))))
 393   (epa--list-keys name nil))
 394
 395 ;;;###autoload
 396 (defun epa-list-secret-keys (&optional name)
 397   "List all keys matched with NAME from the private keyring."
 398   (interactive
 399    (if current-prefix-arg
 400        (let ((name (read-string "Pattern: "
 401                                 (if epa-list-keys-arguments
 402                                     (car epa-list-keys-arguments)))))
 403          (list (if (equal name "") nil name)))
 404      (or epa-list-keys-arguments (list nil nil))))
 405   (epa--list-keys name t))
 406
 407 (defun epa--marked-keys ()
 408   (or (save-excursion
 409         (set-buffer epa-keys-buffer)
 410         (goto-char (point-min))
 411         (let (keys key)
 412           (while (re-search-forward "^\\*" nil t)
 413             (if (setq key (get-text-property (match-beginning 0)
 414                                              'epa-key))
 415                 (setq keys (cons key keys))))
 416           (nreverse keys)))
 417       (save-excursion
 418         (beginning-of-line)
 419         (let ((key (get-text-property (point) 'epa-key)))
 420           (if key
 421               (list key))))))
 422
 423 ;;;###autoload
 424 (defun epa-select-keys (context prompt &optional names secret)
 425   "Display a user's keyring and ask him to select keys.
 426 CONTEXT is an epg-context.
 427 PROMPT is a string to prompt with.
 428 NAMES is a list of strings to be matched with keys.  If it is nil, all
 429 the keys are listed.
 430 If SECRET is non-nil, list secret keys instead of public keys."
 431   (save-excursion
 432     (unless (and epa-keys-buffer
 433                  (buffer-live-p epa-keys-buffer))
 434       (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 435     (set-buffer epa-keys-buffer)
 436     (epa-key-list-mode)
 437     (let ((inhibit-read-only t)
 438           buffer-read-only)
 439       (erase-buffer)
 440       (insert prompt "\n"
 441               (substitute-command-keys "\
 442 - `\\[epa-mark]' to mark a key on the line
 443 - `\\[epa-unmark]' to unmark a key on the line\n"))
 444       (widget-create 'link
 445                      :notify (lambda (&rest ignore) (abort-recursive-edit))
 446                      :help-echo
 447                      (substitute-command-keys
 448                       "Click here or \\[abort-recursive-edit] to cancel")
 449                      "Cancel")
 450       (widget-create 'link
 451                      :notify (lambda (&rest ignore) (exit-recursive-edit))
 452                      :help-echo
 453                      (substitute-command-keys
 454                       "Click here or \\[exit-recursive-edit] to finish")
 455                      "OK")
 456       (insert "\n\n")
 457       (if names
 458           (while names
 459             (epa--insert-keys context (car names) secret)
 460             (if (get-text-property (point) 'epa-list-keys)
 461                 (epa-mark))
 462             (goto-char (point-max))
 463             (setq names (cdr names)))
 464         (if secret
 465             (progn
 466               (epa--insert-keys context nil secret)
 467               (if (get-text-property (point) 'epa-list-keys)
 468                   (epa-mark)))
 469           (epa--insert-keys context nil nil)))
 470       (widget-setup)
 471       (set-keymap-parent (current-local-map) widget-keymap)
 472       (setq epa-exit-buffer-function #'abort-recursive-edit)
 473       (goto-char (point-min))
 474       (pop-to-buffer (current-buffer)))
 475     (unwind-protect
 476         (progn
 477           (recursive-edit)
 478           (epa--marked-keys))
 479       (if (get-buffer-window epa-keys-buffer)
 480           (delete-window (get-buffer-window epa-keys-buffer)))
 481       (kill-buffer epa-keys-buffer))))
 482
 483 (defun epa--format-fingerprint-1 (fingerprint unit-size block-size)
 484   (let ((unit 0))
 485     (with-temp-buffer
 486       (insert fingerprint)
 487       (goto-char (point-min))
 488       (while (progn
 489                (goto-char (+ (point) unit-size))
 490                (not (eobp)))
 491         (setq unit (1+ unit))
 492         (insert (if (= (% unit block-size) 0) "  " " ")))
 493       (buffer-string))))
 494
 495 (defun epa--format-fingerprint (fingerprint)
 496   (if fingerprint
 497       (if (= (length fingerprint) 40)
 498           ;; 1234 5678 9ABC DEF0 1234  5678 9ABC DEF0 1234 5678
 499           (epa--format-fingerprint-1 fingerprint 4 5)
 500         ;; 12 34 56 78 9A BC DE F0  12 34 56 78 9A BC DE F0
 501         (epa--format-fingerprint-1 fingerprint 2 8))))
 502
 503 (defun epa--show-key (key)
 504   (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
 505          (entry (assoc (epg-sub-key-id primary-sub-key)
 506                        epa-key-buffer-alist))
 507          (inhibit-read-only t)
 508          buffer-read-only
 509          pointer)
 510     (unless entry
 511       (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
 512             epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
 513     (unless (and (cdr entry)
 514                  (buffer-live-p (cdr entry)))
 515       (setcdr entry (generate-new-buffer
 516                      (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
 517     (set-buffer (cdr entry))
 518     (epa-key-mode)
 519     (make-local-variable 'epa-key)
 520     (setq epa-key key)
 521     (erase-buffer)
 522     (setq pointer (epg-key-user-id-list key))
 523     (while pointer
 524       (if (car pointer)
 525           (insert " "
 526                   (if (epg-user-id-validity (car pointer))
 527                       (char-to-string
 528                        (car (rassq (epg-user-id-validity (car pointer))
 529                                    epg-key-validity-alist)))
 530                     " ")
 531                   " "
 532                   (if (stringp (epg-user-id-string (car pointer)))
 533                       (epg-user-id-string (car pointer))
 534                     (epg-decode-dn (epg-user-id-string (car pointer))))
 535                   "\n"))
 536       (setq pointer (cdr pointer)))
 537     (setq pointer (epg-key-sub-key-list key))
 538     (while pointer
 539       (insert " "
 540               (if (epg-sub-key-validity (car pointer))
 541                   (char-to-string
 542                    (car (rassq (epg-sub-key-validity (car pointer))
 543                                epg-key-validity-alist)))
 544                 " ")
 545               " "
 546               (epg-sub-key-id (car pointer))
 547               " "
 548               (format "%dbits"
 549                       (epg-sub-key-length (car pointer)))
 550               " "
 551               (cdr (assq (epg-sub-key-algorithm (car pointer))
 552                          epg-pubkey-algorithm-alist))
 553               "\n\tCreated: "
 554               (format-time-string "%Y-%m-%d"
 555                                   (epg-sub-key-creation-time (car pointer)))
 556               (if (epg-sub-key-expiration-time (car pointer))
 557                   (format "\n\tExpires: %s"
 558                           (format-time-string "%Y-%m-%d"
 559                                               (epg-sub-key-expiration-time
 560                                                (car pointer))))
 561                 "")
 562               "\n\tCapabilities: "
 563               (mapconcat #'symbol-name
 564                          (epg-sub-key-capability (car pointer))
 565                          " ")
 566               "\n\tFingerprint: "
 567               (epa--format-fingerprint (epg-sub-key-fingerprint (car pointer)))
 568               "\n")
 569       (setq pointer (cdr pointer)))
 570     (goto-char (point-min))
 571     (pop-to-buffer (current-buffer))))
 572
 573 (defun epa-display-info (info)
 574   (if epa-popup-info-window
 575       (save-selected-window
 576         (unless (and epa-info-buffer (buffer-live-p epa-info-buffer))
 577           (setq epa-info-buffer (generate-new-buffer "*Info*")))
 578         (if (get-buffer-window epa-info-buffer)
 579             (delete-window (get-buffer-window epa-info-buffer)))
 580         (save-excursion
 581           (set-buffer epa-info-buffer)
 582           (let ((inhibit-read-only t)
 583                 buffer-read-only)
 584             (erase-buffer)
 585             (insert info))
 586           (epa-info-mode)
 587           (goto-char (point-min)))
 588         (if (> (window-height)
 589                epa-info-window-height)
 590             (set-window-buffer (split-window nil (- (window-height)
 591                                                     epa-info-window-height))
 592                                epa-info-buffer)
 593           (pop-to-buffer epa-info-buffer)
 594           (if (> (window-height) epa-info-window-height)
 595               (shrink-window (- (window-height) epa-info-window-height)))))
 596     (message "%s" info)))
 597
 598 (defun epa-display-verify-result (verify-result)
 599   (epa-display-info (epg-verify-result-to-string verify-result)))
 600 (make-obsolete 'epa-display-verify-result 'epa-display-info)
 601
 602 (defun epa-passphrase-callback-function (context key-id handback)
 603   (if (eq key-id 'SYM)
 604       (read-passwd "Passphrase for symmetric encryption: "
 605                    (eq (epg-context-operation context) 'encrypt))
 606     (read-passwd
 607      (if (eq key-id 'PIN)
 608         "Passphrase for PIN: "
 609        (let ((entry (assoc key-id epg-user-id-alist)))
 610          (if entry
 611              (format "Passphrase for %s %s: " key-id (cdr entry))
 612            (format "Passphrase for %s: " key-id)))))))
 613
 614 (defun epa-progress-callback-function (context what char current total
 615                                                handback)
 616   (message "%s%d%% (%d/%d)" (or handback
 617                                 (concat what ": "))
 618            (if (> total 0) (floor (* (/ current (float total)) 100)) 0)
 619            current total))
 620
 621 ;;;###autoload
 622 (defun epa-decrypt-file (file)
 623   "Decrypt FILE."
 624   (interactive "fFile: ")
 625   (setq file (expand-file-name file))
 626   (let* ((default-name (file-name-sans-extension file))
 627          (plain (expand-file-name
 628                  (read-file-name
 629                   (concat "To file (default "
 630                           (file-name-nondirectory default-name)
 631                           ") ")
 632                   (file-name-directory default-name)
 633                   default-name)))
 634          (context (epg-make-context epa-protocol)))
 635     (epg-context-set-passphrase-callback context
 636                                          #'epa-passphrase-callback-function)
 637     (epg-context-set-progress-callback context
 638                                        #'epa-progress-callback-function
 639                                        (format "Decrypting %s..."
 640                                                (file-name-nondirectory file)))
 641     (message "Decrypting %s..." (file-name-nondirectory file))
 642     (epg-decrypt-file context file plain)
 643     (message "Decrypting %s...wrote %s" (file-name-nondirectory file)
 644              (file-name-nondirectory plain))
 645     (if (epg-context-result-for context 'verify)
 646         (epa-display-info (epg-verify-result-to-string
 647                            (epg-context-result-for context 'verify))))))
 648
 649 ;;;###autoload
 650 (defun epa-verify-file (file)
 651   "Verify FILE."
 652   (interactive "fFile: ")
 653   (setq file (expand-file-name file))
 654   (let* ((context (epg-make-context epa-protocol))
 655          (plain (if (equal (file-name-extension file) "sig")
 656                     (file-name-sans-extension file))))
 657     (epg-context-set-progress-callback context
 658                                        #'epa-progress-callback-function
 659                                        (format "Verifying %s..."
 660                                                (file-name-nondirectory file)))
 661     (message "Verifying %s..." (file-name-nondirectory file))
 662     (epg-verify-file context file plain)
 663     (message "Verifying %s...done" (file-name-nondirectory file))
 664     (if (epg-context-result-for context 'verify)
 665         (epa-display-info (epg-verify-result-to-string
 666                            (epg-context-result-for context 'verify))))))
 667
 668 (defun epa--read-signature-type ()
 669   (let (type c)
 670     (while (null type)
 671       (message "Signature type (n,c,d,?) ")
 672       (setq c (read-char))
 673       (cond ((eq c ?c)
 674              (setq type 'clear))
 675             ((eq c ?d)
 676              (setq type 'detached))
 677             ((eq c ??)
 678              (with-output-to-temp-buffer "*Help*"
 679                (save-excursion
 680                  (set-buffer standard-output)
 681                  (insert "\
 682 n - Create a normal signature
 683 c - Create a cleartext signature
 684 d - Create a detached signature
 685 ? - Show this help
 686 "))))
 687             (t
 688              (setq type 'normal))))))
 689
 690 ;;;###autoload
 691 (defun epa-sign-file (file signers mode)
 692   "Sign FILE by SIGNERS keys selected."
 693   (interactive
 694    (let ((verbose current-prefix-arg))
 695      (list (expand-file-name (read-file-name "File: "))
 696            (if verbose
 697                (epa-select-keys (epg-make-context epa-protocol)
 698                                 "Select keys for signing.
 699 If no one is selected, default secret key is used.  "
 700                                 nil t))
 701            (if verbose
 702                (epa--read-signature-type)
 703              'clear))))
 704   (let ((signature (concat file
 705                            (if (eq epa-protocol 'OpenPGP)
 706                                (if (or epa-armor
 707                                        (not (memq mode
 708                                                   '(nil t normal detached))))
 709                                    ".asc"
 710                                  (if (memq mode '(t detached))
 711                                      ".sig"
 712                                    ".gpg"))
 713                              (if (memq mode '(t detached))
 714                                  ".p7s"
 715                                ".p7m"))))
 716         (context (epg-make-context epa-protocol)))
 717     (epg-context-set-armor context epa-armor)
 718     (epg-context-set-textmode context epa-textmode)
 719     (epg-context-set-signers context signers)
 720     (epg-context-set-passphrase-callback context
 721                                          #'epa-passphrase-callback-function)
 722     (epg-context-set-progress-callback context
 723                                        #'epa-progress-callback-function
 724                                        (format "Signing %s..."
 725                                                (file-name-nondirectory file)))
 726     (message "Signing %s..." (file-name-nondirectory file))
 727     (epg-sign-file context file signature mode)
 728     (message "Signing %s...wrote %s" (file-name-nondirectory file)
 729              (file-name-nondirectory signature))))
 730
 731 ;;;###autoload
 732 (defun epa-encrypt-file (file recipients)
 733   "Encrypt FILE for RECIPIENTS."
 734   (interactive
 735    (list (expand-file-name (read-file-name "File: "))
 736          (epa-select-keys (epg-make-context epa-protocol)
 737                           "Select recipients for encryption.
 738 If no one is selected, symmetric encryption will be performed.  ")))
 739   (let ((cipher (concat file (if (eq epa-protocol 'OpenPGP)
 740                                  (if epa-armor ".asc" ".gpg")
 741                                ".p7m")))
 742         (context (epg-make-context epa-protocol)))
 743     (epg-context-set-armor context epa-armor)
 744     (epg-context-set-textmode context epa-textmode)
 745     (epg-context-set-passphrase-callback context
 746                                          #'epa-passphrase-callback-function)
 747     (epg-context-set-progress-callback context
 748                                        #'epa-progress-callback-function
 749                                        (format "Encrypting %s..."
 750                                                (file-name-nondirectory file)))
 751     (message "Encrypting %s..." (file-name-nondirectory file))
 752     (epg-encrypt-file context file recipients cipher)
 753     (message "Encrypting %s...wrote %s" (file-name-nondirectory file)
 754              (file-name-nondirectory cipher))))
 755
 756 ;;;###autoload
 757 (defun epa-decrypt-region (start end)
 758   "Decrypt the current region between START and END.
 759
 760 Don't use this command in Lisp programs!"
 761   (interactive "r")
 762   (save-excursion
 763     (let ((context (epg-make-context epa-protocol))
 764           plain)
 765       (epg-context-set-passphrase-callback context
 766                                            #'epa-passphrase-callback-function)
 767       (epg-context-set-progress-callback context
 768                                          #'epa-progress-callback-function
 769                                          "Decrypting...")
 770       (message "Decrypting...")
 771       (setq plain (epg-decrypt-string context (buffer-substring start end)))
 772       (message "Decrypting...done")
 773       (setq plain (epa--decode-coding-string
 774                    plain
 775                    (or coding-system-for-read
 776                        (get-text-property start 'epa-coding-system-used))))
 777       (if (y-or-n-p "Replace the original text? ")
 778           (let ((inhibit-read-only t)
 779                 buffer-read-only)
 780             (delete-region start end)
 781             (goto-char start)
 782             (insert plain))
 783         (with-output-to-temp-buffer "*Temp*"
 784           (set-buffer standard-output)
 785           (insert plain)
 786           (epa-info-mode)))
 787       (if (epg-context-result-for context 'verify)
 788           (epa-display-info (epg-verify-result-to-string
 789                              (epg-context-result-for context 'verify)))))))
 790
 791 (defun epa--find-coding-system-for-mime-charset (mime-charset)
 792   (if (featurep 'xemacs)
 793       (if (fboundp 'find-coding-system)
 794           (find-coding-system mime-charset))
 795     (let ((pointer (coding-system-list)))
 796       (while (and pointer
 797                   (eq (coding-system-get (car pointer) 'mime-charset)
 798                       mime-charset))
 799         (setq pointer (cdr pointer)))
 800       pointer)))
 801
 802 ;;;###autoload
 803 (defun epa-decrypt-armor-in-region (start end)
 804   "Decrypt OpenPGP armors in the current region between START and END.
 805
 806 Don't use this command in Lisp programs!"
 807   (interactive "r")
 808   (save-excursion
 809     (save-restriction
 810       (narrow-to-region start end)
 811       (goto-char start)
 812       (let (armor-start armor-end)
 813         (while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
 814           (setq armor-start (match-beginning 0)
 815                 armor-end (re-search-forward "^-----END PGP MESSAGE-----$"
 816                                              nil t))
 817           (unless armor-end
 818             (error "No armor tail"))
 819           (goto-char armor-start)
 820           (let ((coding-system-for-read
 821                  (or coding-system-for-read
 822                      (if (re-search-forward "^Charset: \\(.*\\)" armor-end t)
 823                          (epa--find-coding-system-for-mime-charset
 824                           (intern (downcase (match-string 1))))))))
 825             (goto-char armor-end)
 826             (epa-decrypt-region armor-start armor-end)))))))
 827
 828 ;;;###autoload
 829 (defun epa-verify-region (start end)
 830   "Verify the current region between START and END.
 831
 832 Don't use this command in Lisp programs!"
 833   (interactive "r")
 834   (let ((context (epg-make-context epa-protocol))
 835         plain)
 836     (epg-context-set-progress-callback context
 837                                        #'epa-progress-callback-function
 838                                        "Verifying...")
 839     (setq plain (epg-verify-string
 840                  context
 841                  (epa--encode-coding-string
 842                   (buffer-substring start end)
 843                   (or coding-system-for-write
 844                       (get-text-property start
 845                                          'epa-coding-system-used)))))
 846     (if (y-or-n-p "Replace the original text? ")
 847         (let ((inhibit-read-only t)
 848               buffer-read-only)
 849           (delete-region start end)
 850           (goto-char start)
 851           (insert plain))
 852         (with-output-to-temp-buffer "*Temp*"
 853           (set-buffer standard-output)
 854           (insert plain)
 855           (epa-info-mode)))
 856     (if (epg-context-result-for context 'verify)
 857         (epa-display-info (epg-verify-result-to-string
 858                            (epg-context-result-for context 'verify))))))
 859
 860 ;;;###autoload
 861 (defun epa-verify-cleartext-in-region (start end)
 862   "Verify OpenPGP cleartext signed messages in the current region
 863 between START and END.
 864
 865 Don't use this command in Lisp programs!"
 866   (interactive "r")
 867   (save-excursion
 868     (save-restriction
 869       (narrow-to-region start end)
 870       (goto-char start)
 871       (let (cleartext-start cleartext-end)
 872         (while (re-search-forward "-----BEGIN PGP SIGNED MESSAGE-----$"
 873                                   nil t)
 874           (setq cleartext-start (match-beginning 0))
 875           (unless (re-search-forward "^-----BEGIN PGP SIGNATURE-----$"
 876                                            nil t)
 877             (error "Invalid cleartext signed message"))
 878           (setq cleartext-end (re-search-forward
 879                            "^-----END PGP SIGNATURE-----$"
 880                            nil t))
 881           (unless cleartext-end
 882             (error "No cleartext tail"))
 883           (epa-verify-region cleartext-start cleartext-end))))))
 884
 885 (if (fboundp 'select-safe-coding-system)
 886     (defalias 'epa--select-safe-coding-system 'select-safe-coding-system)
 887   (defun epa--select-safe-coding-system (from to)
 888     buffer-file-coding-system))
 889
 890 ;;;###autoload
 891 (defun epa-sign-region (start end signers mode)
 892   "Sign the current region between START and END by SIGNERS keys selected.
 893
 894 Don't use this command in Lisp programs!"
 895   (interactive
 896    (let ((verbose current-prefix-arg))
 897      (setq epa-last-coding-system-specified
 898            (or coding-system-for-write
 899                (epa--select-safe-coding-system
 900                 (region-beginning) (region-end))))
 901      (list (region-beginning) (region-end)
 902            (if verbose
 903                (epa-select-keys (epg-make-context epa-protocol)
 904                                 "Select keys for signing.
 905 If no one is selected, default secret key is used.  "
 906                                 nil t))
 907            (if verbose
 908                (epa--read-signature-type)
 909              'clear))))
 910   (save-excursion
 911     (let ((context (epg-make-context epa-protocol))
 912           signature)
 913       ;;(epg-context-set-armor context epa-armor)
 914       (epg-context-set-armor context t)
 915       ;;(epg-context-set-textmode context epa-textmode)
 916       (epg-context-set-textmode context t)
 917       (epg-context-set-signers context signers)
 918       (epg-context-set-passphrase-callback context
 919                                            #'epa-passphrase-callback-function)
 920       (epg-context-set-progress-callback context
 921                                          #'epa-progress-callback-function
 922                                          "Signing...")
 923       (message "Signing...")
 924       (setq signature (epg-sign-string context
 925                                        (epa--encode-coding-string
 926                                         (buffer-substring start end)
 927                                         epa-last-coding-system-specified)
 928                                        mode))
 929       (message "Signing...done")
 930       (delete-region start end)
 931       (goto-char start)
 932       (add-text-properties (point)
 933                            (progn
 934                              (insert (epa--decode-coding-string
 935                                       signature
 936                                       (or coding-system-for-read
 937                                           epa-last-coding-system-specified)))
 938                              (point))
 939                            (list 'epa-coding-system-used
 940                                  epa-last-coding-system-specified
 941                                  'front-sticky nil
 942                                  'rear-nonsticky t
 943                                  'start-open t
 944                                  'end-open t)))))
 945
 946 (if (fboundp 'derived-mode-p)
 947     (defalias 'epa--derived-mode-p 'derived-mode-p)
 948   (defun epa--derived-mode-p (&rest modes)
 949     "Non-nil if the current major mode is derived from one of MODES.
 950 Uses the `derived-mode-parent' property of the symbol to trace backwards."
 951     (let ((parent major-mode))
 952       (while (and (not (memq parent modes))
 953                   (setq parent (get parent 'derived-mode-parent))))
 954       parent)))
 955
 956 ;;;###autoload
 957 (defun epa-encrypt-region (start end recipients sign signers)
 958   "Encrypt the current region between START and END for RECIPIENTS.
 959
 960 Don't use this command in Lisp programs!"
 961   (interactive
 962    (let ((verbose current-prefix-arg)
 963          (context (epg-make-context epa-protocol))
 964          sign)
 965      (setq epa-last-coding-system-specified
 966            (or coding-system-for-write
 967                (epa--select-safe-coding-system
 968                 (region-beginning) (region-end))))
 969      (list (region-beginning) (region-end)
 970            (epa-select-keys context
 971                             "Select recipients for encryption.
 972 If no one is selected, symmetric encryption will be performed.  ")
 973            (setq sign (if verbose (y-or-n-p "Sign? ")))
 974            (if sign
 975                (epa-select-keys context
 976                                 "Select keys for signing.  ")))))
 977   (save-excursion
 978     (let ((context (epg-make-context epa-protocol))
 979           cipher)
 980       ;;(epg-context-set-armor context epa-armor)
 981       (epg-context-set-armor context t)
 982       ;;(epg-context-set-textmode context epa-textmode)
 983       (epg-context-set-textmode context t)
 984       (if sign
 985           (epg-context-set-signers context signers))
 986       (epg-context-set-passphrase-callback context
 987                                            #'epa-passphrase-callback-function)
 988       (epg-context-set-progress-callback context
 989                                          #'epa-progress-callback-function
 990                                          "Encrypting...")
 991       (message "Encrypting...")
 992       (setq cipher (epg-encrypt-string context
 993                                        (epa--encode-coding-string
 994                                         (buffer-substring start end)
 995                                         epa-last-coding-system-specified)
 996                                        recipients
 997                                        sign))
 998       (message "Encrypting...done")
 999       (delete-region start end)
1000       (goto-char start)
1001       (add-text-properties (point)
1002                            (progn
1003                              (insert cipher)
1004                              (point))
1005                            (list 'epa-coding-system-used
1006                                  epa-last-coding-system-specified
1007                                  'front-sticky nil
1008                                  'rear-nonsticky t
1009                                  'start-open t
1010                                  'end-open t)))))
1011
1012 ;;;###autoload
1013 (defun epa-delete-keys (keys &optional allow-secret)
1014   "Delete selected KEYS.
1015
1016 Don't use this command in Lisp programs!"
1017   (interactive
1018    (let ((keys (epa--marked-keys)))
1019      (unless keys
1020        (error "No keys selected"))
1021      (list keys
1022            (eq (nth 1 epa-list-keys-arguments) t))))
1023   (let ((context (epg-make-context epa-protocol)))
1024     (message "Deleting...")
1025     (epg-delete-keys context keys allow-secret)
1026     (message "Deleting...done")
1027     (apply #'epa-list-keys epa-list-keys-arguments)))
1028
1029 ;;;###autoload
1030 (defun epa-import-keys (file)
1031   "Import keys from FILE.
1032
1033 Don't use this command in Lisp programs!"
1034   (interactive "fFile: ")
1035   (setq file (expand-file-name file))
1036   (let ((context (epg-make-context epa-protocol)))
1037     (message "Importing %s..." (file-name-nondirectory file))
1038     (condition-case nil
1039         (progn
1040           (epg-import-keys-from-file context file)
1041           (message "Importing %s...done" (file-name-nondirectory file)))
1042       (error
1043        (message "Importing %s...failed" (file-name-nondirectory file))))
1044     (if (epg-context-result-for context 'import)
1045         (epa-display-info (epg-import-result-to-string
1046                            (epg-context-result-for context 'import))))
1047     (if (eq major-mode 'epa-key-list-mode)
1048         (apply #'epa-list-keys epa-list-keys-arguments))))
1049
1050 ;;;###autoload
1051 (defun epa-import-keys-region (start end)
1052   "Import keys from the region.
1053
1054 Don't use this command in Lisp programs!"
1055   (interactive "r")
1056   (let ((context (epg-make-context epa-protocol)))
1057     (message "Importing...")
1058     (condition-case nil
1059         (progn
1060           (epg-import-keys-from-string context (buffer-substring start end))
1061           (message "Importing...done"))
1062       (error
1063        (message "Importing...failed")))
1064     (if (epg-context-result-for context 'import)
1065         (epa-display-info (epg-import-result-to-string
1066                            (epg-context-result-for context 'import))))))
1067
1068 ;;;###autoload
1069 (defun epa-import-armor-in-region (start end)
1070   "Import keys in the OpenPGP armor format in the current region
1071 between START and END.
1072
1073 Don't use this command in Lisp programs!"
1074   (interactive "r")
1075   (save-excursion
1076     (save-restriction
1077       (narrow-to-region start end)
1078       (goto-char start)
1079       (let (armor-start armor-end)
1080         (while (re-search-forward
1081                 "-----BEGIN \\(PGP \\(PUBLIC\\|PRIVATE\\) KEY BLOCK\\)-----$"
1082                 nil t)
1083           (setq armor-start (match-beginning 0)
1084                 armor-end (re-search-forward
1085                            (concat "^-----END " (match-string 1) "-----$")
1086                            nil t))
1087           (unless armor-end
1088             (error "No armor tail"))
1089           (epa-import-keys-region armor-start armor-end))))))
1090
1091 ;;;###autoload
1092 (defun epa-export-keys (keys file)
1093   "Export selected KEYS to FILE.
1094
1095 Don't use this command in Lisp programs!"
1096   (interactive
1097    (let ((keys (epa--marked-keys))
1098          default-name)
1099      (unless keys
1100        (error "No keys selected"))
1101      (setq default-name
1102            (expand-file-name
1103             (concat (epg-sub-key-id (car (epg-key-sub-key-list (car keys))))
1104                     (if epa-armor ".asc" ".gpg"))
1105             default-directory))
1106      (list keys
1107            (expand-file-name
1108             (read-file-name
1109              (concat "To file (default "
1110                      (file-name-nondirectory default-name)
1111                      ") ")
1112              (file-name-directory default-name)
1113              default-name)))))
1114   (let ((context (epg-make-context epa-protocol)))
1115     (epg-context-set-armor context epa-armor)
1116     (message "Exporting to %s..." (file-name-nondirectory file))
1117     (epg-export-keys-to-file context keys file)
1118     (message "Exporting to %s...done" (file-name-nondirectory file))))
1119
1120 ;;;###autoload
1121 (defun epa-insert-keys (keys)
1122   "Insert selected KEYS after the point.
1123
1124 Don't use this command in Lisp programs!"
1125   (interactive
1126    (list (epa-select-keys (epg-make-context epa-protocol)
1127                           "Select keys to export.  ")))
1128   (let ((context (epg-make-context epa-protocol)))
1129     ;;(epg-context-set-armor context epa-armor)
1130     (epg-context-set-armor context t)
1131     (insert (epg-export-keys-to-string context keys))))
1132
1133 ;;;###autoload
1134 (defun epa-sign-keys (keys &optional local)
1135   "Sign selected KEYS.
1136 If a prefix-arg is specified, the signature is marked as non exportable.
1137
1138 Don't use this command in Lisp programs!"
1139   (interactive
1140    (let ((keys (epa--marked-keys)))
1141      (unless keys
1142        (error "No keys selected"))
1143      (list keys current-prefix-arg)))
1144   (let ((context (epg-make-context epa-protocol)))
1145     (epg-context-set-passphrase-callback context
1146                                          #'epa-passphrase-callback-function)
1147     (epg-context-set-progress-callback context
1148                                        #'epa-progress-callback-function
1149                                        "Signing keys...")
1150     (message "Signing keys...")
1151     (epg-sign-keys context keys local)
1152     (message "Signing keys...done")))
1153 (make-obsolete 'epa-sign-keys "Do not use.")
1154
1155 (provide 'epa)
1156
1157 ;;; epa.el ends here