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