1 ;;; pinentry.el --- GnuPG Pinentry server implementation -*- lexical-binding: t -*-
3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
5 ;; Author: Daiki Ueno <ueno@gnu.org>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; This package allows GnuPG passphrase to be prompted through the
27 ;; minibuffer instead of graphical dialog.
29 ;; To use, add allow-emacs-pinentry to ~/.gnupg/gpg-agent.conf, and
30 ;; start the server with M-x pinentry-start.
32 ;; The actual communication path between the relevant components is
35 ;; gpg --> gpg-agent --> pinentry --> Emacs
37 ;; where pinentry and Emacs communicate through a Unix domain socket
40 ;; ${TMPDIR-/tmp}/emacs$(id -u)/pinentry
42 ;; under the same directory which server.el uses. The protocol is a
43 ;; subset of the Pinentry Assuan protocol described in (info
44 ;; "(pinentry) Protocol").
46 ;; NOTE: As of August 2015, this feature requires newer versions of
47 ;; GnuPG (2.1.5+) and Pinentry (0.9.5+).
51 (defgroup pinentry nil
56 (defcustom pinentry-popup-prompt-window t
57 "If non-nil, display multiline prompt in another window."
61 (defcustom pinentry-prompt-window-height
5
62 "Number of lines used to display multiline prompt."
66 (defvar pinentry-debug nil
)
67 (defvar pinentry-debug-buffer nil
)
68 (defvar pinentry--server-process nil
)
69 (defvar pinentry--connection-process-list nil
)
71 (defvar pinentry--labels nil
)
72 (put 'pinentry-read-point
'permanent-local t
)
73 (defvar pinentry--read-point nil
)
74 (put 'pinentry--read-point
'permanent-local t
)
76 (defvar pinentry--prompt-buffer nil
)
78 ;; We use the same location as `server-socket-dir', when local sockets
80 (defvar pinentry--socket-dir
81 (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))
82 "The directory in which to place the server socket.
83 If local sockets are not supported, this is nil.")
85 (defconst pinentry--set-label-commands
86 '("SETPROMPT" "SETTITLE" "SETDESC"
87 "SETREPEAT" "SETREPEATERROR"
88 "SETOK" "SETCANCEL" "SETNOTOK"))
90 ;; These error codes are defined in libgpg-error/src/err-codes.h.in.
91 (defmacro pinentry--error-code
(code)
92 (logior (lsh 5 24) code
))
93 (defconst pinentry--error-not-implemented
94 (cons (pinentry--error-code 69) "not implemented"))
95 (defconst pinentry--error-cancelled
96 (cons (pinentry--error-code 99) "cancelled"))
97 (defconst pinentry--error-not-confirmed
98 (cons (pinentry--error-code 114) "not confirmed"))
100 (autoload 'server-ensure-safe-dir
"server")
102 (defvar pinentry-prompt-mode-map
103 (let ((keymap (make-sparse-keymap)))
104 (define-key keymap
"q" 'quit-window
)
107 (define-derived-mode pinentry-prompt-mode special-mode
"Pinentry"
108 "Major mode for `pinentry--prompt-buffer'."
109 (buffer-disable-undo)
110 (setq truncate-lines t
113 (defun pinentry--prompt (labels query-function
&rest query-args
)
114 (let ((desc (cdr (assq 'desc labels
)))
115 (error (cdr (assq 'error labels
)))
116 (prompt (cdr (assq 'prompt labels
))))
117 (when (string-match "[ \n]*\\'" prompt
)
120 prompt
0 (match-beginning 0)) " ")))
122 (setq desc
(concat "Error: " (propertize error
'face
'error
)
124 (if (and desc pinentry-popup-prompt-window
)
125 (save-window-excursion
126 (delete-other-windows)
127 (unless (and pinentry--prompt-buffer
128 (buffer-live-p pinentry--prompt-buffer
))
129 (setq pinentry--prompt-buffer
(generate-new-buffer "*Pinentry*")))
130 (if (get-buffer-window pinentry--prompt-buffer
)
131 (delete-window (get-buffer-window pinentry--prompt-buffer
)))
132 (with-current-buffer pinentry--prompt-buffer
133 (let ((inhibit-read-only t
)
137 (pinentry-prompt-mode)
138 (goto-char (point-min)))
139 (if (> (window-height)
140 pinentry-prompt-window-height
)
141 (set-window-buffer (split-window nil
143 pinentry-prompt-window-height
))
144 pinentry--prompt-buffer
)
145 (pop-to-buffer pinentry--prompt-buffer
)
146 (if (> (window-height) pinentry-prompt-window-height
)
147 (shrink-window (- (window-height)
148 pinentry-prompt-window-height
))))
149 (prog1 (apply query-function prompt query-args
)
151 (apply query-function
(concat desc
"\n" prompt
) query-args
))))
154 (defun pinentry-start (&optional quiet
)
155 "Start a Pinentry service.
157 Once the environment is properly set, subsequent invocations of
158 the gpg command will interact with Emacs for passphrase input.
160 If the optional QUIET argument is non-nil, messages at startup
163 (unless (featurep 'make-network-process
'(:family local
))
164 (error "local sockets are not supported"))
165 (if (process-live-p pinentry--server-process
)
167 (message "Pinentry service is already running"))
168 (let* ((server-file (expand-file-name "pinentry" pinentry--socket-dir
)))
169 (server-ensure-safe-dir pinentry--socket-dir
)
170 ;; Delete the socket files made by previous server invocations.
172 (let (delete-by-moving-to-trash)
173 (delete-file server-file
)))
174 (setq pinentry--server-process
175 (make-network-process
179 :sentinel
#'pinentry--process-sentinel
180 :filter
#'pinentry--process-filter
181 :coding
'no-conversion
183 :service server-file
))
184 (process-put pinentry--server-process
:server-file server-file
))))
186 (defun pinentry-stop ()
187 "Stop a Pinentry service."
189 (when (process-live-p pinentry--server-process
)
190 (delete-process pinentry--server-process
))
191 (setq pinentry--server-process nil
)
192 (dolist (process pinentry--connection-process-list
)
193 (when (buffer-live-p (process-buffer process
))
194 (kill-buffer (process-buffer process
))))
195 (setq pinentry--connection-process-list nil
))
197 (defun pinentry--labels-to-shortcuts (labels)
198 "Convert strings in LABEL by stripping mnemonics."
199 (mapcar (lambda (label)
202 (if (string-match "\\(?:\\`\\|[^_]\\)_\\([[:alnum:]]\\)" label
)
203 (let ((key (match-string 1 label
)))
204 (setq c
(downcase (aref key
0)))
205 (setq label
(replace-match
206 (propertize key
'face
'underline
)
208 (setq c
(if (= (length label
) 0)
210 (downcase (aref label
0)))))
211 ;; Double underscores mean a single underscore.
212 (when (string-match "__" label
)
213 (setq label
(replace-match "_" t t label
)))
217 (defun pinentry--escape-string (string)
218 "Escape STRING in the Assuan percent escape."
219 (let ((length (length string
))
222 (while (< index length
)
223 (if (memq (aref string index
) '(?
\n ?
\r ?%
))
224 (setq count
(1+ count
)))
225 (setq index
(1+ index
)))
227 (let ((result (make-string (+ length
(* count
2)) ?\
0))
230 (while (< index length
)
231 (setq c
(aref string index
))
232 (if (memq c
'(?
\n ?
\r ?%
))
233 (let ((hex (format "%02X" c
)))
234 (aset result result-index ?%
)
235 (setq result-index
(1+ result-index
))
236 (aset result result-index
(aref hex
0))
237 (setq result-index
(1+ result-index
))
238 (aset result result-index
(aref hex
1))
239 (setq result-index
(1+ result-index
)))
240 (aset result result-index c
)
241 (setq result-index
(1+ result-index
)))
242 (setq index
(1+ index
)))
245 (defun pinentry--unescape-string (string)
246 "Unescape STRING in the Assuan percent escape."
247 (let ((length (length string
))
249 (let ((result (make-string length ?\
0))
252 (while (< index length
)
253 (setq c
(aref string index
))
254 (if (and (eq c
'?%
) (< (+ index
2) length
))
256 (aset result result-index
257 (string-to-number (substring string
261 (setq result-index
(1+ result-index
))
262 (setq index
(+ index
2)))
263 (aset result result-index c
)
264 (setq result-index
(1+ result-index
)))
265 (setq index
(1+ index
)))
266 (substring result
0 result-index
))))
268 (defun pinentry--send-data (process escaped
)
269 "Send a string ESCAPED to a process PROCESS.
270 ESCAPED will be split if it exceeds the line length limit of the
272 (let ((length (length escaped
))
275 (process-send-string process
"D \n")
276 (while (< index length
)
277 ;; 997 = ASSUAN_LINELENGTH (= 1000) - strlen ("D \n")
278 (let* ((sub-length (min (- length index
) 997))
279 (sub (substring escaped index
(+ index sub-length
))))
282 (process-send-string process
"D ")
283 (process-send-string process sub
)
284 (process-send-string process
"\n"))
286 (setq index
(+ index sub-length
)))))))
288 (defun pinentry--send-error (process error
)
289 (process-send-string process
(format "ERR %d %s\n" (car error
) (cdr error
))))
291 (defun pinentry--process-filter (process input
)
292 (unless (buffer-live-p (process-buffer process
))
293 (let ((buffer (generate-new-buffer " *pinentry*")))
294 (set-process-buffer process buffer
)
295 (with-current-buffer buffer
296 (if (fboundp 'set-buffer-multibyte
)
297 (set-buffer-multibyte nil
))
298 (make-local-variable 'pinentry--read-point
)
299 (setq pinentry--read-point
(point-min))
300 (make-local-variable 'pinentry--labels
))))
301 (with-current-buffer (process-buffer process
)
304 (or pinentry-debug-buffer
305 (setq pinentry-debug-buffer
(generate-new-buffer
306 " *pinentry-debug*")))
307 (goto-char (point-max))
310 (goto-char (point-max))
312 (goto-char pinentry--read-point
)
314 (while (looking-at ".*\n") ;the input line finished
315 (if (looking-at "\\([A-Z_]+\\) ?\\(.*\\)")
316 (let ((command (match-string 1))
317 (string (pinentry--unescape-string (match-string 2))))
319 ((and set
(guard (member set pinentry--set-label-commands
)))
320 (when (> (length string
) 0)
321 (let* ((symbol (intern (downcase (substring set
3))))
322 (entry (assq symbol pinentry--labels
))
323 (label (decode-coding-string string
'utf-8
)))
326 (push (cons symbol label
) pinentry--labels
))))
328 (process-send-string process
"OK\n")))
331 (process-send-string process
"OK\n")))
333 (let ((confirm (not (null (assq 'repeat pinentry--labels
))))
334 passphrase escaped-passphrase encoded-passphrase
)
341 #'read-passwd confirm
))
342 (setq escaped-passphrase
343 (pinentry--escape-string
345 (setq encoded-passphrase
(encode-coding-string
350 process encoded-passphrase
)
351 (process-send-string process
"OK\n")))
353 (message "GETPIN error %S" err
)
355 (pinentry--send-error
357 pinentry--error-cancelled
))))
359 (clear-string passphrase
))
360 (if escaped-passphrase
361 (clear-string escaped-passphrase
))
362 (if encoded-passphrase
363 (clear-string encoded-passphrase
))))
364 (setq pinentry--labels nil
))
367 (or (cdr (assq 'prompt pinentry--labels
))
371 (pinentry--labels-to-shortcuts
372 (list (cdr (assq 'ok pinentry--labels
))
373 (cdr (assq 'notok pinentry--labels
))
374 (cdr (assq 'cancel pinentry--labels
))))))
380 (mapconcat #'cdr buttons
383 (if (setq entry
(assq 'prompt pinentry--labels
))
384 (setcdr entry prompt
)
385 (setq pinentry--labels
(cons (cons 'prompt prompt
)
388 (let ((result (pinentry--prompt pinentry--labels
390 (if (eq result
(caar buttons
))
392 (process-send-string process
"OK\n"))
393 (if (eq result
(car (nth 1 buttons
)))
395 (pinentry--send-error
397 pinentry--error-not-confirmed
))
399 (pinentry--send-error
401 pinentry--error-cancelled
)))))
404 (pinentry--send-error
406 pinentry--error-cancelled
)))))
407 (if (setq entry
(assq 'prompt pinentry--labels
))
408 (setcdr entry prompt
)
409 (setq pinentry--labels
(cons (cons 'prompt prompt
)
411 (if (condition-case nil
412 (pinentry--prompt pinentry--labels
#'y-or-n-p
)
415 (process-send-string process
"OK\n"))
417 (pinentry--send-error
419 pinentry--error-not-confirmed
))))
420 (setq pinentry--labels nil
)))
422 (pinentry--send-error
424 pinentry--error-not-implemented
))))
426 (setq pinentry--read-point
(point))))))))
428 (defun pinentry--process-sentinel (process _status
)
429 "The process sentinel for Emacs server connections."
430 ;; If this is a new client process, set the query-on-exit flag to nil
431 ;; for this process (it isn't inherited from the server process).
432 (when (and (eq (process-status process
) 'open
)
433 (process-query-on-exit-flag process
))
434 (push process pinentry--connection-process-list
)
435 (set-process-query-on-exit-flag process nil
)
437 (process-send-string process
"OK Your orders please\n")))
438 ;; Kill the process buffer of the connection process.
439 (when (and (not (process-contact process
:server
))
440 (eq (process-status process
) 'closed
))
441 (when (buffer-live-p (process-buffer process
))
442 (kill-buffer (process-buffer process
)))
443 (setq pinentry--connection-process-list
444 (delq process pinentry--connection-process-list
)))
445 ;; Delete the associated connection file, if applicable.
446 ;; Although there's no 100% guarantee that the file is owned by the
447 ;; running Emacs instance, server-start uses server-running-p to check
448 ;; for possible servers before doing anything, so it *should* be ours.
449 (and (process-contact process
:server
)
450 (eq (process-status process
) 'closed
)
452 (delete-file (process-get process
:server-file
)))))
456 ;;; pinentry.el ends here