cgit.sxemacs.org Git - gnus/blob - lisp/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 (defvar plstore-cache-passphrase-for-symmetric-encryption nil)
  48 (defvar plstore-passphrase-alist nil)
  49
  50 (defun plstore-passphrase-callback-function (_context _key-id plstore)
  51   (if plstore-cache-passphrase-for-symmetric-encryption
  52       (let* ((file (file-truename (plstore--get-buffer plstore)))
  53              (entry (assoc file plstore-passphrase-alist))
  54              passphrase)
  55         (or (copy-sequence (cdr entry))
  56             (progn
  57               (unless entry
  58                 (setq entry (list file)
  59                       plstore-passphrase-alist
  60                       (cons entry
  61                             plstore-passphrase-alist)))
  62               (setq passphrase
  63                     (read-passwd (format "Passphrase for PLSTORE %s: "
  64                                          (plstore--get-buffer plstore))))
  65               (setcdr entry (copy-sequence passphrase))
  66               passphrase)))
  67     (read-passwd (format "Passphrase for PLSTORE %s: "
  68                          (plstore--get-buffer plstore)))))
  69
  70 (defun plstore-progress-callback-function (_context _what _char current total
  71                                                     handback)
  72   (if (= current total)
  73       (message "%s...done" handback)
  74     (message "%s...%d%%" handback
  75              (if (> total 0) (floor (* (/ current (float total)) 100)) 0))))
  76
  77 (defun plstore--get-buffer (this)
  78   (aref this 0))
  79
  80 (defun plstore--get-alist (this)
  81   (aref this 1))
  82
  83 (defun plstore--get-encrypted-data (this)
  84   (aref this 2))
  85
  86 (defun plstore--get-secret-alist (this)
  87   (aref this 3))
  88
  89 (defun plstore--get-merged-alist (this)
  90   (aref this 4))
  91
  92 (defun plstore--set-file (this file)
  93   (aset this 0 file))
  94
  95 (defun plstore--set-alist (this plist)
  96   (aset this 1 plist))
  97
  98 (defun plstore--set-encrypted-data (this encrypted-data)
  99   (aset this 2 encrypted-data))
 100
 101 (defun plstore--set-secret-alist (this secret-alist)
 102   (aset this 3 secret-alist))
 103
 104 (defun plstore--set-merged-alist (this merged-alist)
 105   (aset this 4 merged-alist))
 106
 107 (defun plstore-get-file (this)
 108   (buffer-file-name (plstore--get-buffer this)))
 109
 110 ;;;###autoload
 111 (defun plstore-open (file)
 112   "Create a plstore instance associated with FILE."
 113   (let ((store (vector
 114                 (find-file-noselect file)
 115                 nil                  ;plist (plist)
 116                 nil                  ;encrypted data (string)
 117                 nil                  ;secret plist (plist)
 118                 nil                  ;merged plist (plist)
 119                 )))
 120     (plstore-revert store)
 121     store))
 122
 123 (defun plstore-revert (plstore)
 124   "Replace current data in PLSTORE with the file on disk."
 125   (with-current-buffer (plstore--get-buffer plstore)
 126     (revert-buffer t t)
 127     ;; make the buffer invisible from user
 128     (rename-buffer (format " plstore %s" (buffer-file-name)))
 129     (goto-char (point-min))
 130     (when (looking-at ";;; public entries\n")
 131       (forward-line)
 132       (plstore--set-alist plstore (read (point-marker)))
 133       (forward-sexp)
 134       (forward-char)
 135       (when (looking-at ";;; secret entries\n")
 136         (forward-line)
 137         (plstore--set-encrypted-data plstore (read (point-marker))))
 138       (plstore--merge-secret plstore))))
 139
 140 (defun plstore-close (plstore)
 141   "Destroy a plstore instance PLSTORE."
 142   (kill-buffer (plstore--get-buffer plstore)))
 143
 144 (defun plstore--merge-secret (plstore)
 145   (let ((alist (plstore--get-secret-alist plstore))
 146         modified-alist
 147         modified-plist
 148         modified-entry
 149         entry
 150         plist
 151         placeholder)
 152     (plstore--set-merged-alist
 153      plstore
 154      (copy-tree (plstore--get-alist plstore)))
 155     (setq modified-alist (plstore--get-merged-alist plstore))
 156     (while alist
 157       (setq entry (car alist)
 158             alist (cdr alist)
 159             plist (cdr entry)
 160             modified-entry (assoc (car entry) modified-alist)
 161             modified-plist (cdr modified-entry))
 162       (while plist
 163         (setq placeholder
 164               (plist-member
 165                modified-plist
 166                (intern (concat ":secret-"
 167                                (substring (symbol-name (car plist)) 1)))))
 168         (if placeholder
 169             (setcar placeholder (car plist)))
 170         (setq modified-plist
 171               (plist-put modified-plist (car plist) (car (cdr plist))))
 172         (setq plist (nthcdr 2 plist)))
 173       (setcdr modified-entry modified-plist))))
 174
 175 (defun plstore--decrypt (plstore)
 176   (if (plstore--get-encrypted-data plstore)
 177       (let ((context (epg-make-context 'OpenPGP))
 178             plain)
 179         (epg-context-set-passphrase-callback
 180          context
 181          (cons #'plstore-passphrase-callback-function
 182                plstore))
 183         (epg-context-set-progress-callback
 184          context
 185          (cons #'plstore-progress-callback-function
 186                (format "Decrypting %s" (plstore-get-file plstore))))
 187         (setq plain
 188               (epg-decrypt-string context
 189                                   (plstore--get-encrypted-data plstore)))
 190         (plstore--set-secret-alist plstore (car (read-from-string plain)))
 191         (plstore--merge-secret plstore)
 192         (plstore--set-encrypted-data plstore nil))))
 193
 194 (defun plstore--match (entry keys skip-if-secret-found)
 195   (let ((result t) key-name key-value prop-value secret-name)
 196     (while keys
 197       (setq key-name (car keys)
 198             key-value (car (cdr keys))
 199             prop-value (plist-get (cdr entry) key-name))
 200         (unless (member prop-value key-value)
 201           (if skip-if-secret-found
 202               (progn
 203                 (setq secret-name
 204                       (intern (concat ":secret-"
 205                                       (substring (symbol-name key-name) 1))))
 206                 (if (plist-member (cdr entry) secret-name)
 207                     (setq result 'secret)
 208                   (setq result nil
 209                         keys nil)))
 210             (setq result nil
 211                   keys nil)))
 212         (setq keys (nthcdr 2 keys)))
 213     result))
 214
 215 (defun plstore-find (plstore keys)
 216   "Perform search on PLSTORE with KEYS.
 217 KEYS is a plist."
 218   (let (entries alist entry match decrypt plist)
 219     ;; First, go through the merged plist alist and collect entries
 220     ;; matched with keys.
 221     (setq alist (plstore--get-merged-alist plstore))
 222     (while alist
 223       (setq entry (car alist)
 224             alist (cdr alist)
 225             match (plstore--match entry keys t))
 226       (if (eq match 'secret)
 227           (setq decrypt t)
 228         (when match
 229           (setq plist (cdr entry))
 230           (while plist
 231             (if (string-match "\\`:secret-" (symbol-name (car plist)))
 232                 (setq decrypt t
 233                       plist nil))
 234             (setq plist (nthcdr 2 plist)))
 235           (setq entries (cons entry entries)))))
 236     ;; Second, decrypt the encrypted plist and try again.
 237     (when decrypt
 238       (setq entries nil)
 239       (plstore--decrypt plstore)
 240       (setq alist (plstore--get-merged-alist plstore))
 241       (while alist
 242         (setq entry (car alist)
 243               alist (cdr alist)
 244               match (plstore--match entry keys nil))
 245         (if match
 246             (setq entries (cons entry entries)))))
 247     (nreverse entries)))
 248
 249 (defun plstore-get (plstore name)
 250   "Get an entry with NAME in PLSTORE."
 251   (let ((entry (assoc name (plstore--get-merged-alist plstore)))
 252         plist)
 253     (setq plist (cdr entry))
 254     (while plist
 255       (if (string-match "\\`:secret-" (symbol-name (car plist)))
 256           (progn
 257             (plstore--decrypt plstore)
 258             (setq entry (assoc name (plstore--get-merged-alist plstore))
 259                   plist nil))
 260         (setq plist (nthcdr 2 plist))))
 261     entry))
 262
 263 (defun plstore-put (plstore name keys secret-keys)
 264   "Put an entry with NAME in PLSTORE.
 265 KEYS is a plist containing non-secret data.
 266 SECRET-KEYS is a plist containing secret data."
 267   (let (entry
 268         plist
 269         secret-plist
 270         symbol)
 271     (if secret-keys
 272         (plstore--decrypt plstore))
 273     (while secret-keys
 274       (setq symbol
 275             (intern (concat ":secret-"
 276                             (substring (symbol-name (car secret-keys)) 1))))
 277       (setq plist (plist-put plist symbol t)
 278             secret-plist (plist-put secret-plist
 279                                     (car secret-keys) (car (cdr secret-keys)))
 280             secret-keys (nthcdr 2 secret-keys)))
 281     (while keys
 282       (setq symbol
 283             (intern (concat ":secret-"
 284                             (substring (symbol-name (car keys)) 1))))
 285       (setq plist (plist-put plist (car keys) (car (cdr keys)))
 286             keys (nthcdr 2 keys)))
 287     (setq entry (assoc name (plstore--get-alist plstore)))
 288     (if entry
 289         (setcdr entry plist)
 290       (plstore--set-alist
 291        plstore
 292        (cons (cons name plist) (plstore--get-alist plstore))))
 293     (when secret-plist
 294       (setq entry (assoc name (plstore--get-secret-alist plstore)))
 295       (if entry
 296           (setcdr entry secret-plist)
 297         (plstore--set-secret-alist
 298          plstore
 299          (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
 300     (plstore--merge-secret plstore)))
 301
 302 (defvar pp-escape-newlines)
 303 (defun plstore-save (plstore)
 304   "Save the contents of PLSTORE associated with a FILE."
 305   (with-current-buffer (plstore--get-buffer plstore)
 306     (erase-buffer)
 307     (insert ";;; public entries\n" (pp-to-string (plstore--get-alist plstore)))
 308     (if (plstore--get-secret-alist plstore)
 309         (let ((context (epg-make-context 'OpenPGP))
 310               (pp-escape-newlines nil)
 311               cipher)
 312           (epg-context-set-armor context t)
 313           (epg-context-set-passphrase-callback
 314            context
 315            (cons #'plstore-passphrase-callback-function
 316                  plstore))
 317           (setq cipher (epg-encrypt-string context
 318                                            (pp-to-string
 319                                             (plstore--get-secret-alist plstore))
 320                                            nil))
 321           (insert ";;; secret entries\n" (pp-to-string cipher))))
 322     (save-buffer)))
 323
 324 (provide 'plstore)
 325
 326 ;;; plstore.el ends here