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 support 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 '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 nil
  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 (defvar pgg-gpg-user-id-alist nil
  62   "An alist mapping from key ID to user ID.")
  63
  64 (defvar pgg-gpg-read-point nil)
  65 (defvar pgg-gpg-output-file-name nil)
  66 (defvar pgg-gpg-pending-status-list nil)
  67 (defvar pgg-gpg-key-id nil)
  68 (defvar pgg-gpg-passphrase nil)
  69 (defvar pgg-gpg-debug nil)
  70
  71 (defun pgg-gpg-start-process (args)
  72   (let* ((output-file-name (pgg-make-temp-file "pgg-output"))
  73          (args
  74           (append (list "--no-tty"
  75                         "--status-fd" "1"
  76                         "--command-fd" "0"
  77                         "--yes" ; overwrite
  78                         "--output" output-file-name)
  79                   (if pgg-gpg-use-agent '("--use-agent"))
  80                   pgg-gpg-extra-args
  81                   args))
  82          (coding-system-for-write 'binary)
  83          (process-connection-type nil)
  84          (orig-mode (default-file-modes))
  85          (buffer (generate-new-buffer " *pgg-gpg*"))
  86          process)
  87     (with-current-buffer buffer
  88       (make-local-variable 'pgg-gpg-read-point)
  89       (setq pgg-gpg-read-point (point-min))
  90       (make-local-variable 'pgg-gpg-output-file-name)
  91       (setq pgg-gpg-output-file-name output-file-name)
  92       (make-local-variable 'pgg-gpg-pending-status-list)
  93       (setq pgg-gpg-pending-status-list nil)
  94       (make-local-variable 'pgg-gpg-key-id)
  95       (setq pgg-gpg-key-id nil)
  96       (make-local-variable 'pgg-gpg-passphrase)
  97       (setq pgg-gpg-passphrase nil))
  98     (unwind-protect
  99         (progn
 100           (set-default-file-modes 448)
 101           (setq process
 102                 (apply #'start-process "pgg-gpg" buffer pgg-gpg-program args)))
 103       (set-default-file-modes orig-mode))
 104     (set-process-filter process #'pgg-gpg-process-filter)
 105     (set-process-sentinel process #'pgg-gpg-process-sentinel)
 106     process))
 107
 108 (defun pgg-gpg-process-filter (process input)
 109   (save-excursion
 110     (if pgg-gpg-debug
 111         (save-excursion
 112           (set-buffer (get-buffer-create  " *pgg-gpg-debug*"))
 113           (goto-char (point-max))
 114           (insert input)))
 115     (set-buffer (process-buffer process))
 116     (goto-char (point-max))
 117     (insert input)
 118     (goto-char pgg-gpg-read-point)
 119     (beginning-of-line)
 120     (while (looking-at ".*\n")          ;the input line is finished
 121       (save-excursion
 122         (if (looking-at "\\[GNUPG:] \\([A-Z_]+\\)\\>.*")
 123             (let* ((status (match-string 1))
 124                    (symbol (intern-soft (concat "pgg-gpg-status-" status)))
 125                    (entry (member status pgg-gpg-pending-status-list)))
 126               (if entry
 127                   (setq pgg-gpg-pending-status-list
 128                         (delq (car entry)
 129                               pgg-gpg-pending-status-list)))
 130               (if (and symbol
 131                        (fboundp symbol))
 132                   (funcall symbol process (buffer-substring (match-beginning 1)
 133                                                             (match-end 0)))))))
 134       (forward-line))
 135     (setq pgg-gpg-read-point (point))))
 136
 137 (defun pgg-gpg-process-sentinel (process status)
 138   (set-process-filter process nil)
 139   (save-excursion
 140     ;; Copy the contents of process-buffer to pgg-errors-buffer.
 141     (set-buffer (get-buffer-create pgg-errors-buffer))
 142     (buffer-disable-undo)
 143     (erase-buffer)
 144     (when (buffer-live-p (process-buffer process))
 145       (insert-buffer-substring (process-buffer process))
 146       (goto-char (point-min))
 147       (delete-matching-lines "^\\[GNUPG:] ")
 148       (goto-char (point-min))
 149       (while (re-search-forward "^gpg: " nil t)
 150         (replace-match "")))
 151     ;; Read the contents of the output file to pgg-output-buffer.
 152     (set-buffer (get-buffer-create pgg-output-buffer))
 153     (buffer-disable-undo)
 154     (erase-buffer)
 155     (if (and (equal status "finished\n")
 156              (buffer-live-p (process-buffer process)))
 157         (let ((output-file-name (with-current-buffer (process-buffer process)
 158                                   pgg-gpg-output-file-name)))
 159           (when (file-exists-p output-file-name)
 160             (let ((coding-system-for-read (if pgg-text-mode
 161                                               'raw-text
 162                                             'binary)))
 163               (insert-file-contents output-file-name))
 164             (delete-file output-file-name))))))
 165
 166 (defun pgg-gpg-wait-for-status (process status-list)
 167   (with-current-buffer (process-buffer process)
 168     (setq pgg-gpg-pending-status-list status-list)
 169     (while (and (eq (process-status process) 'run)
 170                 pgg-gpg-pending-status-list)
 171       (accept-process-output process 1))))
 172
 173 (defun pgg-gpg-wait-for-completion (process &optional status-list)
 174   (process-send-eof process)
 175   (while (eq (process-status process) 'run)
 176     (sit-for 0.1))
 177   (save-excursion
 178     (set-buffer (process-buffer process))
 179     (setq status-list (copy-sequence status-list))
 180     (let ((pointer status-list))
 181       (while pointer
 182         (goto-char (point-min))
 183         (unless (re-search-forward
 184                  (concat "^\\[GNUPG:] " (car pointer) "\\>")
 185                  nil t)
 186           (setq status-list (delq (car pointer) status-list)))
 187         (setq pointer (cdr pointer))))
 188     (kill-buffer (process-buffer process))
 189     status-list))
 190
 191 (defun pgg-gpg-status-USERID_HINT (process line)
 192   (if (string-match "\\`USERID_HINT \\([^ ]+\\) \\(.*\\)" line)
 193       (let* ((key-id (match-string 1 line))
 194              (user-id (match-string 2 line))
 195              (entry (assoc key-id pgg-gpg-user-id-alist)))
 196         (if entry
 197             (setcdr entry user-id)
 198           (setq pgg-gpg-user-id-alist (cons (cons key-id user-id)
 199                                             pgg-gpg-user-id-alist))))))
 200
 201 (defun pgg-gpg-status-NEED_PASSPHRASE (process line)
 202   (if (string-match "\\`NEED_PASSPHRASE \\([^ ]+\\)" line)
 203       (setq pgg-gpg-key-id (match-string 1 line))))
 204
 205 (defun pgg-gpg-status-NEED_PASSPHRASE_SYM (process line)
 206   (setq pgg-gpg-key-id 'SYM))
 207
 208 (defun pgg-gpg-status-NEED_PASSPHRASE_PIN (process line)
 209   (setq pgg-gpg-key-id 'PIN))
 210
 211 (defun pgg-gpg-status-GET_HIDDEN (process line)
 212   (let ((entry (assoc pgg-gpg-key-id pgg-gpg-user-id-alist)))
 213     (if (setq pgg-gpg-passphrase
 214               (if (eq pgg-gpg-key-id 'SYM)
 215                   (pgg-read-passphrase
 216                    "GnuPG passphrase for symmetric encryption: ")
 217                 (pgg-read-passphrase
 218                  (format "GnuPG passphrase for %s: "
 219                          (if entry
 220                              (cdr entry)
 221                            pgg-gpg-key-id))
 222                  (if (eq pgg-gpg-key-id 'PIN)
 223                      "PIN"
 224                    pgg-gpg-key-id))))
 225         (process-send-string process (concat pgg-gpg-passphrase "\n")))))
 226
 227 (defun pgg-gpg-status-GOOD_PASSPHRASE (process line)
 228   (when (and pgg-gpg-passphrase
 229              (stringp pgg-gpg-key-id))
 230     (pgg-add-passphrase-to-cache pgg-gpg-key-id pgg-gpg-passphrase)
 231     (setq pgg-gpg-passphrase nil)))
 232
 233 (defun pgg-gpg-status-BAD_PASSPHRASE (process line)
 234   (when pgg-gpg-passphrase
 235     (fillarray pgg-gpg-passphrase 0)
 236     (setq pgg-gpg-passphrase nil)))
 237
 238 (defun pgg-gpg-lookup-key (string &optional type)
 239   "Search keys associated with STRING."
 240   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 241                     (if type "--list-secret-keys" "--list-keys")
 242                     string)))
 243     (with-temp-buffer
 244       (apply #'call-process pgg-gpg-program nil t nil args)
 245       (goto-char (point-min))
 246       (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)"
 247                              nil t)
 248           (substring (match-string 2) 8)))))
 249
 250 (defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase)
 251   "Encrypt the current region between START and END.
 252
 253 If optional argument SIGN is non-nil, do a combined sign and encrypt."
 254   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 255          (args
 256           (append
 257            '("--armor" "--always-trust" "--encrypt")
 258            (if pgg-text-mode '("--textmode"))
 259            (if sign (list "--sign" "--local-user" pgg-gpg-user-id))
 260            (if recipients
 261                (apply #'nconc
 262                       (mapcar (lambda (rcpt)
 263                                 (list pgg-gpg-recipient-argument rcpt))
 264                               (append recipients
 265                                       (if pgg-encrypt-for-me
 266                                           (list pgg-gpg-user-id))))))))
 267          (process (pgg-gpg-start-process args)))
 268     (if (and sign (not pgg-gpg-use-agent))
 269         (pgg-gpg-wait-for-status process '("GOOD_PASSPHRASE")))
 270     (process-send-region process start end)
 271     (pgg-gpg-wait-for-completion process '("SIG_CREATED" "END_ENCRYPTION"))))
 272
 273 (defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase)
 274   "Encrypt the current region between START and END with symmetric cipher."
 275   (let* ((args
 276           (append '("--armor" "--symmetric")
 277                   (if pgg-text-mode '("--textmode"))))
 278          (process (pgg-gpg-start-process args)))
 279     (pgg-gpg-wait-for-status process '("BEGIN_ENCRYPTION"))
 280     (process-send-region process start end)
 281     (pgg-gpg-wait-for-completion process '("END_ENCRYPTION"))))
 282
 283 (defun pgg-gpg-decrypt-region (start end &optional passphrase)
 284   "Decrypt the current region between START and END."
 285   (let* ((args '("--decrypt"))
 286          (process (pgg-gpg-start-process args)))
 287     (process-send-region process start end)
 288     (pgg-gpg-wait-for-status process '("BEGIN_DECRYPTION"))
 289     (pgg-gpg-wait-for-completion process '("GOODSIG" "DECRYPTION_OKAY"))))
 290
 291 (defun pgg-gpg-sign-region (start end &optional cleartext passphrase)
 292   "Make detached signature from text between START and END."
 293   (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
 294          (args
 295           (append (list (if cleartext "--clearsign" "--detach-sign")
 296                         "--armor" "--verbose"
 297                         "--local-user" pgg-gpg-user-id)
 298                   (if pgg-text-mode '("--textmode"))))
 299          (process (pgg-gpg-start-process args)))
 300     (unless pgg-gpg-use-agent
 301       (pgg-gpg-wait-for-status process '("GOOD_PASSPHRASE")))
 302     (process-send-region process start end)
 303     (pgg-gpg-wait-for-completion process '("SIG_CREATED"))))
 304
 305 (defun pgg-gpg-verify-region (start end &optional signature)
 306   "Verify region between START and END as the detached signature SIGNATURE."
 307   (let ((args '("--verify"))
 308         process)
 309     (when (stringp signature)
 310       (setq args (append args (list signature))))
 311     (setq process (pgg-gpg-start-process (append args '("-"))))
 312     (process-send-region process start end)
 313     (pgg-gpg-wait-for-completion process '("GOODSIG"))))
 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 "--export" "--armor"
 319                      pgg-gpg-user-id))
 320          (process (pgg-gpg-start-process args)))
 321     (pgg-gpg-wait-for-completion process)
 322     (insert-buffer-substring pgg-output-buffer)))
 323
 324 (defun pgg-gpg-snarf-keys-region (start end)
 325   "Add all public keys in region between START and END to the keyring."
 326   (let* ((args '("--import" "-"))
 327          (process (pgg-gpg-start-process args))
 328          status)
 329     (process-send-region process start end)
 330     (pgg-gpg-wait-for-completion process '("IMPORT_RES"))))
 331
 332 (provide 'pgg-gpg)
 333
 334 ;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000
 335 ;;; pgg-gpg.el ends here