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-" status)))
 126                        (entry (member status pgg-gpg-pending-status-list)))
 127                   (if entry
 128                       (setq pgg-gpg-pending-status-list
 129                             (delq (car entry)
 130                                   pgg-gpg-pending-status-list)))
 131                   (if (and symbol
 132                            (fboundp symbol))
 133                       (funcall symbol process (buffer-substring
 134                                                (match-beginning 1)
 135                                                (match-end 0)))))))
 136           (forward-line))
 137         (setq pgg-gpg-read-point (point)))))
 138
 139 (defun pgg-gpg-process-sentinel (process status)
 140   (if (buffer-live-p (process-buffer process))
 141       (save-excursion
 142         (set-buffer (process-buffer process))
 143         (when pgg-gpg-passphrase
 144           (fillarray pgg-gpg-passphrase 0)
 145           (setq pgg-gpg-passphrase nil))
 146         ;; Copy the contents of process-buffer to pgg-errors-buffer.
 147         (set-buffer (get-buffer-create pgg-errors-buffer))
 148         (buffer-disable-undo)
 149         (erase-buffer)
 150         (insert-buffer-substring (process-buffer process))
 151         ;; Read the contents of the output file to pgg-output-buffer.
 152         (set-buffer (get-buffer-create pgg-output-buffer))
 153         (buffer-disable-undo)
 154         (erase-buffer)
 155         (if (equal status "finished\n")
 156             (let ((output-file-name
 157                    (with-current-buffer (process-buffer process)
 158                      pgg-gpg-output-file-name)))
 159               (when (file-exists-p output-file-name)
 160                 (let ((coding-system-for-read (if pgg-text-mode
 161                                                   'raw-text
 162                                                 'binary)))
 163                   (insert-file-contents output-file-name))
 164                 (delete-file output-file-name))))
 165         (kill-buffer (process-buffer process)))))
 166
 167 (defun pgg-gpg-wait-for-status (process status-list)
 168   (with-current-buffer (process-buffer process)
 169     (setq pgg-gpg-pending-status-list status-list)
 170     (while (and (eq (process-status process) 'run)
 171                 pgg-gpg-pending-status-list)
 172       (accept-process-output process 1))))
 173
 174 (defun pgg-gpg-wait-for-completion (process)
 175   (process-send-eof process)
 176   (while (eq (process-status process) 'run)
 177     ;; We can't use accept-process-output instead of sit-for here
 178     ;; because it may cause an interrupt during the sentinel execution.
 179     (sit-for 0.1)))
 180
 181 (defun pgg-gpg-status-USERID_HINT (process line)
 182   (if (string-match "\\`USERID_HINT \\([^ ]+\\) \\(.*\\)" line)
 183       (let* ((key-id (match-string 1 line))
 184              (user-id (match-string 2 line))
 185              (entry (assoc key-id pgg-gpg-user-id-alist)))
 186         (if entry
 187             (setcdr entry user-id)
 188           (setq pgg-gpg-user-id-alist (cons (cons key-id user-id)
 189                                             pgg-gpg-user-id-alist))))))
 190
 191 (defun pgg-gpg-status-NEED_PASSPHRASE (process line)
 192   (if (string-match "\\`NEED_PASSPHRASE \\([^ ]+\\)" line)
 193       (setq pgg-gpg-key-id (match-string 1 line))))
 194
 195 (defun pgg-gpg-status-NEED_PASSPHRASE_SYM (process line)
 196   (setq pgg-gpg-key-id 'SYM))
 197
 198 (defun pgg-gpg-status-NEED_PASSPHRASE_PIN (process line)
 199   (setq pgg-gpg-key-id 'PIN))
 200
 201 (defun pgg-gpg-status-GET_HIDDEN (process line)
 202   (let ((entry (assoc pgg-gpg-key-id pgg-gpg-user-id-alist)))
 203     (if (setq pgg-gpg-passphrase
 204               (if (eq pgg-gpg-key-id 'SYM)
 205                   (pgg-read-passphrase
 206                    "GnuPG passphrase for symmetric encryption: ")
 207                 (pgg-read-passphrase
 208                  (format "GnuPG passphrase for %s: "
 209                          (if entry
 210                              (cdr entry)
 211                            pgg-gpg-key-id))
 212                  (if (eq pgg-gpg-key-id 'PIN)
 213                      "PIN"
 214                    pgg-gpg-key-id))))
 215         (process-send-string process (concat pgg-gpg-passphrase "\n")))))
 216
 217 (defun pgg-gpg-status-GOOD_PASSPHRASE (process line)
 218   (when (and pgg-gpg-passphrase
 219              (stringp pgg-gpg-key-id))
 220     (pgg-add-passphrase-to-cache pgg-gpg-key-id pgg-gpg-passphrase)
 221     (setq pgg-gpg-passphrase nil)))
 222
 223 (defun pgg-gpg-status-BAD_PASSPHRASE (process line)
 224   (when pgg-gpg-passphrase
 225     (fillarray pgg-gpg-passphrase 0)
 226     (setq pgg-gpg-passphrase nil)))
 227
 228 (defun pgg-gpg-lookup-key (string &optional type)
 229   "Search keys associated with STRING."
 230   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 231                     (if type "--list-secret-keys" "--list-keys")
 232                     string)))
 233     (with-temp-buffer
 234       (apply #'call-process pgg-gpg-program nil t nil args)
 235       (goto-char (point-min))
 236       (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)"
 237                              nil t)
 238           (substring (match-string 2) 8)))))
 239
 240 (defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase)
 241   "Encrypt the current region between START and END.
 242
 243 If optional argument SIGN is non-nil, do a combined sign and encrypt."
 244   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 245          (args
 246           (append
 247            '("--armor" "--always-trust" "--encrypt")
 248            (if pgg-text-mode '("--textmode"))
 249            (if sign (list "--sign" "--local-user" pgg-gpg-user-id))
 250            (if recipients
 251                (apply #'nconc
 252                       (mapcar (lambda (rcpt)
 253                                 (list pgg-gpg-recipient-argument rcpt))
 254                               (append recipients
 255                                       (if pgg-encrypt-for-me
 256                                           (list pgg-gpg-user-id))))))))
 257          (process (pgg-gpg-start-process args)))
 258     (if (and sign (not pgg-gpg-use-agent))
 259         (pgg-gpg-wait-for-status process '("GOOD_PASSPHRASE")))
 260     (process-send-region process start end)
 261     (pgg-gpg-wait-for-completion process)
 262     (save-excursion
 263       (set-buffer (get-buffer-create pgg-errors-buffer))
 264       (goto-char (point-max))
 265       (not (null (re-search-backward "^\\[GNUPG:] END_ENCRYPTION\\>"
 266                                      nil t))))))
 267
 268 (defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase)
 269   "Encrypt the current region between START and END with symmetric cipher."
 270   (let* ((args
 271           (append '("--armor" "--symmetric")
 272                   (if pgg-text-mode '("--textmode"))))
 273          (process (pgg-gpg-start-process args)))
 274     (pgg-gpg-wait-for-status process '("BEGIN_ENCRYPTION"))
 275     (process-send-region process start end)
 276     (pgg-gpg-wait-for-completion process)
 277     (save-excursion
 278       (set-buffer (get-buffer-create pgg-errors-buffer))
 279       (goto-char (point-max))
 280       (not (null (re-search-backward "^\\[GNUPG:] END_ENCRYPTION\\>"
 281                                      nil t))))))
 282
 283 (defun pgg-gpg-decrypt-region (start end &optional passphrase)
 284   "Decrypt the current region between START and END."
 285   (let* ((args '("--decrypt"))
 286          (process (pgg-gpg-start-process args)))
 287     (process-send-region process start end)
 288     (pgg-gpg-wait-for-status process '("BEGIN_DECRYPTION"))
 289     (pgg-gpg-wait-for-completion process)
 290     (save-excursion
 291       (set-buffer (get-buffer-create pgg-errors-buffer))
 292       (goto-char (point-max))
 293       (not (null (re-search-backward "^\\[GNUPG:] DECRYPTION_OKAY\\>"
 294                                      nil t))))))
 295
 296 (defun pgg-gpg-sign-region (start end &optional cleartext passphrase)
 297   "Make detached signature from text between START and END."
 298   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 299          (args
 300           (append (list (if cleartext "--clearsign" "--detach-sign")
 301                         "--armor" "--verbose"
 302                         "--local-user" pgg-gpg-user-id)
 303                   (if pgg-text-mode '("--textmode"))))
 304          (process (pgg-gpg-start-process args)))
 305     (unless pgg-gpg-use-agent
 306       (pgg-gpg-wait-for-status process '("GOOD_PASSPHRASE")))
 307     (process-send-region process start end)
 308     (pgg-gpg-wait-for-completion process)
 309     (save-excursion
 310       (set-buffer (get-buffer-create pgg-errors-buffer))
 311       (goto-char (point-max))
 312       (not (null (re-search-backward "^\\[GNUPG:] SIG_CREATED\\>"
 313                                      nil t))))))
 314
 315 (defun pgg-gpg-verify-region (start end &optional signature)
 316   "Verify region between START and END as the detached signature SIGNATURE."
 317   (let ((args '("--verify"))
 318         process)
 319     (when (stringp signature)
 320       (setq args (append args (list signature))))
 321     (setq process (pgg-gpg-start-process (append args '("-"))))
 322     (process-send-region process start end)
 323     (pgg-gpg-wait-for-completion process)
 324     (save-excursion
 325       (set-buffer (get-buffer-create pgg-errors-buffer))
 326       (goto-char (point-max))
 327       (not (null (re-search-backward "^\\[GNUPG:] GOODSIG\\>"
 328                                      nil t))))))
 329
 330 (defun pgg-gpg-insert-key ()
 331   "Insert public key at point."
 332   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 333          (args (list "--export" "--armor"
 334                      pgg-gpg-user-id))
 335          (process (pgg-gpg-start-process args)))
 336     (pgg-gpg-wait-for-completion process)
 337     (insert-buffer-substring pgg-output-buffer)))
 338
 339 (defun pgg-gpg-snarf-keys-region (start end)
 340   "Add all public keys in region between START and END to the keyring."
 341   (let* ((args '("--import" "-"))
 342          (process (pgg-gpg-start-process args))
 343          status)
 344     (process-send-region process start end)
 345     (pgg-gpg-wait-for-completion process)
 346     (save-excursion
 347       (set-buffer (get-buffer-create pgg-errors-buffer))
 348       (goto-char (point-max))
 349       (not (null (re-search-backward "^\\[GNUPG:] IMPORT_RES\\>"
 350                                      nil t))))))
 351
 352 (provide 'pgg-gpg)
 353
 354 ;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000
 355 ;;; pgg-gpg.el ends here