lisp/net/pinentry.el

   1 ;;; pinentry.el --- GnuPG Pinentry server implementation -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015 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 ()
 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   (interactive)
 160   (unless (featurep 'make-network-process '(:family local))
 161     (error "local sockets are not supported"))
 162   (if (process-live-p pinentry--server-process)
 163       (message "Pinentry service is already running")
 164     (let* ((server-file (expand-file-name "pinentry" pinentry--socket-dir)))
 165       (server-ensure-safe-dir pinentry--socket-dir)
 166       ;; Delete the socket files made by previous server invocations.
 167       (ignore-errors
 168         (let (delete-by-moving-to-trash)
 169           (delete-file server-file)))
 170       (setq pinentry--server-process
 171             (make-network-process
 172              :name "pinentry"
 173              :server t
 174              :noquery t
 175              :sentinel #'pinentry--process-sentinel
 176              :filter #'pinentry--process-filter
 177              :coding 'no-conversion
 178              :family 'local
 179              :service server-file))
 180       (process-put pinentry--server-process :server-file server-file))))
 181
 182 (defun pinentry-stop ()
 183   "Stop a Pinentry service."
 184   (interactive)
 185   (when (process-live-p pinentry--server-process)
 186     (delete-process pinentry--server-process))
 187   (setq pinentry--server-process nil)
 188   (dolist (process pinentry--connection-process-list)
 189     (when (buffer-live-p (process-buffer process))
 190       (kill-buffer (process-buffer process))))
 191   (setq pinentry--connection-process-list nil))
 192
 193 (defun pinentry--labels-to-shortcuts (labels)
 194   "Convert strings in LABEL by stripping mnemonics."
 195   (mapcar (lambda (label)
 196             (when label
 197               (let (c)
 198                 (if (string-match "\\(?:\\`\\|[^_]\\)_\\([[:alnum:]]\\)" label)
 199                     (let ((key (match-string 1 label)))
 200                       (setq c (downcase (aref key 0)))
 201                       (setq label (replace-match
 202                                    (propertize key 'face 'underline)
 203                                    t t label)))
 204                   (setq c (if (= (length label) 0)
 205                               ??
 206                             (downcase (aref label 0)))))
 207                 ;; Double underscores mean a single underscore.
 208                 (when (string-match "__" label)
 209                   (setq label (replace-match "_" t t label)))
 210                 (cons c label))))
 211           labels))
 212
 213 (defun pinentry--escape-string (string)
 214   "Escape STRING in the Assuan percent escape."
 215   (let ((length (length string))
 216         (index 0)
 217         (count 0))
 218     (while (< index length)
 219       (if (memq (aref string index) '(?\n ?\r ?%))
 220           (setq count (1+ count)))
 221       (setq index (1+ index)))
 222     (setq index 0)
 223     (let ((result (make-string (+ length (* count 2)) ?\0))
 224           (result-index 0)
 225           c)
 226       (while (< index length)
 227         (setq c (aref string index))
 228         (if (memq c '(?\n ?\r ?%))
 229             (let ((hex (format "%02X" c)))
 230               (aset result result-index ?%)
 231               (setq result-index (1+ result-index))
 232               (aset result result-index (aref hex 0))
 233               (setq result-index (1+ result-index))
 234               (aset result result-index (aref hex 1))
 235               (setq result-index (1+ result-index)))
 236           (aset result result-index c)
 237           (setq result-index (1+ result-index)))
 238         (setq index (1+ index)))
 239       result)))
 240
 241 (defun pinentry--unescape-string (string)
 242   "Unescape STRING in the Assuan percent escape."
 243   (let ((length (length string))
 244         (index 0))
 245     (let ((result (make-string length ?\0))
 246           (result-index 0)
 247           c)
 248       (while (< index length)
 249         (setq c (aref string index))
 250         (if (and (eq c '?%) (< (+ index 2) length))
 251             (progn
 252               (aset result result-index
 253                     (string-to-number (substring string
 254                                                  (1+ index)
 255                                                  (+ index 3))
 256                                       16))
 257               (setq result-index (1+ result-index))
 258               (setq index (+ index 2)))
 259           (aset result result-index c)
 260           (setq result-index (1+ result-index)))
 261         (setq index (1+ index)))
 262       (substring result 0 result-index))))
 263
 264 (defun pinentry--send-data (process escaped)
 265   "Send a string ESCAPED to a process PROCESS.
 266 ESCAPED will be split if it exceeds the line length limit of the
 267 Assuan protocol."
 268   (let ((length (length escaped))
 269         (index 0))
 270     (if (= length 0)
 271         (process-send-string process "D \n")
 272       (while (< index length)
 273         ;; 997 = ASSUAN_LINELENGTH (= 1000) - strlen ("D \n")
 274         (let* ((sub-length (min (- length index) 997))
 275                (sub (substring escaped index (+ index sub-length))))
 276           (unwind-protect
 277               (progn
 278                 (process-send-string process "D ")
 279                 (process-send-string process sub)
 280                 (process-send-string process "\n"))
 281             (clear-string sub))
 282           (setq index (+ index sub-length)))))))
 283
 284 (defun pinentry--send-error (process error)
 285   (process-send-string process (format "ERR %d %s\n" (car error) (cdr error))))
 286
 287 (defun pinentry--process-filter (process input)
 288   (unless (buffer-live-p (process-buffer process))
 289     (let ((buffer (generate-new-buffer " *pinentry*")))
 290       (set-process-buffer process buffer)
 291       (with-current-buffer buffer
 292         (if (fboundp 'set-buffer-multibyte)
 293             (set-buffer-multibyte nil))
 294         (make-local-variable 'pinentry--read-point)
 295         (setq pinentry--read-point (point-min))
 296         (make-local-variable 'pinentry--labels))))
 297   (with-current-buffer (process-buffer process)
 298     (when pinentry-debug
 299       (with-current-buffer
 300           (or pinentry-debug-buffer
 301               (setq pinentry-debug-buffer (generate-new-buffer
 302                                            " *pinentry-debug*")))
 303         (goto-char (point-max))
 304         (insert input)))
 305     (save-excursion
 306       (goto-char (point-max))
 307       (insert input)
 308       (goto-char pinentry--read-point)
 309       (beginning-of-line)
 310       (while (looking-at ".*\n")        ;the input line finished
 311         (if (looking-at "\\([A-Z_]+\\) ?\\(.*\\)")
 312             (let ((command (match-string 1))
 313                   (string (pinentry--unescape-string (match-string 2))))
 314               (pcase command
 315                 ((and set (guard (member set pinentry--set-label-commands)))
 316                  (when (> (length string) 0)
 317                    (let* ((symbol (intern (downcase (substring set 3))))
 318                           (entry (assq symbol pinentry--labels))
 319                           (label (decode-coding-string string 'utf-8)))
 320                      (if entry
 321                          (setcdr entry label)
 322                        (push (cons symbol label) pinentry--labels))))
 323                  (ignore-errors
 324                    (process-send-string process "OK\n")))
 325                 ("NOP"
 326                  (ignore-errors
 327                    (process-send-string process "OK\n")))
 328                 ("GETPIN"
 329                  (let ((confirm (not (null (assq 'repeat pinentry--labels))))
 330                        passphrase escaped-passphrase encoded-passphrase)
 331                    (unwind-protect
 332                        (condition-case err
 333                            (progn
 334                              (setq passphrase
 335                                    (pinentry--prompt
 336                                     pinentry--labels
 337                                     #'read-passwd confirm))
 338                                (setq escaped-passphrase
 339                                      (pinentry--escape-string
 340                                       passphrase))
 341                                (setq encoded-passphrase (encode-coding-string
 342                                                          escaped-passphrase
 343                                                          'utf-8))
 344                                (ignore-errors
 345                                  (pinentry--send-data
 346                                   process encoded-passphrase)
 347                                  (process-send-string process "OK\n")))
 348                          (error
 349                           (message "GETPIN error %S" err)
 350                             (ignore-errors
 351                               (pinentry--send-error
 352                                process
 353                                pinentry--error-cancelled))))
 354                        (if passphrase
 355                            (clear-string passphrase))
 356                        (if escaped-passphrase
 357                            (clear-string escaped-passphrase))
 358                        (if encoded-passphrase
 359                            (clear-string encoded-passphrase))))
 360                    (setq pinentry--labels nil))
 361                 ("CONFIRM"
 362                  (let ((prompt
 363                         (or (cdr (assq 'prompt pinentry--labels))
 364                             "Confirm? "))
 365                        (buttons
 366                         (delq nil
 367                               (pinentry--labels-to-shortcuts
 368                                (list (cdr (assq 'ok pinentry--labels))
 369                                      (cdr (assq 'notok pinentry--labels))
 370                                      (cdr (assq 'cancel pinentry--labels))))))
 371                        entry)
 372                    (if buttons
 373                        (progn
 374                          (setq prompt
 375                                (concat prompt " ("
 376                                        (mapconcat #'cdr buttons
 377                                                   ", ")
 378                                        ") "))
 379                          (if (setq entry (assq 'prompt pinentry--labels))
 380                              (setcdr entry prompt)
 381                            (setq pinentry--labels (cons (cons 'prompt prompt)
 382                                                         pinentry--labels)))
 383                          (condition-case nil
 384                              (let ((result (pinentry--prompt pinentry--labels
 385                                                              #'read-char)))
 386                                (if (eq result (caar buttons))
 387                                    (ignore-errors
 388                                      (process-send-string process "OK\n"))
 389                                  (if (eq result (car (nth 1 buttons)))
 390                                      (ignore-errors
 391                                        (pinentry--send-error
 392                                         process
 393                                         pinentry--error-not-confirmed))
 394                                    (ignore-errors
 395                                      (pinentry--send-error
 396                                       process
 397                                       pinentry--error-cancelled)))))
 398                            (error
 399                             (ignore-errors
 400                               (pinentry--send-error
 401                                process
 402                                pinentry--error-cancelled)))))
 403                      (if (setq entry (assq 'prompt pinentry--labels))
 404                          (setcdr entry prompt)
 405                        (setq pinentry--labels (cons (cons 'prompt prompt)
 406                                                     pinentry--labels)))
 407                      (if (condition-case nil
 408                              (pinentry--prompt pinentry--labels #'y-or-n-p)
 409                            (quit))
 410                          (ignore-errors
 411                            (process-send-string process "OK\n"))
 412                        (ignore-errors
 413                          (pinentry--send-error
 414                           process
 415                           pinentry--error-not-confirmed))))
 416                    (setq pinentry--labels nil)))
 417                 (_ (ignore-errors
 418                      (pinentry--send-error
 419                       process
 420                       pinentry--error-not-implemented))))
 421               (forward-line)
 422               (setq pinentry--read-point (point))))))))
 423
 424 (defun pinentry--process-sentinel (process _status)
 425   "The process sentinel for Emacs server connections."
 426   ;; If this is a new client process, set the query-on-exit flag to nil
 427   ;; for this process (it isn't inherited from the server process).
 428   (when (and (eq (process-status process) 'open)
 429              (process-query-on-exit-flag process))
 430     (push process pinentry--connection-process-list)
 431     (set-process-query-on-exit-flag process nil)
 432     (ignore-errors
 433       (process-send-string process "OK Your orders please\n")))
 434   ;; Kill the process buffer of the connection process.
 435   (when (and (not (process-contact process :server))
 436              (eq (process-status process) 'closed))
 437     (when (buffer-live-p (process-buffer process))
 438       (kill-buffer (process-buffer process)))
 439     (setq pinentry--connection-process-list
 440           (delq process pinentry--connection-process-list)))
 441   ;; Delete the associated connection file, if applicable.
 442   ;; Although there's no 100% guarantee that the file is owned by the
 443   ;; running Emacs instance, server-start uses server-running-p to check
 444   ;; for possible servers before doing anything, so it *should* be ours.
 445   (and (process-contact process :server)
 446        (eq (process-status process) 'closed)
 447        (ignore-errors
 448          (delete-file (process-get process :server-file)))))
 449
 450 (provide 'pinentry)
 451
 452 ;;; pinentry.el ends here