lisp/gnus/plstore.el

   1 ;;; plstore.el --- secure plist store -*- lexical-binding: t -*-
   2 ;; Copyright (C) 2011-2015 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 ;; This file also provides `plstore-mode', a major mode for editing
  68 ;; the PLSTORE format file.  Visit a non-existing file and put the
  69 ;; following line:
  70 ;;
  71 ;; (("foo" :host "foo.example.org" :secret-user "user"))
  72 ;;
  73 ;; where the prefixing `:secret-' means the property (without
  74 ;; `:secret-' prefix) is marked as secret.  Thus, when you save the
  75 ;; buffer, the `:secret-user' property is encrypted as `:user'.
  76 ;;
  77 ;; You can toggle the view between encrypted form and the decrypted
  78 ;; form with C-c C-c.
  79
  80 ;;; Code:
  81
  82 (require 'epg)
  83
  84 (defgroup plstore nil
  85   "Searchable, partially encrypted, persistent plist store"
  86   :version "24.1"
  87   :group 'files)
  88
  89 (defcustom plstore-select-keys 'silent
  90   "Control whether or not to pop up the key selection dialog.
  91
  92 If t, always asks user to select recipients.
  93 If nil, query user only when a file's default recipients are not
  94 known (i.e. `plstore-encrypt-to' is not locally set in the buffer
  95 visiting a plstore file).
  96 If neither t nor nil, doesn't ask user."
  97   :type '(choice (const :tag "Ask always" t)
  98                  (const :tag "Ask when recipients are not set" nil)
  99                  (const :tag "Don't ask" silent))
 100   :group 'plstore)
 101
 102 (defvar plstore-encrypt-to nil
 103   "*Recipient(s) used for encrypting secret entries.
 104 May either be a string or a list of strings.  If it is nil,
 105 symmetric encryption will be used.")
 106
 107 (put 'plstore-encrypt-to 'safe-local-variable
 108      (lambda (val)
 109        (or (stringp val)
 110            (and (listp val)
 111                 (catch 'safe
 112                   (mapc (lambda (elt)
 113                           (unless (stringp elt)
 114                             (throw 'safe nil)))
 115                         val)
 116                   t)))))
 117
 118 (put 'plstore-encrypt-to 'permanent-local t)
 119
 120 (defvar plstore-encoded nil)
 121
 122 (put 'plstore-encoded 'permanent-local t)
 123
 124 (defvar plstore-cache-passphrase-for-symmetric-encryption nil)
 125 (defvar plstore-passphrase-alist nil)
 126
 127 (defun plstore-passphrase-callback-function (_context _key-id plstore)
 128   (if plstore-cache-passphrase-for-symmetric-encryption
 129       (let* ((file (file-truename (plstore-get-file plstore)))
 130              (entry (assoc file plstore-passphrase-alist))
 131              passphrase)
 132         (or (copy-sequence (cdr entry))
 133             (progn
 134               (unless entry
 135                 (setq entry (list file)
 136                       plstore-passphrase-alist
 137                       (cons entry
 138                             plstore-passphrase-alist)))
 139               (setq passphrase
 140                     (read-passwd (format "Passphrase for PLSTORE %s: "
 141                                          (plstore--get-buffer plstore))))
 142               (setcdr entry (copy-sequence passphrase))
 143               passphrase)))
 144     (read-passwd (format "Passphrase for PLSTORE %s: "
 145                          (plstore--get-buffer plstore)))))
 146
 147 (defun plstore-progress-callback-function (_context _what _char current total
 148                                                     handback)
 149   (if (= current total)
 150       (message "%s...done" handback)
 151     (message "%s...%d%%" handback
 152              (if (> total 0) (floor (* (/ current (float total)) 100)) 0))))
 153
 154 (defun plstore--get-buffer (arg)
 155   (aref arg 0))
 156
 157 (defun plstore--get-alist (arg)
 158   (aref arg 1))
 159
 160 (defun plstore--get-encrypted-data (arg)
 161   (aref arg 2))
 162
 163 (defun plstore--get-secret-alist (arg)
 164   (aref arg 3))
 165
 166 (defun plstore--get-merged-alist (arg)
 167   (aref arg 4))
 168
 169 (defun plstore--set-buffer (arg buffer)
 170   (aset arg 0 buffer))
 171
 172 (defun plstore--set-alist (arg plist)
 173   (aset arg 1 plist))
 174
 175 (defun plstore--set-encrypted-data (arg encrypted-data)
 176   (aset arg 2 encrypted-data))
 177
 178 (defun plstore--set-secret-alist (arg secret-alist)
 179   (aset arg 3 secret-alist))
 180
 181 (defun plstore--set-merged-alist (arg merged-alist)
 182   (aset arg 4 merged-alist))
 183
 184 (defun plstore-get-file (arg)
 185   (buffer-file-name (plstore--get-buffer arg)))
 186
 187 (defun plstore--make (&optional buffer alist encrypted-data secret-alist
 188                                 merged-alist)
 189   (vector buffer alist encrypted-data secret-alist merged-alist))
 190
 191 (defun plstore--init-from-buffer (plstore)
 192   (goto-char (point-min))
 193   (when (looking-at ";;; public entries")
 194     (forward-line)
 195     (plstore--set-alist plstore (read (point-marker)))
 196     (forward-sexp)
 197     (forward-char)
 198     (when (looking-at ";;; secret entries")
 199       (forward-line)
 200       (plstore--set-encrypted-data plstore (read (point-marker))))
 201     (plstore--merge-secret plstore)))
 202
 203 ;;;###autoload
 204 (defun plstore-open (file)
 205   "Create a plstore instance associated with FILE."
 206   (let* ((filename (file-truename file))
 207          (buffer (or (find-buffer-visiting filename)
 208                      (generate-new-buffer (format " plstore %s" filename))))
 209          (store (plstore--make buffer)))
 210     (with-current-buffer buffer
 211       (erase-buffer)
 212       (condition-case nil
 213           (insert-file-contents-literally file)
 214         (error))
 215       (setq buffer-file-name (file-truename file))
 216       (set-buffer-modified-p nil)
 217       (plstore--init-from-buffer store)
 218       store)))
 219
 220 (defun plstore-revert (plstore)
 221   "Replace current data in PLSTORE with the file on disk."
 222   (with-current-buffer (plstore--get-buffer plstore)
 223     (revert-buffer t t)
 224     (plstore--init-from-buffer plstore)))
 225
 226 (defun plstore-close (plstore)
 227   "Destroy a plstore instance PLSTORE."
 228   (kill-buffer (plstore--get-buffer plstore)))
 229
 230 (defun plstore--merge-secret (plstore)
 231   (let ((alist (plstore--get-secret-alist plstore))
 232         modified-alist
 233         modified-plist
 234         modified-entry
 235         entry
 236         plist
 237         placeholder)
 238     (plstore--set-merged-alist
 239      plstore
 240      (copy-tree (plstore--get-alist plstore)))
 241     (setq modified-alist (plstore--get-merged-alist plstore))
 242     (while alist
 243       (setq entry (car alist)
 244             alist (cdr alist)
 245             plist (cdr entry)
 246             modified-entry (assoc (car entry) modified-alist)
 247             modified-plist (cdr modified-entry))
 248       (while plist
 249         (setq placeholder
 250               (plist-member
 251                modified-plist
 252                (intern (concat ":secret-"
 253                                (substring (symbol-name (car plist)) 1)))))
 254         (if placeholder
 255             (setcar placeholder (car plist)))
 256         (setq modified-plist
 257               (plist-put modified-plist (car plist) (car (cdr plist))))
 258         (setq plist (nthcdr 2 plist)))
 259       (setcdr modified-entry modified-plist))))
 260
 261 (defun plstore--decrypt (plstore)
 262   (if (plstore--get-encrypted-data plstore)
 263       (let ((context (epg-make-context 'OpenPGP))
 264             plain)
 265         (epg-context-set-passphrase-callback
 266          context
 267          (cons #'plstore-passphrase-callback-function
 268                plstore))
 269         (epg-context-set-progress-callback
 270          context
 271          (cons #'plstore-progress-callback-function
 272                (format "Decrypting %s" (plstore-get-file plstore))))
 273         (condition-case error
 274             (setq plain
 275                   (epg-decrypt-string context
 276                                       (plstore--get-encrypted-data plstore)))
 277           (error
 278            (let ((entry (assoc (plstore-get-file plstore)
 279                                plstore-passphrase-alist)))
 280              (if entry
 281                  (setcdr entry nil)))
 282            (signal (car error) (cdr error))))
 283         (plstore--set-secret-alist plstore (car (read-from-string plain)))
 284         (plstore--merge-secret plstore)
 285         (plstore--set-encrypted-data plstore nil))))
 286
 287 (defun plstore--match (entry keys skip-if-secret-found)
 288   (let ((result t) key-name key-value prop-value secret-name)
 289     (while keys
 290       (setq key-name (car keys)
 291             key-value (car (cdr keys))
 292             prop-value (plist-get (cdr entry) key-name))
 293         (unless (member prop-value key-value)
 294           (if skip-if-secret-found
 295               (progn
 296                 (setq secret-name
 297                       (intern (concat ":secret-"
 298                                       (substring (symbol-name key-name) 1))))
 299                 (if (plist-member (cdr entry) secret-name)
 300                     (setq result 'secret)
 301                   (setq result nil
 302                         keys nil)))
 303             (setq result nil
 304                   keys nil)))
 305         (setq keys (nthcdr 2 keys)))
 306     result))
 307
 308 (defun plstore-find (plstore keys)
 309   "Perform search on PLSTORE with KEYS.
 310 KEYS is a plist."
 311   (let (entries alist entry match decrypt plist)
 312     ;; First, go through the merged plist alist and collect entries
 313     ;; matched with keys.
 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 t))
 319       (if (eq match 'secret)
 320           (setq decrypt t)
 321         (when match
 322           (setq plist (cdr entry))
 323           (while plist
 324             (if (string-match "\\`:secret-" (symbol-name (car plist)))
 325                 (setq decrypt t
 326                       plist nil))
 327             (setq plist (nthcdr 2 plist)))
 328           (setq entries (cons entry entries)))))
 329     ;; Second, decrypt the encrypted plist and try again.
 330     (when decrypt
 331       (setq entries nil)
 332       (plstore--decrypt plstore)
 333       (setq alist (plstore--get-merged-alist plstore))
 334       (while alist
 335         (setq entry (car alist)
 336               alist (cdr alist)
 337               match (plstore--match entry keys nil))
 338         (if match
 339             (setq entries (cons entry entries)))))
 340     (nreverse entries)))
 341
 342 (defun plstore-get (plstore name)
 343   "Get an entry with NAME in PLSTORE."
 344   (let ((entry (assoc name (plstore--get-merged-alist plstore)))
 345         plist)
 346     (setq plist (cdr entry))
 347     (while plist
 348       (if (string-match "\\`:secret-" (symbol-name (car plist)))
 349           (progn
 350             (plstore--decrypt plstore)
 351             (setq entry (assoc name (plstore--get-merged-alist plstore))
 352                   plist nil))
 353         (setq plist (nthcdr 2 plist))))
 354     entry))
 355
 356 (defun plstore-put (plstore name keys secret-keys)
 357   "Put an entry with NAME in PLSTORE.
 358 KEYS is a plist containing non-secret data.
 359 SECRET-KEYS is a plist containing secret data."
 360   (let (entry
 361         plist
 362         secret-plist
 363         symbol)
 364     (if secret-keys
 365         (plstore--decrypt plstore))
 366     (while secret-keys
 367       (setq symbol
 368             (intern (concat ":secret-"
 369                             (substring (symbol-name (car secret-keys)) 1))))
 370       (setq plist (plist-put plist symbol t)
 371             secret-plist (plist-put secret-plist
 372                                     (car secret-keys) (car (cdr secret-keys)))
 373             secret-keys (nthcdr 2 secret-keys)))
 374     (while keys
 375       (setq symbol
 376             (intern (concat ":secret-"
 377                             (substring (symbol-name (car keys)) 1))))
 378       (setq plist (plist-put plist (car keys) (car (cdr keys)))
 379             keys (nthcdr 2 keys)))
 380     (setq entry (assoc name (plstore--get-alist plstore)))
 381     (if entry
 382         (setcdr entry plist)
 383       (plstore--set-alist
 384        plstore
 385        (cons (cons name plist) (plstore--get-alist plstore))))
 386     (when secret-plist
 387       (setq entry (assoc name (plstore--get-secret-alist plstore)))
 388       (if entry
 389           (setcdr entry secret-plist)
 390         (plstore--set-secret-alist
 391          plstore
 392          (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
 393     (plstore--merge-secret plstore)))
 394
 395 (defun plstore-delete (plstore name)
 396   "Delete an entry with NAME from PLSTORE."
 397   (let ((entry (assoc name (plstore--get-alist plstore))))
 398     (if entry
 399         (plstore--set-alist
 400          plstore
 401          (delq entry (plstore--get-alist plstore))))
 402     (setq entry (assoc name (plstore--get-secret-alist plstore)))
 403     (if entry
 404         (plstore--set-secret-alist
 405          plstore
 406          (delq entry (plstore--get-secret-alist plstore))))
 407     (setq entry (assoc name (plstore--get-merged-alist plstore)))
 408     (if entry
 409         (plstore--set-merged-alist
 410          plstore
 411          (delq entry (plstore--get-merged-alist plstore))))))
 412
 413 (defvar pp-escape-newlines)
 414 (defun plstore--insert-buffer (plstore)
 415   (insert ";;; public entries -*- mode: plstore -*- \n"
 416           (pp-to-string (plstore--get-alist plstore)))
 417   (if (plstore--get-secret-alist plstore)
 418       (let ((context (epg-make-context 'OpenPGP))
 419             (pp-escape-newlines nil)
 420             (recipients
 421              (cond
 422               ((listp plstore-encrypt-to) plstore-encrypt-to)
 423               ((stringp plstore-encrypt-to) (list plstore-encrypt-to))))
 424             cipher)
 425         (epg-context-set-armor context t)
 426         (epg-context-set-passphrase-callback
 427          context
 428          (cons #'plstore-passphrase-callback-function
 429                plstore))
 430         (setq cipher (epg-encrypt-string
 431                       context
 432                       (pp-to-string
 433                        (plstore--get-secret-alist plstore))
 434                       (if (or (eq plstore-select-keys t)
 435                               (and (null plstore-select-keys)
 436                                    (not (local-variable-p 'plstore-encrypt-to
 437                                                           (current-buffer)))))
 438                           (epa-select-keys
 439                            context
 440                            "Select recipients for encryption.
 441 If no one is selected, symmetric encryption will be performed.  "
 442                            recipients)
 443                         (if plstore-encrypt-to
 444                             (epg-list-keys context recipients)))))
 445         (goto-char (point-max))
 446         (insert ";;; secret entries\n" (pp-to-string cipher)))))
 447
 448 (defun plstore-save (plstore)
 449   "Save the contents of PLSTORE associated with a FILE."
 450   (with-current-buffer (plstore--get-buffer plstore)
 451     (erase-buffer)
 452     (plstore--insert-buffer plstore)
 453     (save-buffer)))
 454
 455 (defun plstore--encode (plstore)
 456   (plstore--decrypt plstore)
 457   (let ((merged-alist (plstore--get-merged-alist plstore)))
 458     (concat "("
 459             (mapconcat
 460              (lambda (entry)
 461                (setq entry (copy-sequence entry))
 462                (let ((merged-plist (cdr (assoc (car entry) merged-alist)))
 463                      (plist (cdr entry)))
 464                  (while plist
 465                    (if (string-match "\\`:secret-" (symbol-name (car plist)))
 466                        (setcar (cdr plist)
 467                                (plist-get
 468                                 merged-plist
 469                                 (intern (concat ":"
 470                                                 (substring (symbol-name
 471                                                             (car plist))
 472                                                            (match-end 0)))))))
 473                    (setq plist (nthcdr 2 plist)))
 474                  (prin1-to-string entry)))
 475              (plstore--get-alist plstore)
 476              "\n")
 477             ")")))
 478
 479 (defun plstore--decode (string)
 480   (let* ((alist (car (read-from-string string)))
 481          (pointer alist)
 482          secret-alist
 483          plist
 484          entry)
 485     (while pointer
 486       (unless (stringp (car (car pointer)))
 487         (error "Invalid PLSTORE format %s" string))
 488       (setq plist (cdr (car pointer)))
 489       (while plist
 490         (when (string-match "\\`:secret-" (symbol-name (car plist)))
 491           (setq entry (assoc (car (car pointer)) secret-alist))
 492           (unless entry
 493             (setq entry (list (car (car pointer)))
 494                   secret-alist (cons entry secret-alist)))
 495           (setcdr entry (plist-put (cdr entry)
 496                                    (intern (concat ":"
 497                                                 (substring (symbol-name
 498                                                             (car plist))
 499                                                            (match-end 0))))
 500                                    (car (cdr plist))))
 501           (setcar (cdr plist) t))
 502         (setq plist (nthcdr 2 plist)))
 503       (setq pointer (cdr pointer)))
 504     (plstore--make nil alist nil secret-alist)))
 505
 506 (defun plstore--write-contents-functions ()
 507   (when plstore-encoded
 508     (let ((store (plstore--decode (buffer-string)))
 509           (file (buffer-file-name)))
 510       (unwind-protect
 511           (progn
 512             (set-visited-file-name nil)
 513             (with-temp-buffer
 514               (plstore--insert-buffer store)
 515               (write-region (buffer-string) nil file)))
 516         (set-visited-file-name file)
 517         (set-buffer-modified-p nil))
 518       t)))
 519
 520 (defun plstore-mode-original ()
 521   "Show the original form of the this buffer."
 522   (interactive)
 523   (when plstore-encoded
 524     (if (and (buffer-modified-p)
 525              (y-or-n-p "Save buffer before reading the original form? "))
 526         (save-buffer))
 527     (erase-buffer)
 528     (insert-file-contents-literally (buffer-file-name))
 529     (set-buffer-modified-p nil)
 530     (setq plstore-encoded nil)))
 531
 532 (defun plstore-mode-decoded ()
 533   "Show the decoded form of the this buffer."
 534   (interactive)
 535   (unless plstore-encoded
 536     (if (and (buffer-modified-p)
 537              (y-or-n-p "Save buffer before decoding? "))
 538         (save-buffer))
 539     (let ((store (plstore--make (current-buffer))))
 540       (plstore--init-from-buffer store)
 541       (erase-buffer)
 542       (insert
 543        (substitute-command-keys "\
 544 ;;; You are looking at the decoded form of the PLSTORE file.\n\
 545 ;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n"))
 546       (insert (plstore--encode store))
 547       (set-buffer-modified-p nil)
 548       (setq plstore-encoded t))))
 549
 550 (defun plstore-mode-toggle-display ()
 551   "Toggle the display mode of PLSTORE between the original and decoded forms."
 552   (interactive)
 553   (if plstore-encoded
 554       (plstore-mode-original)
 555     (plstore-mode-decoded)))
 556
 557 (eval-when-compile
 558   (defmacro plstore-called-interactively-p (kind)
 559     (condition-case nil
 560         (progn
 561           (eval '(called-interactively-p 'any))
 562           ;; Emacs >=23.2
 563           `(called-interactively-p ,kind))
 564       ;; Emacs <23.2
 565       (wrong-number-of-arguments '(called-interactively-p))
 566       ;; XEmacs
 567       (void-function '(interactive-p)))))
 568
 569 ;;;###autoload
 570 (define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE"
 571   "Major mode for editing PLSTORE files."
 572   (make-local-variable 'plstore-encoded)
 573   (add-hook 'write-contents-functions #'plstore--write-contents-functions)
 574   (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display)
 575   ;; to create a new file with plstore-mode, mark it as already decoded
 576   (if (plstore-called-interactively-p 'any)
 577       (setq plstore-encoded t)
 578     (plstore-mode-decoded)))
 579
 580 (provide 'plstore)
 581
 582 ;;; plstore.el ends here