From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Ulrich Mueller Newsgroups: gmane.emacs.bugs 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 Message-ID: References: <83jzqjqfma.fsf@gnu.org> <87leaz9hrv.fsf@gmx.de> <83h6lnq7y7.fsf@gnu.org> <8334x2mh5s.fsf@gnu.org> <83wmu6cg6j.fsf@gnu.org> <8734wuysbx.fsf@gmx.de> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="30144"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: 67012@debbugs.gnu.org, Eli Zaretskii To: Michael Albinus Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sat Nov 25 13:18:27 2023 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1r6rcA-0007bT-N1 for geb-bug-gnu-emacs@m.gmane-mx.org; Sat, 25 Nov 2023 13:18:26 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1r6rbk-0008EI-D0; Sat, 25 Nov 2023 07:18:00 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1r6rbi-0008Dc-23 for bug-gnu-emacs@gnu.org; Sat, 25 Nov 2023 07:17:58 -0500 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1r6rbh-00040L-Pp for bug-gnu-emacs@gnu.org; Sat, 25 Nov 2023 07:17:57 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1r6rbm-0003Ab-EG for bug-gnu-emacs@gnu.org; Sat, 25 Nov 2023 07:18:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Ulrich Mueller Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 25 Nov 2023 12:18:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 67012 X-GNU-PR-Package: emacs Original-Received: via spool by 67012-submit@debbugs.gnu.org id=B67012.170091467412168 (code B ref 67012); Sat, 25 Nov 2023 12:18:02 +0000 Original-Received: (at 67012) by debbugs.gnu.org; 25 Nov 2023 12:17:54 +0000 Original-Received: from localhost ([127.0.0.1]:38058 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1r6rbd-0003AB-VO for submit@debbugs.gnu.org; Sat, 25 Nov 2023 07:17:54 -0500 Original-Received: from woodpecker.gentoo.org ([140.211.166.183]:40092 helo=smtp.gentoo.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1r6rbc-00039w-92 for 67012@debbugs.gnu.org; Sat, 25 Nov 2023 07:17:53 -0500 In-Reply-To: <8734wuysbx.fsf@gmx.de> (Michael Albinus's message of "Sat, 25 Nov 2023 12:40:02 +0100") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.bugs:274964 Archived-At: --=-=-= Content-Type: text/plain >>>>> 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 . 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.) --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=pinentry.el.diff --- 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 ;; 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 . +;; along with GNU Emacs. If not, see . ;;; 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 -;; -;; Merge commit '32b1944d5f0a65aa10c6768f4865f7ed1de8eb49' as -;; 'packages/pinentry' -;; - - (provide 'pinentry) ;;; pinentry.el ends here --=-=-=--