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     ;; make the buffer invisible from user
 127     (rename-buffer (format " plstore %s" (buffer-file-name)))
 128     (goto-char (point-min))
 129     (when (looking-at ";;; public entries\n")
 130       (forward-line)
 131       (plstore--set-alist plstore (read (point-marker)))
 132       (forward-sexp)
 133       (forward-char)
 134       (when (looking-at ";;; secret entries\n")
 135         (forward-line)
 136         (plstore--set-encrypted-data plstore (read (point-marker))))
 137       (plstore--merge-secret plstore))))
 138
 139 (defun plstore-close (plstore)
 140   "Destroy a plstore instance PLSTORE."
 141   (kill-buffer (plstore--get-buffer plstore)))
 142
 143 (defun plstore--merge-secret (plstore)
 144   (let ((alist (plstore--get-secret-alist plstore))
 145         modified-alist
 146         modified-plist
 147         modified-entry
 148         entry
 149         plist
 150         placeholder)
 151     (plstore--set-merged-alist
 152      plstore
 153      (copy-tree (plstore--get-alist plstore)))
 154     (setq modified-alist (plstore--get-merged-alist plstore))
 155     (while alist
 156       (setq entry (car alist)
 157             alist (cdr alist)
 158             plist (cdr entry)
 159             modified-entry (assoc (car entry) modified-alist)
 160             modified-plist (cdr modified-entry))
 161       (while plist
 162         (setq placeholder
 163               (plist-member
 164                modified-plist
 165                (intern (concat ":secret-"
 166                                (substring (symbol-name (car plist)) 1)))))
 167         (if placeholder
 168             (setcar placeholder (car plist)))
 169         (setq modified-plist
 170               (plist-put modified-plist (car plist) (car (cdr plist))))
 171         (setq plist (nthcdr 2 plist)))
 172       (setcdr modified-entry modified-plist))))
 173
 174 (defun plstore--decrypt (plstore)
 175   (if (plstore--get-encrypted-data plstore)
 176       (let ((context (epg-make-context 'OpenPGP))
 177             plain)
 178         (epg-context-set-passphrase-callback
 179          context
 180          (cons #'plstore-passphrase-callback-function
 181                plstore))
 182         (epg-context-set-progress-callback
 183          context
 184          (cons #'plstore-progress-callback-function
 185                (format "Decrypting %s" (plstore-get-file plstore))))
 186         (setq plain
 187               (epg-decrypt-string context
 188                                   (plstore--get-encrypted-data plstore)))
 189         (plstore--set-secret-alist plstore (car (read-from-string plain)))
 190         (plstore--merge-secret plstore)
 191         (plstore--set-encrypted-data plstore nil))))
 192
 193 (defun plstore--match (entry keys skip-if-secret-found)
 194   (let ((result t) key-name key-value prop-value secret-name)
 195     (while keys
 196       (setq key-name (car keys)
 197             key-value (car (cdr keys))
 198             prop-value (plist-get (cdr entry) key-name))
 199         (unless (member prop-value key-value)
 200           (if skip-if-secret-found
 201               (progn
 202                 (setq secret-name
 203                       (intern (concat ":secret-"
 204                                       (substring (symbol-name key-name) 1))))
 205                 (if (plist-member (cdr entry) secret-name)
 206                     (setq result 'secret)
 207                   (setq result nil
 208                         keys nil)))
 209             (setq result nil
 210                   keys nil)))
 211         (setq keys (nthcdr 2 keys)))
 212     result))
 213
 214 (defun plstore-find (plstore keys)
 215   "Perform search on PLSTORE with KEYS.
 216 KEYS is a plist."
 217   (let (entries alist entry match decrypt plist)
 218     ;; First, go through the merged plist alist and collect entries
 219     ;; matched with keys.
 220     (setq alist (plstore--get-merged-alist plstore))
 221     (while alist
 222       (setq entry (car alist)
 223             alist (cdr alist)
 224             match (plstore--match entry keys t))
 225       (if (eq match 'secret)
 226           (setq decrypt t)
 227         (when match
 228           (setq plist (cdr entry))
 229           (while plist
 230             (if (string-match "\\`:secret-" (symbol-name (car plist)))
 231                 (setq decrypt t
 232                       plist nil))
 233             (setq plist (nthcdr 2 plist)))
 234           (setq entries (cons entry entries)))))
 235     ;; Second, decrypt the encrypted plist and try again.
 236     (when decrypt
 237       (setq entries nil)
 238       (plstore--decrypt plstore)
 239       (setq alist (plstore--get-merged-alist plstore))
 240       (while alist
 241         (setq entry (car alist)
 242               alist (cdr alist)
 243               match (plstore--match entry keys nil))
 244         (if match
 245             (setq entries (cons entry entries)))))
 246     (nreverse entries)))
 247
 248 (defun plstore-get (plstore name)
 249   "Get an entry with NAME in PLSTORE."
 250   (let ((entry (assoc name (plstore--get-merged-alist plstore)))
 251         plist)
 252     (setq plist (cdr entry))
 253     (while plist
 254       (if (string-match "\\`:secret-" (symbol-name (car plist)))
 255           (progn
 256             (plstore--decrypt plstore)
 257             (setq entry (assoc name (plstore--get-merged-alist plstore))
 258                   plist nil))
 259         (setq plist (nthcdr 2 plist))))
 260     entry))
 261
 262 (defun plstore-put (plstore name keys secret-keys)
 263   "Put an entry with NAME in PLSTORE.
 264 KEYS is a plist containing non-secret data.
 265 SECRET-KEYS is a plist containing secret data."
 266   (let (entry
 267         plist
 268         secret-plist
 269         symbol)
 270     (if secret-keys
 271         (plstore--decrypt plstore))
 272     (while secret-keys
 273       (setq symbol
 274             (intern (concat ":secret-"
 275                             (substring (symbol-name (car secret-keys)) 1))))
 276       (setq plist (plist-put plist symbol t)
 277             secret-plist (plist-put secret-plist
 278                                     (car secret-keys) (car (cdr secret-keys)))
 279             secret-keys (nthcdr 2 secret-keys)))
 280     (while keys
 281       (setq symbol
 282             (intern (concat ":secret-"
 283                             (substring (symbol-name (car keys)) 1))))
 284       (setq plist (plist-put plist (car keys) (car (cdr keys)))
 285             keys (nthcdr 2 keys)))
 286     (setq entry (assoc name (plstore--get-alist plstore)))
 287     (if entry
 288         (setcdr entry plist)
 289       (plstore--set-alist
 290        plstore
 291        (cons (cons name plist) (plstore--get-alist plstore))))
 292     (when secret-plist
 293       (setq entry (assoc name (plstore--get-secret-alist plstore)))
 294       (if entry
 295           (setcdr entry secret-plist)
 296         (plstore--set-secret-alist
 297          plstore
 298          (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
 299     (plstore--merge-secret plstore)))
 300
 301 (defvar pp-escape-newlines)
 302 (defun plstore-save (plstore)
 303   "Save the contents of PLSTORE associated with a FILE."
 304   (with-current-buffer (plstore--get-buffer plstore)
 305     (erase-buffer)
 306     (insert ";;; public entries\n" (pp-to-string (plstore--get-alist plstore)))
 307     (if (plstore--get-secret-alist plstore)
 308         (let ((context (epg-make-context 'OpenPGP))
 309               (pp-escape-newlines nil)
 310               cipher)
 311           (epg-context-set-armor context t)
 312           (epg-context-set-passphrase-callback
 313            context
 314            (cons #'plstore-passphrase-callback-function
 315                  plstore))
 316           (setq cipher (epg-encrypt-string context
 317                                            (pp-to-string
 318                                             (plstore--get-secret-alist plstore))
 319                                            nil))
 320           (insert ";;; secret entries\n" (pp-to-string cipher))))
 321     (save-buffer)))
 322
 323 (provide 'plstore)
 324
 325 ;;; plstore.el ends here