code.delx.au - gnu-emacs/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 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 2, 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 nil
  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 (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 passphrase-with-newline
  98                                               pgg-passphrase-coding-system))
  99                   (pgg-clear-string passphrase-with-newline))
 100               (setq encoded-passphrase-with-new-line passphrase-with-newline
 101                     passphrase-with-newline nil))
 102             (process-send-string process encoded-passphrase-with-new-line))
 103           (process-send-region process start end)
 104           (process-send-eof process)
 105           (while (eq 'run (process-status process))
 106             (accept-process-output process 5))
 107           (setq status (process-status process)
 108                 exit-status (process-exit-status process))
 109           (delete-process process)
 110           (with-current-buffer (get-buffer-create output-buffer)
 111             (buffer-disable-undo)
 112             (erase-buffer)
 113             (if (file-exists-p output-file-name)
 114                 (let ((coding-system-for-read (if pgg-text-mode
 115                                                   'raw-text
 116                                                 'binary)))
 117                   (insert-file-contents output-file-name)))
 118             (set-buffer errors-buffer)
 119             (if (memq status '(stop signal))
 120                 (error "%s exited abnormally: '%s'" program exit-status))
 121             (if (= 127 exit-status)
 122                 (error "%s could not be found" program))))
 123       (if passphrase-with-newline
 124           (pgg-clear-string passphrase-with-newline))
 125       (if encoded-passphrase-with-new-line
 126           (pgg-clear-string encoded-passphrase-with-new-line))
 127       (if (and process (eq 'run (process-status process)))
 128           (interrupt-process process))
 129       (if (file-exists-p output-file-name)
 130           (delete-file output-file-name))
 131       (set-default-file-modes orig-mode))))
 132
 133 (defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key notruncate)
 134   (if (and passphrase
 135            pgg-cache-passphrase
 136            (progn
 137              (goto-char (point-min))
 138              (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t)))
 139       (pgg-add-passphrase-to-cache
 140        (or key
 141            (progn
 142              (goto-char (point-min))
 143              (if (re-search-forward
 144                   "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t)
 145                  (substring (match-string 0) -8))))
 146        passphrase
 147        notruncate)))
 148
 149 (defvar pgg-gpg-all-secret-keys 'unknown)
 150
 151 (defun pgg-gpg-lookup-all-secret-keys ()
 152   "Return all secret keys present in secret key ring."
 153   (when (eq pgg-gpg-all-secret-keys 'unknown)
 154     (setq pgg-gpg-all-secret-keys '())
 155     (let ((args (list "--with-colons" "--no-greeting" "--batch"
 156                       "--list-secret-keys")))
 157       (with-temp-buffer
 158         (apply #'call-process pgg-gpg-program nil t nil args)
 159         (goto-char (point-min))
 160         (while (re-search-forward
 161                 "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t)
 162           (push (substring (match-string 2) 8)
 163                 pgg-gpg-all-secret-keys)))))
 164   pgg-gpg-all-secret-keys)
 165
 166 (defun pgg-gpg-lookup-key (string &optional type)
 167   "Search keys associated with STRING."
 168   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 169                     (if type "--list-secret-keys" "--list-keys")
 170                     string)))
 171     (with-temp-buffer
 172       (apply #'call-process pgg-gpg-program nil t nil args)
 173       (goto-char (point-min))
 174       (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)"
 175                              nil t)
 176           (substring (match-string 2) 8)))))
 177
 178 (defun pgg-gpg-lookup-key-owner (string &optional all)
 179   "Search keys associated with STRING and return owner of identified key.
 180
 181 The value may be just the bare key id, or it may be a combination of the
 182 user name associated with the key and the key id, with the key id enclosed
 183 in \"<...>\" angle brackets.
 184
 185 Optional ALL non-nil means search all keys, including secret keys."
 186   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 187                     (if all "--list-secret-keys" "--list-keys")
 188                     string))
 189         (key-regexp (concat "^\\(sec\\|pub\\)"
 190                             ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):[^:]*"
 191                             ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):")))
 192     (with-temp-buffer
 193       (apply #'call-process pgg-gpg-program nil t nil args)
 194       (goto-char (point-min))
 195       (if (re-search-forward key-regexp
 196                              nil t)
 197           (match-string 3)))))
 198
 199 (defun pgg-gpg-key-id-from-key-owner (key-owner)
 200   (cond ((not key-owner) nil)
 201         ;; Extract bare key id from outermost paired angle brackets, if any:
 202         ((string-match "[^<]*<\\(.+\\)>[^>]*" key-owner)
 203          (substring key-owner (match-beginning 1)(match-end 1)))
 204         (key-owner)))
 205
 206 (defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase)
 207   "Encrypt the current region between START and END.
 208
 209 If optional argument SIGN is non-nil, do a combined sign and encrypt.
 210
 211 If optional PASSPHRASE is not specified, it will be obtained from the
 212 passphrase cache or user."
 213   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 214          (passphrase (or passphrase
 215                          (when (and sign (not (pgg-gpg-use-agent-p)))
 216                            (pgg-read-passphrase
 217                             (format "GnuPG passphrase for %s: "
 218                                     pgg-gpg-user-id)
 219                             pgg-gpg-user-id))))
 220          (args
 221           (append
 222            (list "--batch" "--armor" "--always-trust" "--encrypt")
 223            (if pgg-text-mode (list "--textmode"))
 224            (if sign (list "--sign" "--local-user" pgg-gpg-user-id))
 225            (if recipients
 226                (apply #'nconc
 227                       (mapcar (lambda (rcpt)
 228                                 (list pgg-gpg-recipient-argument rcpt))
 229                               (append recipients
 230                                       (if pgg-encrypt-for-me
 231                                           (list pgg-gpg-user-id)))))))))
 232     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 233     (when sign
 234       (with-current-buffer pgg-errors-buffer
 235         ;; Possibly cache passphrase under, e.g. "jas", for future sign.
 236         (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
 237         ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
 238         (pgg-gpg-possibly-cache-passphrase passphrase)))
 239     (pgg-process-when-success)))
 240
 241 (defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase)
 242   "Encrypt the current region between START and END with symmetric cipher.
 243
 244 If optional PASSPHRASE is not specified, it will be obtained from the
 245 passphrase cache or user."
 246   (let* ((passphrase (or passphrase
 247                          (when (not (pgg-gpg-use-agent-p))
 248                            (pgg-read-passphrase
 249                             "GnuPG passphrase for symmetric encryption: "))))
 250          (args
 251           (append (list "--batch" "--armor" "--symmetric" )
 252                   (if pgg-text-mode (list "--textmode")))))
 253     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 254     (pgg-process-when-success)))
 255
 256 (defun pgg-gpg-decrypt-region (start end &optional passphrase)
 257   "Decrypt the current region between START and END.
 258
 259 If optional PASSPHRASE is not specified, it will be obtained from the
 260 passphrase cache or user."
 261   (let* ((current-buffer (current-buffer))
 262          (message-keys (with-temp-buffer
 263                          (insert-buffer-substring current-buffer)
 264                          (pgg-decode-armor-region (point-min) (point-max))))
 265          (secret-keys (pgg-gpg-lookup-all-secret-keys))
 266          ;; XXX the user is stuck if they need to use the passphrase for
 267          ;;     any but the first secret key for which the message is
 268          ;;     encrypted.  ideally, we would incrementally give them a
 269          ;;     chance with subsequent keys each time they fail with one.
 270          (key (pgg-gpg-select-matching-key message-keys secret-keys))
 271          (key-owner (and key (pgg-gpg-lookup-key-owner key t)))
 272          (key-id (pgg-gpg-key-id-from-key-owner key-owner))
 273          (pgg-gpg-user-id (or key-id key
 274                               pgg-gpg-user-id pgg-default-user-id))
 275          (passphrase (or passphrase
 276                          (when (not (pgg-gpg-use-agent-p))
 277                            (pgg-read-passphrase
 278                             (format (if (pgg-gpg-symmetric-key-p message-keys)
 279                                         "Passphrase for symmetric decryption: "
 280                                       "GnuPG passphrase for %s: ")
 281                                     (or key-owner "??"))
 282                             pgg-gpg-user-id))))
 283          (args '("--batch" "--decrypt")))
 284     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 285     (with-current-buffer pgg-errors-buffer
 286       (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
 287       (goto-char (point-min))
 288       (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t))))
 289
 290 ;;;###autoload
 291 (defun pgg-gpg-symmetric-key-p (message-keys)
 292   "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator."
 293   (let (result)
 294     (dolist (key message-keys result)
 295       (when (and (eq (car key) 3)
 296                  (member '(symmetric-key-algorithm) key))
 297         (setq result key)))))
 298
 299 (defun pgg-gpg-select-matching-key (message-keys secret-keys)
 300   "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS."
 301   (loop for message-key in message-keys
 302         for message-key-id = (and (equal (car message-key) 1)
 303                                   (cdr (assq 'key-identifier
 304                                              (cdr message-key))))
 305         for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt))
 306         when (and key (member key secret-keys)) return key))
 307
 308 (defun pgg-gpg-sign-region (start end &optional cleartext passphrase)
 309   "Make detached signature from text between START and END."
 310   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 311          (passphrase (or passphrase
 312                          (when (not (pgg-gpg-use-agent-p))
 313                            (pgg-read-passphrase
 314                             (format "GnuPG passphrase for %s: "
 315                                     pgg-gpg-user-id)
 316                             pgg-gpg-user-id))))
 317          (args
 318           (append (list (if cleartext "--clearsign" "--detach-sign")
 319                         "--armor" "--batch" "--verbose"
 320                         "--local-user" pgg-gpg-user-id)
 321                   (if pgg-text-mode (list "--textmode"))))
 322          (inhibit-read-only t)
 323          buffer-read-only)
 324     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 325     (with-current-buffer pgg-errors-buffer
 326       ;; Possibly cache passphrase under, e.g. "jas", for future sign.
 327       (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
 328       ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
 329       (pgg-gpg-possibly-cache-passphrase passphrase))
 330     (pgg-process-when-success)))
 331
 332 (defun pgg-gpg-verify-region (start end &optional signature)
 333   "Verify region between START and END as the detached signature SIGNATURE."
 334   (let ((args '("--batch" "--verify")))
 335     (when (stringp signature)
 336       (setq args (append args (list signature))))
 337     (setq args (append args '("-")))
 338     (pgg-gpg-process-region start end nil pgg-gpg-program args)
 339     (with-current-buffer pgg-errors-buffer
 340       (goto-char (point-min))
 341       (while (re-search-forward "^gpg: \\(.*\\)\n" nil t)
 342         (with-current-buffer pgg-output-buffer
 343           (insert-buffer-substring pgg-errors-buffer
 344                                    (match-beginning 1) (match-end 0)))
 345         (delete-region (match-beginning 0) (match-end 0)))
 346       (goto-char (point-min))
 347       (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t))))
 348
 349 (defun pgg-gpg-insert-key ()
 350   "Insert public key at point."
 351   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 352          (args (list "--batch" "--export" "--armor"
 353                      pgg-gpg-user-id)))
 354     (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args)
 355     (insert-buffer-substring pgg-output-buffer)))
 356
 357 (defun pgg-gpg-snarf-keys-region (start end)
 358   "Add all public keys in region between START and END to the keyring."
 359   (let ((args '("--import" "--batch" "-")) status)
 360     (pgg-gpg-process-region start end nil pgg-gpg-program args)
 361     (set-buffer pgg-errors-buffer)
 362     (goto-char (point-min))
 363     (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t)
 364       (setq status (buffer-substring (match-end 0)
 365                                      (progn (end-of-line)(point)))
 366             status (vconcat (mapcar #'string-to-number (split-string status))))
 367       (erase-buffer)
 368       (insert (format "Imported %d key(s).
 369 \tArmor contains %d key(s) [%d bad, %d old].\n"
 370                       (+ (aref status 2)
 371                          (aref status 10))
 372                       (aref status 0)
 373                       (aref status 1)
 374                       (+ (aref status 4)
 375                          (aref status 11)))
 376               (if (zerop (aref status 9))
 377                   ""
 378                 "\tSecret keys are imported.\n")))
 379     (append-to-buffer pgg-output-buffer (point-min)(point-max))
 380     (pgg-process-when-success)))
 381
 382 (defun pgg-gpg-update-agent ()
 383   "Try to connet to gpg-agent and send UPDATESTARTUPTTY."
 384   (if (fboundp 'make-network-process)
 385       (let* ((agent-info (getenv "GPG_AGENT_INFO"))
 386              (socket (and agent-info
 387                           (string-match "^\\([^:]*\\)" agent-info)
 388                           (match-string 1 agent-info)))
 389              (conn (and socket
 390                         (make-network-process :name "gpg-agent-process"
 391                                               :host 'local :family 'local
 392                                               :service socket))))
 393         (when (and conn (eq (process-status conn) 'open))
 394           (process-send-string conn "UPDATESTARTUPTTY\n")
 395           (delete-process conn)
 396           t))
 397     ;; We can't check, so assume gpg-agent is up.
 398     t))
 399
 400 (defun pgg-gpg-use-agent-p ()
 401   "Return t if `pgg-gpg-use-agent' is t and gpg-agent is available."
 402   (and pgg-gpg-use-agent (pgg-gpg-update-agent)))
 403
 404 (provide 'pgg-gpg)
 405
 406 ;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000
 407 ;;; pgg-gpg.el ends here