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