code.delx.au - gnu-emacs/blob - lisp/net/pinentry.el

   1 ;;; pinentry.el --- GnuPG Pinentry server implementation -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015-2016 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, and
  30 ;; start the server with M-x pinentry-start.
  31 ;;
  32 ;; The actual communication path between the relevant components is
  33 ;; as follows:
  34 ;;
  35 ;;   gpg --> gpg-agent --> pinentry --> Emacs
  36 ;;
  37 ;; where pinentry and Emacs communicate through a Unix domain socket
  38 ;; created at:
  39 ;;
  40 ;;   ${TMPDIR-/tmp}/emacs$(id -u)/pinentry
  41 ;;
  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").
  45 ;;
  46 ;; NOTE: As of August 2015, this feature requires newer versions of
  47 ;; GnuPG (2.1.5+) and Pinentry (0.9.5+).
  48
  49 ;;; Code:
  50
  51 (defgroup pinentry nil
  52   "The Pinentry server"
  53   :version "25.1"
  54   :group 'external)
  55
  56 (defcustom pinentry-popup-prompt-window t
  57   "If non-nil, display multiline prompt in another window."
  58   :type 'boolean
  59   :group 'pinentry)
  60
  61 (defcustom pinentry-prompt-window-height 5
  62   "Number of lines used to display multiline prompt."
  63   :type 'integer
  64   :group 'pinentry)
  65
  66 (defvar pinentry-debug nil)
  67 (defvar pinentry-debug-buffer nil)
  68 (defvar pinentry--server-process nil)
  69 (defvar pinentry--connection-process-list nil)
  70
  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)
  75
  76 (defvar pinentry--prompt-buffer nil)
  77
  78 ;; We use the same location as `server-socket-dir', when local sockets
  79 ;; are supported.
  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.")
  84
  85 (defconst pinentry--set-label-commands
  86   '("SETPROMPT" "SETTITLE" "SETDESC"
  87     "SETREPEAT" "SETREPEATERROR"
  88     "SETOK" "SETCANCEL" "SETNOTOK"))
  89
  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"))
  99
 100 (autoload 'server-ensure-safe-dir "server")
 101
 102 (defvar pinentry-prompt-mode-map
 103   (let ((keymap (make-sparse-keymap)))
 104     (define-key keymap "q" 'quit-window)
 105     keymap))
 106
 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
 111         buffer-read-only t))
 112
 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)
 118       (setq prompt (concat
 119                     (substring
 120                      prompt 0 (match-beginning 0)) " ")))
 121     (when error
 122       (setq desc (concat "Error: " (propertize error 'face 'error)
 123                          "\n" desc)))
 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)
 134                 buffer-read-only)
 135             (erase-buffer)
 136             (insert desc))
 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
 142                                              (- (window-height)
 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)
 150           (quit-window)))
 151       (apply query-function (concat desc "\n" prompt) query-args))))
 152
 153 ;;;###autoload
 154 (defun pinentry-start (&optional quiet)
 155   "Start a Pinentry service.
 156
 157 Once the environment is properly set, subsequent invocations of
 158 the gpg command will interact with Emacs for passphrase input.
 159
 160 If the optional QUIET argument is non-nil, messages at startup
 161 will not be shown."
 162   (interactive)
 163   (unless (featurep 'make-network-process '(:family local))
 164     (error "local sockets are not supported"))
 165   (if (process-live-p pinentry--server-process)
 166       (unless quiet
 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.
 171       (ignore-errors
 172         (let (delete-by-moving-to-trash)
 173           (delete-file server-file)))
 174       (setq pinentry--server-process
 175             (make-network-process
 176              :name "pinentry"
 177              :server t
 178              :noquery t
 179              :sentinel #'pinentry--process-sentinel
 180              :filter #'pinentry--process-filter
 181              :coding 'no-conversion
 182              :family 'local
 183              :service server-file))
 184       (process-put pinentry--server-process :server-file server-file))))
 185
 186 (defun pinentry-stop ()
 187   "Stop a Pinentry service."
 188   (interactive)
 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))
 196
 197 (defun pinentry--labels-to-shortcuts (labels)
 198   "Convert strings in LABEL by stripping mnemonics."
 199   (mapcar (lambda (label)
 200             (when label
 201               (let (c)
 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)
 207                                    t t label)))
 208                   (setq c (if (= (length label) 0)
 209                               ??
 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)))
 214                 (cons c label))))
 215           labels))
 216
 217 (defun pinentry--escape-string (string)
 218   "Escape STRING in the Assuan percent escape."
 219   (let ((length (length string))
 220         (index 0)
 221         (count 0))
 222     (while (< index length)
 223       (if (memq (aref string index) '(?\n ?\r ?%))
 224           (setq count (1+ count)))
 225       (setq index (1+ index)))
 226     (setq index 0)
 227     (let ((result (make-string (+ length (* count 2)) ?\0))
 228           (result-index 0)
 229           c)
 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)))
 243       result)))
 244
 245 (defun pinentry--unescape-string (string)
 246   "Unescape STRING in the Assuan percent escape."
 247   (let ((length (length string))
 248         (index 0))
 249     (let ((result (make-string length ?\0))
 250           (result-index 0)
 251           c)
 252       (while (< index length)
 253         (setq c (aref string index))
 254         (if (and (eq c '?%) (< (+ index 2) length))
 255             (progn
 256               (aset result result-index
 257                     (string-to-number (substring string
 258                                                  (1+ index)
 259                                                  (+ index 3))
 260                                       16))
 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))))
 267
 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
 271 Assuan protocol."
 272   (let ((length (length escaped))
 273         (index 0))
 274     (if (= length 0)
 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))))
 280           (unwind-protect
 281               (progn
 282                 (process-send-string process "D ")
 283                 (process-send-string process sub)
 284                 (process-send-string process "\n"))
 285             (clear-string sub))
 286           (setq index (+ index sub-length)))))))
 287
 288 (defun pinentry--send-error (process error)
 289   (process-send-string process (format "ERR %d %s\n" (car error) (cdr error))))
 290
 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)
 302     (when pinentry-debug
 303       (with-current-buffer
 304           (or pinentry-debug-buffer
 305               (setq pinentry-debug-buffer (generate-new-buffer
 306                                            " *pinentry-debug*")))
 307         (goto-char (point-max))
 308         (insert input)))
 309     (save-excursion
 310       (goto-char (point-max))
 311       (insert input)
 312       (goto-char pinentry--read-point)
 313       (beginning-of-line)
 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))))
 318               (pcase command
 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)))
 324                      (if entry
 325                          (setcdr entry label)
 326                        (push (cons symbol label) pinentry--labels))))
 327                  (ignore-errors
 328                    (process-send-string process "OK\n")))
 329                 ("NOP"
 330                  (ignore-errors
 331                    (process-send-string process "OK\n")))
 332                 ("GETPIN"
 333                  (let ((confirm (not (null (assq 'repeat pinentry--labels))))
 334                        passphrase escaped-passphrase encoded-passphrase)
 335                    (unwind-protect
 336                        (condition-case err
 337                            (progn
 338                              (setq passphrase
 339                                    (pinentry--prompt
 340                                     pinentry--labels
 341                                     #'read-passwd confirm))
 342                                (setq escaped-passphrase
 343                                      (pinentry--escape-string
 344                                       passphrase))
 345                                (setq encoded-passphrase (encode-coding-string
 346                                                          escaped-passphrase
 347                                                          'utf-8))
 348                                (ignore-errors
 349                                  (pinentry--send-data
 350                                   process encoded-passphrase)
 351                                  (process-send-string process "OK\n")))
 352                          (error
 353                           (message "GETPIN error %S" err)
 354                             (ignore-errors
 355                               (pinentry--send-error
 356                                process
 357                                pinentry--error-cancelled))))
 358                        (if passphrase
 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))
 365                 ("CONFIRM"
 366                  (let ((prompt
 367                         (or (cdr (assq 'prompt pinentry--labels))
 368                             "Confirm? "))
 369                        (buttons
 370                         (delq nil
 371                               (pinentry--labels-to-shortcuts
 372                                (list (cdr (assq 'ok pinentry--labels))
 373                                      (cdr (assq 'notok pinentry--labels))
 374                                      (cdr (assq 'cancel pinentry--labels))))))
 375                        entry)
 376                    (if buttons
 377                        (progn
 378                          (setq prompt
 379                                (concat prompt " ("
 380                                        (mapconcat #'cdr buttons
 381                                                   ", ")
 382                                        ") "))
 383                          (if (setq entry (assq 'prompt pinentry--labels))
 384                              (setcdr entry prompt)
 385                            (setq pinentry--labels (cons (cons 'prompt prompt)
 386                                                         pinentry--labels)))
 387                          (condition-case nil
 388                              (let ((result (pinentry--prompt pinentry--labels
 389                                                              #'read-char)))
 390                                (if (eq result (caar buttons))
 391                                    (ignore-errors
 392                                      (process-send-string process "OK\n"))
 393                                  (if (eq result (car (nth 1 buttons)))
 394                                      (ignore-errors
 395                                        (pinentry--send-error
 396                                         process
 397                                         pinentry--error-not-confirmed))
 398                                    (ignore-errors
 399                                      (pinentry--send-error
 400                                       process
 401                                       pinentry--error-cancelled)))))
 402                            (error
 403                             (ignore-errors
 404                               (pinentry--send-error
 405                                process
 406                                pinentry--error-cancelled)))))
 407                      (if (setq entry (assq 'prompt pinentry--labels))
 408                          (setcdr entry prompt)
 409                        (setq pinentry--labels (cons (cons 'prompt prompt)
 410                                                     pinentry--labels)))
 411                      (if (condition-case nil
 412                              (pinentry--prompt pinentry--labels #'y-or-n-p)
 413                            (quit))
 414                          (ignore-errors
 415                            (process-send-string process "OK\n"))
 416                        (ignore-errors
 417                          (pinentry--send-error
 418                           process
 419                           pinentry--error-not-confirmed))))
 420                    (setq pinentry--labels nil)))
 421                 (_ (ignore-errors
 422                      (pinentry--send-error
 423                       process
 424                       pinentry--error-not-implemented))))
 425               (forward-line)
 426               (setq pinentry--read-point (point))))))))
 427
 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)
 436     (ignore-errors
 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)
 451        (ignore-errors
 452          (delete-file (process-get process :server-file)))))
 453
 454 (provide 'pinentry)
 455
 456 ;;; pinentry.el ends here