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

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