lisp/net/pinentry.el

   1 ;;; pinentry.el --- GnuPG Pinentry server implementation -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Daiki Ueno <ueno@gnu.org>
   6 ;; Version: 0.1
   7 ;; Keywords: GnuPG
   8
   9 ;; This file is part of GNU Emacs.
  10
  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.
  15
  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.
  20
  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/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This package allows GnuPG passphrase to be prompted through the
  27 ;; minibuffer instead of graphical dialog.
  28 ;;
  29 ;; To use, add "allow-emacs-pinentry" to "~/.gnupg/gpg-agent.conf",
  30 ;; reload the configuration with "gpgconf --reload gpg-agent", and
  31 ;; start the server with M-x pinentry-start.
  32 ;;
  33 ;; The actual communication path between the relevant components is
  34 ;; as follows:
  35 ;;
  36 ;;   gpg --> gpg-agent --> pinentry --> Emacs
  37 ;;
  38 ;; where pinentry and Emacs communicate through a Unix domain socket
  39 ;; created at:
  40 ;;
  41 ;;   ${TMPDIR-/tmp}/emacs$(id -u)/pinentry
  42 ;;
  43 ;; under the same directory which server.el uses.  The protocol is a
  44 ;; subset of the Pinentry Assuan protocol described in (info
  45 ;; "(pinentry) Protocol").
  46 ;;
  47 ;; NOTE: As of August 2015, this feature requires newer versions of
  48 ;; GnuPG (2.1.5+) and Pinentry (0.9.5+).
  49
  50 ;;; Code:
  51
  52 (eval-when-compile (require 'cl-lib))
  53
  54 (defgroup pinentry nil
  55   "The Pinentry server"
  56   :version "25.1"
  57   :group 'external)
  58
  59 (defcustom pinentry-popup-prompt-window t
  60   "If non-nil, display multiline prompt in another window."
  61   :type 'boolean
  62   :group 'pinentry)
  63
  64 (defcustom pinentry-prompt-window-height 5
  65   "Number of lines used to display multiline prompt."
  66   :type 'integer
  67   :group 'pinentry)
  68
  69 (defvar pinentry-debug nil)
  70 (defvar pinentry-debug-buffer nil)
  71 (defvar pinentry--server-process nil)
  72 (defvar pinentry--connection-process-list nil)
  73
  74 (defvar pinentry--labels nil)
  75 (put 'pinentry-read-point 'permanent-local t)
  76 (defvar pinentry--read-point nil)
  77 (put 'pinentry--read-point 'permanent-local t)
  78
  79 (defvar pinentry--prompt-buffer nil)
  80
  81 ;; We use the same location as `server-socket-dir', when local sockets
  82 ;; are supported.
  83 (defvar pinentry--socket-dir
  84   (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))
  85   "The directory in which to place the server socket.
  86 If local sockets are not supported, this is nil.")
  87
  88 (defconst pinentry--set-label-commands
  89   '("SETPROMPT" "SETTITLE" "SETDESC"
  90     "SETREPEAT" "SETREPEATERROR"
  91     "SETOK" "SETCANCEL" "SETNOTOK"))
  92
  93 ;; These error codes are defined in libgpg-error/src/err-codes.h.in.
  94 (defmacro pinentry--error-code (code)
  95   (logior (lsh 5 24) code))
  96 (defconst pinentry--error-not-implemented
  97   (cons (pinentry--error-code 69) "not implemented"))
  98 (defconst pinentry--error-cancelled
  99   (cons (pinentry--error-code 99) "cancelled"))
 100 (defconst pinentry--error-not-confirmed
 101   (cons (pinentry--error-code 114) "not confirmed"))
 102
 103 (autoload 'server-ensure-safe-dir "server")
 104
 105 (defvar pinentry-prompt-mode-map
 106   (let ((keymap (make-sparse-keymap)))
 107     (define-key keymap "q" 'quit-window)
 108     keymap))
 109
 110 (define-derived-mode pinentry-prompt-mode special-mode "Pinentry"
 111   "Major mode for `pinentry--prompt-buffer'."
 112   (buffer-disable-undo)
 113   (setq truncate-lines t
 114         buffer-read-only t))
 115
 116 (defun pinentry--prompt (labels query-function &rest query-args)
 117   (let ((desc (cdr (assq 'desc labels)))
 118         (error (cdr (assq 'error labels)))
 119         (prompt (cdr (assq 'prompt labels))))
 120     (when (string-match "[ \n]*\\'" prompt)
 121       (setq prompt (concat
 122                     (substring
 123                      prompt 0 (match-beginning 0)) " ")))
 124     (when error
 125       (setq desc (concat "Error: " (propertize error 'face 'error)
 126                          "\n" desc)))
 127     (if (and desc pinentry-popup-prompt-window)
 128       (save-window-excursion
 129         (delete-other-windows)
 130         (unless (and pinentry--prompt-buffer
 131                      (buffer-live-p pinentry--prompt-buffer))
 132           (setq pinentry--prompt-buffer (generate-new-buffer "*Pinentry*")))
 133         (if (get-buffer-window pinentry--prompt-buffer)
 134             (delete-window (get-buffer-window pinentry--prompt-buffer)))
 135         (with-current-buffer pinentry--prompt-buffer
 136           (let ((inhibit-read-only t)
 137                 buffer-read-only)
 138             (erase-buffer)
 139             (insert desc))
 140           (pinentry-prompt-mode)
 141           (goto-char (point-min)))
 142         (if (> (window-height)
 143                pinentry-prompt-window-height)
 144             (set-window-buffer (split-window nil
 145                                              (- (window-height)
 146                                                 pinentry-prompt-window-height))
 147                                pinentry--prompt-buffer)
 148           (pop-to-buffer pinentry--prompt-buffer)
 149           (if (> (window-height) pinentry-prompt-window-height)
 150               (shrink-window (- (window-height)
 151                                 pinentry-prompt-window-height))))
 152         (prog1 (apply query-function prompt query-args)
 153           (quit-window)))
 154       (apply query-function (concat desc "\n" prompt) query-args))))
 155
 156 ;;;###autoload
 157 (defun pinentry-start (&optional quiet)
 158   "Start a Pinentry service.
 159
 160 Once the environment is properly set, subsequent invocations of
 161 the gpg command will interact with Emacs for passphrase input.
 162
 163 If the optional QUIET argument is non-nil, messages at startup
 164 will not be shown."
 165   (interactive)
 166   (unless (featurep 'make-network-process '(:family local))
 167     (error "local sockets are not supported"))
 168   (if (process-live-p pinentry--server-process)
 169       (unless quiet
 170         (message "Pinentry service is already running"))
 171     (let* ((server-file (expand-file-name "pinentry" pinentry--socket-dir)))
 172       (server-ensure-safe-dir pinentry--socket-dir)
 173       ;; Delete the socket files made by previous server invocations.
 174       (ignore-errors
 175         (let (delete-by-moving-to-trash)
 176           (delete-file server-file)))
 177       (cl-letf (((default-file-modes) ?\700))
 178         (setq pinentry--server-process
 179               (make-network-process
 180                :name "pinentry"
 181                :server t
 182                :noquery t
 183                :sentinel #'pinentry--process-sentinel
 184                :filter #'pinentry--process-filter
 185                :coding 'no-conversion
 186                :family 'local
 187                :service server-file))
 188         (process-put pinentry--server-process :server-file server-file)))))
 189
 190 (defun pinentry-stop ()
 191   "Stop a Pinentry service."
 192   (interactive)
 193   (when (process-live-p pinentry--server-process)
 194     (delete-process pinentry--server-process))
 195   (setq pinentry--server-process nil)
 196   (dolist (process pinentry--connection-process-list)
 197     (when (buffer-live-p (process-buffer process))
 198       (kill-buffer (process-buffer process))))
 199   (setq pinentry--connection-process-list nil))
 200
 201 (defun pinentry--labels-to-shortcuts (labels)
 202   "Convert strings in LABEL by stripping mnemonics."
 203   (mapcar (lambda (label)
 204             (when label
 205               (let (c)
 206                 (if (string-match "\\(?:\\`\\|[^_]\\)_\\([[:alnum:]]\\)" label)
 207                     (let ((key (match-string 1 label)))
 208                       (setq c (downcase (aref key 0)))
 209                       (setq label (replace-match
 210                                    (propertize key 'face 'underline)
 211                                    t t label)))
 212                   (setq c (if (= (length label) 0)
 213                               ??
 214                             (downcase (aref label 0)))))
 215                 ;; Double underscores mean a single underscore.
 216                 (when (string-match "__" label)
 217                   (setq label (replace-match "_" t t label)))
 218                 (cons c label))))
 219           labels))
 220
 221 (defun pinentry--escape-string (string)
 222   "Escape STRING in the Assuan percent escape."
 223   (let ((length (length string))
 224         (index 0)
 225         (count 0))
 226     (while (< index length)
 227       (if (memq (aref string index) '(?\n ?\r ?%))
 228           (setq count (1+ count)))
 229       (setq index (1+ index)))
 230     (setq index 0)
 231     (let ((result (make-string (+ length (* count 2)) ?\0))
 232           (result-index 0)
 233           c)
 234       (while (< index length)
 235         (setq c (aref string index))
 236         (if (memq c '(?\n ?\r ?%))
 237             (let ((hex (format "%02X" c)))
 238               (aset result result-index ?%)
 239               (setq result-index (1+ result-index))
 240               (aset result result-index (aref hex 0))
 241               (setq result-index (1+ result-index))
 242               (aset result result-index (aref hex 1))
 243               (setq result-index (1+ result-index)))
 244           (aset result result-index c)
 245           (setq result-index (1+ result-index)))
 246         (setq index (1+ index)))
 247       result)))
 248
 249 (defun pinentry--unescape-string (string)
 250   "Unescape STRING in the Assuan percent escape."
 251   (let ((length (length string))
 252         (index 0))
 253     (let ((result (make-string length ?\0))
 254           (result-index 0)
 255           c)
 256       (while (< index length)
 257         (setq c (aref string index))
 258         (if (and (eq c '?%) (< (+ index 2) length))
 259             (progn
 260               (aset result result-index
 261                     (string-to-number (substring string
 262                                                  (1+ index)
 263                                                  (+ index 3))
 264                                       16))
 265               (setq result-index (1+ result-index))
 266               (setq index (+ index 2)))
 267           (aset result result-index c)
 268           (setq result-index (1+ result-index)))
 269         (setq index (1+ index)))
 270       (substring result 0 result-index))))
 271
 272 (defun pinentry--send-data (process escaped)
 273   "Send a string ESCAPED to a process PROCESS.
 274 ESCAPED will be split if it exceeds the line length limit of the
 275 Assuan protocol."
 276   (let ((length (length escaped))
 277         (index 0))
 278     (if (= length 0)
 279         (process-send-string process "D \n")
 280       (while (< index length)
 281         ;; 997 = ASSUAN_LINELENGTH (= 1000) - strlen ("D \n")
 282         (let* ((sub-length (min (- length index) 997))
 283                (sub (substring escaped index (+ index sub-length))))
 284           (unwind-protect
 285               (progn
 286                 (process-send-string process "D ")
 287                 (process-send-string process sub)
 288                 (process-send-string process "\n"))
 289             (clear-string sub))
 290           (setq index (+ index sub-length)))))))
 291
 292 (defun pinentry--send-error (process error)
 293   (process-send-string process (format "ERR %d %s\n" (car error) (cdr error))))
 294
 295 (defun pinentry--process-filter (process input)
 296   (unless (buffer-live-p (process-buffer process))
 297     (let ((buffer (generate-new-buffer " *pinentry*")))
 298       (set-process-buffer process buffer)
 299       (with-current-buffer buffer
 300         (if (fboundp 'set-buffer-multibyte)
 301             (set-buffer-multibyte nil))
 302         (make-local-variable 'pinentry--read-point)
 303         (setq pinentry--read-point (point-min))
 304         (make-local-variable 'pinentry--labels))))
 305   (with-current-buffer (process-buffer process)
 306     (when pinentry-debug
 307       (with-current-buffer
 308           (or pinentry-debug-buffer
 309               (setq pinentry-debug-buffer (generate-new-buffer
 310                                            " *pinentry-debug*")))
 311         (goto-char (point-max))
 312         (insert input)))
 313     (save-excursion
 314       (goto-char (point-max))
 315       (insert input)
 316       (goto-char pinentry--read-point)
 317       (beginning-of-line)
 318       (while (looking-at ".*\n")        ;the input line finished
 319         (if (looking-at "\\([A-Z_]+\\) ?\\(.*\\)")
 320             (let ((command (match-string 1))
 321                   (string (pinentry--unescape-string (match-string 2))))
 322               (pcase command
 323                 ((and set (guard (member set pinentry--set-label-commands)))
 324                  (when (> (length string) 0)
 325                    (let* ((symbol (intern (downcase (substring set 3))))
 326                           (entry (assq symbol pinentry--labels))
 327                           (label (decode-coding-string string 'utf-8)))
 328                      (if entry
 329                          (setcdr entry label)
 330                        (push (cons symbol label) pinentry--labels))))
 331                  (ignore-errors
 332                    (process-send-string process "OK\n")))
 333                 ("NOP"
 334                  (ignore-errors
 335                    (process-send-string process "OK\n")))
 336                 ("GETPIN"
 337                  (let ((confirm (not (null (assq 'repeat pinentry--labels))))
 338                        passphrase escaped-passphrase encoded-passphrase)
 339                    (unwind-protect
 340                        (condition-case err
 341                            (progn
 342                              (setq passphrase
 343                                    (pinentry--prompt
 344                                     pinentry--labels
 345                                     #'read-passwd confirm))
 346                                (setq escaped-passphrase
 347                                      (pinentry--escape-string
 348                                       passphrase))
 349                                (setq encoded-passphrase (encode-coding-string
 350                                                          escaped-passphrase
 351                                                          'utf-8))
 352                                (ignore-errors
 353                                  (pinentry--send-data
 354                                   process encoded-passphrase)
 355                                  (process-send-string process "OK\n")))
 356                          (error
 357                           (message "GETPIN error %S" err)
 358                             (ignore-errors
 359                               (pinentry--send-error
 360                                process
 361                                pinentry--error-cancelled))))
 362                        (if passphrase
 363                            (clear-string passphrase))
 364                        (if escaped-passphrase
 365                            (clear-string escaped-passphrase))
 366                        (if encoded-passphrase
 367                            (clear-string encoded-passphrase))))
 368                    (setq pinentry--labels nil))
 369                 ("CONFIRM"
 370                  (let ((prompt
 371                         (or (cdr (assq 'prompt pinentry--labels))
 372                             "Confirm? "))
 373                        (buttons
 374                         (delq nil
 375                               (pinentry--labels-to-shortcuts
 376                                (list (cdr (assq 'ok pinentry--labels))
 377                                      (cdr (assq 'notok pinentry--labels))
 378                                      (cdr (assq 'cancel pinentry--labels))))))
 379                        entry)
 380                    (if buttons
 381                        (progn
 382                          (setq prompt
 383                                (concat prompt " ("
 384                                        (mapconcat #'cdr buttons
 385                                                   ", ")
 386                                        ") "))
 387                          (if (setq entry (assq 'prompt pinentry--labels))
 388                              (setcdr entry prompt)
 389                            (setq pinentry--labels (cons (cons 'prompt prompt)
 390                                                         pinentry--labels)))
 391                          (condition-case nil
 392                              (let ((result (pinentry--prompt pinentry--labels
 393                                                              #'read-char)))
 394                                (if (eq result (caar buttons))
 395                                    (ignore-errors
 396                                      (process-send-string process "OK\n"))
 397                                  (if (eq result (car (nth 1 buttons)))
 398                                      (ignore-errors
 399                                        (pinentry--send-error
 400                                         process
 401                                         pinentry--error-not-confirmed))
 402                                    (ignore-errors
 403                                      (pinentry--send-error
 404                                       process
 405                                       pinentry--error-cancelled)))))
 406                            (error
 407                             (ignore-errors
 408                               (pinentry--send-error
 409                                process
 410                                pinentry--error-cancelled)))))
 411                      (if (setq entry (assq 'prompt pinentry--labels))
 412                          (setcdr entry prompt)
 413                        (setq pinentry--labels (cons (cons 'prompt prompt)
 414                                                     pinentry--labels)))
 415                      (if (condition-case nil
 416                              (pinentry--prompt pinentry--labels #'y-or-n-p)
 417                            (quit))
 418                          (ignore-errors
 419                            (process-send-string process "OK\n"))
 420                        (ignore-errors
 421                          (pinentry--send-error
 422                           process
 423                           pinentry--error-not-confirmed))))
 424                    (setq pinentry--labels nil)))
 425                 (_ (ignore-errors
 426                      (pinentry--send-error
 427                       process
 428                       pinentry--error-not-implemented))))
 429               (forward-line)
 430               (setq pinentry--read-point (point))))))))
 431
 432 (defun pinentry--process-sentinel (process _status)
 433   "The process sentinel for Emacs server connections."
 434   ;; If this is a new client process, set the query-on-exit flag to nil
 435   ;; for this process (it isn't inherited from the server process).
 436   (when (and (eq (process-status process) 'open)
 437              (process-query-on-exit-flag process))
 438     (push process pinentry--connection-process-list)
 439     (set-process-query-on-exit-flag process nil)
 440     (ignore-errors
 441       (process-send-string process "OK Your orders please\n")))
 442   ;; Kill the process buffer of the connection process.
 443   (when (and (not (process-contact process :server))
 444              (eq (process-status process) 'closed))
 445     (when (buffer-live-p (process-buffer process))
 446       (kill-buffer (process-buffer process)))
 447     (setq pinentry--connection-process-list
 448           (delq process pinentry--connection-process-list)))
 449   ;; Delete the associated connection file, if applicable.
 450   ;; Although there's no 100% guarantee that the file is owned by the
 451   ;; running Emacs instance, server-start uses server-running-p to check
 452   ;; for possible servers before doing anything, so it *should* be ours.
 453   (and (process-contact process :server)
 454        (eq (process-status process) 'closed)
 455        (ignore-errors
 456          (delete-file (process-get process :server-file)))))
 457
 458 (provide 'pinentry)
 459
 460 ;;; pinentry.el ends here