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 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 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 183The value may be just the bare key id, or it may be a combination of the 184user name associated with the key and the key id, with the key id enclosed 185in \"<...>\" angle brackets. 186 187Optional 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 211If optional argument SIGN is non-nil, do a combined sign and encrypt. 212 213If optional PASSPHRASE is not specified, it will be obtained from the 214passphrase 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 246If optional PASSPHRASE is not specified, it will be obtained from the 247passphrase 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 261If optional PASSPHRASE is not specified, it will be obtained from the 262passphrase 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 410