lisp/plstore.el

   1 ;;; plstore.el --- secure plist store -*- lexical-binding: t -*-
   2 ;; Copyright (C) 2011-2016 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 <http://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           (insert-file-contents-literally file)
 216         (error))
 217       (setq buffer-file-name (file-truename file))
 218       (set-buffer-modified-p nil)
 219       (plstore--init-from-buffer store)
 220       store)))
 221
 222 (defun plstore-revert (plstore)
 223   "Replace current data in PLSTORE with the file on disk."
 224   (with-current-buffer (plstore--get-buffer plstore)
 225     (revert-buffer t t)
 226     (plstore--init-from-buffer plstore)))
 227
 228 (defun plstore-close (plstore)
 229   "Destroy a plstore instance PLSTORE."
 230   (kill-buffer (plstore--get-buffer plstore)))
 231
 232 (defun plstore--merge-secret (plstore)
 233   (let ((alist (plstore--get-secret-alist plstore))
 234         modified-alist
 235         modified-plist
 236         modified-entry
 237         entry
 238         plist
 239         placeholder)
 240     (plstore--set-merged-alist
 241      plstore
 242      (copy-tree (plstore--get-alist plstore)))
 243     (setq modified-alist (plstore--get-merged-alist plstore))
 244     (while alist
 245       (setq entry (car alist)
 246             alist (cdr alist)
 247             plist (cdr entry)
 248             modified-entry (assoc (car entry) modified-alist)
 249             modified-plist (cdr modified-entry))
 250       (while plist
 251         (setq placeholder
 252               (plist-member
 253                modified-plist
 254                (intern (concat ":secret-"
 255                                (substring (symbol-name (car plist)) 1)))))
 256         (if placeholder
 257             (setcar placeholder (car plist)))
 258         (setq modified-plist
 259               (plist-put modified-plist (car plist) (car (cdr plist))))
 260         (setq plist (nthcdr 2 plist)))
 261       (setcdr modified-entry modified-plist))))
 262
 263 (defun plstore--decrypt (plstore)
 264   (if (plstore--get-encrypted-data plstore)
 265       (let ((context (epg-make-context 'OpenPGP))
 266             plain)
 267         (epg-context-set-passphrase-callback
 268          context
 269          (cons #'plstore-passphrase-callback-function
 270                plstore))
 271         (epg-context-set-progress-callback
 272          context
 273          (cons #'plstore-progress-callback-function
 274                (format "Decrypting %s" (plstore-get-file plstore))))
 275         (condition-case error
 276             (setq plain
 277                   (epg-decrypt-string context
 278                                       (plstore--get-encrypted-data plstore)))
 279           (error
 280            (let ((entry (assoc (plstore-get-file plstore)
 281                                plstore-passphrase-alist)))
 282              (if entry
 283                  (setcdr entry nil)))
 284            (signal (car error) (cdr error))))
 285         (plstore--set-secret-alist plstore (car (read-from-string plain)))
 286         (plstore--merge-secret plstore)
 287         (plstore--set-encrypted-data plstore nil))))
 288
 289 (defun plstore--match (entry keys skip-if-secret-found)
 290   (let ((result t) key-name key-value prop-value secret-name)
 291     (while keys
 292       (setq key-name (car keys)
 293             key-value (car (cdr keys))
 294             prop-value (plist-get (cdr entry) key-name))
 295         (unless (member prop-value key-value)
 296           (if skip-if-secret-found
 297               (progn
 298                 (setq secret-name
 299                       (intern (concat ":secret-"
 300                                       (substring (symbol-name key-name) 1))))
 301                 (if (plist-member (cdr entry) secret-name)
 302                     (setq result 'secret)
 303                   (setq result nil
 304                         keys nil)))
 305             (setq result nil
 306                   keys nil)))
 307         (setq keys (nthcdr 2 keys)))
 308     result))
 309
 310 (defun plstore-find (plstore keys)
 311   "Perform search on PLSTORE with KEYS.
 312 KEYS is a plist."
 313   (let (entries alist entry match decrypt plist)
 314     ;; First, go through the merged plist alist and collect entries
 315     ;; matched with keys.
 316     (setq alist (plstore--get-merged-alist plstore))
 317     (while alist
 318       (setq entry (car alist)
 319             alist (cdr alist)
 320             match (plstore--match entry keys t))
 321       (if (eq match 'secret)
 322           (setq decrypt t)
 323         (when match
 324           (setq plist (cdr entry))
 325           (while plist
 326             (if (string-match "\\`:secret-" (symbol-name (car plist)))
 327                 (setq decrypt t
 328                       plist nil))
 329             (setq plist (nthcdr 2 plist)))
 330           (setq entries (cons entry entries)))))
 331     ;; Second, decrypt the encrypted plist and try again.
 332     (when decrypt
 333       (setq entries nil)
 334       (plstore--decrypt plstore)
 335       (setq alist (plstore--get-merged-alist plstore))
 336       (while alist
 337         (setq entry (car alist)
 338               alist (cdr alist)
 339               match (plstore--match entry keys nil))
 340         (if match
 341             (setq entries (cons entry entries)))))
 342     (nreverse entries)))
 343
 344 (defun plstore-get (plstore name)
 345   "Get an entry with NAME in PLSTORE."
 346   (let ((entry (assoc name (plstore--get-merged-alist plstore)))
 347         plist)
 348     (setq plist (cdr entry))
 349     (while plist
 350       (if (string-match "\\`:secret-" (symbol-name (car plist)))
 351           (progn
 352             (plstore--decrypt plstore)
 353             (setq entry (assoc name (plstore--get-merged-alist plstore))
 354                   plist nil))
 355         (setq plist (nthcdr 2 plist))))
 356     entry))
 357
 358 (defun plstore-put (plstore name keys secret-keys)
 359   "Put an entry with NAME in PLSTORE.
 360 KEYS is a plist containing non-secret data.
 361 SECRET-KEYS is a plist containing secret data."
 362   (let (entry
 363         plist
 364         secret-plist
 365         symbol)
 366     (if secret-keys
 367         (plstore--decrypt plstore))
 368     (while secret-keys
 369       (setq symbol
 370             (intern (concat ":secret-"
 371                             (substring (symbol-name (car secret-keys)) 1))))
 372       (setq plist (plist-put plist symbol t)
 373             secret-plist (plist-put secret-plist
 374                                     (car secret-keys) (car (cdr secret-keys)))
 375             secret-keys (nthcdr 2 secret-keys)))
 376     (while keys
 377       (setq symbol
 378             (intern (concat ":secret-"
 379                             (substring (symbol-name (car keys)) 1))))
 380       (setq plist (plist-put plist (car keys) (car (cdr keys)))
 381             keys (nthcdr 2 keys)))
 382     (setq entry (assoc name (plstore--get-alist plstore)))
 383     (if entry
 384         (setcdr entry plist)
 385       (plstore--set-alist
 386        plstore
 387        (cons (cons name plist) (plstore--get-alist plstore))))
 388     (when secret-plist
 389       (setq entry (assoc name (plstore--get-secret-alist plstore)))
 390       (if entry
 391           (setcdr entry secret-plist)
 392         (plstore--set-secret-alist
 393          plstore
 394          (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
 395     (plstore--merge-secret plstore)))
 396
 397 (defun plstore-delete (plstore name)
 398   "Delete an entry with NAME from PLSTORE."
 399   (let ((entry (assoc name (plstore--get-alist plstore))))
 400     (if entry
 401         (plstore--set-alist
 402          plstore
 403          (delq entry (plstore--get-alist plstore))))
 404     (setq entry (assoc name (plstore--get-secret-alist plstore)))
 405     (if entry
 406         (plstore--set-secret-alist
 407          plstore
 408          (delq entry (plstore--get-secret-alist plstore))))
 409     (setq entry (assoc name (plstore--get-merged-alist plstore)))
 410     (if entry
 411         (plstore--set-merged-alist
 412          plstore
 413          (delq entry (plstore--get-merged-alist plstore))))))
 414
 415 (defvar pp-escape-newlines)
 416 (defun plstore--insert-buffer (plstore)
 417   (insert ";;; public entries -*- mode: plstore -*- \n"
 418           (pp-to-string (plstore--get-alist plstore)))
 419   (if (plstore--get-secret-alist plstore)
 420       (let ((context (epg-make-context 'OpenPGP))
 421             (pp-escape-newlines nil)
 422             (recipients
 423              (cond
 424               ((listp plstore-encrypt-to) plstore-encrypt-to)
 425               ((stringp plstore-encrypt-to) (list plstore-encrypt-to))))
 426             cipher)
 427         (setf (epg-context-armor context) t)
 428         (epg-context-set-passphrase-callback
 429          context
 430          (cons #'plstore-passphrase-callback-function
 431                plstore))
 432         (setq cipher (epg-encrypt-string
 433                       context
 434                       (pp-to-string
 435                        (plstore--get-secret-alist plstore))
 436                       (if (or (eq plstore-select-keys t)
 437                               (and (null plstore-select-keys)
 438                                    (not (local-variable-p 'plstore-encrypt-to
 439                                                           (current-buffer)))))
 440                           (epa-select-keys
 441                            context
 442                            "Select recipients for encryption.
 443 If no one is selected, symmetric encryption will be performed.  "
 444                            recipients)
 445                         (if plstore-encrypt-to
 446                             (epg-list-keys context recipients)))))
 447         (goto-char (point-max))
 448         (insert ";;; secret entries\n" (pp-to-string cipher)))))
 449
 450 (defun plstore-save (plstore)
 451   "Save the contents of PLSTORE associated with a FILE."
 452   (with-current-buffer (plstore--get-buffer plstore)
 453     (erase-buffer)
 454     (plstore--insert-buffer plstore)
 455     (save-buffer)))
 456
 457 (defun plstore--encode (plstore)
 458   (plstore--decrypt plstore)
 459   (let ((merged-alist (plstore--get-merged-alist plstore)))
 460     (concat "("
 461             (mapconcat
 462              (lambda (entry)
 463                (setq entry (copy-sequence entry))
 464                (let ((merged-plist (cdr (assoc (car entry) merged-alist)))
 465                      (plist (cdr entry)))
 466                  (while plist
 467                    (if (string-match "\\`:secret-" (symbol-name (car plist)))
 468                        (setcar (cdr plist)
 469                                (plist-get
 470                                 merged-plist
 471                                 (intern (concat ":"
 472                                                 (substring (symbol-name
 473                                                             (car plist))
 474                                                            (match-end 0)))))))
 475                    (setq plist (nthcdr 2 plist)))
 476                  (prin1-to-string entry)))
 477              (plstore--get-alist plstore)
 478              "\n")
 479             ")")))
 480
 481 (defun plstore--decode (string)
 482   (let* ((alist (car (read-from-string string)))
 483          (pointer alist)
 484          secret-alist
 485          plist
 486          entry)
 487     (while pointer
 488       (unless (stringp (car (car pointer)))
 489         (error "Invalid PLSTORE format %s" string))
 490       (setq plist (cdr (car pointer)))
 491       (while plist
 492         (when (string-match "\\`:secret-" (symbol-name (car plist)))
 493           (setq entry (assoc (car (car pointer)) secret-alist))
 494           (unless entry
 495             (setq entry (list (car (car pointer)))
 496                   secret-alist (cons entry secret-alist)))
 497           (setcdr entry (plist-put (cdr entry)
 498                                    (intern (concat ":"
 499                                                 (substring (symbol-name
 500                                                             (car plist))
 501                                                            (match-end 0))))
 502                                    (car (cdr plist))))
 503           (setcar (cdr plist) t))
 504         (setq plist (nthcdr 2 plist)))
 505       (setq pointer (cdr pointer)))
 506     (plstore--make nil alist nil secret-alist)))
 507
 508 (defun plstore--write-contents-functions ()
 509   (when plstore-encoded
 510     (let ((store (plstore--decode (buffer-string)))
 511           (file (buffer-file-name)))
 512       (unwind-protect
 513           (progn
 514             (set-visited-file-name nil)
 515             (with-temp-buffer
 516               (plstore--insert-buffer store)
 517               (write-region (buffer-string) nil file)))
 518         (set-visited-file-name file)
 519         (set-buffer-modified-p nil))
 520       t)))
 521
 522 (defun plstore-mode-original ()
 523   "Show the original form of the this buffer."
 524   (interactive)
 525   (when plstore-encoded
 526     (if (and (buffer-modified-p)
 527              (y-or-n-p "Save buffer before reading the original form? "))
 528         (save-buffer))
 529     (erase-buffer)
 530     (insert-file-contents-literally (buffer-file-name))
 531     (set-buffer-modified-p nil)
 532     (setq plstore-encoded nil)))
 533
 534 (defun plstore-mode-decoded ()
 535   "Show the decoded form of the this buffer."
 536   (interactive)
 537   (unless plstore-encoded
 538     (if (and (buffer-modified-p)
 539              (y-or-n-p "Save buffer before decoding? "))
 540         (save-buffer))
 541     (let ((store (plstore--make (current-buffer))))
 542       (plstore--init-from-buffer store)
 543       (erase-buffer)
 544       (insert
 545        (substitute-command-keys "\
 546 ;;; You are looking at the decoded form of the PLSTORE file.\n\
 547 ;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n"))
 548       (insert (plstore--encode store))
 549       (set-buffer-modified-p nil)
 550       (setq plstore-encoded t))))
 551
 552 (defun plstore-mode-toggle-display ()
 553   "Toggle the display mode of PLSTORE between the original and decoded forms."
 554   (interactive)
 555   (if plstore-encoded
 556       (plstore-mode-original)
 557     (plstore-mode-decoded)))
 558
 559 ;;;###autoload
 560 (define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE"
 561   "Major mode for editing PLSTORE files."
 562   (make-local-variable 'plstore-encoded)
 563   (add-hook 'write-contents-functions #'plstore--write-contents-functions)
 564   (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display)
 565   ;; to create a new file with plstore-mode, mark it as already decoded
 566   (if (called-interactively-p 'any)
 567       (setq plstore-encoded t)
 568     (plstore-mode-decoded)))
 569
 570 (provide 'plstore)
 571
 572 ;;; plstore.el ends here