--- /dev/null
+;;; gpg-ring.el --- Major mode for editing GnuPG key rings.
+
+;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart
+
+;; Author: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
+;; Maintainer: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
+;; Keywords: crypto
+;; Created: 2000-04-28
+
+;; $Id: gpg-ring.el,v 1.1.2.1 2000-10-31 22:56:40 yamaoka Exp $
+
+;; This file is NOT (yet?) part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+
+\f
+;;;; Code:
+
+(require 'gpg)
+(eval-when-compile
+ (require 'cl))
+
+;;;; Customization:
+
+;;; Customization: Groups:
+
+(defgroup gpg-ring nil
+ "GNU Privacy Guard user interface."
+ :tag "GnuPG user interface"
+ :group 'gpg)
+
+;;; Customization: Variables:
+
+(defface gpg-ring-key-invalid-face
+ '((((class color))
+ (:foreground "yellow" :background "red"))
+ (t (:bold t :italic t :underline t)))
+ "Face for strings indicating key invalidity."
+ :group 'gpg-ring)
+
+(defface gpg-ring-uncertain-validity-face
+ '((((class color)) (:foreground "red"))
+ (t (:bold t)))
+ "Face for strings indicating uncertain validity."
+ :group 'gpg-ring)
+
+(defface gpg-ring-full-validity-face
+ '((((class color)) (:foreground "ForestGreen" :bold t))
+ (t (:bold t)))
+ "Face for strings indicating key invalidity."
+ :group 'gpg-ring)
+
+(defvar gpg-ring-mode-hook nil
+ "Normal hook run when entering GnuPG ring mode.")
+
+;;; Constants
+
+(defconst gpg-ring-algo-alist
+ '((rsa . "RSA")
+ (rsa-encrypt-only . "RSA-E")
+ (rsa-sign-only . "RSA-S")
+ (elgamal-encrypt-only . "ELG-E")
+ (dsa . "DSA")
+ (elgamal . "ELG-E"))
+ "Alist mapping algorithm IDs to algorithm abbreviations.")
+
+(defconst gpg-ring-trust-alist
+ '((not-known "???" gpg-ring-uncertain-validity-face)
+ (disabled "DIS" gpg-ring-key-invalid-face)
+ (revoked "REV" gpg-ring-key-invalid-face)
+ (expired "EXP" gpg-ring-key-invalid-face)
+ (trust-undefined "QES" gpg-ring-uncertain-validity-face)
+ (trust-none "NON" gpg-ring-uncertain-validity-face)
+ (trust-marginal "MAR")
+ (trust-full "FUL" gpg-ring-full-validity-face)
+ (trust-ultimate "ULT" gpg-ring-full-validity-face))
+ "Alist mapping trust IDs to trust abbrevs and faces.")
+
+(defvar gpg-ring-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map t)
+ map)
+ "Keymap for `gpg-ring-mode'.")
+
+(define-key gpg-ring-mode-map "0" 'delete-window)
+(define-key gpg-ring-mode-map "1" 'delete-other-windows)
+(define-key gpg-ring-mode-map "M" 'gpg-ring-mark-process-all)
+(define-key gpg-ring-mode-map "U" 'gpg-ring-unmark-all)
+(define-key gpg-ring-mode-map "a" 'gpg-ring-toggle-show-unusable)
+(define-key gpg-ring-mode-map "d" 'gpg-ring-mark-delete)
+(define-key gpg-ring-mode-map "f" 'gpg-ring-update-key)
+(define-key gpg-ring-mode-map "g" 'gpg-ring-update)
+(define-key gpg-ring-mode-map "i" 'gpg-ring-show-key)
+(define-key gpg-ring-mode-map "l" 'gpg-ring-toggle-show-all-ids)
+(define-key gpg-ring-mode-map "m" 'gpg-ring-mark-process)
+(define-key gpg-ring-mode-map "n" 'gpg-ring-next-record)
+(define-key gpg-ring-mode-map "p" 'gpg-ring-previous-record)
+(define-key gpg-ring-mode-map "q" 'gpg-ring-quit)
+(define-key gpg-ring-mode-map "u" 'gpg-ring-unmark)
+(define-key gpg-ring-mode-map "x" 'gpg-ring-extract-keys)
+(define-key gpg-ring-mode-map "X" 'gpg-ring-extract-keys-to-kill)
+
+(define-key gpg-ring-mode-map "\C-c\C-c" 'gpg-ring-action)
+
+;;; Internal functions:
+
+(defvar gpg-ring-key-list
+ nil
+ "List of keys in the key list buffer.")
+(make-variable-buffer-local 'gpg-ring-key-list)
+
+(defvar gpg-ring-update-funcs
+ nil
+ "List of functions called to obtain the key list.")
+(make-variable-buffer-local 'gpg-ring-update-funcs)
+
+(defvar gpg-ring-show-unusable
+ nil
+ "If t, show expired, revoked and disabled keys, too.")
+(make-variable-buffer-local 'gpg-ring-show-unusable)
+
+(defvar gpg-ring-show-all-ids
+ nil
+ "If t, show all user IDs. If nil, show only the primary user ID.")
+(make-variable-buffer-local 'gpg-ring-show-all-ids)
+
+(defvar gpg-ring-marks-alist
+ nil
+ "Alist of (UNIQUE-ID MARK KEY).
+UNIQUE-ID is a unique key ID from GnuPG. MARK is either `?D'
+(marked for deletion), or `?*' (marked for processing).")
+(make-variable-buffer-local 'gpg-ring-marks-alist)
+
+(defvar gpg-ring-action
+ nil
+ "Function to call when `gpg-ring-action' is invoked.
+A list of the keys which are marked for processing is passed as argument.")
+(make-variable-buffer-local 'gpg-ring-action)
+
+(defun gpg-ring-mode ()
+ "Mode for editing GnuPG key rings.
+\\{gpg-ring-mode-map}
+Turning on gpg-ring-mode runs `gpg-ring-mode-hook'."
+ (interactive)
+ (kill-all-local-variables)
+ (buffer-disable-undo)
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (use-local-map gpg-ring-mode-map)
+ (setq mode-name "Key Ring")
+ (setq major-mode 'gpg-ring-mode)
+ (run-hooks 'gpg-ring-mode-hook))
+
+
+(defmacro gpg-ring-record-start (&optional pos)
+ "Return buffer position of start of record containing POS."
+ `(get-text-property (or ,pos (point)) 'gpg-record-start))
+
+(defun gpg-ring-current-key (&optional pos)
+ "Return GnuPG key at POS, or at point if ommitted."
+ (or (get-text-property (or pos (point)) 'gpg-key)
+ (error "No record on current line")))
+
+(defun gpg-ring-goto-record (pos)
+ "Go to record starting at POS.
+Position point after the marks at the beginning of a record."
+ (goto-char pos)
+ (forward-char 2))
+
+(defun gpg-ring-next-record ()
+ "Advances point to the start of the next record."
+ (interactive)
+ (let ((start (next-single-property-change
+ (point) 'gpg-record-start nil (point-max))))
+ ;; Don't advance to the last line of the buffer.
+ (when (/= start (point-max))
+ (gpg-ring-goto-record start))))
+
+(defun gpg-ring-previous-record ()
+ "Advances point to the start of the previous record."
+ (interactive)
+ ;; The last line of the buffer doesn't contain a record.
+ (let ((start (gpg-ring-record-start)))
+ (if start
+ (gpg-ring-goto-record (previous-single-property-change
+ start 'gpg-record-start nil (point-min)))
+ (gpg-ring-goto-record
+ (gpg-ring-record-start (1- (point-max)))))))
+
+(defun gpg-ring-set-mark (&optional pos mark)
+ "Set MARK on record at POS, or at point if POS is omitted.
+If MARK is omitted, clear it."
+ (save-excursion
+ (let* ((start (gpg-ring-record-start pos))
+ (key (gpg-ring-current-key start))
+ (id (gpg-key-unique-id key))
+ (entry (assoc id gpg-ring-marks-alist))
+ buffer-read-only)
+ (goto-char start)
+ ;; Replace the mark character.
+ (subst-char-in-region (point) (1+ (point)) (char-after)
+ (or mark ? ))
+ ;; Store the mark in alist.
+ (if entry
+ (setcdr entry (if mark (list mark key)))
+ (when mark
+ (push (list id mark key) gpg-ring-marks-alist))))))
+
+(defun gpg-ring-marked-keys (&optional only-marked mark)
+ "Return list of key specs which have MARK.
+If no marks are present and ONLY-MARKED is not nil, return singleton
+list with key of the current record. If MARK is omitted, `?*' is
+used."
+ (let ((the-marker (or mark ?*))
+ (marks gpg-ring-marks-alist)
+ key-list)
+ (while marks
+ (let ((mark (pop marks)))
+ ;; If this entry has got the right mark ...
+ (when (equal (nth 1 mark) the-marker)
+ ;; ... rember the key spec.
+ (push (nth 2 mark) key-list))))
+ (or key-list (if (not only-marked) (list (gpg-ring-current-key))))))
+
+(defun gpg-ring-mark-process ()
+ "Mark record at point for processing."
+ (interactive)
+ (gpg-ring-set-mark nil ?*)
+ (gpg-ring-next-record))
+
+(defun gpg-ring-mark-delete ()
+ "Mark record at point for processing."
+ (interactive)
+ (gpg-ring-set-mark nil ?D)
+ (gpg-ring-next-record))
+
+(defun gpg-ring-unmark ()
+ "Mark record at point for processing."
+ (interactive)
+ (gpg-ring-set-mark)
+ (gpg-ring-next-record))
+
+(defun gpg-ring-mark-process-all ()
+ "Put process mark on all records."
+ (interactive)
+ (setq gpg-ring-marks-alist
+ (mapcar (lambda (key)
+ (list (gpg-key-unique-id key) ?* key))
+ gpg-ring-key-list))
+ (gpg-ring-regenerate))
+
+(defun gpg-ring-unmark-all ()
+ "Remove all record marks."
+ (interactive)
+ (setq gpg-ring-marks-alist nil)
+ (gpg-ring-regenerate))
+
+(defun gpg-ring-toggle-show-unusable ()
+ "Toggle value if `gpg-ring-show-unusable'."
+ (interactive)
+ (setq gpg-ring-show-unusable (not gpg-ring-show-unusable))
+ (gpg-ring-regenerate))
+
+(defun gpg-ring-toggle-show-all-ids ()
+ "Toggle value of `gpg-ring-show-all-ids'."
+ (interactive)
+ (setq gpg-ring-show-all-ids (not gpg-ring-show-all-ids))
+ (gpg-ring-regenerate))
+
+(defvar gpg-ring-output-buffer-name "*GnuPG Output*"
+ "Name buffer to which output from GnuPG is sent.")
+
+(defmacro gpg-ring-with-output-buffer (&rest body)
+ "Erase GnuPG output buffer, evaluate BODY in it, and display it."
+ `(with-current-buffer (get-buffer-create gpg-ring-output-buffer-name)
+ (erase-buffer)
+ (setq truncate-lines t)
+ ,@body
+ (goto-char (point-min))
+ (display-buffer gpg-ring-output-buffer-name)))
+
+(defun gpg-ring-quit ()
+ "Bury key list buffer and kill GnuPG output buffer."
+ (interactive)
+ (let ((output (get-buffer gpg-ring-output-buffer-name)))
+ (when output
+ (kill-buffer output)))
+ (when (eq 'gpg-ring-mode major-mode)
+ (bury-buffer)))
+
+(defun gpg-ring-show-key ()
+ "Show information for current key."
+ (interactive)
+ (let ((keys (gpg-ring-marked-keys)))
+ (gpg-ring-with-output-buffer
+ (gpg-key-insert-information (gpg-key-unique-id-list keys)))))
+
+(defun gpg-ring-extract-keys ()
+ "Export currently selected public keys in ASCII armor."
+ (interactive)
+ (let ((keys (gpg-ring-marked-keys)))
+ (gpg-ring-with-output-buffer
+ (gpg-key-insert-public-key (gpg-key-unique-id-list keys)))))
+
+(defun gpg-ring-extract-keys-to-kill ()
+ "Export currently selected public keys in ASCII armor to kill ring."
+ (interactive)
+ (let ((keys (gpg-ring-marked-keys)))
+ (with-temp-buffer
+ (gpg-key-insert-public-key (gpg-key-unique-id-list keys))
+ (copy-region-as-kill (point-min) (point-max)))))
+
+(defun gpg-ring-update-key ()
+ "Fetch key information from key server."
+ (interactive)
+ (let ((keys (gpg-ring-marked-keys)))
+ (gpg-ring-with-output-buffer
+ (gpg-key-retrieve (gpg-key-unique-id-list keys)))))
+
+(defun gpg-ring-insert-key-stat (key)
+ (let* ((validity (gpg-key-validity key))
+ (validity-entry (assq validity gpg-ring-trust-alist))
+ (trust (gpg-key-trust key))
+ (trust-entry (assq trust gpg-ring-trust-alist)))
+ ;; Insert abbrev for key status.
+ (let ((start (point)))
+ (insert (nth 1 validity-entry))
+ ;; Change face if necessary.
+ (when (nth 2 validity-entry)
+ (add-text-properties start (point)
+ (list 'face (nth 2 validity-entry)))))
+ ;; Trust, key ID, length, algorithm, creation date.
+ (insert (format "/%s %-8s/%4d/%-5s created %s"
+ (nth 1 trust-entry)
+ (gpg-short-key-id key)
+ (gpg-key-length key)
+ (cdr (assq (gpg-key-algorithm key) gpg-ring-algo-alist))
+ (gpg-key-creation-date key)))
+ ;; Expire date.
+ (when (gpg-key-expire-date key)
+ (insert ", ")
+ (let ((start (point))
+ (expired (eq 'expired validity))
+ (notice (concat )))
+ (insert (if expired "EXPIRED" "expires")
+ " " (gpg-key-expire-date key))
+ (when expired
+ (add-text-properties start (point)
+ '(face gpg-ring-key-invalid-face)))))))
+
+(defun gpg-ring-insert-key (key &optional mark)
+ "Inserts description for KEY into current buffer before point."
+ (let ((start (point)))
+ (insert (if mark mark " ")
+ " " (gpg-key-primary-user-id key) "\n"
+ " ")
+ (gpg-ring-insert-key-stat key)
+ (insert "\n")
+ (when gpg-ring-show-all-ids
+ (let ((uids (gpg-key-user-ids key)))
+ (while uids
+ (insert " ID " (pop uids) "\n"))))
+ (add-text-properties start (point)
+ (list 'gpg-record-start start
+ 'gpg-key key))))
+
+(defun gpg-ring-regenerate ()
+ "Regenerate the key list buffer from stored data."
+ (interactive)
+ (let* ((key-list gpg-ring-key-list)
+ ;; Record position of point.
+ (old-record (if (eobp) ; No record on last line.
+ nil
+ (gpg-key-unique-id (gpg-ring-current-key))))
+ (old-pos (if old-record (- (point) (gpg-ring-record-start))))
+ found new-pos new-pos-offset buffer-read-only new-marks)
+ ;; Replace buffer contents with new data.
+ (erase-buffer)
+ (while key-list
+ (let* ((key (pop key-list))
+ (id (gpg-key-unique-id key))
+ (mark (assoc id gpg-ring-marks-alist)))
+ (when (or gpg-ring-show-unusable
+ (not (memq (gpg-key-validity key)
+ '(disabled revoked expired))))
+ ;; Check if point was in this record.
+ (when (and old-record
+ (string-equal old-record id))
+ (setq new-pos (point))
+ (setq new-pos-offset (+ new-pos old-pos)))
+ ;; Check if this record was marked.
+ (if (nth 1 mark)
+ (progn
+ (push mark new-marks)
+ (gpg-ring-insert-key key (nth 1 mark)))
+ (gpg-ring-insert-key key)))))
+ ;; Replace mark alist with the new one (which does not contain
+ ;; marks for records which vanished during this update).
+ (setq gpg-ring-marks-alist new-marks)
+ ;; Restore point.
+ (if (not old-record)
+ ;; We were at the end of the buffer before.
+ (goto-char (point-max))
+ (if new-pos
+ (if (and (< new-pos-offset (point-max))
+ (equal old-record (gpg-key-unique-id
+ (gpg-ring-current-key new-pos-offset))))
+ ;; Record is there, with offset.
+ (goto-char new-pos-offset)
+ ;; Record is there, but not offset.
+ (goto-char new-pos))
+ ;; Record is not there.
+ (goto-char (point-min))))))
+
+(defun gpg-ring-update ()
+ "Update the key list buffer with new data."
+ (interactive)
+ (let ((funcs gpg-ring-update-funcs)
+ old)
+ ;; Merge the sorted lists obtained by calling elements of
+ ;; `gpg-ring-update-funcs'.
+ (while funcs
+ (let ((additional (funcall (pop funcs)))
+ new)
+ (while (and additional old)
+ (if (gpg-key-lessp (car additional) (car old))
+ (push (pop additional) new)
+ (if (gpg-key-lessp (car old) (car additional))
+ (push (pop old) new)
+ ;; Keys are perhaps equal. Always Add old key.
+ (push (pop old) new)
+ ;; If new key is equal, drop it, otherwise add it as well.
+ (if (string-equal (gpg-key-unique-id (car old))
+ (gpg-key-unique-id (car additional)))
+ (pop additional)
+ (push (pop additional) new)))))
+ ;; Store new list as old one for next round.
+ (setq old (nconc (nreverse new) old additional))))
+ ;; Store the list in the buffer.
+ (setq gpg-ring-key-list old))
+ (gpg-ring-regenerate))
+
+(defun gpg-ring-action ()
+ "Perform the action associated with this buffer."
+ (interactive)
+ (if gpg-ring-action
+ (funcall gpg-ring-action (gpg-ring-marked-keys))
+ (error "No action for this buffer specified")))
+
+;;;###autoload
+(defun gpg-ring-keys (&optional key-list-funcs action)
+ (interactive)
+ (let ((buffer (get-buffer-create "*GnuPG Key List*")))
+ (with-current-buffer buffer
+ (gpg-ring-mode)
+ (setq gpg-ring-action action)
+ (setq gpg-ring-update-funcs key-list-funcs key-list-funcs)
+ (gpg-ring-update)
+ (goto-char (point-min)))
+ (switch-to-buffer buffer)))
+
+;;;###autoload
+(defun gpg-ring-public (key-spec)
+ "List public keys matching keys KEY-SPEC."
+ (interactive "sList public keys containing: ")
+ (gpg-ring-keys `((lambda () (gpg-key-list-keys ,key-spec)))))
+
+(provide 'gpg-ring)
+
+;;; gpg-ring.el ends here
\ No newline at end of file
--- /dev/null
+;;; gpg.el --- Interface to GNU Privacy Guard
+
+;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart
+
+;; Author: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
+;; Maintainer: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
+;; Keywords: crypto
+;; Created: 2000-04-15
+
+;; $Id: gpg.el,v 1.1.2.1 2000-10-31 22:56:40 yamaoka Exp $
+
+;; This file is NOT (yet?) part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA
+;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA
+;;
+;; This code is not well-tested. BE CAREFUL!
+;;
+;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA
+;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA
+
+;; Implemented features which can be tested:
+;;
+;; * Customization for all flavors of PGP is possible.
+;; * The main operations (verify, decrypt, sign, encrypt, sign &
+;; encrypt) are implemented.
+;; * Gero Treuner's gpg-2comp script is supported, and data which is is
+;; compatible with PGP 2.6.3 is generated.
+
+;; Customizing external programs
+;; =============================
+
+;; The customization are very similar to those of others programs,
+;; only the C-ish "%" constructs have been replaced by more Lisp-like
+;; syntax.
+;;
+;; First, you have to adjust the default executable paths
+;; (`gpg-command-default-alist', customization group `gpg-options',
+;; "Controlling GnuPG invocation."). After that, you should
+;; change the configuration options which control how specific
+;; command line flags are built (`gpg-command-flag-sign-with-key',
+;; (`gpg-command-flag-recipient'). The elements of these lists are
+;; concatenated without spaces, and a new argument is only started
+;; where indicated. The `gpg-command-flag-recipient' list is special:
+;; it consists of two parts, the first one remains at the beginning
+;; of the argument, the second one is repeated for each recipient.
+;; Finally, `gpg-command-passphrase-env' has to be changed if there's
+;; no command line flag to force the external program to read the data
+;; from standard input before the message.
+;;
+;; In customization group `gpg-commands', "Controlling GnuPG
+;; invocation.", you have to supply the actual syntax for external
+;; program calls. Each variable consists of a pair of a program
+;; specification (if a Lisp symbol is given here, it is translated
+;; via `gpg-command-default-alist') and a list of program arguments
+;; with placeholders. Please read the documentation of each variable
+;; before making your adjustments and try to match the given
+;; requirements as closely as possible!
+;;
+;; The `gpg-commands-key' group, "GnuPG Key Management Commands.",
+;; specifies key management commands. The syntax of these variables
+;; is like those in the `gpg-commands' group. Note that the output
+;; format of some of these external programs has to match very close
+;; that of GnuPG. Additional tools (Thomas Roessler's "pgpring.c")
+;; are available if your favorite implementation of OpenPGP cannot
+;; output the this format.
+
+;; Security considerations
+;; =======================
+
+;; On a typical multiuser UNIX system, the memory image of the
+;; Emacs process is not locked, therefore it can be swapped to disk
+;; at any time. As a result, the passphrase might show up in the
+;; swap space (even if you don't use the passphrase cache, i.e. if
+;; `gpg-passphrase-timeout' is 0). If someone is able to run `gdb' or
+;; another debugger on your Emacs process, he might be able to recover
+;; the passphrase as well. Unfortunately, nothing can be done in
+;; order to prevent this at the moment.
+;;
+;; BE CAREFUL: If you use the passphrase cache feature, the passphrase
+;; is stored in the variable `gpg-passphrase' -- and it is NOT
+;; encrypted in any way. (This is a conceptual problem because the
+;; nature of the passphrase cache requires that Emacs is able to
+;; decrypt automatically, so only a very weak protection could be
+;; applied anyway.)
+;;
+;; In addition, if you use an unpatched Emacs 20 (and earlier
+;; versions), passwords show up in the output of the `view-lossage'
+;; function (bound to `C-h l' by default).
+
+\f
+;;;; Code:
+
+(require 'timer)
+(eval-when-compile
+ (require 'cl))
+
+;;;; Customization:
+
+;;; Customization: Groups:
+
+(defgroup gpg nil
+ "GNU Privacy Guard interface."
+ :tag "GnuPG"
+ :group 'processes)
+
+(defgroup gpg-options nil
+ "Controlling GnuPG invocation."
+ :tag "GnuPG Options"
+ :group 'gpg)
+
+(defgroup gpg-commands nil
+ "Primary GnuPG Operations."
+ :tag "GnuPG Commands"
+ :group 'gpg)
+
+(defgroup gpg-commands-key nil
+ "Commands for GnuPG key management."
+ :tag "GnuPG Key Commands"
+ :group 'gpg-commands)
+
+;;; Customization: Widgets:
+
+(define-widget 'gpg-command-alist 'alist
+ "An association list for GnuPG command names."
+ :key-type '(symbol :tag "Abbreviation")
+ :value-type '(string :tag "Program name")
+ :convert-widget 'widget-alist-convert-widget
+ :tag "Alist")
+
+(define-widget 'gpg-command-program 'choice
+ "Widget for entering the name of a program (mostly the GnuPG binary)."
+ :tag "Program"
+ :args '((const :tag "Default GnuPG program."
+ :value gpg)
+ (const :tag "GnuPG compatibility wrapper."
+ :value gpg-2comp)
+ (const :tag "Disabled"
+ :value nil)
+ (string :tag "Custom program" :format "%v")))
+
+(define-widget 'gpg-command-sign-options 'cons
+ "Widget for entering signing options."
+ :args '(gpg-command-program
+ (repeat
+ :tag "Arguments"
+ (choice
+ :format "%[Type%] %v"
+ (const :tag "Insert armor option here if necessary."
+ :value armor)
+ (const :tag "Insert text mode option here if necessary."
+ :value textmode)
+ (const :tag "Insert the sign with key option here if necessary."
+ :value sign-with-key)
+ (string :format "%v")))))
+
+(define-widget 'gpg-command-key-options 'cons
+ "Widget for entering key command options."
+ :args '(gpg-command-program
+ (repeat
+ :tag "Arguments"
+ (choice
+ :format "%[Type%] %v"
+ (const :tag "Insert key ID here."
+ :value key-id)
+ (string :format "%v")))))
+
+;;; Customization: Variables:
+
+;;; Customization: Variables: Paths and Flags:
+
+(defcustom gpg-passphrase-timeout
+ 0
+ "Timeout (in seconds) for the passphrase cache.
+The passphrase cache is cleared after is hasn't been used for this
+many seconds. The values 0 means that the passphrase is not cached at
+all."
+ :tag "Passphrase Timeout"
+ :type 'number
+ :group 'gpg-options)
+
+(defcustom gpg-default-key-id
+ nil
+ "Default key/user ID used for signatures."
+ :tag "Default Key ID"
+ :type '(choice
+ (const :tag "Use GnuPG default." :value nil)
+ (string))
+ :group 'gpg-options)
+
+(defcustom gpg-temp-directory
+ (expand-file-name "~/tmp")
+ "Directory for temporary files.
+If you are running Emacs 20, this directory must have mode 0700."
+ :tag "Temp directory"
+ :type 'string
+ :group 'gpg-options)
+
+(defcustom gpg-command-default-alist
+ '((gpg . "gpg")
+ (gpg-2comp . "gpg-2comp"))
+ "Default paths for some GnuPG-related programs.
+Modify this variable if you have to change the paths to the
+executables required by the GnuPG interface. You can enter \"gpg\"
+for `gpg-2comp' if you don't have this script, but you'll lose PGP
+2.6.x compatibility."
+ :tag "GnuPG programs"
+ :type 'gpg-command-alist
+ :group 'gpg-options)
+
+(defcustom gpg-command-flag-textmode "--textmode"
+ "The flag to indicate canonical text mode to GnuPG."
+ :tag "Text mode flag"
+ :type 'string
+ :group 'gpg-options)
+
+(defcustom gpg-command-flag-armor "--armor"
+ "The flag to request ASCII-armoring output from GnuPG."
+ :tag "Armor flag"
+ :type 'string
+ :group 'gpg-options)
+
+(defcustom gpg-command-flag-sign-with-key '("--local-user=" sign-with-key)
+ "String to include to specify the signing key ID.
+The elements are concatenated (without spaces) to form a command line
+option."
+ :tag "Sign with key flag"
+ :type '(repeat :tag "Argument parts"
+ (choice :format "%[Type%] %v"
+ (const :tag "Start next argument." :value next-argument)
+ (const :tag "Insert signing key ID here." :value sign-with-key)
+ (string)))
+ :group 'gpg-options)
+
+(defcustom gpg-command-flag-recipient
+ '(nil . ("-r" next-argument recipient next-argument))
+ "Format of a recipient specification.
+The elements are concatenated (without spaces) to form a command line
+option. The second part is repeated for each recipient."
+ :tag "Recipients Flag"
+ :type '(cons
+ (repeat :tag "Common prefix"
+ (choice :format "%[Type%] %v"
+ (const :tag "Start next argument." :value next-argument)
+ (string)))
+ (repeat :tag "For each recipient"
+ (choice :format "%[Type%] %v"
+ (const :tag "Start next argument." :value next-argument)
+ (const :tag "Insert recipient key ID here." :value recipient)
+ (string))))
+ :group 'gpg-options)
+
+(defcustom gpg-command-passphrase-env
+ nil
+ "Environment variable to set when a passphrase is required, or nil.
+If an operation is invoked which requires a passphrase, this
+environment variable is set before calling the external program to
+indicate that it should read the passphrase from standard input."
+ :tag "Passphrase environment"
+ :type '(choice
+ (const :tag "Disabled" :value nil)
+ (cons
+ (string :tag "Variable")
+ (string :tag "Value")))
+ :group 'gpg-options)
+
+;;; Customization: Variables: GnuPG Commands:
+
+(defcustom gpg-command-verify
+ '(gpg . ("--batch" "--verbose" "--verify" signature-file message-file))
+ "Command to verify a detached signature.
+The invoked program has to read the signed message and the signature
+from the given files. It should write human-readable information to
+standard output and/or standard error. The program shall not convert
+charsets or line endings; the input data shall be treated as binary."
+ :tag "Verify Command"
+ :type '(cons
+ gpg-command-program
+ (repeat
+ :tag "Arguments"
+ (choice
+ :format "%[Type%] %v"
+ (const :tag "Insert name of file containing the message here."
+ :value message-file)
+ (const :tag "Insert name of file containing the signature here."
+ :value signature-file)
+ (string :format "%v"))))
+ :group 'gpg-commands)
+
+(defcustom gpg-command-decrypt
+ '(gpg . ("--decrypt" "--batch" "--passphrase-fd=0"))
+ "Command to decrypt a message.
+The invoked program has to read the passphrase from standard
+input, followed by the encrypted message. It writes the decrypted
+message to standard output, and human-readable diagnostic messages to
+standard error."
+ :tag "Decrypt Command"
+ :type '(cons
+ gpg-command-program
+ (repeat
+ :tag "Arguments"
+ (choice
+ :format "%[Type%] %v"
+ (const :tag "Insert name of file containing the message here."
+ :value message-file)
+ (string :format "%v"))))
+ :group 'gpg-commands)
+
+(defcustom gpg-command-sign-cleartext
+ '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-"
+ armor textmode "--clearsign"
+ sign-with-key))
+ "Command to create a create a \"clearsign\" text file.
+The invoked program has to read the passphrase from standard input,
+followed by the message to sign. It should write the ASCII-amored
+signed text message to standard output, and diagnostic messages to
+standard error."
+ :tag "Clearsign Command"
+ :type 'gpg-command-sign-options
+ :group 'gpg-commands)
+
+(defcustom gpg-command-sign-detached
+ '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-"
+ armor textmode "--detach-sign"
+ sign-with-key))
+ "Command to create a create a detached signature.
+The invoked program has to read the passphrase from standard input,
+followed by the message to sign. It should write the ASCII-amored
+detached signature to standard output, and diagnostic messages to
+standard error. The program shall not convert charsets or line
+endings; the input data shall be treated as binary."
+ :tag "Sign Detached Command"
+ :type 'gpg-command-sign-options
+ :group 'gpg-commands)
+
+(defcustom gpg-command-sign-encrypt
+ '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-"
+ armor textmode "--always-trust" sign-with-key recipients
+ "--sign" "--encrypt" plaintext-file))
+ "Command to sign and encrypt a file.
+The invoked program has to read the passphrase from standard input,
+followed by the message to sign and encrypt if there is no
+`plaintext-file' placeholder. It should write the ASCII-amored
+encrypted message to standard output, and diagnostic messages to
+standard error."
+ :tag "Sign And Encrypt Command"
+ :type '(cons
+ gpg-command-program
+ (repeat
+ :tag "Arguments"
+ (choice
+ :format "%[Type%] %v"
+ (const :tag "Insert the `sign with key' option here if necessary."
+ :value sign-with-key)
+ (const :tag "Insert list of recipients here."
+ :value recipients)
+ (const :tag "Insert here name of file with plaintext."
+ :value plaintext-file)
+ (string :format "%v"))))
+ :group 'gpg-commands)
+
+(defcustom gpg-command-encrypt
+ '(gpg-2comp . ("--batch" "--output=-" armor textmode "--always-trust"
+ "--encrypt" recipients plaintext-file))
+ "Command to encrypt a file.
+The invoked program has to read the message to encrypt from standard
+input or from the plaintext file (if the `plaintext-file' placeholder
+is present). It should write the ASCII-amored encrypted message to
+standard output, and diagnostic messages to standard error."
+ :type '(cons
+ gpg-command-program
+ (repeat
+ :tag "Arguments"
+ (choice
+ :format "%[Type%] %v"
+ (const :tag "Insert list of recipients here."
+ :value recipients)
+ (const :tag "Insert here name of file with plaintext."
+ :value plaintext-file)
+ (string :format "%v"))))
+ :group 'gpg-commands)
+
+;;; Customization: Variables: Key Management Commands:
+
+(defcustom gpg-command-key-import
+ '(gpg . ("--import" "--verbose" message-file))
+ "Command to import a public key from a file."
+ :tag "Import Command"
+ :type '(cons
+ gpg-command-program
+ (repeat
+ :tag "Arguments"
+ (choice
+ :format "%[Type%] %v"
+ (const :tag "Insert name of file containing the key here."
+ :value message-file)
+ (string :format "%v"))))
+ :group 'gpg-commands-key)
+
+(defcustom gpg-command-key-export
+ '(gpg . ("--no-verbose" "--armor" "--export" key-id))
+ "Command to export a public key from the key ring.
+The key should be written to standard output using ASCII armor."
+ :tag "Export Command"
+ :type 'gpg-command-key-options
+ :group 'gpg-commands-key)
+
+(defcustom gpg-command-key-verify
+ '(gpg . ("--no-verbose" "--batch" "--fingerprint" "--check-sigs" key-id))
+ "Command to verify a public key."
+ :tag "Verification Command"
+ :type 'gpg-command-key-options
+ :group 'gpg-commands-key)
+
+(defcustom gpg-command-key-public-ring
+ '(gpg . ("--no-verbose" "--batch" "--with-colons" "--list-keys" key-id))
+ "Command to list the contents of the public key ring."
+ :tag "List Public Key Ring Command"
+ :type 'gpg-command-key-options
+ :group 'gpg-commands-key)
+
+(defcustom gpg-command-key-secret-ring
+ '(gpg . ("--no-verbose" "--batch" "--with-colons"
+ "--list-secret-keys" key-id))
+ "Command to list the contents of the secret key ring."
+ :tag "List Secret Key Ring Command"
+ :type 'gpg-command-key-options
+ :group 'gpg-commands-key)
+
+(defcustom gpg-command-key-retrieve
+ '(gpg . ("--batch" "--recv-keys" key-id))
+ "Command to retrieve public keys."
+ :tag "Retrieve Keys Command"
+ :type 'gpg-command-key-options
+ :group 'gpg-commands-key)
+
+\f
+;;;; Helper functions for GnuPG invocation:
+
+;;; Build the GnuPG command line:
+
+(defun gpg-build-argument (template substitutions &optional pass-start)
+ "Build command line argument(s) by substituting placeholders.
+TEMPLATE is a list of strings and symbols. The placeholder symbols in
+it are replaced by SUBSTITUTIONS, the elements between
+`next-argument' symbols are concatenated without spaces and are
+returned in a list.
+
+SUBSTITIONS is a list of (SYMBOL . SEXP) pairs, where SEXP is either
+a string (which is inserted literally), a list of strings (which are
+inserted as well), or nil, which means to insert nothing.
+
+If PASS-START is t, `next-argument' is also inserted into the result,
+and symbols without a proper substitution are retained in the output,
+otherwise, an untranslated symbol results in an error.
+
+This function does not handle empty arguments reliably."
+ (let ((current-arg "")
+ (arglist nil))
+ (while template
+ (let* ((templ (pop template))
+ (repl (assoc templ substitutions))
+ (new (if repl (cdr repl) templ)))
+ (cond
+ ((eq templ 'next-argument)
+ ;; If the current argument is not empty, start a new one.
+ (unless (equal current-arg "")
+ (setq arglist (nconc arglist
+ (if pass-start
+ (list current-arg 'next-argument)
+ (list current-arg))))
+ (setq current-arg "")))
+ ((null new) nil) ; Drop it.
+ ((and (not (stringp templ)) (null repl))
+ ;; Retain an untranslated symbol in the output if
+ ;; `pass-start' is true.
+ (unless pass-start
+ (error "No replacement for `%s'" templ))
+ (setq arglist (nconc arglist (list current-arg templ)))
+ (setq current-arg ""))
+ (t
+ (unless (listp new)
+ (setq new (list new)))
+ (setq current-arg (concat current-arg
+ (apply 'concat new)))))))
+ (unless (equal current-arg "")
+ (setq arglist (nconc arglist (list current-arg))))
+ arglist))
+
+(defun gpg-build-arg-list (template substitutions)
+ "Build command line by substituting placeholders.
+TEMPLATE is a list of strings and symbols. The placeholder symbols in
+it are replaced by SUBSTITUTIONS.
+
+SUBSTITIONS is a list of (SYMBOL . SEXP) pairs, where SEXP is either a
+string (which is inserted literally), a list of strings (which are
+inserted as well), or nil, which means to insert nothing."
+ (let (arglist)
+ (while template
+ (let* ((templ (pop template))
+ (repl (assoc templ substitutions))
+ (new (if repl (cdr repl) templ)))
+ (cond
+ ((and (symbolp templ) (null repl))
+ (error "No replacement for `%s'" templ))
+ ((null new) nil) ; Drop it.
+ (t
+ (unless (listp new)
+ (setq new (list new)))
+ (setq arglist (nconc arglist new))))))
+ arglist))
+
+(defun gpg-build-flag-recipients-one (recipient)
+ "Build argument for one RECIPIENT."
+ (gpg-build-argument (cdr gpg-command-flag-recipient)
+ `((recipient . ,recipient)) t))
+
+(defun gpg-build-flag-recipients (recipients)
+ "Build list of RECIPIENTS using `gpg-command-flag-recipient'."
+ (gpg-build-argument
+ (apply 'append (car gpg-command-flag-recipient)
+ (mapcar 'gpg-build-flag-recipients-one
+ recipients))
+ nil))
+
+(defun gpg-read-recipients ()
+ "Query the user for several recipients."
+ (let ((go t)
+ recipients r)
+ (while go
+ (setq r (read-string "Enter recipient ID [RET when no more]: "))
+ (if (equal r "")
+ (setq go nil)
+ (setq recipients (nconc recipients (list r)))))
+ recipients))
+
+(defun gpg-build-flag-sign-with-key (key)
+ "Build sign with key flag using `gpg-command-flag-sign-with-key'."
+ (let ((k (if key key
+ (if gpg-default-key-id gpg-default-key-id
+ nil))))
+ (if k
+ (gpg-build-argument gpg-command-flag-sign-with-key
+ (list (cons 'sign-with-key k)))
+ nil)))
+
+(defmacro gpg-with-passphrase-env (&rest body)
+ "Adjust the process environment and evaluate BODY.
+During the evaluation of the body forms, the process environment is
+adjust according to `gpg-command-passphrase-env'."
+ (let ((env-value (make-symbol "env-value")))
+ `(let ((,env-value))
+ (unwind-protect
+ (progn
+ (when gpg-command-passphrase-env
+ (setq ,env-value (getenv (car gpg-command-passphrase-env)))
+ (setenv (car gpg-command-passphrase-env)
+ (cdr gpg-command-passphrase-env)))
+ ,@body)
+ (when gpg-command-passphrase-env
+ ;; This will clear the variable if it wasn't set before.
+ (setenv (car gpg-command-passphrase-env) ,env-value))))))
+
+;;; Temporary files:
+
+(defun gpg-make-temp-file ()
+ "Create a temporary file in a safe way"
+ (let ((name (concat gpg-temp-directory "/gnupg")))
+ (if (fboundp 'make-temp-file)
+ ;; If we've got make-temp-file, we are on the save side.
+ (make-temp-file name)
+ ;; make-temp-name doesn't create the file, and an ordinary
+ ;; write-file operation is prone to nasty symlink attacks if the
+ ;; temporary file resides in a world-writable directory.
+ (unless (eq (file-modes gpg-temp-directory) 448) ; mode 0700
+ (error "Directory for temporary files must have mode 0700."))
+ (setq name (make-temp-name name))
+ (let ((mode (default-file-modes)))
+ (unwind-protect
+ (progn
+ (set-default-file-modes 384) ; mode 0600
+ (with-temp-file name))
+ (set-default-file-modes mode)))
+ name)))
+
+(defvar gpg-temp-files nil
+ "List of temporary files used by the GnuPG interface.
+Do not set this variable. Call `gpg-with-temp-files' if you need
+temporary files.")
+
+(defun gpg-with-temp-files-create (count)
+ "Do not call this function. Used internally by `gpg-with-temp-files'."
+ (while (> count 0)
+ (setq gpg-temp-files (cons (gpg-make-temp-file) gpg-temp-files))
+ (setq count (1- count))))
+
+(defun gpg-with-temp-files-delete ()
+ "Do not call this function. Used internally by `gpg-with-temp-files'."
+ (while gpg-temp-files
+ (let ((file (pop gpg-temp-files)))
+ (condition-case nil
+ (delete-file file)
+ (error nil)))))
+
+(defmacro gpg-with-temp-files (count &rest body)
+ "Create COUNT temporary files, USE them, and delete them.
+The function USE is called with the names of all temporary files as
+arguments."
+ `(let ((gpg-temp-files))
+ (unwind-protect
+ (progn
+ ;; Create the temporary files.
+ (gpg-with-temp-files-create ,count)
+ ,@body)
+ (gpg-with-temp-files-delete))))
+
+;;; Making subprocesses:
+
+(defun gpg-exec-path (option)
+ "Return the program name for OPTION.
+OPTION is of the form (PROGRAM . ARGLIST). This functions returns
+PROGRAM, but takes default values into account."
+ (let* ((prg (car option))
+ (path (assq prg gpg-command-default-alist)))
+ (cond
+ (path (if (null (cdr path))
+ (error "Command `%s' is not available" prg)
+ (cdr path)))
+ ((null prg) (error "Command is disabled"))
+ (t prg))))
+
+(defun gpg-call-process (cmd args stdin stdout stderr &optional passphrase)
+ "Invoke external program CMD with ARGS on buffer STDIN.
+Standard output is insert before point in STDOUT, standard error in
+STDERR. If PASSPHRASE is given, send it before STDIN. PASSPHRASE
+should not end with a line feed (\"\\n\").
+
+If `stdin-file' is present in ARGS, it is replaced by the name of a
+temporary file. Before invoking CMD, the contents of STDIN is written
+to this file."
+ (gpg-with-temp-files 2
+ (let* ((coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion)
+ (have-stdin-file (memq 'stdin-file args))
+ (stdin-file (nth 0 gpg-temp-files))
+ (stderr-file (nth 1 gpg-temp-files))
+ (cpr-args `(,cmd
+ nil ; don't delete
+ (,stdout ,stderr-file)
+ nil ; don't display
+ ;; Replace `stdin-file'.
+ ,@(gpg-build-arg-list
+ args (list (cons 'stdin-file stdin-file)))))
+ res)
+ (when have-stdin-file
+ (with-temp-file stdin-file
+ (buffer-disable-undo)
+ (insert-buffer-substring stdin)))
+ (setq res
+ (if passphrase
+ (with-temp-buffer
+ (buffer-disable-undo)
+ (insert passphrase "\n")
+ (unless have-stdin-file
+ (apply 'insert-buffer-substring
+ (if (listp stdin) stdin (list stdin))))
+ (apply 'call-process-region (point-min) (point-max) cpr-args)
+ ;; Wipe out passphrase.
+ (goto-char (point-min))
+ (translate-region (point) (line-end-position)
+ (make-string 256 ? )))
+ (if (listp stdin)
+ (with-current-buffer (car stdin)
+ (apply 'call-process-region
+ (cadr stdin)
+ (if have-stdin-file (cadr stdin) (caddr stdin))
+ cpr-args))
+ (with-current-buffer stdin
+ (apply 'call-process-region
+ (point-min)
+ (if have-stdin-file (point-min) (point-max))
+ cpr-args)))))
+ (with-current-buffer stderr
+ (insert-file-contents-literally stderr-file))
+ (if (or (stringp res) (> res 0))
+ ;; Signal or abnormal exit.
+ (with-current-buffer stderr
+ (goto-char (point-max))
+ (insert (format "\nCommand exit status: %s\n" res))
+ nil)
+ t))))
+
+(defvar gpg-result-buffer nil
+ "The result of a GnuPG operation is stored in this buffer.
+Never set this variable directly, use `gpg-show-result' instead.")
+
+(defun gpg-show-result-buffer (always-show result)
+ "Called by `gpg-show-results' to actually show the buffer."
+ (with-current-buffer gpg-result-buffer
+ ;; Only proceed if the buffer is non-empty.
+ (when (and (/= (point-min) (point-max))
+ (or always-show (not result)))
+ (save-window-excursion
+ (display-buffer (current-buffer))
+ (unless (y-or-n-p "Continue? ")
+ (error "GnuPG operation aborted."))))))
+
+(defmacro gpg-show-result (always-show &rest body)
+ "Show GnuPG result to user for confirmation.
+This macro binds `gpg-result-buffer' to a temporary buffer and
+evaluates BODY, like `progn'. If BODY evaluates to `nil' (or
+`always-show' is not nil), the user is asked for confirmation."
+ `(let ((gpg-result-buffer (get-buffer-create
+ (generate-new-buffer-name "*GnuPG Output*"))))
+ (unwind-protect
+ (gpg-show-result-buffer ,always-show (progn ,@body))
+ (kill-buffer gpg-result-buffer))))
+
+;;; Passphrase handling:
+
+(defvar gpg-passphrase-timer
+ (timer-create)
+ "This timer will clear the passphrase cache periodically.")
+
+(defvar gpg-passphrase
+ nil
+ "The (unencrypted) passphrase cache.")
+
+(defun gpg-passphrase-clear-string (str)
+ "Erases STR by overwriting all characters."
+ (let ((pos 0)
+ (len (length str)))
+ (while (< pos len)
+ (aset str pos ? )
+ (incf pos))))
+
+;;;###autoload
+(defun gpg-passphrase-forget ()
+ "Forget stored passphrase."
+ (interactive)
+ (cancel-timer gpg-passphrase-timer)
+ (gpg-passphrase-clear-string gpg-passphrase)
+ (setq gpg-passphrase nil))
+
+(defun gpg-passphrase-store (passphrase)
+ "Store PASSPHRASE in cache.
+Updates the timeout for clearing the cache to `gpg-passphrase-timeout'."
+ (unless (equal gpg-passphrase-timeout 0)
+ (timer-set-time gpg-passphrase-timer
+ (timer-relative-time (current-time)
+ gpg-passphrase-timeout))
+ (timer-set-function gpg-passphrase-timer 'gpg-passphrase-forget)
+ (timer-activate gpg-passphrase-timer)
+ (setq gpg-passphrase passphrase))
+ passphrase)
+
+(defun gpg-passphrase-read ()
+ "Read a passphrase and remember it for some time."
+ (interactive)
+ (if gpg-passphrase
+ ;; This reinitializes the timer.
+ (gpg-passphrase-store gpg-passphrase)
+ (let ((pp (read-passwd "Enter passphrase: ")))
+ (gpg-passphrase-store pp))))
+
+\f
+;;;; Main operations:
+
+;;;###autoload
+(defun gpg-verify (message signature result)
+ "Verify buffer MESSAGE against detached SIGNATURE buffer.
+Returns t if everything worked out well, nil otherwise. Consult
+buffer RESULT for details."
+ (interactive "bBuffer containing message: \nbBuffer containing signature: \nbBuffor for result: ")
+ (gpg-with-temp-files 2
+ (let* ((sig-file (nth 0 gpg-temp-files))
+ (msg-file (nth 1 gpg-temp-files))
+ (cmd (gpg-exec-path gpg-command-verify))
+ (args (gpg-build-arg-list (cdr gpg-command-verify)
+ `((signature-file . ,sig-file)
+ (message-file . ,msg-file))))
+ res)
+ (with-temp-file sig-file
+ (buffer-disable-undo)
+ (apply 'insert-buffer-substring signature))
+ (with-temp-file msg-file
+ (buffer-disable-undo)
+ (apply 'insert-buffer-substring message))
+ (setq res (apply 'call-process-region
+ (point-min) (point-min) ; no data
+ cmd
+ nil ; don't delete
+ result
+ nil ; don't display
+ args))
+ (if (or (stringp res) (> res 0))
+ ;; Signal or abnormal exit.
+ (with-current-buffer result
+ (insert (format "\nCommand exit status: %s\n" res))
+ nil)
+ t))))
+
+;;;###autoload
+(defun gpg-decrypt (ciphertext plaintext result &optional passphrase)
+ "Decrypt buffer CIPHERTEXT to buffer PLAINTEXT.
+Returns t if everything worked out well, nil otherwise. Consult
+buffer RESULT for details. Reads a missing PASSPHRASE using
+`gpg-passphrase-read'."
+ (interactive "bBuffer containing ciphertext: \nbBuffer for plaintext: \nbBuffor for decryption status: ")
+ (gpg-call-process (gpg-exec-path gpg-command-decrypt)
+ (gpg-build-arg-list (cdr gpg-command-decrypt) nil)
+ ciphertext plaintext result
+ (if passphrase passphrase (gpg-passphrase-read)))
+ (when passphrase
+ (gpg-passphrase-clear-string passphrase)))
+
+;;;###autoload
+(defun gpg-sign-cleartext
+ (plaintext signed-text result &optional passphrase sign-with-key)
+ "Sign buffer PLAINTEXT, and store PLAINTEXT with signature in
+SIGNED-TEXT.
+Reads a missing PASSPHRASE using `gpg-passphrase-read'. Uses key ID
+SIGN-WITH-KEY if given, otherwise the default key ID. Returns t if
+everything worked out well, nil otherwise. Consult buffer RESULT for
+details.
+
+NOTE: Use of this function is deprecated."
+ (interactive "bBuffer containing plaintext: \nbBuffer for text with signature: \nbBuffer for status information: ")
+ (let ((subst (list (cons 'sign-with-key
+ (gpg-build-flag-sign-with-key sign-with-key))
+ (cons 'armor gpg-command-flag-armor)
+ (cons 'textmode gpg-command-flag-textmode))))
+ (gpg-call-process (gpg-exec-path gpg-command-sign-cleartext)
+ (gpg-build-arg-list (cdr gpg-command-sign-cleartext)
+ subst)
+ plaintext signed-text result
+ (if passphrase passphrase (gpg-passphrase-read))))
+ (when passphrase
+ (gpg-passphrase-clear-string passphrase)))
+
+;;;###autoload
+(defun gpg-sign-detached
+ (plaintext signature result &optional passphrase sign-with-key
+ armor textmode)
+ "Sign buffer PLAINTEXT, and store SIGNATURE in that buffer.
+Reads a missing PASSPHRASE using `gpg-passphrase-read'. Uses key ID
+SIGN-WITH-KEY if given, otherwise the default key ID. Returns t if
+everything worked out well, nil otherwise. Consult buffer RESULT for
+details. ARMOR the result and activate canonical TEXTMODE if
+requested."
+ (interactive "bBuffer containing plaintext: \nbBuffer for text with signature: \nbBuffer for status information: ")
+ (let ((subst (list (cons 'sign-with-key
+ (gpg-build-flag-sign-with-key sign-with-key))
+ (cons 'armor (if armor gpg-command-flag-armor))
+ (cons 'textmode (if armor gpg-command-flag-textmode)))))
+ (gpg-call-process (gpg-exec-path gpg-command-sign-detached)
+ (gpg-build-arg-list (cdr gpg-command-sign-detached)
+ subst)
+ plaintext signature result
+ (if passphrase passphrase (gpg-passphrase-read))))
+ (when passphrase
+ (gpg-passphrase-clear-string passphrase)))
+
+
+;;;###autoload
+(defun gpg-sign-encrypt
+ (plaintext ciphertext result recipients &optional passphrase sign-with-key
+ armor textmode)
+ "Sign buffer PLAINTEXT, and store SIGNATURE in that buffer.
+RECIPIENTS is a list of key IDs used for encryption. This function
+reads a missing PASSPHRASE using `gpg-passphrase-read', and uses key
+ID SIGN-WITH-KEY for the signature if given, otherwise the default key
+ID. Returns t if everything worked out well, nil otherwise. Consult
+buffer RESULT for details. ARMOR the result and activate canonical
+TEXTMODE if requested."
+ (interactive (list
+ (read-buffer "Buffer containing plaintext: " nil t)
+ (read-buffer "Buffer for ciphertext: " nil t)
+ (read-buffer "Buffer for status informationt: " nil t)
+ (gpg-read-recipients)))
+ (let ((subst `((sign-with-key . ,(gpg-build-flag-sign-with-key
+ sign-with-key))
+ (plaintext-file . stdin-file)
+ (recipients . ,(gpg-build-flag-recipients recipients))
+ (armor ,(if armor gpg-command-flag-armor))
+ (textmode ,(if armor gpg-command-flag-textmode)))))
+ (gpg-call-process (gpg-exec-path gpg-command-sign-encrypt)
+ (gpg-build-arg-list (cdr gpg-command-sign-encrypt)
+ subst)
+ plaintext ciphertext result
+ (if passphrase passphrase (gpg-passphrase-read))))
+ (when passphrase
+ (gpg-passphrase-clear-string passphrase)))
+
+
+;;;###autoload
+(defun gpg-encrypt
+ (plaintext ciphertext result recipients &optional armor textmode)
+ "Encrypt buffer PLAINTEXT, and store CIPHERTEXT in that buffer.
+RECIPIENTS is a list of key IDs used for encryption. Returns t if
+everything worked out well, nil otherwise. Consult buffer RESULT for
+details. ARMOR the result and activate canonical
+TEXTMODE if requested."
+ (interactive (list
+ (read-buffer "Buffer containing plaintext: " nil t)
+ (read-buffer "Buffer for ciphertext: " nil t)
+ (read-buffer "Buffer for status informationt: " nil t)
+ (gpg-read-recipients)))
+ (let ((subst `((plaintext-file . stdin-file)
+ (recipients . ,(gpg-build-flag-recipients recipients))
+ (armor ,(if armor gpg-command-flag-armor))
+ (textmode ,(if armor gpg-command-flag-textmode)))))
+ (gpg-call-process (gpg-exec-path gpg-command-encrypt)
+ (gpg-build-arg-list (cdr gpg-command-encrypt) subst)
+ plaintext ciphertext result nil))
+ (when passphrase
+ (gpg-passphrase-clear-string passphrase)))
+
+\f
+;;;; Key management
+
+;;; ADT: OpenPGP Key
+
+(defun gpg-key-make (user-id key-id unique-id length algorithm
+ creation-date expire-date validity trust)
+ "Create a new key object (for internal use only)."
+ (vector
+ ;; 0 1 2 3 4
+ user-id key-id unique-id length algorithm
+ ;; 5 6 7 8
+ creation-date expire-date validity trust))
+
+
+(defun gpg-key-p (key)
+ "Return t if KEY is a key specification."
+ (and (arrayp key) (equal (length key) 9) key))
+
+(defmacro gpg-key-primary-user-id (key)
+ "The primary user ID for KEY (human-readable).
+DO NOT USE this ID for selecting recipients. It is probably not
+unique."
+ (list 'car (list 'aref key 0)))
+
+(defmacro gpg-key-user-ids (key)
+ "A list of additional user IDs for KEY (human-readable).
+DO NOT USE these IDs for selecting recipients. They are probably not
+unique."
+ (list 'cdr (list 'aref key 0)))
+
+(defmacro gpg-key-id (key)
+ "The key ID of KEY.
+DO NOT USE this ID for selecting recipients. It is not guaranteed to
+be unique."
+ (list 'aref key 1))
+
+(defun gpg-short-key-id (key)
+ "The short key ID of KEY."
+ (let* ((id (gpg-key-id key))
+ (len (length id)))
+ (if (> len 8)
+ (substring id (- len 8))
+ id)))
+
+(defmacro gpg-key-unique-id (key)
+ "A non-standard ID of KEY which is only valid locally.
+This ID can be used to specify recipients in a safe manner. Note,
+even this ID might not be unique unless GnuPG is used."
+ (list 'aref key 2))
+
+(defmacro gpg-key-unique-id-list (key-list)
+ "Like `gpg-key-unique-id', but operate on a list."
+ `(mapcar (lambda (key) (gpg-key-unique-id key))
+ ,key-list))
+
+(defmacro gpg-key-length (key)
+ "Returns the key length."
+ (list 'aref key 3))
+
+(defmacro gpg-key-algorithm (key)
+ "The encryption algorithm used by KEY.
+One of the symbols `rsa', `rsa-encrypt', `rsa-sign', `elgamal',
+`elgamal-encrypt', `dsa'."
+ (list 'aref key 4))
+
+(defmacro gpg-key-creation-date (key)
+ "A string with the creation date of KEY in ISO format."
+ (list 'aref key 5))
+
+(defmacro gpg-key-expire-date (key)
+ "A string with the expiration date of KEY in ISO format."
+ (list 'aref key 6))
+
+(defmacro gpg-key-validity (key)
+ "The calculated validity of KEY.
+One of the symbols `not-known', `disabled', `revoked', `expired',
+`undefined', `trust-none', `trust-marginal', `trust-full',
+`trust-ultimate' (see the GnuPG documentation for details)."
+ (list 'aref key 7))
+
+(defmacro gpg-key-trust (key)
+ "The assigned trust for KEY.
+One of the symbols `not-known', `undefined', `trust-none',
+`trust-marginal', `trust-full' (see the GnuPG
+documentation for details)."
+ (list 'aref key 8))
+
+(defun gpg-key-lessp (a b)
+ "Returns t if primary user ID of A is less than B."
+ (let ((res (compare-strings (gpg-key-primary-user-id a) 0 nil
+ (gpg-key-primary-user-id b) 0 nil
+ t)))
+ (if (eq res t)
+ nil
+ (< res 0))))
+
+;;; Accessing the key database:
+
+;; Internal functions:
+
+(defmacro gpg-key-list-keys-skip-field ()
+ '(search-forward ":" eol 'move))
+
+(defmacro gpg-key-list-keys-get-field ()
+ '(buffer-substring (point) (if (gpg-key-list-keys-skip-field)
+ (1- (point))
+ eol)))
+(defmacro gpg-key-list-keys-string-field ()
+ '(gpg-key-list-keys-get-field))
+
+(defmacro gpg-key-list-keys-read-field ()
+ (let ((field (make-symbol "field")))
+ `(let ((,field (gpg-key-list-keys-get-field)))
+ (if (equal (length ,field) 0)
+ nil
+ (read ,field)))))
+
+(defun gpg-key-list-keys-parse-line ()
+ "Parse the line in the current buffer and return a vector of fields."
+ (let* ((eol (line-end-position))
+ (v (if (eolp)
+ nil
+ (vector
+ (gpg-key-list-keys-read-field) ; type
+ (gpg-key-list-keys-get-field) ; trust
+ (gpg-key-list-keys-read-field) ; key length
+ (gpg-key-list-keys-read-field) ; algorithm
+ (gpg-key-list-keys-get-field) ; key ID
+ (gpg-key-list-keys-get-field) ; creation data
+ (gpg-key-list-keys-get-field) ; expire
+ (gpg-key-list-keys-get-field) ; unique (local) ID
+ (gpg-key-list-keys-get-field) ; ownertrust
+ (gpg-key-list-keys-string-field) ; user ID
+ ))))
+ (if (eolp)
+ (when v
+ (forward-char 1))
+ (error "Too many fields in GnuPG key database"))
+ v))
+
+(defconst gpg-pubkey-algo-alist
+ '((1 . rsa)
+ (2 . rsa-encrypt-only)
+ (3 . rsa-sign-only)
+ (16 . elgamal-encrypt-only)
+ (17 . dsa)
+ (20 . elgamal))
+ "Alist mapping OpenPGP public key algorithm numbers to symbols.")
+
+(defconst gpg-trust-alist
+ '((?- . not-known)
+ (?o . not-known)
+ (?d . disabled)
+ (?r . revoked)
+ (?e . expired)
+ (?q . trust-undefined)
+ (?n . trust-none)
+ (?m . trust-marginal)
+ (?f . trust-full)
+ (?u . trust-ultimate))
+ "Alist mapping GnuPG trust value short forms to long symbols.")
+
+(defmacro gpg-key-list-keys-in-buffer-store ()
+ '(when primary-user-id
+ (sort user-id 'string-lessp)
+ (push (gpg-key-make (cons primary-user-id user-id)
+ key-id unique-id key-length
+ algorithm creation-date
+ expire-date validity trust)
+ key-list)))
+
+(defun gpg-key-list-keys-in-buffer (&optional buffer)
+ "Return a list of keys for BUFFER.
+If BUFFER is omitted, use current buffer."
+ (with-current-buffer (if buffer buffer (current-buffer))
+ (goto-char (point-min))
+ ;; Skip key ring filename written by GnuPG.
+ (search-forward "\n---------------------------\n" nil t)
+ ;; Loop over all lines in buffer and analyze them.
+ (let (primary-user-id user-id key-id unique-id ; current key components
+ key-length algorithm creation-date expire-date validity trust
+ line ; fields in current line
+ key-list) ; keys gather so far
+
+ (while (setq line (gpg-key-list-keys-parse-line))
+ (cond
+ ;; Public or secret key.
+ ((memq (aref line 0) '(pub sec))
+ ;; Store previous key, if any.
+ (gpg-key-list-keys-in-buffer-store)
+ ;; Record field values.
+ (setq primary-user-id (aref line 9))
+ (setq user-id nil)
+ (setq key-id (aref line 4))
+ ;; We use the key ID if no unique ID is available.
+ (setq unique-id (if (> (length (aref line 7)) 0)
+ (concat "#" (aref line 7))
+ (concat "0x" key-id)))
+ (setq key-length (aref line 2))
+ (setq algorithm (assq (aref line 3) gpg-pubkey-algo-alist))
+ (if algorithm
+ (setq algorithm (cdr algorithm))
+ (error "Unknown algorithm %s" (aref line 3)))
+ (setq creation-date (if (> (length (aref line 5)) 0)
+ (aref line 5)))
+ (setq expire-date (if (> (length (aref line 6)) 0)
+ (aref line 6)))
+ (setq validity (assq (aref (aref line 1) 0) gpg-trust-alist))
+ (if validity
+ (setq validity (cdr validity))
+ (error "Unknown validity specification %S" (aref line 1)))
+ (setq trust (assq (aref (aref line 8) 0) gpg-trust-alist))
+ (if trust
+ (setq trust (cdr trust))
+ (error "Unknown trust specification %S" (aref line 8))))
+
+ ;; Additional user ID
+ ((eq 'uid (aref line 0))
+ (setq user-id (cons (aref line 9) user-id)))
+
+ ;; Subkeys are ignored for now.
+ ((memq (aref line 0) '(sub ssb))
+ t)
+ (t (error "Unknown record type %S" (aref line 0)))))
+
+ ;; Store the key retrieved last.
+ (gpg-key-list-keys-in-buffer-store)
+ ;; Sort the keys according to the primary user ID.
+ (sort key-list 'gpg-key-lessp))))
+
+(defun gpg-key-list-keyspec (command &optional keyspec stderr ignore-error)
+ "Insert the output of COMMAND before point in current buffer."
+ (let* ((cmd (gpg-exec-path command))
+ (key (if (equal keyspec "") nil keyspec))
+ (args (gpg-build-arg-list (cdr command) `((key-id . ,key))))
+ exit-status)
+ (setq exit-status
+ (apply 'call-process-region
+ (point-min) (point-min) ; no data
+ cmd
+ nil ; don't delete
+ (if stderr t '(t nil))
+ nil ; don't display
+ args))
+ (unless (or ignore-error (equal exit-status 0))
+ (error "GnuPG command exited unsuccessfully"))))
+
+
+(defun gpg-key-list-keyspec-parse (command &optional keyspec)
+ "Return a list of keys matching KEYSPEC.
+COMMAND is used to obtain the key list. The usual substring search
+for keys is performed."
+ (with-temp-buffer
+ (buffer-disable-undo)
+ (gpg-key-list-keyspec command keyspec)
+ (gpg-key-list-keys-in-buffer)))
+
+;;;###autoload
+(defun gpg-key-list-keys (&optional keyspec)
+ "A list of public keys matching KEYSPEC.
+The usual substring search for keys is performed."
+ (gpg-key-list-keyspec-parse gpg-command-key-public-ring keyspec))
+
+;;;###autoload
+(defun gpg-key-list-secret-keys (&optional keyspec)
+ "A list of secret keys matching KEYSPEC.
+The usual substring search for keys is performed."
+ (gpg-key-list-keyspec-parse gpg-command-key-secret-ring keyspec))
+
+;;;###autoload
+(defun gpg-key-insert-public-key (key)
+ "Inserts the public key(s) matching KEYSPEC.
+The ASCII-armored key is inserted before point into current buffer."
+ (gpg-key-list-keyspec gpg-command-key-export key))
+
+;;;###autoload
+(defun gpg-key-insert-information (key)
+ "Insert human-readable information (including fingerprint) on KEY.
+Insertion takes place in current buffer before point."
+ (gpg-key-list-keyspec gpg-command-key-verify key))
+
+;;;###autoload
+(defun gpg-key-retrieve (key)
+ "Fetch KEY from default key server.
+KEY is a key ID or a list of key IDs. Status information about this
+operation is inserted into the current buffer before point."
+ (gpg-key-list-keyspec gpg-command-key-retrieve key t t))
+
+;;;###autoload
+(defun gpg-key-add-to-ring (key result)
+ "Adds key in buffer KEY to the GnuPG key ring.
+Human-readable information on the RESULT is stored in buffer RESULT
+before point.")
+
+(provide 'gpg)
+
+;;; gpg.el ends here
\ No newline at end of file
projects / elisp / gnus.git- / commitdiff