zedhugh/creature
1
0 Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

update pinentry

Browse Source
This commit is contained in:
zedhugh committed 2024-05-28 23:48:10 +08:00
1 parent 1b9cb8683b
commit 386c36ba8a
1 file changed
+148 -93
Download Patch File Download Diff File Expand all files Collapse all files
site-lisp/pinentry.el
+148 -93
View File
@@ -19,16 +19,15 @@
;; GNU General Public License for more details. ;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License ;; 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: ;;; Commentary:
;; This package allows GnuPG passphrase to be prompted through the ;; This package allows GnuPG passphrase to be prompted through the
;; minibuffer instead of graphical dialog. As of June 2015, this ;; minibuffer instead of graphical dialog.
;; feature requires newer versions of GnuPG (2.1.5 or later) and
;; Pinentry (not yet released).
;; ;;
;; 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. ;; start the server with M-x pinentry-start.
;; ;;
;; The actual communication path between the relevant components is ;; The actual communication path between the relevant components is
@@ -41,12 +40,32 @@
;; ;;
;; ${TMPDIR-/tmp}/emacs$(id -u)/pinentry ;; ${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 ;; subset of the Pinentry Assuan protocol described in (info
;; "(pinentry) Protocol"). ;; "(pinentry) Protocol").
;;
;; NOTE: As of August 2015, this feature requires newer versions of
;; GnuPG (2.1.5+) and Pinentry (0.9.5+).
;;; Code: ;;; Code:
(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--server-process nil)
(defvar pinentry--connection-process-list nil) (defvar pinentry--connection-process-list nil)
@@ -55,6 +74,8 @@
(defvar pinentry--read-point nil) (defvar pinentry--read-point nil)
(put 'pinentry--read-point 'permanent-local t) (put 'pinentry--read-point 'permanent-local t)
(defvar pinentry--prompt-buffer nil)
;; We use the same location as `server-socket-dir', when local sockets ;; We use the same location as `server-socket-dir', when local sockets
;; are supported. ;; are supported.
(defvar pinentry--socket-dir (defvar pinentry--socket-dir
@@ -69,7 +90,7 @@ If local sockets are not supported, this is nil.")
;; These error codes are defined in libgpg-error/src/err-codes.h.in. ;; These error codes are defined in libgpg-error/src/err-codes.h.in.
(defmacro pinentry--error-code (code) (defmacro pinentry--error-code (code)
(logior (lsh 5 24) code)) (logior (ash 5 24) code))
(defconst pinentry--error-not-implemented (defconst pinentry--error-not-implemented
(cons (pinentry--error-code 69) "not implemented")) (cons (pinentry--error-code 69) "not implemented"))
(defconst pinentry--error-cancelled (defconst pinentry--error-cancelled
@@ -79,34 +100,90 @@ If local sockets are not supported, this is nil.")
(autoload 'server-ensure-safe-dir "server") (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 ;;;###autoload
(defun pinentry-start () (defun pinentry-start (&optional quiet)
"Start a Pinentry service. "Start a Pinentry service.
Once the environment is properly set, subsequent invocations of 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) (interactive)
(unless (featurep 'make-network-process '(:family local)) (unless (featurep 'make-network-process '(:family local))
(error "local sockets are not supported")) (error "local sockets are not supported"))
(if (process-live-p pinentry--server-process) (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))) (let* ((server-file (expand-file-name "pinentry" pinentry--socket-dir)))
(server-ensure-safe-dir pinentry--socket-dir) (server-ensure-safe-dir pinentry--socket-dir)
;; Delete the socket files made by previous server invocations. ;; Delete the socket files made by previous server invocations.
(ignore-errors (ignore-errors
(let (delete-by-moving-to-trash) (let (delete-by-moving-to-trash)
(delete-file server-file))) (delete-file server-file)))
(setq pinentry--server-process (with-file-modes ?\700
(make-network-process (setq pinentry--server-process
:name "pinentry" (make-network-process
:server t :name "pinentry"
:noquery t :server t
:sentinel #'pinentry--process-sentinel :noquery t
:filter #'pinentry--process-filter :sentinel #'pinentry--process-sentinel
:coding 'no-conversion :filter #'pinentry--process-filter
:family 'local :coding 'no-conversion
:service server-file)) :family 'local
(process-put pinentry--server-process :server-file server-file)))) :service server-file))
(process-put pinentry--server-process :server-file server-file)))))
(defun pinentry-stop () (defun pinentry-stop ()
"Stop a Pinentry service." "Stop a Pinentry service."
@@ -224,6 +301,13 @@ Assuan protocol."
(setq pinentry--read-point (point-min)) (setq pinentry--read-point (point-min))
(make-local-variable 'pinentry--labels)))) (make-local-variable 'pinentry--labels))))
(with-current-buffer (process-buffer process) (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 (save-excursion
(goto-char (point-max)) (goto-char (point-max))
(insert input) (insert input)
@@ -248,32 +332,15 @@ Assuan protocol."
(ignore-errors (ignore-errors
(process-send-string process "OK\n"))) (process-send-string process "OK\n")))
("GETPIN" ("GETPIN"
(let ((prompt (let ((confirm (not (null (assq 'repeat pinentry--labels))))
(or (cdr (assq 'desc pinentry--labels)) passphrase escaped-passphrase encoded-passphrase)
(cdr (assq 'prompt pinentry--labels)) (unwind-protect
"")) (condition-case err
(confirm (not (null (assq 'repeat pinentry--labels)))) (progn
entry) (setq passphrase
(if (setq entry (assq 'error pinentry--labels)) (pinentry--prompt
(setq prompt (concat "Error: " pinentry--labels
(propertize #'read-passwd confirm))
(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))
(setq escaped-passphrase (setq escaped-passphrase
(pinentry--escape-string (pinentry--escape-string
passphrase)) passphrase))
@@ -284,7 +351,8 @@ Assuan protocol."
(pinentry--send-data (pinentry--send-data
process encoded-passphrase) process encoded-passphrase)
(process-send-string process "OK\n"))) (process-send-string process "OK\n")))
(error (error
(message "GETPIN error %S" err)
(ignore-errors (ignore-errors
(pinentry--send-error (pinentry--send-error
process process
@@ -295,59 +363,55 @@ Assuan protocol."
(clear-string escaped-passphrase)) (clear-string escaped-passphrase))
(if encoded-passphrase (if encoded-passphrase
(clear-string encoded-passphrase)))) (clear-string encoded-passphrase))))
(setq pinentry--labels nil))) (setq pinentry--labels nil))
("CONFIRM" ("CONFIRM"
(let ((prompt (let ((prompt
(or (cdr (assq 'desc pinentry--labels)) (or (cdr (assq 'prompt pinentry--labels))
"")) "Confirm? "))
(buttons (buttons
(pinentry--labels-to-shortcuts (delq nil
(list (cdr (assq 'ok pinentry--labels)) (pinentry--labels-to-shortcuts
(cdr (assq 'notok pinentry--labels)) (list (cdr (assq 'ok pinentry--labels))
(cdr (assq 'cancel pinentry--labels))))) (cdr (assq 'notok pinentry--labels))
(cdr (assq 'cancel pinentry--labels))))))
entry) entry)
(if (setq entry (assq 'error pinentry--labels)) (if buttons
(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)
(progn (progn
(setq prompt (setq prompt
(concat 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 (condition-case nil
(let ((result (read-char prompt))) (let ((result (pinentry--prompt pinentry--labels
#'read-char)))
(if (eq result (caar buttons)) (if (eq result (caar buttons))
(ignore-errors (ignore-errors
(process-send-string process "OK\n")) (process-send-string process "OK\n"))
(if (eq result (car (nth 1 buttons))) (if (eq result (car (nth 1 buttons)))
(ignore-errors (ignore-errors
(pinentry--send-error (pinentry--send-error
process process
pinentry--error-not-confirmed)) pinentry--error-not-confirmed))
(ignore-errors (ignore-errors
(pinentry--send-error (pinentry--send-error
process process
pinentry--error-cancelled))))) pinentry--error-cancelled)))))
(error (error
(ignore-errors (ignore-errors
(pinentry--send-error (pinentry--send-error
process process
pinentry--error-cancelled))))) pinentry--error-cancelled)))))
(if (string-match "[ \n]*\\'" prompt) (if (setq entry (assq 'prompt pinentry--labels))
(setq prompt (concat (setcdr entry prompt)
(substring (setq pinentry--labels (cons (cons 'prompt prompt)
prompt 0 (match-beginning 0)) " "))) pinentry--labels)))
(if (condition-case nil (if (condition-case nil
(y-or-n-p prompt) (pinentry--prompt pinentry--labels #'y-or-n-p)
(quit)) (quit))
(ignore-errors (ignore-errors
(process-send-string process "OK\n")) (process-send-string process "OK\n"))
@@ -389,15 +453,6 @@ Assuan protocol."
(ignore-errors (ignore-errors
(delete-file (process-get process :server-file))))) (delete-file (process-get process :server-file)))))
;;;; ChangeLog:
;; 2015-06-12 Daiki Ueno <ueno@gnu.org>
;;
;; Merge commit '32b1944d5f0a65aa10c6768f4865f7ed1de8eb49' as
;; 'packages/pinentry'
;;
(provide 'pinentry) (provide 'pinentry)
;;; pinentry.el ends here ;;; pinentry.el ends here