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