epa.el

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