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