lisp/obsolete/pgg-gpg.el

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