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 June 2015, this feature requires newer versions of
47 ;; GnuPG (2.1.5+) and Pinentry (not yet released, possibly 0.9.5+).
48 ;; For details, see the discussion on gnupg-devel mailing list:
49 ;; <https://lists.gnupg.org/pipermail/gnupg-devel/2015-May/029875.html>.
53 (defvar pinentry--server-process nil)
54 (defvar pinentry--connection-process-list nil)
56 (defvar pinentry--labels nil)
57 (put 'pinentry-read-point 'permanent-local t)
58 (defvar pinentry--read-point nil)
59 (put 'pinentry--read-point 'permanent-local t)
61 ;; We use the same location as `server-socket-dir', when local sockets
63 (defvar pinentry--socket-dir
64 (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))
65 "The directory in which to place the server socket.
66 If local sockets are not supported, this is nil.")
68 (defconst pinentry--set-label-commands
69 '("SETPROMPT" "SETTITLE" "SETDESC"
70 "SETREPEAT" "SETREPEATERROR"
71 "SETOK" "SETCANCEL" "SETNOTOK"))
73 ;; These error codes are defined in libgpg-error/src/err-codes.h.in.
74 (defmacro pinentry--error-code (code)
75 (logior (lsh 5 24) code))
76 (defconst pinentry--error-not-implemented
77 (cons (pinentry--error-code 69) "not implemented"))
78 (defconst pinentry--error-cancelled
79 (cons (pinentry--error-code 99) "cancelled"))
80 (defconst pinentry--error-not-confirmed
81 (cons (pinentry--error-code 114) "not confirmed"))
83 (autoload 'server-ensure-safe-dir "server")
86 (defun pinentry-start ()
87 "Start a Pinentry service.
89 Once the environment is properly set, subsequent invocations of
90 the gpg command will interact with Emacs for passphrase input."
92 (unless (featurep 'make-network-process '(:family local))
93 (error "local sockets are not supported"))
94 (if (process-live-p pinentry--server-process)
95 (message "Pinentry service is already running")
96 (let* ((server-file (expand-file-name "pinentry" pinentry--socket-dir)))
97 (server-ensure-safe-dir pinentry--socket-dir)
98 ;; Delete the socket files made by previous server invocations.
100 (let (delete-by-moving-to-trash)
101 (delete-file server-file)))
102 (setq pinentry--server-process
103 (make-network-process
107 :sentinel #'pinentry--process-sentinel
108 :filter #'pinentry--process-filter
109 :coding 'no-conversion
111 :service server-file))
112 (process-put pinentry--server-process :server-file server-file))))
114 (defun pinentry-stop ()
115 "Stop a Pinentry service."
117 (when (process-live-p pinentry--server-process)
118 (delete-process pinentry--server-process))
119 (setq pinentry--server-process nil)
120 (dolist (process pinentry--connection-process-list)
121 (when (buffer-live-p (process-buffer process))
122 (kill-buffer (process-buffer process))))
123 (setq pinentry--connection-process-list nil))
125 (defun pinentry--labels-to-shortcuts (labels)
126 "Convert strings in LABEL by stripping mnemonics."
127 (mapcar (lambda (label)
130 (if (string-match "\\(?:\\`\\|[^_]\\)_\\([[:alnum:]]\\)" label)
131 (let ((key (match-string 1 label)))
132 (setq c (downcase (aref key 0)))
133 (setq label (replace-match
134 (propertize key 'face 'underline)
136 (setq c (if (= (length label) 0)
138 (downcase (aref label 0)))))
139 ;; Double underscores mean a single underscore.
140 (when (string-match "__" label)
141 (setq label (replace-match "_" t t label)))
145 (defun pinentry--escape-string (string)
146 "Escape STRING in the Assuan percent escape."
147 (let ((length (length string))
150 (while (< index length)
151 (if (memq (aref string index) '(?\n ?\r ?%))
152 (setq count (1+ count)))
153 (setq index (1+ index)))
155 (let ((result (make-string (+ length (* count 2)) ?\0))
158 (while (< index length)
159 (setq c (aref string index))
160 (if (memq c '(?\n ?\r ?%))
161 (let ((hex (format "%02X" c)))
162 (aset result result-index ?%)
163 (setq result-index (1+ result-index))
164 (aset result result-index (aref hex 0))
165 (setq result-index (1+ result-index))
166 (aset result result-index (aref hex 1))
167 (setq result-index (1+ result-index)))
168 (aset result result-index c)
169 (setq result-index (1+ result-index)))
170 (setq index (1+ index)))
173 (defun pinentry--unescape-string (string)
174 "Unescape STRING in the Assuan percent escape."
175 (let ((length (length string))
177 (let ((result (make-string length ?\0))
180 (while (< index length)
181 (setq c (aref string index))
182 (if (and (eq c '?%) (< (+ index 2) length))
184 (aset result result-index
185 (string-to-number (substring string
189 (setq result-index (1+ result-index))
190 (setq index (+ index 2)))
191 (aset result result-index c)
192 (setq result-index (1+ result-index)))
193 (setq index (1+ index)))
194 (substring result 0 result-index))))
196 (defun pinentry--send-data (process escaped)
197 "Send a string ESCAPED to a process PROCESS.
198 ESCAPED will be split if it exceeds the line length limit of the
200 (let ((length (length escaped))
203 (process-send-string process "D \n")
204 (while (< index length)
205 ;; 997 = ASSUAN_LINELENGTH (= 1000) - strlen ("D \n")
206 (let* ((sub-length (min (- length index) 997))
207 (sub (substring escaped index (+ index sub-length))))
210 (process-send-string process "D ")
211 (process-send-string process sub)
212 (process-send-string process "\n"))
214 (setq index (+ index sub-length)))))))
216 (defun pinentry--send-error (process error)
217 (process-send-string process (format "ERR %d %s\n" (car error) (cdr error))))
219 (defun pinentry--process-filter (process input)
220 (unless (buffer-live-p (process-buffer process))
221 (let ((buffer (generate-new-buffer " *pinentry*")))
222 (set-process-buffer process buffer)
223 (with-current-buffer buffer
224 (if (fboundp 'set-buffer-multibyte)
225 (set-buffer-multibyte nil))
226 (make-local-variable 'pinentry--read-point)
227 (setq pinentry--read-point (point-min))
228 (make-local-variable 'pinentry--labels))))
229 (with-current-buffer (process-buffer process)
231 (goto-char (point-max))
233 (goto-char pinentry--read-point)
235 (while (looking-at ".*\n") ;the input line finished
236 (if (looking-at "\\([A-Z_]+\\) ?\\(.*\\)")
237 (let ((command (match-string 1))
238 (string (pinentry--unescape-string (match-string 2))))
240 ((and set (guard (member set pinentry--set-label-commands)))
241 (when (> (length string) 0)
242 (let* ((symbol (intern (downcase (substring set 3))))
243 (entry (assq symbol pinentry--labels))
244 (label (decode-coding-string string 'utf-8)))
247 (push (cons symbol label) pinentry--labels))))
249 (process-send-string process "OK\n")))
252 (process-send-string process "OK\n")))
255 (or (cdr (assq 'desc pinentry--labels))
256 (cdr (assq 'prompt pinentry--labels))
258 (confirm (not (null (assq 'repeat pinentry--labels))))
260 (if (setq entry (assq 'error pinentry--labels))
261 (setq prompt (concat "Error: "
263 (copy-sequence (cdr entry))
267 (if (setq entry (assq 'title pinentry--labels))
268 (setq prompt (format "[%s] %s"
269 (cdr entry) prompt)))
270 (if (string-match ":?[ \n]*\\'" prompt)
273 prompt 0 (match-beginning 0)) ": ")))
274 (let (passphrase escaped-passphrase encoded-passphrase)
279 (read-passwd prompt confirm))
280 (setq escaped-passphrase
281 (pinentry--escape-string
283 (setq encoded-passphrase (encode-coding-string
288 process encoded-passphrase)
289 (process-send-string process "OK\n")))
292 (pinentry--send-error
294 pinentry--error-cancelled))))
296 (clear-string passphrase))
297 (if escaped-passphrase
298 (clear-string escaped-passphrase))
299 (if encoded-passphrase
300 (clear-string encoded-passphrase))))
301 (setq pinentry--labels nil)))
304 (or (cdr (assq 'desc pinentry--labels))
307 (pinentry--labels-to-shortcuts
308 (list (cdr (assq 'ok pinentry--labels))
309 (cdr (assq 'notok pinentry--labels))
310 (cdr (assq 'cancel pinentry--labels)))))
312 (if (setq entry (assq 'error pinentry--labels))
313 (setq prompt (concat "Error: "
315 (copy-sequence (cdr entry))
319 (if (setq entry (assq 'title pinentry--labels))
320 (setq prompt (format "[%s] %s"
321 (cdr entry) prompt)))
322 (if (remq nil buttons)
326 (mapconcat #'cdr (remq nil buttons)
330 (let ((result (read-char prompt)))
331 (if (eq result (caar buttons))
333 (process-send-string process "OK\n"))
334 (if (eq result (car (nth 1 buttons)))
336 (pinentry--send-error
338 pinentry--error-not-confirmed))
340 (pinentry--send-error
342 pinentry--error-cancelled)))))
345 (pinentry--send-error
347 pinentry--error-cancelled)))))
348 (if (string-match "[ \n]*\\'" prompt)
351 prompt 0 (match-beginning 0)) " ")))
352 (if (condition-case nil
356 (process-send-string process "OK\n"))
358 (pinentry--send-error
360 pinentry--error-not-confirmed))))
361 (setq pinentry--labels nil)))
363 (pinentry--send-error
365 pinentry--error-not-implemented))))
367 (setq pinentry--read-point (point))))))))
369 (defun pinentry--process-sentinel (process _status)
370 "The process sentinel for Emacs server connections."
371 ;; If this is a new client process, set the query-on-exit flag to nil
372 ;; for this process (it isn't inherited from the server process).
373 (when (and (eq (process-status process) 'open)
374 (process-query-on-exit-flag process))
375 (push process pinentry--connection-process-list)
376 (set-process-query-on-exit-flag process nil)
378 (process-send-string process "OK Your orders please\n")))
379 ;; Kill the process buffer of the connection process.
380 (when (and (not (process-contact process :server))
381 (eq (process-status process) 'closed))
382 (when (buffer-live-p (process-buffer process))
383 (kill-buffer (process-buffer process)))
384 (setq pinentry--connection-process-list
385 (delq process pinentry--connection-process-list)))
386 ;; Delete the associated connection file, if applicable.
387 ;; Although there's no 100% guarantee that the file is owned by the
388 ;; running Emacs instance, server-start uses server-running-p to check
389 ;; for possible servers before doing anything, so it *should* be ours.
390 (and (process-contact process :server)
391 (eq (process-status process) 'closed)
393 (delete-file (process-get process :server-file)))))
397 ;;; pinentry.el ends here