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