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