code.delx.au - gnu-emacs/blob - lisp/gnus/plstore.el

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