cgit.sxemacs.org Git - gnus/blob - lisp/plstore.el

   1 ;;; plstore.el --- secure plist store -*- lexical-binding: t -*-
   2 ;; Copyright (C) 2011-2012 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 ;; Currently not supported but in the future plstore will provide a
  68 ;; major mode to edit PLSTORE files.
  69
  70 ;;; Code:
  71
  72 (require 'epg)
  73
  74 (defgroup plstore nil
  75   "Searchable, partially encrypted, persistent plist store"
  76   :version "24.1"
  77   :group 'files)
  78
  79 (defcustom plstore-select-keys 'silent
  80   "Control whether or not to pop up the key selection dialog.
  81
  82 If t, always asks user to select recipients.
  83 If nil, query user only when a file's default recipients are not
  84 known (i.e. `plstore-encrypt-to' is not locally set in the buffer
  85 visiting a plstore file).
  86 If neither t nor nil, doesn't ask user."
  87   :type '(choice (const :tag "Ask always" t)
  88                  (const :tag "Ask when recipients are not set" nil)
  89                  (const :tag "Don't ask" silent))
  90   :group 'plstore)
  91
  92 (defvar plstore-encrypt-to nil
  93   "*Recipient(s) used for encrypting secret entries.
  94 May either be a string or a list of strings.  If it is nil,
  95 symmetric encryption will be used.")
  96
  97 (put 'plstore-encrypt-to 'safe-local-variable
  98      (lambda (val)
  99        (or (stringp val)
 100            (and (listp val)
 101                 (catch 'safe
 102                   (mapc (lambda (elt)
 103                           (unless (stringp elt)
 104                             (throw 'safe nil)))
 105                         val)
 106                   t)))))
 107
 108 (put 'plstore-encrypt-to 'permanent-local t)
 109
 110 (defvar plstore-cache-passphrase-for-symmetric-encryption nil)
 111 (defvar plstore-passphrase-alist nil)
 112
 113 (defun plstore-passphrase-callback-function (_context _key-id plstore)
 114   (if plstore-cache-passphrase-for-symmetric-encryption
 115       (let* ((file (file-truename (plstore--get-buffer plstore)))
 116              (entry (assoc file plstore-passphrase-alist))
 117              passphrase)
 118         (or (copy-sequence (cdr entry))
 119             (progn
 120               (unless entry
 121                 (setq entry (list file)
 122                       plstore-passphrase-alist
 123                       (cons entry
 124                             plstore-passphrase-alist)))
 125               (setq passphrase
 126                     (read-passwd (format "Passphrase for PLSTORE %s: "
 127                                          (plstore--get-buffer plstore))))
 128               (setcdr entry (copy-sequence passphrase))
 129               passphrase)))
 130     (read-passwd (format "Passphrase for PLSTORE %s: "
 131                          (plstore--get-buffer plstore)))))
 132
 133 (defun plstore-progress-callback-function (_context _what _char current total
 134                                                     handback)
 135   (if (= current total)
 136       (message "%s...done" handback)
 137     (message "%s...%d%%" handback
 138              (if (> total 0) (floor (* (/ current (float total)) 100)) 0))))
 139
 140 (defun plstore--get-buffer (arg)
 141   (aref arg 0))
 142
 143 (defun plstore--get-alist (arg)
 144   (aref arg 1))
 145
 146 (defun plstore--get-encrypted-data (arg)
 147   (aref arg 2))
 148
 149 (defun plstore--get-secret-alist (arg)
 150   (aref arg 3))
 151
 152 (defun plstore--get-merged-alist (arg)
 153   (aref arg 4))
 154
 155 (defun plstore--set-buffer (arg buffer)
 156   (aset arg 0 buffer))
 157
 158 (defun plstore--set-alist (arg plist)
 159   (aset arg 1 plist))
 160
 161 (defun plstore--set-encrypted-data (arg encrypted-data)
 162   (aset arg 2 encrypted-data))
 163
 164 (defun plstore--set-secret-alist (arg secret-alist)
 165   (aset arg 3 secret-alist))
 166
 167 (defun plstore--set-merged-alist (arg merged-alist)
 168   (aset arg 4 merged-alist))
 169
 170 (defun plstore-get-file (arg)
 171   (buffer-file-name (plstore--get-buffer arg)))
 172
 173 (defun plstore--make (&optional buffer alist encrypted-data secret-alist
 174                                 merged-alist)
 175   (vector buffer alist encrypted-data secret-alist merged-alist))
 176
 177 (defun plstore--init-from-buffer (plstore)
 178   (goto-char (point-min))
 179   (when (looking-at ";;; public entries")
 180     (forward-line)
 181     (plstore--set-alist plstore (read (point-marker)))
 182     (forward-sexp)
 183     (forward-char)
 184     (when (looking-at ";;; secret entries")
 185       (forward-line)
 186       (plstore--set-encrypted-data plstore (read (point-marker))))
 187     (plstore--merge-secret plstore)))
 188
 189 ;;;###autoload
 190 (defun plstore-open (file)
 191   "Create a plstore instance associated with FILE."
 192   (let* ((filename (file-truename file))
 193          (buffer (or (find-buffer-visiting filename)
 194                      (generate-new-buffer (format " plstore %s" filename))))
 195          (store (plstore--make buffer)))
 196     (with-current-buffer buffer
 197       ;; In the future plstore will provide a major mode called
 198       ;; `plstore-mode' to edit PLSTORE files.
 199       (if (eq major-mode 'plstore-mode)
 200           (error "%s is opened for editing; kill the buffer first" file))
 201       (erase-buffer)
 202       (condition-case nil
 203           (insert-file-contents-literally file)
 204         (error))
 205       (setq buffer-file-name (file-truename file))
 206       (set-buffer-modified-p nil)
 207       (plstore--init-from-buffer store)
 208       store)))
 209
 210 (defun plstore-revert (plstore)
 211   "Replace current data in PLSTORE with the file on disk."
 212   (with-current-buffer (plstore--get-buffer plstore)
 213     (revert-buffer t t)
 214     (plstore--init-from-buffer plstore)))
 215
 216 (defun plstore-close (plstore)
 217   "Destroy a plstore instance PLSTORE."
 218   (kill-buffer (plstore--get-buffer plstore)))
 219
 220 (defun plstore--merge-secret (plstore)
 221   (let ((alist (plstore--get-secret-alist plstore))
 222         modified-alist
 223         modified-plist
 224         modified-entry
 225         entry
 226         plist
 227         placeholder)
 228     (plstore--set-merged-alist
 229      plstore
 230      (copy-tree (plstore--get-alist plstore)))
 231     (setq modified-alist (plstore--get-merged-alist plstore))
 232     (while alist
 233       (setq entry (car alist)
 234             alist (cdr alist)
 235             plist (cdr entry)
 236             modified-entry (assoc (car entry) modified-alist)
 237             modified-plist (cdr modified-entry))
 238       (while plist
 239         (setq placeholder
 240               (plist-member
 241                modified-plist
 242                (intern (concat ":secret-"
 243                                (substring (symbol-name (car plist)) 1)))))
 244         (if placeholder
 245             (setcar placeholder (car plist)))
 246         (setq modified-plist
 247               (plist-put modified-plist (car plist) (car (cdr plist))))
 248         (setq plist (nthcdr 2 plist)))
 249       (setcdr modified-entry modified-plist))))
 250
 251 (defun plstore--decrypt (plstore)
 252   (if (plstore--get-encrypted-data plstore)
 253       (let ((context (epg-make-context 'OpenPGP))
 254             plain)
 255         (epg-context-set-passphrase-callback
 256          context
 257          (cons #'plstore-passphrase-callback-function
 258                plstore))
 259         (epg-context-set-progress-callback
 260          context
 261          (cons #'plstore-progress-callback-function
 262                (format "Decrypting %s" (plstore-get-file plstore))))
 263         (setq plain
 264               (epg-decrypt-string context
 265                                   (plstore--get-encrypted-data plstore)))
 266         (plstore--set-secret-alist plstore (car (read-from-string plain)))
 267         (plstore--merge-secret plstore)
 268         (plstore--set-encrypted-data plstore nil))))
 269
 270 (defun plstore--match (entry keys skip-if-secret-found)
 271   (let ((result t) key-name key-value prop-value secret-name)
 272     (while keys
 273       (setq key-name (car keys)
 274             key-value (car (cdr keys))
 275             prop-value (plist-get (cdr entry) key-name))
 276         (unless (member prop-value key-value)
 277           (if skip-if-secret-found
 278               (progn
 279                 (setq secret-name
 280                       (intern (concat ":secret-"
 281                                       (substring (symbol-name key-name) 1))))
 282                 (if (plist-member (cdr entry) secret-name)
 283                     (setq result 'secret)
 284                   (setq result nil
 285                         keys nil)))
 286             (setq result nil
 287                   keys nil)))
 288         (setq keys (nthcdr 2 keys)))
 289     result))
 290
 291 (defun plstore-find (plstore keys)
 292   "Perform search on PLSTORE with KEYS.
 293 KEYS is a plist."
 294   (let (entries alist entry match decrypt plist)
 295     ;; First, go through the merged plist alist and collect entries
 296     ;; matched with keys.
 297     (setq alist (plstore--get-merged-alist plstore))
 298     (while alist
 299       (setq entry (car alist)
 300             alist (cdr alist)
 301             match (plstore--match entry keys t))
 302       (if (eq match 'secret)
 303           (setq decrypt t)
 304         (when match
 305           (setq plist (cdr entry))
 306           (while plist
 307             (if (string-match "\\`:secret-" (symbol-name (car plist)))
 308                 (setq decrypt t
 309                       plist nil))
 310             (setq plist (nthcdr 2 plist)))
 311           (setq entries (cons entry entries)))))
 312     ;; Second, decrypt the encrypted plist and try again.
 313     (when decrypt
 314       (setq entries nil)
 315       (plstore--decrypt plstore)
 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 nil))
 321         (if match
 322             (setq entries (cons entry entries)))))
 323     (nreverse entries)))
 324
 325 (defun plstore-get (plstore name)
 326   "Get an entry with NAME in PLSTORE."
 327   (let ((entry (assoc name (plstore--get-merged-alist plstore)))
 328         plist)
 329     (setq plist (cdr entry))
 330     (while plist
 331       (if (string-match "\\`:secret-" (symbol-name (car plist)))
 332           (progn
 333             (plstore--decrypt plstore)
 334             (setq entry (assoc name (plstore--get-merged-alist plstore))
 335                   plist nil))
 336         (setq plist (nthcdr 2 plist))))
 337     entry))
 338
 339 (defun plstore-put (plstore name keys secret-keys)
 340   "Put an entry with NAME in PLSTORE.
 341 KEYS is a plist containing non-secret data.
 342 SECRET-KEYS is a plist containing secret data."
 343   (let (entry
 344         plist
 345         secret-plist
 346         symbol)
 347     (if secret-keys
 348         (plstore--decrypt plstore))
 349     (while secret-keys
 350       (setq symbol
 351             (intern (concat ":secret-"
 352                             (substring (symbol-name (car secret-keys)) 1))))
 353       (setq plist (plist-put plist symbol t)
 354             secret-plist (plist-put secret-plist
 355                                     (car secret-keys) (car (cdr secret-keys)))
 356             secret-keys (nthcdr 2 secret-keys)))
 357     (while keys
 358       (setq symbol
 359             (intern (concat ":secret-"
 360                             (substring (symbol-name (car keys)) 1))))
 361       (setq plist (plist-put plist (car keys) (car (cdr keys)))
 362             keys (nthcdr 2 keys)))
 363     (setq entry (assoc name (plstore--get-alist plstore)))
 364     (if entry
 365         (setcdr entry plist)
 366       (plstore--set-alist
 367        plstore
 368        (cons (cons name plist) (plstore--get-alist plstore))))
 369     (when secret-plist
 370       (setq entry (assoc name (plstore--get-secret-alist plstore)))
 371       (if entry
 372           (setcdr entry secret-plist)
 373         (plstore--set-secret-alist
 374          plstore
 375          (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
 376     (plstore--merge-secret plstore)))
 377
 378 (defun plstore-delete (plstore name)
 379   "Delete an entry with NAME from PLSTORE."
 380   (let ((entry (assoc name (plstore--get-alist plstore))))
 381     (if entry
 382         (plstore--set-alist
 383          plstore
 384          (delq entry (plstore--get-alist plstore))))
 385     (setq entry (assoc name (plstore--get-secret-alist plstore)))
 386     (if entry
 387         (plstore--set-secret-alist
 388          plstore
 389          (delq entry (plstore--get-secret-alist plstore))))
 390     (setq entry (assoc name (plstore--get-merged-alist plstore)))
 391     (if entry
 392         (plstore--set-merged-alist
 393          plstore
 394          (delq entry (plstore--get-merged-alist plstore))))))
 395
 396 (defvar pp-escape-newlines)
 397 (defun plstore--insert-buffer (plstore)
 398   (insert ";;; public entries -*- mode: plstore -*- \n"
 399           (pp-to-string (plstore--get-alist plstore)))
 400   (if (plstore--get-secret-alist plstore)
 401       (let ((context (epg-make-context 'OpenPGP))
 402             (pp-escape-newlines nil)
 403             (recipients
 404              (cond
 405               ((listp plstore-encrypt-to) plstore-encrypt-to)
 406               ((stringp plstore-encrypt-to) (list plstore-encrypt-to))))
 407             cipher)
 408         (epg-context-set-armor context t)
 409         (epg-context-set-passphrase-callback
 410          context
 411          (cons #'plstore-passphrase-callback-function
 412                plstore))
 413         (setq cipher (epg-encrypt-string
 414                       context
 415                       (pp-to-string
 416                        (plstore--get-secret-alist plstore))
 417                       (if (or (eq plstore-select-keys t)
 418                               (and (null plstore-select-keys)
 419                                    (not (local-variable-p 'plstore-encrypt-to
 420                                                           (current-buffer)))))
 421                           (epa-select-keys
 422                            context
 423                            "Select recipients for encryption.
 424 If no one is selected, symmetric encryption will be performed.  "
 425                            recipients)
 426                         (if plstore-encrypt-to
 427                             (epg-list-keys context recipients)))))
 428         (goto-char (point-max))
 429         (insert ";;; secret entries\n" (pp-to-string cipher)))))
 430
 431 (defun plstore-save (plstore)
 432   "Save the contents of PLSTORE associated with a FILE."
 433   (with-current-buffer (plstore--get-buffer plstore)
 434     (erase-buffer)
 435     (plstore--insert-buffer plstore)
 436     (save-buffer)))
 437
 438 (provide 'plstore)
 439
 440 ;;; plstore.el ends here