From: Ulrich Mueller <ulm@gentoo.org>
To: Michael Albinus <michael.albinus@gmx.de>
Cc: 67012@debbugs.gnu.org, Eli Zaretskii <eliz@gnu.org>
Subject: bug#67012: 29.1; epa-sign-file pinentry loopback mode does not work with S/MIME
Date: Sat, 25 Nov 2023 13:17:36 +0100 [thread overview]
Message-ID: <u5y1qm3hb@gentoo.org> (raw)
In-Reply-To: <8734wuysbx.fsf@gmx.de> (Michael Albinus's message of "Sat, 25 Nov 2023 12:40:02 +0100")
[-- Attachment #1: Type: text/plain, Size: 817 bytes --]
>>>>> On Sat, 25 Nov 2023, Michael Albinus wrote:
> I have no idea what I'm speaking about. However, on GNU ELPA there is
> the package pinentry 0.1 from Daiki Ueno <ueno@gnu.org>. Same is for
> Emacs 25. Shouldn't we advertise the GNU ELPA package?
I am aware that there's a package on ELPA, but looks like it's very
outdated.
> However, there are differences. [...]
There are quite a few differences, see full diff attached.
> Shouldn't we upgrade the GNU ELPA version?
Probably. Gentoo also has a (rather trivial) patch that fixes some
warnings with newer Emacs versions:
https://gitweb.gentoo.org/repo/gentoo.git/tree/app-emacs/pinentry/files/pinentry-emacs-29.patch
(I still don't entirely understand why pinentry.el was dropped from
Emacs proper, but I won't challenge the decision made in bug #27445.)
[-- Attachment #2: pinentry.el.diff --]
[-- Type: text/plain, Size: 14791 bytes --]
--- pinentry-0.1.el
+++ emacs-25.3/lisp/net/pinentry.el
@@ -1,6 +1,6 @@
;;; pinentry.el --- GnuPG Pinentry server implementation -*- lexical-binding: t -*-
-;; Copyright (C) 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@gnu.org>
;; Version: 0.1
@@ -19,16 +19,15 @@
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This package allows GnuPG passphrase to be prompted through the
-;; minibuffer instead of graphical dialog. As of June 2015, this
-;; feature requires newer versions of GnuPG (2.1.5 or later) and
-;; Pinentry (not yet released).
+;; minibuffer instead of graphical dialog.
;;
-;; To use, add allow-emacs-pinentry to ~/.gnupg/gpg-agent.conf, and
+;; To use, add "allow-emacs-pinentry" to "~/.gnupg/gpg-agent.conf",
+;; reload the configuration with "gpgconf --reload gpg-agent", and
;; start the server with M-x pinentry-start.
;;
;; The actual communication path between the relevant components is
@@ -41,12 +40,34 @@
;;
;; ${TMPDIR-/tmp}/emacs$(id -u)/pinentry
;;
-;; under the same directory as server.el uses. The protocol is a
+;; under the same directory which server.el uses. The protocol is a
;; subset of the Pinentry Assuan protocol described in (info
;; "(pinentry) Protocol").
+;;
+;; NOTE: As of August 2015, this feature requires newer versions of
+;; GnuPG (2.1.5+) and Pinentry (0.9.5+).
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
+(defgroup pinentry nil
+ "The Pinentry server"
+ :version "25.1"
+ :group 'external)
+
+(defcustom pinentry-popup-prompt-window t
+ "If non-nil, display multiline prompt in another window."
+ :type 'boolean
+ :group 'pinentry)
+
+(defcustom pinentry-prompt-window-height 5
+ "Number of lines used to display multiline prompt."
+ :type 'integer
+ :group 'pinentry)
+
+(defvar pinentry-debug nil)
+(defvar pinentry-debug-buffer nil)
(defvar pinentry--server-process nil)
(defvar pinentry--connection-process-list nil)
@@ -55,6 +76,8 @@
(defvar pinentry--read-point nil)
(put 'pinentry--read-point 'permanent-local t)
+(defvar pinentry--prompt-buffer nil)
+
;; We use the same location as `server-socket-dir', when local sockets
;; are supported.
(defvar pinentry--socket-dir
@@ -79,34 +102,90 @@
(autoload 'server-ensure-safe-dir "server")
+(defvar pinentry-prompt-mode-map
+ (let ((keymap (make-sparse-keymap)))
+ (define-key keymap "q" 'quit-window)
+ keymap))
+
+(define-derived-mode pinentry-prompt-mode special-mode "Pinentry"
+ "Major mode for `pinentry--prompt-buffer'."
+ (buffer-disable-undo)
+ (setq truncate-lines t
+ buffer-read-only t))
+
+(defun pinentry--prompt (labels query-function &rest query-args)
+ (let ((desc (cdr (assq 'desc labels)))
+ (error (cdr (assq 'error labels)))
+ (prompt (cdr (assq 'prompt labels))))
+ (when (string-match "[ \n]*\\'" prompt)
+ (setq prompt (concat
+ (substring
+ prompt 0 (match-beginning 0)) " ")))
+ (when error
+ (setq desc (concat "Error: " (propertize error 'face 'error)
+ "\n" desc)))
+ (if (and desc pinentry-popup-prompt-window)
+ (save-window-excursion
+ (delete-other-windows)
+ (unless (and pinentry--prompt-buffer
+ (buffer-live-p pinentry--prompt-buffer))
+ (setq pinentry--prompt-buffer (generate-new-buffer "*Pinentry*")))
+ (if (get-buffer-window pinentry--prompt-buffer)
+ (delete-window (get-buffer-window pinentry--prompt-buffer)))
+ (with-current-buffer pinentry--prompt-buffer
+ (let ((inhibit-read-only t)
+ buffer-read-only)
+ (erase-buffer)
+ (insert desc))
+ (pinentry-prompt-mode)
+ (goto-char (point-min)))
+ (if (> (window-height)
+ pinentry-prompt-window-height)
+ (set-window-buffer (split-window nil
+ (- (window-height)
+ pinentry-prompt-window-height))
+ pinentry--prompt-buffer)
+ (pop-to-buffer pinentry--prompt-buffer)
+ (if (> (window-height) pinentry-prompt-window-height)
+ (shrink-window (- (window-height)
+ pinentry-prompt-window-height))))
+ (prog1 (apply query-function prompt query-args)
+ (quit-window)))
+ (apply query-function (concat desc "\n" prompt) query-args))))
+
;;;###autoload
-(defun pinentry-start ()
+(defun pinentry-start (&optional quiet)
"Start a Pinentry service.
Once the environment is properly set, subsequent invocations of
-the gpg command will interact with Emacs for passphrase input."
+the gpg command will interact with Emacs for passphrase input.
+
+If the optional QUIET argument is non-nil, messages at startup
+will not be shown."
(interactive)
(unless (featurep 'make-network-process '(:family local))
(error "local sockets are not supported"))
(if (process-live-p pinentry--server-process)
- (message "Pinentry service is already running")
+ (unless quiet
+ (message "Pinentry service is already running"))
(let* ((server-file (expand-file-name "pinentry" pinentry--socket-dir)))
(server-ensure-safe-dir pinentry--socket-dir)
;; Delete the socket files made by previous server invocations.
(ignore-errors
(let (delete-by-moving-to-trash)
(delete-file server-file)))
- (setq pinentry--server-process
- (make-network-process
- :name "pinentry"
- :server t
- :noquery t
- :sentinel #'pinentry--process-sentinel
- :filter #'pinentry--process-filter
- :coding 'no-conversion
- :family 'local
- :service server-file))
- (process-put pinentry--server-process :server-file server-file))))
+ (cl-letf (((default-file-modes) ?\700))
+ (setq pinentry--server-process
+ (make-network-process
+ :name "pinentry"
+ :server t
+ :noquery t
+ :sentinel #'pinentry--process-sentinel
+ :filter #'pinentry--process-filter
+ :coding 'no-conversion
+ :family 'local
+ :service server-file))
+ (process-put pinentry--server-process :server-file server-file)))))
(defun pinentry-stop ()
"Stop a Pinentry service."
@@ -224,6 +303,13 @@
(setq pinentry--read-point (point-min))
(make-local-variable 'pinentry--labels))))
(with-current-buffer (process-buffer process)
+ (when pinentry-debug
+ (with-current-buffer
+ (or pinentry-debug-buffer
+ (setq pinentry-debug-buffer (generate-new-buffer
+ " *pinentry-debug*")))
+ (goto-char (point-max))
+ (insert input)))
(save-excursion
(goto-char (point-max))
(insert input)
@@ -248,32 +334,15 @@
(ignore-errors
(process-send-string process "OK\n")))
("GETPIN"
- (let ((prompt
- (or (cdr (assq 'desc pinentry--labels))
- (cdr (assq 'prompt pinentry--labels))
- ""))
- (confirm (not (null (assq 'repeat pinentry--labels))))
- entry)
- (if (setq entry (assq 'error pinentry--labels))
- (setq prompt (concat "Error: "
- (propertize
- (copy-sequence (cdr entry))
- 'face 'error)
- "\n"
- prompt)))
- (if (setq entry (assq 'title pinentry--labels))
- (setq prompt (format "[%s] %s"
- (cdr entry) prompt)))
- (if (string-match ":?[ \n]*\\'" prompt)
- (setq prompt (concat
- (substring
- prompt 0 (match-beginning 0)) ": ")))
- (let (passphrase escaped-passphrase encoded-passphrase)
- (unwind-protect
- (condition-case nil
- (progn
- (setq passphrase
- (read-passwd prompt confirm))
+ (let ((confirm (not (null (assq 'repeat pinentry--labels))))
+ passphrase escaped-passphrase encoded-passphrase)
+ (unwind-protect
+ (condition-case err
+ (progn
+ (setq passphrase
+ (pinentry--prompt
+ pinentry--labels
+ #'read-passwd confirm))
(setq escaped-passphrase
(pinentry--escape-string
passphrase))
@@ -284,7 +353,8 @@
(pinentry--send-data
process encoded-passphrase)
(process-send-string process "OK\n")))
- (error
+ (error
+ (message "GETPIN error %S" err)
(ignore-errors
(pinentry--send-error
process
@@ -295,59 +365,55 @@
(clear-string escaped-passphrase))
(if encoded-passphrase
(clear-string encoded-passphrase))))
- (setq pinentry--labels nil)))
+ (setq pinentry--labels nil))
("CONFIRM"
(let ((prompt
- (or (cdr (assq 'desc pinentry--labels))
- ""))
+ (or (cdr (assq 'prompt pinentry--labels))
+ "Confirm? "))
(buttons
- (pinentry--labels-to-shortcuts
- (list (cdr (assq 'ok pinentry--labels))
- (cdr (assq 'notok pinentry--labels))
- (cdr (assq 'cancel pinentry--labels)))))
+ (delq nil
+ (pinentry--labels-to-shortcuts
+ (list (cdr (assq 'ok pinentry--labels))
+ (cdr (assq 'notok pinentry--labels))
+ (cdr (assq 'cancel pinentry--labels))))))
entry)
- (if (setq entry (assq 'error pinentry--labels))
- (setq prompt (concat "Error: "
- (propertize
- (copy-sequence (cdr entry))
- 'face 'error)
- "\n"
- prompt)))
- (if (setq entry (assq 'title pinentry--labels))
- (setq prompt (format "[%s] %s"
- (cdr entry) prompt)))
- (if (remq nil buttons)
+ (if buttons
(progn
(setq prompt
(concat prompt " ("
- (mapconcat #'cdr (remq nil buttons)
+ (mapconcat #'cdr buttons
", ")
") "))
+ (if (setq entry (assq 'prompt pinentry--labels))
+ (setcdr entry prompt)
+ (setq pinentry--labels (cons (cons 'prompt prompt)
+ pinentry--labels)))
(condition-case nil
- (let ((result (read-char prompt)))
+ (let ((result (pinentry--prompt pinentry--labels
+ #'read-char)))
(if (eq result (caar buttons))
- (ignore-errors
- (process-send-string process "OK\n"))
+ (ignore-errors
+ (process-send-string process "OK\n"))
(if (eq result (car (nth 1 buttons)))
- (ignore-errors
- (pinentry--send-error
- process
- pinentry--error-not-confirmed))
- (ignore-errors
- (pinentry--send-error
- process
- pinentry--error-cancelled)))))
+ (ignore-errors
+ (pinentry--send-error
+ process
+ pinentry--error-not-confirmed))
+ (ignore-errors
+ (pinentry--send-error
+ process
+ pinentry--error-cancelled)))))
(error
- (ignore-errors
+ (ignore-errors
(pinentry--send-error
process
pinentry--error-cancelled)))))
- (if (string-match "[ \n]*\\'" prompt)
- (setq prompt (concat
- (substring
- prompt 0 (match-beginning 0)) " ")))
+ (if (setq entry (assq 'prompt pinentry--labels))
+ (setcdr entry prompt)
+ (setq pinentry--labels (cons (cons 'prompt prompt)
+ pinentry--labels)))
(if (condition-case nil
- (y-or-n-p prompt)
+ (pinentry--prompt pinentry--labels #'y-or-n-p)
(quit))
(ignore-errors
(process-send-string process "OK\n"))
@@ -389,15 +455,6 @@
(ignore-errors
(delete-file (process-get process :server-file)))))
-;;;; ChangeLog:
-
-;; 2015-06-12 Daiki Ueno <ueno@gnu.org>
-;;
-;; Merge commit '32b1944d5f0a65aa10c6768f4865f7ed1de8eb49' as
-;; 'packages/pinentry'
-;;
-
-
(provide 'pinentry)
;;; pinentry.el ends here
next prev parent reply other threads:[~2023-11-25 12:17 UTC|newest]
Thread overview: 21+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-11-09 6:56 bug#67012: 29.1; epa-sign-file pinentry loopback mode does not work with S/MIME Ulrich Mueller
[not found] ` <handler.67012.B.169951307615474.ack@debbugs.gnu.org>
2023-11-09 9:46 ` Ulrich Mueller
2023-11-09 11:21 ` Eli Zaretskii
2023-11-09 11:43 ` Ulrich Mueller
2023-11-15 14:02 ` Eli Zaretskii
2023-11-15 15:07 ` Michael Albinus
2023-11-15 15:32 ` Michael Albinus
2023-11-15 16:48 ` Eli Zaretskii
2023-11-15 17:13 ` Michael Albinus
2023-11-16 9:54 ` Ulrich Mueller
2023-11-17 11:40 ` Ulrich Mueller
2023-11-19 5:43 ` Eli Zaretskii
2023-11-19 11:13 ` Ulrich Mueller
2023-11-25 9:53 ` Eli Zaretskii
2023-11-25 11:16 ` Ulrich Mueller
2023-11-25 11:40 ` Michael Albinus
2023-11-25 12:17 ` Ulrich Mueller [this message]
2023-11-25 14:59 ` Ulrich Mueller
2023-11-25 15:44 ` Michael Albinus
2023-11-25 16:32 ` Ulrich Mueller
2023-11-25 12:27 ` Eli Zaretskii
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=u5y1qm3hb@gentoo.org \
--to=ulm@gentoo.org \
--cc=67012@debbugs.gnu.org \
--cc=eliz@gnu.org \
--cc=michael.albinus@gmx.de \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).