cgit.sxemacs.org Git - gnus/blob - lisp/pgg-gpg.el

   1 ;;; pgg-gpg.el --- GnuPG support for PGG.
   2
   3 ;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
   4 ;;   2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Author: Daiki Ueno <ueno@unixuser.org>
   7 ;; Symmetric encryption support added by: Sascha Wilde <wilde@sha-bang.de>
   8 ;; Created: 1999/10/28
   9 ;; Keywords: PGP, OpenPGP, GnuPG
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Code:
  29
  30 (eval-when-compile
  31   (require 'pgg))
  32
  33 (defgroup pgg-gpg ()
  34   "GnuPG interface."
  35   :group 'pgg)
  36
  37 (defcustom pgg-gpg-program "gpg"
  38   "The GnuPG executable."
  39   :group 'pgg-gpg
  40   :type 'string)
  41
  42 (defcustom pgg-gpg-extra-args nil
  43   "Extra arguments for every GnuPG invocation."
  44   :group 'pgg-gpg
  45   :type '(repeat (string :tag "Argument")))
  46
  47 (defcustom pgg-gpg-recipient-argument "--recipient"
  48   "GnuPG option to specify recipient."
  49   :group 'pgg-gpg
  50   :type '(choice (const :tag "New `--recipient' option" "--recipient")
  51                  (const :tag "Old `--remote-user' option" "--remote-user")))
  52
  53 (defcustom pgg-gpg-use-agent nil
  54   "Whether to use gnupg agent for key caching."
  55   :group 'pgg-gpg
  56   :type 'boolean)
  57
  58 (defvar pgg-gpg-user-id nil
  59   "GnuPG ID of your default identity.")
  60
  61 (defvar pgg-gpg-user-id-alist nil
  62   "An alist mapping from key ID to user ID.")
  63
  64 (defvar pgg-gpg-read-point nil)
  65 (defvar pgg-gpg-output-file-name nil)
  66 (defvar pgg-gpg-pending-status-list nil)
  67 (defvar pgg-gpg-key-id nil)
  68 (defvar pgg-gpg-passphrase nil)
  69 (defvar pgg-gpg-debug nil)
  70
  71 (defun pgg-gpg-start-process (args)
  72   (let* ((output-file-name (pgg-make-temp-file "pgg-output"))
  73          (args
  74           (append (list "--no-tty"
  75                         "--status-fd" "1"
  76                         "--command-fd" "0"
  77                         "--yes" ; overwrite
  78                         "--output" output-file-name)
  79                   (if pgg-gpg-use-agent '("--use-agent"))
  80                   pgg-gpg-extra-args
  81                   args))
  82          (coding-system-for-write 'binary)
  83          (process-connection-type nil)
  84          (orig-mode (default-file-modes))
  85          (buffer (generate-new-buffer " *pgg-gpg*"))
  86          process)
  87     (with-current-buffer buffer
  88       (make-local-variable 'pgg-gpg-read-point)
  89       (setq pgg-gpg-read-point (point-min))
  90       (make-local-variable 'pgg-gpg-output-file-name)
  91       (setq pgg-gpg-output-file-name output-file-name)
  92       (make-local-variable 'pgg-gpg-pending-status-list)
  93       (setq pgg-gpg-pending-status-list nil)
  94       (make-local-variable 'pgg-gpg-key-id)
  95       (setq pgg-gpg-key-id nil)
  96       (make-local-variable 'pgg-gpg-passphrase)
  97       (setq pgg-gpg-passphrase nil))
  98     (unwind-protect
  99         (progn
 100           (set-default-file-modes 448)
 101           (setq process
 102                 (apply #'start-process "pgg-gpg" buffer pgg-gpg-program args)))
 103       (set-default-file-modes orig-mode))
 104     (set-process-filter process #'pgg-gpg-process-filter)
 105     (set-process-sentinel process #'pgg-gpg-process-sentinel)
 106     process))
 107
 108 (defun pgg-gpg-process-filter (process input)
 109   (if pgg-gpg-debug
 110       (save-excursion
 111         (set-buffer (get-buffer-create  " *pgg-gpg-debug*"))
 112         (goto-char (point-max))
 113         (insert input)))
 114   (if (buffer-live-p (process-buffer process))
 115       (save-excursion
 116         (set-buffer (process-buffer process))
 117         (goto-char (point-max))
 118         (insert input)
 119         (goto-char pgg-gpg-read-point)
 120         (beginning-of-line)
 121         (while (looking-at ".*\n")      ;the input line is finished
 122           (save-excursion
 123             (if (looking-at "\\[GNUPG:] \\([A-Z_]+\\)\\>.*")
 124                 (let* ((status (match-string 1))
 125                        (symbol (intern-soft (concat "pgg-gpg-status-"
 126                                                     status))))
 127                   (if (member status pgg-gpg-pending-status-list)
 128                       (setq pgg-gpg-pending-status-list nil))
 129                   (if (and symbol
 130                            (fboundp symbol))
 131                       (funcall symbol process (buffer-substring
 132                                                (match-beginning 1)
 133                                                (match-end 0)))))))
 134           (forward-line))
 135         (setq pgg-gpg-read-point (point)))))
 136
 137 (eval-and-compile
 138   (cond ((and (fboundp 'string-to-multibyte)
 139               (subrp (symbol-function 'string-to-multibyte)))
 140          (defalias 'pgg-string-to-multibyte 'string-to-multibyte))
 141         ((and (fboundp 'string-as-multibyte)
 142               (subrp (symbol-function 'string-as-multibyte)))
 143          (defun pgg-string-to-multibyte (string) "\
 144 Return a multibyte string with the same individual chars as string."
 145            (mapconcat
 146             (lambda (ch) (string-as-multibyte (char-to-string ch)))
 147             string "")))
 148         (t
 149          (defalias 'pgg-string-to-multibyte 'identity))))
 150
 151 (defun pgg-gpg-process-sentinel (process status)
 152   (if (buffer-live-p (process-buffer process))
 153       (save-excursion
 154         (set-buffer (process-buffer process))
 155         (when pgg-gpg-passphrase
 156           (fillarray pgg-gpg-passphrase 0)
 157           (setq pgg-gpg-passphrase nil))
 158         ;; Copy the contents of process-buffer to pgg-errors-buffer.
 159         (set-buffer (get-buffer-create pgg-errors-buffer))
 160         (buffer-disable-undo)
 161         (erase-buffer)
 162         (insert-buffer-substring (process-buffer process))
 163         ;; Read the contents of the output file to pgg-output-buffer.
 164         (set-buffer (let ((default-enable-multibyte-characters t))
 165                       (get-buffer-create pgg-output-buffer)))
 166         (buffer-disable-undo)
 167         (erase-buffer)
 168         (if (equal status "finished\n")
 169             (let ((output-file-name
 170                    (with-current-buffer (process-buffer process)
 171                      pgg-gpg-output-file-name)))
 172               (when (file-exists-p output-file-name)
 173                 ;; Buffer's multibyteness might be turned off after
 174                 ;; inserting file's contents, as the case may be.
 175                 (let ((coding-system-for-read (if pgg-text-mode
 176                                                   'raw-text
 177                                                 'binary)))
 178                   (insert-file-contents output-file-name))
 179                 (when (and (fboundp 'set-buffer-multibyte)
 180                            (subrp (symbol-function 'set-buffer-multibyte))
 181                            (not enable-multibyte-characters))
 182                   (if (zerop (buffer-size))
 183                       (set-buffer-multibyte t)
 184                     (insert (pgg-string-to-multibyte
 185                              (prog1
 186                                  (buffer-string)
 187                                (erase-buffer)
 188                                (set-buffer-multibyte t))))))
 189                 (delete-file output-file-name))))
 190         (kill-buffer (process-buffer process)))))
 191
 192 (defun pgg-gpg-wait-for-status (process status-list)
 193   (with-current-buffer (process-buffer process)
 194     (setq pgg-gpg-pending-status-list status-list)
 195     (while (and (eq (process-status process) 'run)
 196                 pgg-gpg-pending-status-list)
 197       (accept-process-output process 1))))
 198
 199 (defun pgg-gpg-wait-for-completion (process)
 200   (process-send-eof process)
 201   (while (eq (process-status process) 'run)
 202     ;; We can't use accept-process-output instead of sit-for here
 203     ;; because it may cause an interrupt during the sentinel execution.
 204     (sit-for 0.1)))
 205
 206 (defun pgg-gpg-status-USERID_HINT (process line)
 207   (if (string-match "\\`USERID_HINT \\([^ ]+\\) \\(.*\\)" line)
 208       (let* ((key-id (match-string 1 line))
 209              (user-id (match-string 2 line))
 210              (entry (assoc key-id pgg-gpg-user-id-alist)))
 211         (if entry
 212             (setcdr entry user-id)
 213           (setq pgg-gpg-user-id-alist (cons (cons key-id user-id)
 214                                             pgg-gpg-user-id-alist))))))
 215
 216 (defun pgg-gpg-status-NEED_PASSPHRASE (process line)
 217   (if (string-match "\\`NEED_PASSPHRASE \\([^ ]+\\)" line)
 218       (setq pgg-gpg-key-id (match-string 1 line))))
 219
 220 (defun pgg-gpg-status-NEED_PASSPHRASE_SYM (process line)
 221   (setq pgg-gpg-key-id 'SYM))
 222
 223 (defun pgg-gpg-status-NEED_PASSPHRASE_PIN (process line)
 224   (setq pgg-gpg-key-id 'PIN))
 225
 226 (defun pgg-gpg-status-GET_HIDDEN (process line)
 227   (let ((entry (assoc pgg-gpg-key-id pgg-gpg-user-id-alist)))
 228     (if (setq pgg-gpg-passphrase
 229               (if (eq pgg-gpg-key-id 'SYM)
 230                   (pgg-read-passphrase
 231                    "GnuPG passphrase for symmetric encryption: ")
 232                 (pgg-read-passphrase
 233                  (format "GnuPG passphrase for %s: "
 234                          (if entry
 235                              (cdr entry)
 236                            pgg-gpg-key-id))
 237                  (if (eq pgg-gpg-key-id 'PIN)
 238                      "PIN"
 239                    pgg-gpg-key-id))))
 240         (process-send-string process (concat pgg-gpg-passphrase "\n")))))
 241
 242 (defun pgg-gpg-status-GOOD_PASSPHRASE (process line)
 243   (when (and pgg-gpg-passphrase
 244              (stringp pgg-gpg-key-id))
 245     (pgg-add-passphrase-to-cache pgg-gpg-key-id pgg-gpg-passphrase)
 246     (setq pgg-gpg-passphrase nil)))
 247
 248 (defun pgg-gpg-status-BAD_PASSPHRASE (process line)
 249   (when pgg-gpg-passphrase
 250     (fillarray pgg-gpg-passphrase 0)
 251     (setq pgg-gpg-passphrase nil)))
 252
 253 (defun pgg-gpg-lookup-key (string &optional type)
 254   "Search keys associated with STRING."
 255   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 256                     (if type "--list-secret-keys" "--list-keys")
 257                     string)))
 258     (with-temp-buffer
 259       (apply #'call-process pgg-gpg-program nil t nil args)
 260       (goto-char (point-min))
 261       (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)"
 262                              nil t)
 263           (substring (match-string 2) 8)))))
 264
 265 (defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase)
 266   "Encrypt the current region between START and END.
 267
 268 If optional argument SIGN is non-nil, do a combined sign and encrypt."
 269   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 270          (args
 271           (append
 272            '("--armor" "--always-trust" "--encrypt")
 273            (if pgg-text-mode '("--textmode"))
 274            (if sign (list "--sign" "--local-user" pgg-gpg-user-id))
 275            (if recipients
 276                (apply #'nconc
 277                       (mapcar (lambda (rcpt)
 278                                 (list pgg-gpg-recipient-argument rcpt))
 279                               (append recipients
 280                                       (if pgg-encrypt-for-me
 281                                           (list pgg-gpg-user-id))))))))
 282          (process (pgg-gpg-start-process args)))
 283     (if (and sign (not pgg-gpg-use-agent))
 284         (pgg-gpg-wait-for-status process '("BEGIN_SIGNING" "GOOD_PASSPHRASE")))
 285     (process-send-region process start end)
 286     (pgg-gpg-wait-for-completion process)
 287     (save-excursion
 288       (set-buffer (get-buffer-create pgg-errors-buffer))
 289       (goto-char (point-max))
 290       (not (null (re-search-backward "^\\[GNUPG:] END_ENCRYPTION\\>"
 291                                      nil t))))))
 292
 293 (defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase)
 294   "Encrypt the current region between START and END with symmetric cipher."
 295   (let* ((args
 296           (append '("--armor" "--symmetric")
 297                   (if pgg-text-mode '("--textmode"))))
 298          (process (pgg-gpg-start-process args)))
 299     (pgg-gpg-wait-for-status process '("BEGIN_ENCRYPTION"))
 300     (process-send-region process start end)
 301     (pgg-gpg-wait-for-completion process)
 302     (save-excursion
 303       (set-buffer (get-buffer-create pgg-errors-buffer))
 304       (goto-char (point-max))
 305       (not (null (re-search-backward "^\\[GNUPG:] END_ENCRYPTION\\>"
 306                                      nil t))))))
 307
 308 (defun pgg-gpg-decrypt-region (start end &optional passphrase)
 309   "Decrypt the current region between START and END."
 310   (let* ((args '("--decrypt"))
 311          (process (pgg-gpg-start-process args)))
 312     (process-send-region process start end)
 313     (pgg-gpg-wait-for-status process '("BEGIN_DECRYPTION"))
 314     (pgg-gpg-wait-for-completion process)
 315     (save-excursion
 316       (set-buffer (get-buffer-create pgg-errors-buffer))
 317       (goto-char (point-max))
 318       (not (null (re-search-backward "^\\[GNUPG:] DECRYPTION_OKAY\\>"
 319                                      nil t))))))
 320
 321 (defun pgg-gpg-sign-region (start end &optional cleartext passphrase)
 322   "Make detached signature from text between START and END."
 323   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 324          (args
 325           (append (list (if cleartext "--clearsign" "--detach-sign")
 326                         "--armor" "--verbose"
 327                         "--local-user" pgg-gpg-user-id)
 328                   (if pgg-text-mode '("--textmode"))))
 329          (process (pgg-gpg-start-process args)))
 330     (unless pgg-gpg-use-agent
 331       (pgg-gpg-wait-for-status process '("BEGIN_SIGNING" "GOOD_PASSPHRASE")))
 332     (process-send-region process start end)
 333     (pgg-gpg-wait-for-completion process)
 334     (save-excursion
 335       (set-buffer (get-buffer-create pgg-errors-buffer))
 336       (goto-char (point-max))
 337       (not (null (re-search-backward "^\\[GNUPG:] SIG_CREATED\\>"
 338                                      nil t))))))
 339
 340 (defun pgg-gpg-verify-region (start end &optional signature)
 341   "Verify region between START and END as the detached signature SIGNATURE."
 342   (let ((args '("--verify"))
 343         process)
 344     (when (stringp signature)
 345       (setq args (append args (list signature))))
 346     (setq process (pgg-gpg-start-process (append args '("-"))))
 347     (process-send-region process start end)
 348     (pgg-gpg-wait-for-completion process)
 349     (save-excursion
 350       (set-buffer (get-buffer-create pgg-errors-buffer))
 351       (goto-char (point-max))
 352       (not (null (re-search-backward "^\\[GNUPG:] GOODSIG\\>"
 353                                      nil t))))))
 354
 355 (defun pgg-gpg-insert-key ()
 356   "Insert public key at point."
 357   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 358          (args (list "--export" "--armor"
 359                      pgg-gpg-user-id))
 360          (process (pgg-gpg-start-process args)))
 361     (pgg-gpg-wait-for-completion process)
 362     (insert-buffer-substring pgg-output-buffer)))
 363
 364 (defun pgg-gpg-snarf-keys-region (start end)
 365   "Add all public keys in region between START and END to the keyring."
 366   (let* ((args '("--import" "-"))
 367          (process (pgg-gpg-start-process args))
 368          status)
 369     (process-send-region process start end)
 370     (pgg-gpg-wait-for-completion process)
 371     (save-excursion
 372       (set-buffer (get-buffer-create pgg-errors-buffer))
 373       (goto-char (point-max))
 374       (not (null (re-search-backward "^\\[GNUPG:] IMPORT_RES\\>"
 375                                      nil t))))))
 376
 377 (provide 'pgg-gpg)
 378
 379 ;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000
 380 ;;; pgg-gpg.el ends here