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