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 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 'cl)                         ; for gpg macros
  32   (require 'pgg))
  33
  34 (defgroup pgg-gpg ()
  35   "GnuPG interface."
  36   :group 'pgg)
  37
  38 (defcustom pgg-gpg-program "gpg"
  39   "The GnuPG executable."
  40   :group 'pgg-gpg
  41   :type 'string)
  42
  43 (defcustom pgg-gpg-extra-args nil
  44   "Extra arguments for every GnuPG invocation."
  45   :group 'pgg-gpg
  46   :type '(repeat (string :tag "Argument")))
  47
  48 (defcustom pgg-gpg-recipient-argument "--recipient"
  49   "GnuPG option to specify recipient."
  50   :group 'pgg-gpg
  51   :type '(choice (const :tag "New `--recipient' option" "--recipient")
  52                  (const :tag "Old `--remote-user' option" "--remote-user")))
  53
  54 (defvar pgg-gpg-user-id nil
  55   "GnuPG ID of your default identity.")
  56
  57 (defun pgg-gpg-process-region (start end passphrase program args)
  58   (let* ((output-file-name (pgg-make-temp-file "pgg-output"))
  59          (args
  60           `("--status-fd" "2"
  61             ,@(if passphrase '("--passphrase-fd" "0"))
  62             "--yes" ; overwrite
  63             "--output" ,output-file-name
  64             ,@pgg-gpg-extra-args ,@args))
  65          (output-buffer pgg-output-buffer)
  66          (errors-buffer pgg-errors-buffer)
  67          (orig-mode (default-file-modes))
  68          (process-connection-type nil)
  69          exit-status)
  70     (with-current-buffer (get-buffer-create errors-buffer)
  71       (buffer-disable-undo)
  72       (erase-buffer))
  73     (unwind-protect
  74         (progn
  75           (set-default-file-modes 448)
  76           (let ((coding-system-for-write 'binary)
  77                 (input (buffer-substring-no-properties start end))
  78                 (default-enable-multibyte-characters nil))
  79             (with-temp-buffer
  80               (when passphrase
  81                 (insert passphrase "\n"))
  82               (insert input)
  83               (setq exit-status
  84                     (apply #'call-process-region (point-min) (point-max) program
  85                            nil errors-buffer nil args))))
  86           (with-current-buffer (get-buffer-create output-buffer)
  87             (buffer-disable-undo)
  88             (erase-buffer)
  89             (if (file-exists-p output-file-name)
  90                 (let ((coding-system-for-read (if pgg-text-mode
  91                                                   'raw-text
  92                                                 'binary)))
  93                   (insert-file-contents output-file-name)))
  94             (set-buffer errors-buffer)
  95             (if (not (equal exit-status 0))
  96                 (insert (format "\n%s exited abnormally: '%s'\n"
  97                                 program exit-status)))))
  98       (if (file-exists-p output-file-name)
  99           (delete-file output-file-name))
 100       (set-default-file-modes orig-mode))))
 101
 102 (defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key notruncate)
 103   (if (and pgg-cache-passphrase
 104            (progn
 105              (goto-char (point-min))
 106              (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t)))
 107       (pgg-add-passphrase-to-cache
 108        (or key
 109            (progn
 110              (goto-char (point-min))
 111              (if (re-search-forward
 112                   "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t)
 113                  (substring (match-string 0) -8))))
 114        passphrase
 115        notruncate)))
 116
 117 (defvar pgg-gpg-all-secret-keys 'unknown)
 118
 119 (defun pgg-gpg-lookup-all-secret-keys ()
 120   "Return all secret keys present in secret key ring."
 121   (when (eq pgg-gpg-all-secret-keys 'unknown)
 122     (setq pgg-gpg-all-secret-keys '())
 123     (let ((args (list "--with-colons" "--no-greeting" "--batch"
 124                       "--list-secret-keys")))
 125       (with-temp-buffer
 126         (apply #'call-process pgg-gpg-program nil t nil args)
 127         (goto-char (point-min))
 128         (while (re-search-forward
 129                 "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t)
 130           (push (substring (match-string 2) 8)
 131                 pgg-gpg-all-secret-keys)))))
 132   pgg-gpg-all-secret-keys)
 133
 134 (defun pgg-gpg-lookup-key (string &optional type)
 135   "Search keys associated with STRING."
 136   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 137                     (if type "--list-secret-keys" "--list-keys")
 138                     string)))
 139     (with-temp-buffer
 140       (apply #'call-process pgg-gpg-program nil t nil args)
 141       (goto-char (point-min))
 142       (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)"
 143                              nil t)
 144           (substring (match-string 2) 8)))))
 145
 146 (defun pgg-gpg-lookup-key-owner (string &optional all)
 147   "Search keys associated with STRING and return owner of identified key.
 148
 149 The value may be just the bare key id, or it may be a combination of the
 150 user name associated with the key and the key id, with the key id enclosed
 151 in \"<...>\" angle brackets.
 152
 153 Optional ALL non-nil means search all keys, including secret keys."
 154   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 155                     (if all "--list-secret-keys" "--list-keys")
 156                     string))
 157         (key-regexp (concat "^\\(sec\\|pub\\)"
 158                             ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):[^:]*"
 159                             ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):"))
 160         )
 161     (with-temp-buffer
 162       (apply #'call-process pgg-gpg-program nil t nil args)
 163       (goto-char (point-min))
 164       (if (re-search-forward key-regexp
 165                              nil t)
 166           (match-string 3)))))
 167
 168 (defun pgg-gpg-key-id-from-key-owner (key-owner)
 169   (cond ((not key-owner) nil)
 170         ;; Extract bare key id from outermost paired angle brackets, if any:
 171         ((string-match "[^<]*<\\(.+\\)>[^>]*" key-owner)
 172          (substring key-owner (match-beginning 1)(match-end 1)))
 173         (key-owner))
 174   )
 175
 176 (defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase)
 177   "Encrypt the current region between START and END.
 178
 179 If optional argument SIGN is non-nil, do a combined sign and encrypt.
 180
 181 If optional PASSPHRASE is not specified, it will be obtained from the
 182 passphrase cache or user."
 183   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 184          (passphrase (or passphrase
 185                          (when sign
 186                            (pgg-read-passphrase
 187                             (format "GnuPG passphrase for %s: "
 188                                     pgg-gpg-user-id)
 189                             pgg-gpg-user-id))))
 190          (args
 191           (append
 192            (list "--batch" "--armor" "--always-trust" "--encrypt")
 193            (if pgg-text-mode (list "--textmode"))
 194            (if sign (list "--sign" "--local-user" pgg-gpg-user-id))
 195            (if recipients
 196                (apply #'nconc
 197                       (mapcar (lambda (rcpt)
 198                                 (list pgg-gpg-recipient-argument rcpt))
 199                               (append recipients
 200                                       (if pgg-encrypt-for-me
 201                                           (list pgg-gpg-user-id)))))))))
 202     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 203     (when sign
 204       (with-current-buffer pgg-errors-buffer
 205         ;; Possibly cache passphrase under, e.g. "jas", for future sign.
 206         (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
 207         ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
 208         (pgg-gpg-possibly-cache-passphrase passphrase)))
 209     (pgg-process-when-success)))
 210
 211 (defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase)
 212   "Encrypt the current region between START and END with symmetric cipher.
 213
 214 If optional PASSPHRASE is not specified, it will be obtained from the
 215 passphrase cache or user."
 216   (let* ((passphrase (or passphrase
 217                          (pgg-read-passphrase
 218                           "GnuPG passphrase for symmetric encryption: ")))
 219          (args
 220           (append (list "--batch" "--armor" "--symmetric" )
 221                   (if pgg-text-mode (list "--textmode")))))
 222     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 223     (pgg-process-when-success)))
 224
 225 (defun pgg-gpg-decrypt-region (start end &optional passphrase)
 226   "Decrypt the current region between START and END.
 227
 228 If optional PASSPHRASE is not specified, it will be obtained from the
 229 passphrase cache or user."
 230   (let* ((current-buffer (current-buffer))
 231          (message-keys (with-temp-buffer
 232                          (insert-buffer-substring current-buffer)
 233                          (pgg-decode-armor-region (point-min) (point-max))))
 234          (secret-keys (pgg-gpg-lookup-all-secret-keys))
 235          ;; XXX the user is stuck if they need to use the passphrase for
 236          ;;     any but the first secret key for which the message is
 237          ;;     encrypted.  ideally, we would incrementally give them a
 238          ;;     chance with subsequent keys each time they fail with one.
 239          (key (pgg-gpg-select-matching-key message-keys secret-keys))
 240          (key-owner (and key (pgg-gpg-lookup-key-owner key t)))
 241          (key-id (pgg-gpg-key-id-from-key-owner key-owner))
 242          (pgg-gpg-user-id (or key-id key
 243                               pgg-gpg-user-id pgg-default-user-id))
 244          (passphrase (or passphrase
 245                          (pgg-read-passphrase
 246                           (format (if (pgg-gpg-symmetric-key-p message-keys)
 247                                       "Passphrase for symmetric decryption: "
 248                                     "GnuPG passphrase for %s: ")
 249                                   (or key-owner "??"))
 250                           pgg-gpg-user-id)))
 251          (args '("--batch" "--decrypt")))
 252     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 253     (with-current-buffer pgg-errors-buffer
 254       (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
 255       (goto-char (point-min))
 256       (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t))))
 257
 258 ;;;###autoload
 259 (defun pgg-gpg-symmetric-key-p (message-keys)
 260   "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator."
 261   (let (result)
 262     (dolist (key message-keys result)
 263       (when (and (eq (car key) 3)
 264                  (member '(symmetric-key-algorithm) key))
 265         (setq result key)))))
 266
 267 (defun pgg-gpg-select-matching-key (message-keys secret-keys)
 268   "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS."
 269   (loop for message-key in message-keys
 270         for message-key-id = (and (equal (car message-key) 1)
 271                                   (cdr (assq 'key-identifier
 272                                              (cdr message-key))))
 273         for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt))
 274         when (and key (member key secret-keys)) return key))
 275
 276 (defun pgg-gpg-sign-region (start end &optional cleartext passphrase)
 277   "Make detached signature from text between START and END."
 278   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 279          (passphrase (or passphrase
 280                          (pgg-read-passphrase
 281                           (format "GnuPG passphrase for %s: " pgg-gpg-user-id)
 282                           pgg-gpg-user-id)))
 283          (args
 284           (append (list (if cleartext "--clearsign" "--detach-sign")
 285                         "--armor" "--batch" "--verbose"
 286                         "--local-user" pgg-gpg-user-id)
 287                   (if pgg-text-mode (list "--textmode"))))
 288          (inhibit-read-only t)
 289          buffer-read-only)
 290     (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
 291     (with-current-buffer pgg-errors-buffer
 292       ;; Possibly cache passphrase under, e.g. "jas", for future sign.
 293       (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
 294       ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
 295       (pgg-gpg-possibly-cache-passphrase passphrase))
 296     (pgg-process-when-success)))
 297
 298 (defun pgg-gpg-verify-region (start end &optional signature)
 299   "Verify region between START and END as the detached signature SIGNATURE."
 300   (let ((args '("--batch" "--verify")))
 301     (when (stringp signature)
 302       (setq args (append args (list signature))))
 303     (setq args (append args '("-")))
 304     (pgg-gpg-process-region start end nil pgg-gpg-program args)
 305     (with-current-buffer pgg-errors-buffer
 306       (goto-char (point-min))
 307       (while (re-search-forward "^gpg: \\(.*\\)\n" nil t)
 308         (with-current-buffer pgg-output-buffer
 309           (insert-buffer-substring pgg-errors-buffer
 310                                    (match-beginning 1) (match-end 0)))
 311         (delete-region (match-beginning 0) (match-end 0)))
 312       (goto-char (point-min))
 313       (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t))))
 314
 315 (defun pgg-gpg-insert-key ()
 316   "Insert public key at point."
 317   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 318          (args (list "--batch" "--export" "--armor"
 319                      pgg-gpg-user-id)))
 320     (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args)
 321     (insert-buffer-substring pgg-output-buffer)))
 322
 323 (defun pgg-gpg-snarf-keys-region (start end)
 324   "Add all public keys in region between START and END to the keyring."
 325   (let ((args '("--import" "--batch" "-")) status)
 326     (pgg-gpg-process-region start end nil pgg-gpg-program args)
 327     (set-buffer pgg-errors-buffer)
 328     (goto-char (point-min))
 329     (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t)
 330       (setq status (buffer-substring (match-end 0)
 331                                      (progn (end-of-line)(point)))
 332             status (vconcat (mapcar #'string-to-number (split-string status))))
 333       (erase-buffer)
 334       (insert (format "Imported %d key(s).
 335 \tArmor contains %d key(s) [%d bad, %d old].\n"
 336                       (+ (aref status 2)
 337                          (aref status 10))
 338                       (aref status 0)
 339                       (aref status 1)
 340                       (+ (aref status 4)
 341                          (aref status 11)))
 342               (if (zerop (aref status 9))
 343                   ""
 344                 "\tSecret keys are imported.\n")))
 345     (append-to-buffer pgg-output-buffer (point-min)(point-max))
 346     (pgg-process-when-success)))
 347
 348 (provide 'pgg-gpg)
 349
 350 ;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000
 351 ;;; pgg-gpg.el ends here