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