From cbd8475142a351bd35c54cfe0809ad8fb079142b Mon Sep 17 00:00:00 2001 From: ShengHuo ZHU Date: Tue, 31 Oct 2000 21:31:31 +0000 Subject: [PATCH] Add files. --- lisp/ChangeLog | 5 + lisp/gpg-ring.el | 484 ++++++++++++++++++ lisp/gpg.el | 1233 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 1722 insertions(+) create mode 100644 lisp/gpg-ring.el create mode 100644 lisp/gpg.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 38a504a7b..1b7612559 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2000-10-31 17:28:45 ShengHuo ZHU + + * gpg.el: New file. + * gpg-ring.el: New file. + 2000-10-31 11:44:29 ShengHuo ZHU * gnus-sum.el (gnus-summary-show-article): Fix the summary line. diff --git a/lisp/gpg-ring.el b/lisp/gpg-ring.el new file mode 100644 index 000000000..76fa62f11 --- /dev/null +++ b/lisp/gpg-ring.el @@ -0,0 +1,484 @@ +;;; gpg-ring.el --- Major mode for editing GnuPG key rings. + +;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart + +;; Author: Florian Weimer +;; Maintainer: Florian Weimer +;; Keywords: crypto +;; Created: 2000-04-28 + +;; $Id: gpg-ring.el,v 1.1 2000/05/28 12:40:38 fw 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. + + + +;;;; 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 diff --git a/lisp/gpg.el b/lisp/gpg.el new file mode 100644 index 000000000..1e6c5440f --- /dev/null +++ b/lisp/gpg.el @@ -0,0 +1,1233 @@ +;;; gpg.el --- Interface to GNU Privacy Guard + +;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart + +;; Author: Florian Weimer +;; Maintainer: Florian Weimer +;; Keywords: crypto +;; Created: 2000-04-15 + +;; $Id: gpg.el,v 1.4 2000/05/28 12:41:08 fw Exp fw $ + +;; 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). + + +;;;; 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) + + +;;;; 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)))) + + +;;;; 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))) + + +;;;; 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 -- 2.25.1