lisp/plstore.el

   1 ;;; plstore.el --- secure plist store -*- lexical-binding: t -*-
   2 ;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Keywords: PGP, GnuPG
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary
  23
  24 ;; Plist based data store providing search and partial encryption.
  25 ;;
  26 ;; Creating:
  27 ;;
  28 ;; ;; Open a new store associated with ~/.emacs.d/auth.plist.
  29 ;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist")))
  30 ;; ;; Both `:host' and `:port' are public property.
  31 ;; (plstore-put store "foo" '(:host "foo.example.org" :port 80) nil)
  32 ;; ;; No encryption will be needed.
  33 ;; (plstore-save store)
  34 ;;
  35 ;; ;; `:user' is marked as secret.
  36 ;; (plstore-put store "bar" '(:host "bar.example.org") '(:user "test"))
  37 ;; ;; `:password' is marked as secret.
  38 ;; (plstore-put store "baz" '(:host "baz.example.org") '(:password "test"))
  39 ;; ;; Those secret properties are encrypted together.
  40 ;; (plstore-save store)
  41 ;;
  42 ;; ;; Kill the buffer visiting ~/.emacs.d/auth.plist.
  43 ;; (plstore-close store)
  44 ;;
  45 ;; Searching:
  46 ;;
  47 ;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist")))
  48 ;;
  49 ;; ;; As the entry "foo" associated with "foo.example.org" has no
  50 ;; ;; secret properties, no need to decryption.
  51 ;; (plstore-find store '(:host ("foo.example.org")))
  52 ;;
  53 ;; ;; As the entry "bar" associated with "bar.example.org" has a
  54 ;; ;; secret property `:user', Emacs tries to decrypt the secret (and
  55 ;; ;; thus you will need to input passphrase).
  56 ;; (plstore-find store '(:host ("bar.example.org")))
  57 ;;
  58 ;; ;; While the entry "baz" associated with "baz.example.org" has also
  59 ;; ;; a secret property `:password', it is encrypted together with
  60 ;; ;; `:user' of "bar", so no need to decrypt the secret.
  61 ;; (plstore-find store '(:host ("bar.example.org")))
  62 ;;
  63 ;; (plstore-close store)
  64 ;;
  65 ;; Editing:
  66 ;;
  67 ;; This file also provides `plstore-mode', a major mode for editing
  68 ;; the PLSTORE format file.  Visit a non-existing file and put the
  69 ;; following line:
  70 ;;
  71 ;; (("foo" :host "foo.example.org" :secret-user "user"))
  72 ;;
  73 ;; where the prefixing `:secret-' means the property (without
  74 ;; `:secret-' prefix) is marked as secret.  Thus, when you save the
  75 ;; buffer, the `:secret-user' property is encrypted as `:user'.
  76 ;;
  77 ;; You can toggle the view between encrypted form and the decrypted
  78 ;; form with C-c C-c.
  79
  80 ;;; Code:
  81
  82 (require 'epg)
  83
  84 (defgroup plstore nil
  85   "Searchable, partially encrypted, persistent plist store"
  86   :version "24.1"
  87   :group 'files)
  88
  89 (defcustom plstore-select-keys 'silent
  90   "Control whether or not to pop up the key selection dialog.
  91
  92 If t, always asks user to select recipients.
  93 If nil, query user only when a file's default recipients are not
  94 known (i.e. `plstore-encrypt-to' is not locally set in the buffer
  95 visiting a plstore file).
  96 If neither t nor nil, doesn't ask user."
  97   :type '(choice (const :tag "Ask always" t)
  98                  (const :tag "Ask when recipients are not set" nil)
  99                  (const :tag "Don't ask" silent))
 100   :group 'plstore)
 101
 102 (defcustom plstore-encrypt-to nil
 103   "Recipient(s) used for encrypting secret entries.
 104 May either be a string or a list of strings.  If it is nil,
 105 symmetric encryption will be used."
 106   :type '(choice (const nil) (repeat :tag "Recipient(s)" string))
 107   :group 'plstore)
 108
 109 (put 'plstore-encrypt-to 'safe-local-variable
 110      (lambda (val)
 111        (or (stringp val)
 112            (and (listp val)
 113                 (catch 'safe
 114                   (mapc (lambda (elt)
 115                           (unless (stringp elt)
 116                             (throw 'safe nil)))
 117                         val)
 118                   t)))))
 119
 120 (put 'plstore-encrypt-to 'permanent-local t)
 121
 122 (defvar plstore-encoded nil)
 123
 124 (put 'plstore-encoded 'permanent-local t)
 125
 126 (defvar plstore-cache-passphrase-for-symmetric-encryption nil)
 127 (defvar plstore-passphrase-alist nil)
 128
 129 (defun plstore-passphrase-callback-function (_context _key-id plstore)
 130   (if plstore-cache-passphrase-for-symmetric-encryption
 131       (let* ((file (file-truename (plstore-get-file plstore)))
 132              (entry (assoc file plstore-passphrase-alist))
 133              passphrase)
 134         (or (copy-sequence (cdr entry))
 135             (progn
 136               (unless entry
 137                 (setq entry (list file)
 138                       plstore-passphrase-alist
 139                       (cons entry
 140                             plstore-passphrase-alist)))
 141               (setq passphrase
 142                     (read-passwd (format "Passphrase for PLSTORE %s: "
 143                                          (plstore--get-buffer plstore))))
 144               (setcdr entry (copy-sequence passphrase))
 145               passphrase)))
 146     (read-passwd (format "Passphrase for PLSTORE %s: "
 147                          (plstore--get-buffer plstore)))))
 148
 149 (defun plstore-progress-callback-function (_context _what _char current total
 150                                                     handback)
 151   (if (= current total)
 152       (message "%s...done" handback)
 153     (message "%s...%d%%" handback
 154              (if (> total 0) (floor (* (/ current (float total)) 100)) 0))))
 155
 156 (defun plstore--get-buffer (arg)
 157   (aref arg 0))
 158
 159 (defun plstore--get-alist (arg)
 160   (aref arg 1))
 161
 162 (defun plstore--get-encrypted-data (arg)
 163   (aref arg 2))
 164
 165 (defun plstore--get-secret-alist (arg)
 166   (aref arg 3))
 167
 168 (defun plstore--get-merged-alist (arg)
 169   (aref arg 4))
 170
 171 (defun plstore--set-buffer (arg buffer)
 172   (aset arg 0 buffer))
 173
 174 (defun plstore--set-alist (arg plist)
 175   (aset arg 1 plist))
 176
 177 (defun plstore--set-encrypted-data (arg encrypted-data)
 178   (aset arg 2 encrypted-data))
 179
 180 (defun plstore--set-secret-alist (arg secret-alist)
 181   (aset arg 3 secret-alist))
 182
 183 (defun plstore--set-merged-alist (arg merged-alist)
 184   (aset arg 4 merged-alist))
 185
 186 (defun plstore-get-file (arg)
 187   (buffer-file-name (plstore--get-buffer arg)))
 188
 189 (defun plstore--make (&optional buffer alist encrypted-data secret-alist
 190                                 merged-alist)
 191   (vector buffer alist encrypted-data secret-alist merged-alist))
 192
 193 (defun plstore--init-from-buffer (plstore)
 194   (goto-char (point-min))
 195   (when (looking-at ";;; public entries")
 196     (forward-line)
 197     (plstore--set-alist plstore (read (point-marker)))
 198     (forward-sexp)
 199     (forward-char)
 200     (when (looking-at ";;; secret entries")
 201       (forward-line)
 202       (plstore--set-encrypted-data plstore (read (point-marker))))
 203     (plstore--merge-secret plstore)))
 204
 205 ;;;###autoload
 206 (defun plstore-open (file)
 207   "Create a plstore instance associated with FILE."
 208   (let* ((filename (file-truename file))
 209          (buffer (or (find-buffer-visiting filename)
 210                      (generate-new-buffer (format " plstore %s" filename))))
 211          (store (plstore--make buffer)))
 212     (with-current-buffer buffer
 213       (erase-buffer)
 214       (condition-case nil
 215           (let ((coding-system-for-read 'raw-text))
 216             (insert-file-contents file))
 217         (error))
 218       (setq buffer-file-name (file-truename file))
 219       (set-buffer-modified-p nil)
 220       (plstore--init-from-buffer store)
 221       store)))
 222
 223 (defun plstore-revert (plstore)
 224   "Replace current data in PLSTORE with the file on disk."
 225   (with-current-buffer (plstore--get-buffer plstore)
 226     (revert-buffer t t)
 227     (plstore--init-from-buffer plstore)))
 228
 229 (defun plstore-close (plstore)
 230   "Destroy a plstore instance PLSTORE."
 231   (kill-buffer (plstore--get-buffer plstore)))
 232
 233 (defun plstore--merge-secret (plstore)
 234   (let ((alist (plstore--get-secret-alist plstore))
 235         modified-alist
 236         modified-plist
 237         modified-entry
 238         entry
 239         plist
 240         placeholder)
 241     (plstore--set-merged-alist
 242      plstore
 243      (copy-tree (plstore--get-alist plstore)))
 244     (setq modified-alist (plstore--get-merged-alist plstore))
 245     (while alist
 246       (setq entry (car alist)
 247             alist (cdr alist)
 248             plist (cdr entry)
 249             modified-entry (assoc (car entry) modified-alist)
 250             modified-plist (cdr modified-entry))
 251       (while plist
 252         (setq placeholder
 253               (plist-member
 254                modified-plist
 255                (intern (concat ":secret-"
 256                                (substring (symbol-name (car plist)) 1)))))
 257         (if placeholder
 258             (setcar placeholder (car plist)))
 259         (setq modified-plist
 260               (plist-put modified-plist (car plist) (car (cdr plist))))
 261         (setq plist (nthcdr 2 plist)))
 262       (setcdr modified-entry modified-plist))))
 263
 264 (defun plstore--decrypt (plstore)
 265   (if (plstore--get-encrypted-data plstore)
 266       (let ((context (epg-make-context 'OpenPGP))
 267             plain)
 268         (epg-context-set-passphrase-callback
 269          context
 270          (cons #'plstore-passphrase-callback-function
 271                plstore))
 272         (epg-context-set-progress-callback
 273          context
 274          (cons #'plstore-progress-callback-function
 275                (format "Decrypting %s" (plstore-get-file plstore))))
 276         (condition-case error
 277             (setq plain
 278                   (epg-decrypt-string context
 279                                       (plstore--get-encrypted-data plstore)))
 280           (error
 281            (let ((entry (assoc (plstore-get-file plstore)
 282                                plstore-passphrase-alist)))
 283              (if entry
 284                  (setcdr entry nil)))
 285            (signal (car error) (cdr error))))
 286         (plstore--set-secret-alist plstore (car (read-from-string plain)))
 287         (plstore--merge-secret plstore)
 288         (plstore--set-encrypted-data plstore nil))))
 289
 290 (defun plstore--match (entry keys skip-if-secret-found)
 291   (let ((result t) key-name key-value prop-value secret-name)
 292     (while keys
 293       (setq key-name (car keys)
 294             key-value (car (cdr keys))
 295             prop-value (plist-get (cdr entry) key-name))
 296         (unless (member prop-value key-value)
 297           (if skip-if-secret-found
 298               (progn
 299                 (setq secret-name
 300                       (intern (concat ":secret-"
 301                                       (substring (symbol-name key-name) 1))))
 302                 (if (plist-member (cdr entry) secret-name)
 303                     (setq result 'secret)
 304                   (setq result nil
 305                         keys nil)))
 306             (setq result nil
 307                   keys nil)))
 308         (setq keys (nthcdr 2 keys)))
 309     result))
 310
 311 (defun plstore-find (plstore keys)
 312   "Perform search on PLSTORE with KEYS.
 313 KEYS is a plist."
 314   (let (entries alist entry match decrypt plist)
 315     ;; First, go through the merged plist alist and collect entries
 316     ;; matched with keys.
 317     (setq alist (plstore--get-merged-alist plstore))
 318     (while alist
 319       (setq entry (car alist)
 320             alist (cdr alist)
 321             match (plstore--match entry keys t))
 322       (if (eq match 'secret)
 323           (setq decrypt t)
 324         (when match
 325           (setq plist (cdr entry))
 326           (while plist
 327             (if (string-match "\\`:secret-" (symbol-name (car plist)))
 328                 (setq decrypt t
 329                       plist nil))
 330             (setq plist (nthcdr 2 plist)))
 331           (setq entries (cons entry entries)))))
 332     ;; Second, decrypt the encrypted plist and try again.
 333     (when decrypt
 334       (setq entries nil)
 335       (plstore--decrypt plstore)
 336       (setq alist (plstore--get-merged-alist plstore))
 337       (while alist
 338         (setq entry (car alist)
 339               alist (cdr alist)
 340               match (plstore--match entry keys nil))
 341         (if match
 342             (setq entries (cons entry entries)))))
 343     (nreverse entries)))
 344
 345 (defun plstore-get (plstore name)
 346   "Get an entry with NAME in PLSTORE."
 347   (let ((entry (assoc name (plstore--get-merged-alist plstore)))
 348         plist)
 349     (setq plist (cdr entry))
 350     (while plist
 351       (if (string-match "\\`:secret-" (symbol-name (car plist)))
 352           (progn
 353             (plstore--decrypt plstore)
 354             (setq entry (assoc name (plstore--get-merged-alist plstore))
 355                   plist nil))
 356         (setq plist (nthcdr 2 plist))))
 357     entry))
 358
 359 (defun plstore-put (plstore name keys secret-keys)
 360   "Put an entry with NAME in PLSTORE.
 361 KEYS is a plist containing non-secret data.
 362 SECRET-KEYS is a plist containing secret data."
 363   (let (entry
 364         plist
 365         secret-plist
 366         symbol)
 367     (if secret-keys
 368         (plstore--decrypt plstore))
 369     (while secret-keys
 370       (setq symbol
 371             (intern (concat ":secret-"
 372                             (substring (symbol-name (car secret-keys)) 1))))
 373       (setq plist (plist-put plist symbol t)
 374             secret-plist (plist-put secret-plist
 375                                     (car secret-keys) (car (cdr secret-keys)))
 376             secret-keys (nthcdr 2 secret-keys)))
 377     (while keys
 378       (setq symbol
 379             (intern (concat ":secret-"
 380                             (substring (symbol-name (car keys)) 1))))
 381       (setq plist (plist-put plist (car keys) (car (cdr keys)))
 382             keys (nthcdr 2 keys)))
 383     (setq entry (assoc name (plstore--get-alist plstore)))
 384     (if entry
 385         (setcdr entry plist)
 386       (plstore--set-alist
 387        plstore
 388        (cons (cons name plist) (plstore--get-alist plstore))))
 389     (when secret-plist
 390       (setq entry (assoc name (plstore--get-secret-alist plstore)))
 391       (if entry
 392           (setcdr entry secret-plist)
 393         (plstore--set-secret-alist
 394          plstore
 395          (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
 396     (plstore--merge-secret plstore)))
 397
 398 (defun plstore-delete (plstore name)
 399   "Delete an entry with NAME from PLSTORE."
 400   (let ((entry (assoc name (plstore--get-alist plstore))))
 401     (if entry
 402         (plstore--set-alist
 403          plstore
 404          (delq entry (plstore--get-alist plstore))))
 405     (setq entry (assoc name (plstore--get-secret-alist plstore)))
 406     (if entry
 407         (plstore--set-secret-alist
 408          plstore
 409          (delq entry (plstore--get-secret-alist plstore))))
 410     (setq entry (assoc name (plstore--get-merged-alist plstore)))
 411     (if entry
 412         (plstore--set-merged-alist
 413          plstore
 414          (delq entry (plstore--get-merged-alist plstore))))))
 415
 416 (defvar pp-escape-newlines)
 417 (defun plstore--insert-buffer (plstore)
 418   (insert ";;; public entries -*- mode: plstore -*- \n"
 419           (pp-to-string (plstore--get-alist plstore)))
 420   (if (plstore--get-secret-alist plstore)
 421       (let ((context (epg-make-context 'OpenPGP))
 422             (pp-escape-newlines nil)
 423             (recipients
 424              (cond
 425               ((listp plstore-encrypt-to) plstore-encrypt-to)
 426               ((stringp plstore-encrypt-to) (list plstore-encrypt-to))))
 427             cipher)
 428         (setf (epg-context-armor context) t)
 429         (epg-context-set-passphrase-callback
 430          context
 431          (cons #'plstore-passphrase-callback-function
 432                plstore))
 433         (setq cipher (epg-encrypt-string
 434                       context
 435                       (pp-to-string
 436                        (plstore--get-secret-alist plstore))
 437                       (if (or (eq plstore-select-keys t)
 438                               (and (null plstore-select-keys)
 439                                    (not (local-variable-p 'plstore-encrypt-to
 440                                                           (current-buffer)))))
 441                           (epa-select-keys
 442                            context
 443                            "Select recipients for encryption.
 444 If no one is selected, symmetric encryption will be performed.  "
 445                            recipients)
 446                         (if plstore-encrypt-to
 447                             (epg-list-keys context recipients)))))
 448         (goto-char (point-max))
 449         (insert ";;; secret entries\n" (pp-to-string cipher)))))
 450
 451 (defun plstore-save (plstore)
 452   "Save the contents of PLSTORE associated with a FILE."
 453   (with-current-buffer (plstore--get-buffer plstore)
 454     (erase-buffer)
 455     (plstore--insert-buffer plstore)
 456     (save-buffer)))
 457
 458 (defun plstore--encode (plstore)
 459   (plstore--decrypt plstore)
 460   (let ((merged-alist (plstore--get-merged-alist plstore)))
 461     (concat "("
 462             (mapconcat
 463              (lambda (entry)
 464                (setq entry (copy-sequence entry))
 465                (let ((merged-plist (cdr (assoc (car entry) merged-alist)))
 466                      (plist (cdr entry)))
 467                  (while plist
 468                    (if (string-match "\\`:secret-" (symbol-name (car plist)))
 469                        (setcar (cdr plist)
 470                                (plist-get
 471                                 merged-plist
 472                                 (intern (concat ":"
 473                                                 (substring (symbol-name
 474                                                             (car plist))
 475                                                            (match-end 0)))))))
 476                    (setq plist (nthcdr 2 plist)))
 477                  (prin1-to-string entry)))
 478              (plstore--get-alist plstore)
 479              "\n")
 480             ")")))
 481
 482 (defun plstore--decode (string)
 483   (let* ((alist (car (read-from-string string)))
 484          (pointer alist)
 485          secret-alist
 486          plist
 487          entry)
 488     (while pointer
 489       (unless (stringp (car (car pointer)))
 490         (error "Invalid PLSTORE format %s" string))
 491       (setq plist (cdr (car pointer)))
 492       (while plist
 493         (when (string-match "\\`:secret-" (symbol-name (car plist)))
 494           (setq entry (assoc (car (car pointer)) secret-alist))
 495           (unless entry
 496             (setq entry (list (car (car pointer)))
 497                   secret-alist (cons entry secret-alist)))
 498           (setcdr entry (plist-put (cdr entry)
 499                                    (intern (concat ":"
 500                                                 (substring (symbol-name
 501                                                             (car plist))
 502                                                            (match-end 0))))
 503                                    (car (cdr plist))))
 504           (setcar (cdr plist) t))
 505         (setq plist (nthcdr 2 plist)))
 506       (setq pointer (cdr pointer)))
 507     (plstore--make nil alist nil secret-alist)))
 508
 509 (defun plstore--write-contents-functions ()
 510   (when plstore-encoded
 511     (let ((store (plstore--decode (buffer-string)))
 512           (file (buffer-file-name)))
 513       (unwind-protect
 514           (progn
 515             (set-visited-file-name nil)
 516             (with-temp-buffer
 517               (plstore--insert-buffer store)
 518               (write-region (buffer-string) nil file)))
 519         (set-visited-file-name file)
 520         (set-buffer-modified-p nil))
 521       t)))
 522
 523 (defun plstore-mode-original ()
 524   "Show the original form of the this buffer."
 525   (interactive)
 526   (when plstore-encoded
 527     (if (and (buffer-modified-p)
 528              (y-or-n-p "Save buffer before reading the original form? "))
 529         (save-buffer))
 530     (erase-buffer)
 531     (insert-file-contents-literally (buffer-file-name))
 532     (set-buffer-modified-p nil)
 533     (setq plstore-encoded nil)))
 534
 535 (defun plstore-mode-decoded ()
 536   "Show the decoded form of the this buffer."
 537   (interactive)
 538   (unless plstore-encoded
 539     (if (and (buffer-modified-p)
 540              (y-or-n-p "Save buffer before decoding? "))
 541         (save-buffer))
 542     (let ((store (plstore--make (current-buffer))))
 543       (plstore--init-from-buffer store)
 544       (erase-buffer)
 545       (insert
 546        (substitute-command-keys "\
 547 ;;; You are looking at the decoded form of the PLSTORE file.\n\
 548 ;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n"))
 549       (insert (plstore--encode store))
 550       (set-buffer-modified-p nil)
 551       (setq plstore-encoded t))))
 552
 553 (defun plstore-mode-toggle-display ()
 554   "Toggle the display mode of PLSTORE between the original and decoded forms."
 555   (interactive)
 556   (if plstore-encoded
 557       (plstore-mode-original)
 558     (plstore-mode-decoded)))
 559
 560 ;;;###autoload
 561 (define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE"
 562   "Major mode for editing PLSTORE files."
 563   (make-local-variable 'plstore-encoded)
 564   (add-hook 'write-contents-functions #'plstore--write-contents-functions)
 565   (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display)
 566   ;; to create a new file with plstore-mode, mark it as already decoded
 567   (if (called-interactively-p 'any)
 568       (setq plstore-encoded t)
 569     (plstore-mode-decoded)))
 570
 571 (provide 'plstore)
 572
 573 ;;; plstore.el ends here