lisp/gnus/plstore.el

   1 ;;; plstore.el --- secure plist store -*- lexical-binding: t -*-
   2 ;; Copyright (C) 2011-2012 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-buffer 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         (setq plain
 274               (epg-decrypt-string context
 275                                   (plstore--get-encrypted-data plstore)))
 276         (plstore--set-secret-alist plstore (car (read-from-string plain)))
 277         (plstore--merge-secret plstore)
 278         (plstore--set-encrypted-data plstore nil))))
 279
 280 (defun plstore--match (entry keys skip-if-secret-found)
 281   (let ((result t) key-name key-value prop-value secret-name)
 282     (while keys
 283       (setq key-name (car keys)
 284             key-value (car (cdr keys))
 285             prop-value (plist-get (cdr entry) key-name))
 286         (unless (member prop-value key-value)
 287           (if skip-if-secret-found
 288               (progn
 289                 (setq secret-name
 290                       (intern (concat ":secret-"
 291                                       (substring (symbol-name key-name) 1))))
 292                 (if (plist-member (cdr entry) secret-name)
 293                     (setq result 'secret)
 294                   (setq result nil
 295                         keys nil)))
 296             (setq result nil
 297                   keys nil)))
 298         (setq keys (nthcdr 2 keys)))
 299     result))
 300
 301 (defun plstore-find (plstore keys)
 302   "Perform search on PLSTORE with KEYS.
 303 KEYS is a plist."
 304   (let (entries alist entry match decrypt plist)
 305     ;; First, go through the merged plist alist and collect entries
 306     ;; matched with keys.
 307     (setq alist (plstore--get-merged-alist plstore))
 308     (while alist
 309       (setq entry (car alist)
 310             alist (cdr alist)
 311             match (plstore--match entry keys t))
 312       (if (eq match 'secret)
 313           (setq decrypt t)
 314         (when match
 315           (setq plist (cdr entry))
 316           (while plist
 317             (if (string-match "\\`:secret-" (symbol-name (car plist)))
 318                 (setq decrypt t
 319                       plist nil))
 320             (setq plist (nthcdr 2 plist)))
 321           (setq entries (cons entry entries)))))
 322     ;; Second, decrypt the encrypted plist and try again.
 323     (when decrypt
 324       (setq entries nil)
 325       (plstore--decrypt plstore)
 326       (setq alist (plstore--get-merged-alist plstore))
 327       (while alist
 328         (setq entry (car alist)
 329               alist (cdr alist)
 330               match (plstore--match entry keys nil))
 331         (if match
 332             (setq entries (cons entry entries)))))
 333     (nreverse entries)))
 334
 335 (defun plstore-get (plstore name)
 336   "Get an entry with NAME in PLSTORE."
 337   (let ((entry (assoc name (plstore--get-merged-alist plstore)))
 338         plist)
 339     (setq plist (cdr entry))
 340     (while plist
 341       (if (string-match "\\`:secret-" (symbol-name (car plist)))
 342           (progn
 343             (plstore--decrypt plstore)
 344             (setq entry (assoc name (plstore--get-merged-alist plstore))
 345                   plist nil))
 346         (setq plist (nthcdr 2 plist))))
 347     entry))
 348
 349 (defun plstore-put (plstore name keys secret-keys)
 350   "Put an entry with NAME in PLSTORE.
 351 KEYS is a plist containing non-secret data.
 352 SECRET-KEYS is a plist containing secret data."
 353   (let (entry
 354         plist
 355         secret-plist
 356         symbol)
 357     (if secret-keys
 358         (plstore--decrypt plstore))
 359     (while secret-keys
 360       (setq symbol
 361             (intern (concat ":secret-"
 362                             (substring (symbol-name (car secret-keys)) 1))))
 363       (setq plist (plist-put plist symbol t)
 364             secret-plist (plist-put secret-plist
 365                                     (car secret-keys) (car (cdr secret-keys)))
 366             secret-keys (nthcdr 2 secret-keys)))
 367     (while keys
 368       (setq symbol
 369             (intern (concat ":secret-"
 370                             (substring (symbol-name (car keys)) 1))))
 371       (setq plist (plist-put plist (car keys) (car (cdr keys)))
 372             keys (nthcdr 2 keys)))
 373     (setq entry (assoc name (plstore--get-alist plstore)))
 374     (if entry
 375         (setcdr entry plist)
 376       (plstore--set-alist
 377        plstore
 378        (cons (cons name plist) (plstore--get-alist plstore))))
 379     (when secret-plist
 380       (setq entry (assoc name (plstore--get-secret-alist plstore)))
 381       (if entry
 382           (setcdr entry secret-plist)
 383         (plstore--set-secret-alist
 384          plstore
 385          (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
 386     (plstore--merge-secret plstore)))
 387
 388 (defun plstore-delete (plstore name)
 389   "Delete an entry with NAME from PLSTORE."
 390   (let ((entry (assoc name (plstore--get-alist plstore))))
 391     (if entry
 392         (plstore--set-alist
 393          plstore
 394          (delq entry (plstore--get-alist plstore))))
 395     (setq entry (assoc name (plstore--get-secret-alist plstore)))
 396     (if entry
 397         (plstore--set-secret-alist
 398          plstore
 399          (delq entry (plstore--get-secret-alist plstore))))
 400     (setq entry (assoc name (plstore--get-merged-alist plstore)))
 401     (if entry
 402         (plstore--set-merged-alist
 403          plstore
 404          (delq entry (plstore--get-merged-alist plstore))))))
 405
 406 (defvar pp-escape-newlines)
 407 (defun plstore--insert-buffer (plstore)
 408   (insert ";;; public entries -*- mode: plstore -*- \n"
 409           (pp-to-string (plstore--get-alist plstore)))
 410   (if (plstore--get-secret-alist plstore)
 411       (let ((context (epg-make-context 'OpenPGP))
 412             (pp-escape-newlines nil)
 413             (recipients
 414              (cond
 415               ((listp plstore-encrypt-to) plstore-encrypt-to)
 416               ((stringp plstore-encrypt-to) (list plstore-encrypt-to))))
 417             cipher)
 418         (epg-context-set-armor context t)
 419         (epg-context-set-passphrase-callback
 420          context
 421          (cons #'plstore-passphrase-callback-function
 422                plstore))
 423         (setq cipher (epg-encrypt-string
 424                       context
 425                       (pp-to-string
 426                        (plstore--get-secret-alist plstore))
 427                       (if (or (eq plstore-select-keys t)
 428                               (and (null plstore-select-keys)
 429                                    (not (local-variable-p 'plstore-encrypt-to
 430                                                           (current-buffer)))))
 431                           (epa-select-keys
 432                            context
 433                            "Select recipients for encryption.
 434 If no one is selected, symmetric encryption will be performed.  "
 435                            recipients)
 436                         (if plstore-encrypt-to
 437                             (epg-list-keys context recipients)))))
 438         (goto-char (point-max))
 439         (insert ";;; secret entries\n" (pp-to-string cipher)))))
 440
 441 (defun plstore-save (plstore)
 442   "Save the contents of PLSTORE associated with a FILE."
 443   (with-current-buffer (plstore--get-buffer plstore)
 444     (erase-buffer)
 445     (plstore--insert-buffer plstore)
 446     (save-buffer)))
 447
 448 (defun plstore--encode (plstore)
 449   (plstore--decrypt plstore)
 450   (let ((merged-alist (plstore--get-merged-alist plstore)))
 451     (concat "("
 452             (mapconcat
 453              (lambda (entry)
 454                (setq entry (copy-sequence entry))
 455                (let ((merged-plist (cdr (assoc (car entry) merged-alist)))
 456                      (plist (cdr entry)))
 457                  (while plist
 458                    (if (string-match "\\`:secret-" (symbol-name (car plist)))
 459                        (setcar (cdr plist)
 460                                (plist-get
 461                                 merged-plist
 462                                 (intern (concat ":"
 463                                                 (substring (symbol-name
 464                                                             (car plist))
 465                                                            (match-end 0)))))))
 466                    (setq plist (nthcdr 2 plist)))
 467                  (prin1-to-string entry)))
 468              (plstore--get-alist plstore)
 469              "\n")
 470             ")")))
 471
 472 (defun plstore--decode (string)
 473   (let* ((alist (car (read-from-string string)))
 474          (pointer alist)
 475          secret-alist
 476          plist
 477          entry)
 478     (while pointer
 479       (unless (stringp (car (car pointer)))
 480         (error "Invalid PLSTORE format %s" string))
 481       (setq plist (cdr (car pointer)))
 482       (while plist
 483         (when (string-match "\\`:secret-" (symbol-name (car plist)))
 484           (setq entry (assoc (car (car pointer)) secret-alist))
 485           (unless entry
 486             (setq entry (list (car (car pointer)))
 487                   secret-alist (cons entry secret-alist)))
 488           (setcdr entry (plist-put (cdr entry)
 489                                    (intern (concat ":"
 490                                                 (substring (symbol-name
 491                                                             (car plist))
 492                                                            (match-end 0))))
 493                                    (car (cdr plist))))
 494           (setcar (cdr plist) t))
 495         (setq plist (nthcdr 2 plist)))
 496       (setq pointer (cdr pointer)))
 497     (plstore--make nil alist nil secret-alist)))
 498
 499 (defun plstore--write-contents-functions ()
 500   (when plstore-encoded
 501     (let ((store (plstore--decode (buffer-string)))
 502           (file (buffer-file-name)))
 503       (unwind-protect
 504           (progn
 505             (set-visited-file-name nil)
 506             (with-temp-buffer
 507               (plstore--insert-buffer store)
 508               (write-region (buffer-string) nil file)))
 509         (set-visited-file-name file)
 510         (set-buffer-modified-p nil))
 511       t)))
 512
 513 (defun plstore-mode-original ()
 514   "Show the original form of the this buffer."
 515   (interactive)
 516   (when plstore-encoded
 517     (if (and (buffer-modified-p)
 518              (y-or-n-p "Save buffer before reading the original form? "))
 519         (save-buffer))
 520     (erase-buffer)
 521     (insert-file-contents-literally (buffer-file-name))
 522     (set-buffer-modified-p nil)
 523     (setq plstore-encoded nil)))
 524
 525 (defun plstore-mode-decoded ()
 526   "Show the decoded form of the this buffer."
 527   (interactive)
 528   (unless plstore-encoded
 529     (if (and (buffer-modified-p)
 530              (y-or-n-p "Save buffer before decoding? "))
 531         (save-buffer))
 532     (let ((store (plstore--make (current-buffer))))
 533       (plstore--init-from-buffer store)
 534       (erase-buffer)
 535       (insert
 536        (substitute-command-keys "\
 537 ;;; You are looking at the decoded form of the PLSTORE file.\n\
 538 ;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n"))
 539       (insert (plstore--encode store))
 540       (set-buffer-modified-p nil)
 541       (setq plstore-encoded t))))
 542
 543 (defun plstore-mode-toggle-display ()
 544   "Toggle the display mode of PLSTORE between the original and decoded forms."
 545   (interactive)
 546   (if plstore-encoded
 547       (plstore-mode-original)
 548     (plstore-mode-decoded)))
 549
 550 (eval-when-compile
 551   (defmacro plstore-called-interactively-p (kind)
 552     (condition-case nil
 553         (progn
 554           (eval '(called-interactively-p 'any))
 555           ;; Emacs >=23.2
 556           `(called-interactively-p ,kind))
 557       ;; Emacs <23.2
 558       (wrong-number-of-arguments '(called-interactively-p))
 559       ;; XEmacs
 560       (void-function '(interactive-p)))))
 561
 562 ;;;###autoload
 563 (define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE"
 564   "Major mode for editing PLSTORE files."
 565   (make-local-variable 'plstore-encoded)
 566   (add-hook 'write-contents-functions #'plstore--write-contents-functions)
 567   (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display)
 568   ;; to create a new file with plstore-mode, mark it as already decoded
 569   (if (plstore-called-interactively-p 'any)
 570       (setq plstore-encoded t)
 571     (plstore-mode-decoded)))
 572
 573 (provide 'plstore)
 574
 575 ;;; plstore.el ends here