[bpt/emacs.git] / lisp / gnus / plstore.el

;;; plstore.el --- searchable, partially encrypted, persistent plist store -*- lexical-binding: t -*-
;; Copyright (C) 2011 Free Software Foundation, Inc.

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary

;; Creating:
;;
;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist")))
;; (plstore-put store "foo" '(:host "foo.example.org" :port 80) nil)
;; (plstore-save store)
;; ;; :user property is secret
;; (plstore-put store "bar" '(:host "bar.example.org") '(:user "test"))
;; (plstore-put store "baz" '(:host "baz.example.org") '(:user "test"))
;; (plstore-save store) ;<= will ask passphrase via GPG
;; (plstore-close store)
;;
;; Searching:
;;
;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist")))
;; (plstore-find store '(:host ("foo.example.org")))
;; (plstore-find store '(:host ("bar.example.org"))) ;<= will ask passphrase via GPG
;; (plstore-close store)
;;

;;; Code:

(require 'epg)

(defvar plstore-cache-passphrase-for-symmetric-encryption nil)
(defvar plstore-passphrase-alist nil)

(defun plstore-passphrase-callback-function (_context _key-id plstore)
  (if plstore-cache-passphrase-for-symmetric-encryption
      (let* ((file (file-truename (plstore--get-buffer plstore)))
	     (entry (assoc file plstore-passphrase-alist))
	     passphrase)
	(or (copy-sequence (cdr entry))
	    (progn
	      (unless entry
		(setq entry (list file)
		      plstore-passphrase-alist
		      (cons entry
			    plstore-passphrase-alist)))
	      (setq passphrase
		    (read-passwd (format "Passphrase for PLSTORE %s: "
					 (plstore--get-buffer plstore))))
	      (setcdr entry (copy-sequence passphrase))
	      passphrase)))
    (read-passwd (format "Passphrase for PLSTORE %s: "
			 (plstore--get-buffer plstore)))))

(defun plstore-progress-callback-function (_context _what _char current total
						    handback)
  (if (= current total)
      (message "%s...done" handback)
    (message "%s...%d%%" handback
	     (if (> total 0) (floor (* (/ current (float total)) 100)) 0))))

(defun plstore--get-buffer (this)
  (aref this 0))

(defun plstore--get-alist (this)
  (aref this 1))

(defun plstore--get-encrypted-data (this)
  (aref this 2))

(defun plstore--get-secret-alist (this)
  (aref this 3))

(defun plstore--get-merged-alist (this)
  (aref this 4))

(defun plstore--set-file (this file)
  (aset this 0 file))

(defun plstore--set-alist (this plist)
  (aset this 1 plist))

(defun plstore--set-encrypted-data (this encrypted-data)
  (aset this 2 encrypted-data))

(defun plstore--set-secret-alist (this secret-alist)
  (aset this 3 secret-alist))

(defun plstore--set-merged-alist (this merged-alist)
  (aset this 4 merged-alist))

(defun plstore-get-file (this)
  (buffer-file-name (plstore--get-buffer this)))

;;;###autoload
(defun plstore-open (file)
  "Create a plstore instance associated with FILE."
  (let ((store (vector
		(find-file-noselect file)
		nil		     ;plist (plist)
		nil		     ;encrypted data (string)
		nil		     ;secret plist (plist)
		nil		     ;merged plist (plist)
		)))
    (plstore-revert store)
    store))

(defun plstore-revert (plstore)
  "Replace current data in PLSTORE with the file on disk."
  (with-current-buffer (plstore--get-buffer plstore)
    (revert-buffer t t)
    ;; make the buffer invisible from user
    (rename-buffer (format " plstore %s" (buffer-file-name)))
    (goto-char (point-min))
    (when (looking-at ";;; public entries\n")
      (forward-line)
      (plstore--set-alist plstore (read (point-marker)))
      (forward-sexp)
      (forward-char)
      (when (looking-at ";;; secret entries\n")
	(forward-line)
	(plstore--set-encrypted-data plstore (read (point-marker))))
      (plstore--merge-secret plstore))))

(defun plstore-close (plstore)
  "Destroy a plstore instance PLSTORE."
  (kill-buffer (plstore--get-buffer plstore)))

(defun plstore--merge-secret (plstore)
  (let ((alist (plstore--get-secret-alist plstore))
	modified-alist
	modified-plist
	modified-entry
	entry
	plist
	placeholder)
    (plstore--set-merged-alist
     plstore
     (copy-tree (plstore--get-alist plstore)))
    (setq modified-alist (plstore--get-merged-alist plstore))
    (while alist
      (setq entry (car alist)
	    alist (cdr alist)
	    plist (cdr entry)
	    modified-entry (assoc (car entry) modified-alist)
	    modified-plist (cdr modified-entry))
      (while plist
	(setq placeholder
	      (plist-member
	       modified-plist
	       (intern (concat ":secret-"
			       (substring (symbol-name (car plist)) 1)))))
	(if placeholder
	    (setcar placeholder (car plist)))
	(setq modified-plist
	      (plist-put modified-plist (car plist) (car (cdr plist))))
	(setq plist (nthcdr 2 plist)))
      (setcdr modified-entry modified-plist))))

(defun plstore--decrypt (plstore)
  (if (plstore--get-encrypted-data plstore)
      (let ((context (epg-make-context 'OpenPGP))
	    plain)
	(epg-context-set-passphrase-callback
	 context
	 (cons #'plstore-passphrase-callback-function
	       plstore))
	(epg-context-set-progress-callback
	 context
	 (cons #'plstore-progress-callback-function
	       (format "Decrypting %s" (plstore-get-file plstore))))
	(setq plain
	      (epg-decrypt-string context
				  (plstore--get-encrypted-data plstore)))
	(plstore--set-secret-alist plstore (car (read-from-string plain)))
	(plstore--merge-secret plstore)
	(plstore--set-encrypted-data plstore nil))))

(defun plstore--match (entry keys skip-if-secret-found)
  (let ((result t) key-name key-value prop-value secret-name)
    (while keys
      (setq key-name (car keys)
	    key-value (car (cdr keys))
	    prop-value (plist-get (cdr entry) key-name))
	(unless (member prop-value key-value)
	  (if skip-if-secret-found
	      (progn
		(setq secret-name
		      (intern (concat ":secret-"
				      (substring (symbol-name key-name) 1))))
		(if (plist-member (cdr entry) secret-name)
		    (setq result 'secret)
		  (setq result nil
			keys nil)))
	    (setq result nil
		  keys nil)))
	(setq keys (nthcdr 2 keys)))
    result))

(defun plstore-find (plstore keys)
  "Perform search on PLSTORE with KEYS.
KEYS is a plist."
  (let (entries alist entry match decrypt plist)
    ;; First, go through the merged plist alist and collect entries
    ;; matched with keys.
    (setq alist (plstore--get-merged-alist plstore))
    (while alist
      (setq entry (car alist)
	    alist (cdr alist)
	    match (plstore--match entry keys t))
      (if (eq match 'secret)
	  (setq decrypt t)
	(when match
	  (setq plist (cdr entry))
	  (while plist
	    (if (string-match "\\`:secret-" (symbol-name (car plist)))
		(setq decrypt t
		      plist nil))
	    (setq plist (nthcdr 2 plist)))
	  (setq entries (cons entry entries)))))
    ;; Second, decrypt the encrypted plist and try again.
    (when decrypt
      (setq entries nil)
      (plstore--decrypt plstore)
      (setq alist (plstore--get-merged-alist plstore))
      (while alist
	(setq entry (car alist)
	      alist (cdr alist)
	      match (plstore--match entry keys nil))
	(if match
	    (setq entries (cons entry entries)))))
    (nreverse entries)))

(defun plstore-get (plstore name)
  "Get an entry with NAME in PLSTORE."
  (let ((entry (assoc name (plstore--get-merged-alist plstore)))
	plist)
    (setq plist (cdr entry))
    (while plist
      (if (string-match "\\`:secret-" (symbol-name (car plist)))
	  (progn
	    (plstore--decrypt plstore)
	    (setq entry (assoc name (plstore--get-merged-alist plstore))
		  plist nil))
	(setq plist (nthcdr 2 plist))))
    entry))

(defun plstore-put (plstore name keys secret-keys)
  "Put an entry with NAME in PLSTORE.
KEYS is a plist containing non-secret data.
SECRET-KEYS is a plist containing secret data."
  (let (entry
	plist
	secret-plist
	symbol)
    (if secret-keys
	(plstore--decrypt plstore))
    (while secret-keys
      (setq symbol
	    (intern (concat ":secret-"
			    (substring (symbol-name (car secret-keys)) 1))))
      (setq plist (plist-put plist symbol t)
	    secret-plist (plist-put secret-plist
				    (car secret-keys) (car (cdr secret-keys)))
	    secret-keys (nthcdr 2 secret-keys)))
    (while keys
      (setq symbol
	    (intern (concat ":secret-"
			    (substring (symbol-name (car keys)) 1))))
      (setq plist (plist-put plist (car keys) (car (cdr keys)))
	    keys (nthcdr 2 keys)))
    (setq entry (assoc name (plstore--get-alist plstore)))
    (if entry
	(setcdr entry plist)
      (plstore--set-alist
       plstore
       (cons (cons name plist) (plstore--get-alist plstore))))
    (when secret-plist
      (setq entry (assoc name (plstore--get-secret-alist plstore)))
      (if entry
	  (setcdr entry secret-plist)
	(plstore--set-secret-alist
	 plstore
	 (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
    (plstore--merge-secret plstore)))

(defvar pp-escape-newlines)
(defun plstore-save (plstore)
  "Save the contents of PLSTORE associated with a FILE."
  (with-current-buffer (plstore--get-buffer plstore)
    (erase-buffer)
    (insert ";;; public entries\n" (pp-to-string (plstore--get-alist plstore)))
    (if (plstore--get-secret-alist plstore)
	(let ((context (epg-make-context 'OpenPGP))
	      (pp-escape-newlines nil)
	      cipher)
	  (epg-context-set-armor context t)
	  (epg-context-set-passphrase-callback
	   context
	   (cons #'plstore-passphrase-callback-function
		 plstore))
	  (setq cipher (epg-encrypt-string context
					   (pp-to-string
					    (plstore--get-secret-alist plstore))
					   nil))
	  (insert ";;; secret entries\n" (pp-to-string cipher))))
    (save-buffer)))

(provide 'plstore)

;;; plstore.el ends here
Commit	Line	Data
8977de27 DU	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	)))
8a8cdb19	120	(plstore-revert store)
8977de27 DU	121	store))
8977de27 DU	122
8a8cdb19 DU	123	(defun plstore-revert (plstore)
	124	"Replace current data in PLSTORE with the file on disk."
	125	(with-current-buffer (plstore--get-buffer plstore)
f11f303b	126	(revert-buffer t t)
8a8cdb19 DU	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
8977de27 DU	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