lisp/pgg-gpg.el

   1 ;;; pgg-gpg.el --- GnuPG support for PGG.
   2
   3 ;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Daiki Ueno <ueno@unixuser.org>
   7 ;; Symmetric encryption and gpg-agent support added by:
   8 ;;   Sascha Wilde <wilde@sha-bang.de>
   9 ;; Created: 1999/10/28
  10 ;; Keywords: PGP, OpenPGP, GnuPG
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 3, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Code:
  30
  31 (eval-when-compile
  32   (require 'cl)                         ; for gpg macros
  33   (require 'pgg))
  34
  35 (defgroup pgg-gpg ()
  36   "GnuPG interface."
  37   :group 'pgg)
  38
  39 (defcustom pgg-gpg-program "gpg"
  40   "The GnuPG executable."
  41   :group 'pgg-gpg
  42   :type 'string)
  43
  44 (defcustom pgg-gpg-extra-args nil
  45   "Extra arguments for every GnuPG invocation."
  46   :group 'pgg-gpg
  47   :type '(repeat (string :tag "Argument")))
  48
  49 (defcustom pgg-gpg-recipient-argument "--recipient"
  50   "GnuPG option to specify recipient."
  51   :group 'pgg-gpg
  52   :type '(choice (const :tag "New `--recipient' option" "--recipient")
  53                  (const :tag "Old `--remote-user' option" "--remote-user")))
  54
  55 (defcustom pgg-gpg-use-agent t
  56   "Whether to use gnupg agent for key caching."
  57   :group 'pgg-gpg
  58   :type 'boolean)
  59
  60 (defvar pgg-gpg-user-id nil
  61   "GnuPG ID of your default identity.")
  62
  63 (defun pgg-gpg-process-region (start end passphrase program args)
  64   (let* ((use-agent (and (null passphrase) (pgg-gpg-use-agent-p)))
  65          (output-file-name (pgg-make-temp-file "pgg-output"))
  66          (args
  67           `("--status-fd" "2"
  68             ,@(if use-agent '("--use-agent")
  69                 (if passphrase '("--passphrase-fd" "0")))
  70             "--yes" ; overwrite
  71             "--output" ,output-file-name
  72             ,@pgg-gpg-extra-args ,@args))
  73          (output-buffer pgg-output-buffer)
  74          (errors-buffer pgg-errors-buffer)
  75          (orig-mode (default-file-modes))
  76          (process-connection-type nil)
  77          (inhibit-redisplay t)
  78          process status exit-status
  79          passphrase-with-newline
  80          encoded-passphrase-with-new-line)
  81     (with-current-buffer (get-buffer-create errors-buffer)
  82       (buffer-disable-undo)
  83       (erase-buffer))
  84     (unwind-protect
  85         (progn
  86           (set-default-file-modes 448)
  87           (let ((coding-system-for-write 'binary))
  88             (setq process
  89                   (apply #'start-process "*GnuPG*" errors-buffer
  90                          program args)))
  91           (set-process-sentinel process #'ignore)
  92           (when passphrase
  93             (setq passphrase-with-newline (concat passphrase "\n"))
  94             (if pgg-passphrase-coding-system
  95                 (progn
  96                   (setq encoded-passphrase-with-new-line
  97                         (encode-coding-string
  98                          passphrase-with-newline
  99                          (coding-system-change-eol-conversion
 100                           pgg-passphrase-coding-system 'unix)))
 101                   (pgg-clear-string passphrase-with-newline))
 102               (setq encoded-passphrase-with-new-line passphrase-with-newline
 103                     passphrase-with-newline nil))
 104             (process-send-string process encoded-passphrase-with-new-line))
 105           (process-send-region process start end)
 106           (process-send-eof process)
 107           (while (eq 'run (process-status process))
 108             (accept-process-output process 5))
 109           ;; Accept any remaining pending output coming after the
 110           ;; status change.
 111           (accept-process-output process 5)
 112           (setq status (process-status process)
 113                 exit-status (process-exit-status process))
 114           (delete-process process)
 115           (with-current-buffer (get-buffer-create output-buffer)
 116             (buffer-disable-undo)
 117             (erase-buffer)
 118             (if (file-exists-p output-file-name)
 119                 (let ((coding-system-for-read (if pgg-text-mode
 120                                                   'raw-text
 121                                                 'binary)))
 122                   (insert-file-contents output-file-name)))
 123             (set-buffer errors-buffer)
 124             (if (memq status '(stop signal))
 125                 (error "%s exited abnormally: '%s'" program exit-status))
 126             (if (= 127 exit-status)
 127                 (error "%s could not be found" program))))
 128       (if passphrase-with-newline
 129           (pgg-clear-string passphrase-with-newline))
 130       (if encoded-passphrase-with-new-line
 131           (pgg-clear-string encoded-passphrase-with-new-line))
 132       (if (and process (eq 'run (process-status process)))
 133           (interrupt-process process))
 134       (if (file-exists-p output-file-name)
 135           (delete-file output-file-name))
 136       (set-default-file-modes orig-mode))))
 137
 138 (defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key notruncate)
 139   (if (and passphrase
 140            pgg-cache-passphrase
 141            (progn
 142              (goto-char (point-min))
 143              (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t)))
 144       (pgg-add-passphrase-to-cache
 145        (or key
 146            (progn
 147              (goto-char (point-min))
 148              (if (re-search-forward
 149                   "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t)
 150                  (substring (match-string 0) -8))))
 151        passphrase
 152        notruncate)))
 153
 154 (defvar pgg-gpg-all-secret-keys 'unknown)
 155
 156 (defun pgg-gpg-lookup-all-secret-keys ()
 157   "Return all secret keys present in secret key ring."
 158   (when (eq pgg-gpg-all-secret-keys 'unknown)
 159     (setq pgg-gpg-all-secret-keys '())
 160     (let ((args (list "--with-colons" "--no-greeting" "--batch"
 161                       "--list-secret-keys")))
 162       (with-temp-buffer
 163         (apply #'call-process pgg-gpg-program nil t nil args)
 164         (goto-char (point-min))
 165         (while (re-search-forward
 166                 "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t)
 167           (push (substring (match-string 2) 8)
 168                 pgg-gpg-all-secret-keys)))))
 169   pgg-gpg-all-secret-keys)
 170
 171 (defun pgg-gpg-lookup-key (string &optional type)
 172   "Search keys associated with STRING."
 173   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 174                     (if type "--list-secret-keys" "--list-keys")
 175                     string)))
 176     (with-temp-buffer
 177       (apply #'call-process pgg-gpg-program nil t nil args)
 178       (goto-char (point-min))
 179       (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)"
 180                              nil t)
 181           (substring (match-string 2) 8)))))
 182
 183 (defun pgg-gpg-lookup-key-owner (string &optional all)
 184   "Search keys associated with STRING and return owner of identified key.
 185
 186 The value may be just the bare key id, or it may be a combination of the
 187 user name associated with the key and the key id, with the key id enclosed
 188 in \"<...>\" angle brackets.
 189
 190 Optional ALL non-nil means search all keys, including secret keys."
 191   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 192                     (if all "--list-secret-keys" "--list-keys")
 193                     string))
 194         (key-regexp (concat "^\\(sec\\|pub\\)"
 195                             ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):[^:]*"
 196                             ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):")))
 197     (with-temp-buffer
 198       (apply #'call-process pgg-gpg-program nil t nil args)
 199       (goto-char (point-min))
 200       (if (re-search-forward key-regexp
 201                              nil t)
 202           (match-string 3)))))
 203
 204 (defun pgg-gpg-key-id-from-key-owner (key-owner)
 205   (cond ((not key-owner) nil)
 206         ;; Extract bare key id from outermost paired angle brackets, if any:
 207         ((string-match "[^<]*<\\(.+\\)>[^>]*" key-owner)
 208          (substring key-owner (match-beginning 1)(match-end 1)))
 209         (key-owner)))
 210
 211 (defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase)
 212   "Encrypt the current region between START and END.
 213
 214 If optional argument SIGN is non-nil, do a combined sign and encrypt.
 215
 216 If optional PASSPHRASE is not specified, it will be obtained from the
 217 passphrase cache or user."
 218   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 219          (passphrase (or passphrase
 220                          (when (and sign (not (pgg-gpg-use-agent-p)))
 221                            (pgg-read-passphrase
 222                             (format "GnuPG passphrase for %s: "
 223                                     pgg-gpg-user-id)
 224                             pgg-gpg-user-id))))
 225          (args
 226           (append
 227            (list "--batch" "--armor" "--always-trust" "--encrypt")
 228            (if pgg-text-mode (list "--textmode"))
 229            (if sign (list "--sign" "--local-user" pgg-gpg-user-id))
 230            (if (or recipients pgg-encrypt-for-me)
 231                (apply #'nconc
 232                       (mapcar (lambda (rcpt)
 233                                 (list pgg-gpg-recipient-argument rcpt))
 234                               (append recipients
 235                                       (if pgg-encrypt-for-me
 236                                           (list pgg-gpg-user-id)))))))))
 237     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 238     (when sign
 239       (with-current-buffer pgg-errors-buffer
 240         ;; Possibly cache passphrase under, e.g. "jas", for future sign.
 241         (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
 242         ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
 243         (pgg-gpg-possibly-cache-passphrase passphrase)))
 244     (pgg-process-when-success)))
 245
 246 (defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase)
 247   "Encrypt the current region between START and END with symmetric cipher.
 248
 249 If optional PASSPHRASE is not specified, it will be obtained from the
 250 passphrase cache or user."
 251   (let* ((passphrase (or passphrase
 252                          (when (not (pgg-gpg-use-agent-p))
 253                            (pgg-read-passphrase
 254                             "GnuPG passphrase for symmetric encryption: "))))
 255          (args
 256           (append (list "--batch" "--armor" "--symmetric" )
 257                   (if pgg-text-mode (list "--textmode")))))
 258     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 259     (pgg-process-when-success)))
 260
 261 (defun pgg-gpg-decrypt-region (start end &optional passphrase)
 262   "Decrypt the current region between START and END.
 263
 264 If optional PASSPHRASE is not specified, it will be obtained from the
 265 passphrase cache or user."
 266   (let* ((current-buffer (current-buffer))
 267          (message-keys (with-temp-buffer
 268                          (insert-buffer-substring current-buffer)
 269                          (pgg-decode-armor-region (point-min) (point-max))))
 270          (secret-keys (pgg-gpg-lookup-all-secret-keys))
 271          ;; XXX the user is stuck if they need to use the passphrase for
 272          ;;     any but the first secret key for which the message is
 273          ;;     encrypted.  ideally, we would incrementally give them a
 274          ;;     chance with subsequent keys each time they fail with one.
 275          (key (pgg-gpg-select-matching-key message-keys secret-keys))
 276          (key-owner (and key (pgg-gpg-lookup-key-owner key t)))
 277          (key-id (pgg-gpg-key-id-from-key-owner key-owner))
 278          (pgg-gpg-user-id (or key-id key
 279                               pgg-gpg-user-id pgg-default-user-id))
 280          (passphrase (or passphrase
 281                          (when (not (pgg-gpg-use-agent-p))
 282                            (pgg-read-passphrase
 283                             (format (if (pgg-gpg-symmetric-key-p message-keys)
 284                                         "Passphrase for symmetric decryption: "
 285                                       "GnuPG passphrase for %s: ")
 286                                     (or key-owner "??"))
 287                             pgg-gpg-user-id))))
 288          (args '("--batch" "--decrypt")))
 289     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 290     (with-current-buffer pgg-errors-buffer
 291       (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
 292       (goto-char (point-min))
 293       (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t))))
 294
 295 ;;;###autoload
 296 (defun pgg-gpg-symmetric-key-p (message-keys)
 297   "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator."
 298   (let (result)
 299     (dolist (key message-keys result)
 300       (when (and (eq (car key) 3)
 301                  (member '(symmetric-key-algorithm) key))
 302         (setq result key)))))
 303
 304 (defun pgg-gpg-select-matching-key (message-keys secret-keys)
 305   "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS."
 306   (loop for message-key in message-keys
 307         for message-key-id = (and (equal (car message-key) 1)
 308                                   (cdr (assq 'key-identifier
 309                                              (cdr message-key))))
 310         for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt))
 311         when (and key (member key secret-keys)) return key))
 312
 313 (defun pgg-gpg-sign-region (start end &optional cleartext passphrase)
 314   "Make detached signature from text between START and END."
 315   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 316          (passphrase (or passphrase
 317                          (when (not (pgg-gpg-use-agent-p))
 318                            (pgg-read-passphrase
 319                             (format "GnuPG passphrase for %s: "
 320                                     pgg-gpg-user-id)
 321                             pgg-gpg-user-id))))
 322          (args
 323           (append (list (if cleartext "--clearsign" "--detach-sign")
 324                         "--armor" "--batch" "--verbose"
 325                         "--local-user" pgg-gpg-user-id)
 326                   (if pgg-text-mode (list "--textmode"))))
 327          (inhibit-read-only t)
 328          buffer-read-only)
 329     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 330     (with-current-buffer pgg-errors-buffer
 331       ;; Possibly cache passphrase under, e.g. "jas", for future sign.
 332       (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
 333       ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
 334       (pgg-gpg-possibly-cache-passphrase passphrase))
 335     (pgg-process-when-success)))
 336
 337 (defun pgg-gpg-verify-region (start end &optional signature)
 338   "Verify region between START and END as the detached signature SIGNATURE."
 339   (let ((args '("--batch" "--verify")))
 340     (when (stringp signature)
 341       (setq args (append args (list signature))))
 342     (setq args (append args '("-")))
 343     (pgg-gpg-process-region start end nil pgg-gpg-program args)
 344     (with-current-buffer pgg-errors-buffer
 345       (goto-char (point-min))
 346       (while (re-search-forward "^gpg: \\(.*\\)\n" nil t)
 347         (with-current-buffer pgg-output-buffer
 348           (insert-buffer-substring pgg-errors-buffer
 349                                    (match-beginning 1) (match-end 0)))
 350         (delete-region (match-beginning 0) (match-end 0)))
 351       (goto-char (point-min))
 352       (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t))))
 353
 354 (defun pgg-gpg-insert-key ()
 355   "Insert public key at point."
 356   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 357          (args (list "--batch" "--export" "--armor"
 358                      pgg-gpg-user-id)))
 359     (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args)
 360     (insert-buffer-substring pgg-output-buffer)))
 361
 362 (defun pgg-gpg-snarf-keys-region (start end)
 363   "Add all public keys in region between START and END to the keyring."
 364   (let ((args '("--import" "--batch" "-")) status)
 365     (pgg-gpg-process-region start end nil pgg-gpg-program args)
 366     (set-buffer pgg-errors-buffer)
 367     (goto-char (point-min))
 368     (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t)
 369       (setq status (buffer-substring (match-end 0)
 370                                      (progn (end-of-line)(point)))
 371             status (vconcat (mapcar #'string-to-number (split-string status))))
 372       (erase-buffer)
 373       (insert (format "Imported %d key(s).
 374 \tArmor contains %d key(s) [%d bad, %d old].\n"
 375                       (+ (aref status 2)
 376                          (aref status 10))
 377                       (aref status 0)
 378                       (aref status 1)
 379                       (+ (aref status 4)
 380                          (aref status 11)))
 381               (if (zerop (aref status 9))
 382                   ""
 383                 "\tSecret keys are imported.\n")))
 384     (append-to-buffer pgg-output-buffer (point-min)(point-max))
 385     (pgg-process-when-success)))
 386
 387 (defun pgg-gpg-update-agent ()
 388   "Try to connet to gpg-agent and send UPDATESTARTUPTTY."
 389   (if (fboundp 'make-network-process)
 390       (let* ((agent-info (getenv "GPG_AGENT_INFO"))
 391              (socket (and agent-info
 392                           (string-match "^\\([^:]*\\)" agent-info)
 393                           (match-string 1 agent-info)))
 394              (conn (and socket
 395                         (make-network-process :name "gpg-agent-process"
 396                                               :host 'local :family 'local
 397                                               :service socket))))
 398         (when (and conn (eq (process-status conn) 'open))
 399           (process-send-string conn "UPDATESTARTUPTTY\n")
 400           (delete-process conn)
 401           t))
 402     ;; We can't check, so assume gpg-agent is up.
 403     t))
 404
 405 (defun pgg-gpg-use-agent-p ()
 406   "Return t if `pgg-gpg-use-agent' is t and gpg-agent is available."
 407   (and pgg-gpg-use-agent (pgg-gpg-update-agent)))
 408
 409 (provide 'pgg-gpg)
 410
 411 ;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000
 412 ;;; pgg-gpg.el ends here