code.delx.au - gnu-emacs-elpa/blob - packages/pinentry/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 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>.
  50
  51 ;;; Code:
  52
  53 (defvar pinentry--server-process nil)
  54 (defvar pinentry--connection-process-list nil)
  55
  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)
  60
  61 ;; We use the same location as `server-socket-dir', when local sockets
  62 ;; are supported.
  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.")
  67
  68 (defconst pinentry--set-label-commands
  69   '("SETPROMPT" "SETTITLE" "SETDESC"
  70     "SETREPEAT" "SETREPEATERROR"
  71     "SETOK" "SETCANCEL" "SETNOTOK"))
  72
  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"))
  82
  83 (autoload 'server-ensure-safe-dir "server")
  84
  85 ;;;###autoload
  86 (defun pinentry-start ()
  87   "Start a Pinentry service.
  88
  89 Once the environment is properly set, subsequent invocations of
  90 the gpg command will interact with Emacs for passphrase input."
  91   (interactive)
  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.
  99       (ignore-errors
 100         (let (delete-by-moving-to-trash)
 101           (delete-file server-file)))
 102       (setq pinentry--server-process
 103             (make-network-process
 104              :name "pinentry"
 105              :server t
 106              :noquery t
 107              :sentinel #'pinentry--process-sentinel
 108              :filter #'pinentry--process-filter
 109              :coding 'no-conversion
 110              :family 'local
 111              :service server-file))
 112       (process-put pinentry--server-process :server-file server-file))))
 113
 114 (defun pinentry-stop ()
 115   "Stop a Pinentry service."
 116   (interactive)
 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))
 124
 125 (defun pinentry--labels-to-shortcuts (labels)
 126   "Convert strings in LABEL by stripping mnemonics."
 127   (mapcar (lambda (label)
 128             (when label
 129               (let (c)
 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)
 135                                    t t label)))
 136                   (setq c (if (= (length label) 0)
 137                               ??
 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)))
 142                 (cons c label))))
 143           labels))
 144
 145 (defun pinentry--escape-string (string)
 146   "Escape STRING in the Assuan percent escape."
 147   (let ((length (length string))
 148         (index 0)
 149         (count 0))
 150     (while (< index length)
 151       (if (memq (aref string index) '(?\n ?\r ?%))
 152           (setq count (1+ count)))
 153       (setq index (1+ index)))
 154     (setq index 0)
 155     (let ((result (make-string (+ length (* count 2)) ?\0))
 156           (result-index 0)
 157           c)
 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)))
 171       result)))
 172
 173 (defun pinentry--unescape-string (string)
 174   "Unescape STRING in the Assuan percent escape."
 175   (let ((length (length string))
 176         (index 0))
 177     (let ((result (make-string length ?\0))
 178           (result-index 0)
 179           c)
 180       (while (< index length)
 181         (setq c (aref string index))
 182         (if (and (eq c '?%) (< (+ index 2) length))
 183             (progn
 184               (aset result result-index
 185                     (string-to-number (substring string
 186                                                  (1+ index)
 187                                                  (+ index 3))
 188                                       16))
 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))))
 195
 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
 199 Assuan protocol."
 200   (let ((length (length escaped))
 201         (index 0))
 202     (if (= length 0)
 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))))
 208           (unwind-protect
 209               (progn
 210                 (process-send-string process "D ")
 211                 (process-send-string process sub)
 212                 (process-send-string process "\n"))
 213             (clear-string sub))
 214           (setq index (+ index sub-length)))))))
 215
 216 (defun pinentry--send-error (process error)
 217   (process-send-string process (format "ERR %d %s\n" (car error) (cdr error))))
 218
 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)
 230     (save-excursion
 231       (goto-char (point-max))
 232       (insert input)
 233       (goto-char pinentry--read-point)
 234       (beginning-of-line)
 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))))
 239               (pcase command
 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)))
 245                      (if entry
 246                          (setcdr entry label)
 247                        (push (cons symbol label) pinentry--labels))))
 248                  (ignore-errors
 249                    (process-send-string process "OK\n")))
 250                 ("NOP"
 251                  (ignore-errors
 252                    (process-send-string process "OK\n")))
 253                 ("GETPIN"
 254                  (let ((prompt
 255                         (or (cdr (assq 'desc pinentry--labels))
 256                             (cdr (assq 'prompt pinentry--labels))
 257                             ""))
 258                        (confirm (not (null (assq 'repeat pinentry--labels))))
 259                        entry)
 260                    (if (setq entry (assq 'error pinentry--labels))
 261                        (setq prompt (concat "Error: "
 262                                             (propertize
 263                                              (copy-sequence (cdr entry))
 264                                              'face 'error)
 265                                             "\n"
 266                                             prompt)))
 267                    (if (setq entry (assq 'title pinentry--labels))
 268                        (setq prompt (format "[%s] %s"
 269                                             (cdr entry) prompt)))
 270                    (if (string-match ":?[ \n]*\\'" prompt)
 271                        (setq prompt (concat
 272                                      (substring
 273                                       prompt 0 (match-beginning 0)) ": ")))
 274                    (let (passphrase escaped-passphrase encoded-passphrase)
 275                      (unwind-protect
 276                          (condition-case nil
 277                              (progn
 278                                (setq passphrase
 279                                      (read-passwd prompt confirm))
 280                                (setq escaped-passphrase
 281                                      (pinentry--escape-string
 282                                       passphrase))
 283                                (setq encoded-passphrase (encode-coding-string
 284                                                          escaped-passphrase
 285                                                          'utf-8))
 286                                (ignore-errors
 287                                  (pinentry--send-data
 288                                   process encoded-passphrase)
 289                                  (process-send-string process "OK\n")))
 290                            (error
 291                             (ignore-errors
 292                               (pinentry--send-error
 293                                process
 294                                pinentry--error-cancelled))))
 295                        (if passphrase
 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)))
 302                 ("CONFIRM"
 303                  (let ((prompt
 304                         (or (cdr (assq 'desc pinentry--labels))
 305                             ""))
 306                        (buttons
 307                         (pinentry--labels-to-shortcuts
 308                          (list (cdr (assq 'ok pinentry--labels))
 309                                (cdr (assq 'notok pinentry--labels))
 310                                (cdr (assq 'cancel pinentry--labels)))))
 311                        entry)
 312                    (if (setq entry (assq 'error pinentry--labels))
 313                        (setq prompt (concat "Error: "
 314                                             (propertize
 315                                              (copy-sequence (cdr entry))
 316                                              'face 'error)
 317                                             "\n"
 318                                             prompt)))
 319                    (if (setq entry (assq 'title pinentry--labels))
 320                        (setq prompt (format "[%s] %s"
 321                                             (cdr entry) prompt)))
 322                    (if (remq nil buttons)
 323                        (progn
 324                          (setq prompt
 325                                (concat prompt " ("
 326                                        (mapconcat #'cdr (remq nil buttons)
 327                                                   ", ")
 328                                        ") "))
 329                          (condition-case nil
 330                              (let ((result (read-char prompt)))
 331                                (if (eq result (caar buttons))
 332                                    (ignore-errors
 333                                      (process-send-string process "OK\n"))
 334                                  (if (eq result (car (nth 1 buttons)))
 335                                      (ignore-errors
 336                                        (pinentry--send-error
 337                                         process
 338                                         pinentry--error-not-confirmed))
 339                                    (ignore-errors
 340                                      (pinentry--send-error
 341                                       process
 342                                       pinentry--error-cancelled)))))
 343                            (error
 344                             (ignore-errors
 345                               (pinentry--send-error
 346                                process
 347                                pinentry--error-cancelled)))))
 348                      (if (string-match "[ \n]*\\'" prompt)
 349                          (setq prompt (concat
 350                                        (substring
 351                                         prompt 0 (match-beginning 0)) " ")))
 352                      (if (condition-case nil
 353                              (y-or-n-p prompt)
 354                            (quit))
 355                          (ignore-errors
 356                            (process-send-string process "OK\n"))
 357                        (ignore-errors
 358                          (pinentry--send-error
 359                           process
 360                           pinentry--error-not-confirmed))))
 361                    (setq pinentry--labels nil)))
 362                 (_ (ignore-errors
 363                      (pinentry--send-error
 364                       process
 365                       pinentry--error-not-implemented))))
 366               (forward-line)
 367               (setq pinentry--read-point (point))))))))
 368
 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)
 377     (ignore-errors
 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)
 392        (ignore-errors
 393          (delete-file (process-get process :server-file)))))
 394
 395 (provide 'pinentry)
 396
 397 ;;; pinentry.el ends here