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