Add new auth-source backend 'plstore.

* auth-source.el (auth-source-backend): New member "arg".
(auth-source-backend-parse): Handle new backend 'plstore.
* plstore.el: New file.

3 files changed, 549 insertions, 6 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 5f173b2aeed..4f31130b2c5 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,9 @@
+2011-06-30  Daiki Ueno  <ueno@unixuser.org>
+
+        * auth-source.el (auth-source-backend): New member "arg".
+        (auth-source-backend-parse): Handle new backend 'plstore.
+        * plstore.el: New file.
+
 2011-06-30  Glenn Morris  <rgm@gnu.org>
 
         * gnus-fun.el (gnus-convert-image-to-x-face-command): Doc fix.
diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el
index 72f0cb7ae58..4de1f1abf8b 100644
--- a/lisp/gnus/auth-source.el
+++ b/lisp/gnus/auth-source.el
@@ -56,6 +56,11 @@
 
 (autoload 'rfc2104-hash "rfc2104")
 
+(autoload 'plstore-open "plstore")
+(autoload 'plstore-find "plstore")
+(autoload 'plstore-put "plstore")
+(autoload 'plstore-save "plstore")
+
 (defvar secrets-enabled)
 
 (defgroup auth-source nil
@@ -100,6 +105,9 @@ let-binding."
          :type t
          :custom string
          :documentation "The backend protocol.")
+   (arg :initarg :arg
+        :initform nil
+        :documentation "The backend arg.")
    (create-function :initarg :create-function
                     :initform ignore
                     :type function
@@ -375,12 +383,20 @@ with \"[a/b/c] \" if CHOICES is '\(?a ?b ?c\)."
 
     ;; a file name with parameters
     ((stringp (plist-get entry :source))
-     (auth-source-backend
-      (plist-get entry :source)
-      :source (plist-get entry :source)
-      :type 'netrc
-      :search-function 'auth-source-netrc-search
-      :create-function 'auth-source-netrc-create))
+     (if (equal (file-name-extension (plist-get entry :source)) "plist")
+         (auth-source-backend
+          (plist-get entry :source)
+          :source (plist-get entry :source)
+          :type 'plstore
+          :search-function 'auth-source-plstore-search
+          :create-function 'auth-source-plstore-create
+          :arg (plstore-open (plist-get entry :source)))
+       (auth-source-backend
+        (plist-get entry :source)
+        :source (plist-get entry :source)
+        :type 'netrc
+        :search-function 'auth-source-netrc-search
+        :create-function 'auth-source-netrc-create)))
 
     ;; the Secrets API.  We require the package, in order to have a
     ;; defined value for `secrets-enabled'.
@@ -1503,6 +1519,208 @@ authentication tokens:
   ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
   (debug spec))
 
+;;; Backend specific parsing: PLSTORE backend
+
+(defun* auth-source-plstore-search (&rest
+                                    spec
+                                    &key backend create delete label
+                                    type max host user port
+                                    &allow-other-keys)
+  "Search the PLSTORE; spec is like `auth-source'."
+
+  ;; TODO
+  (assert (not delete) nil
+          "The PLSTORE auth-source backend doesn't support deletion yet")
+
+  (let* ((store (oref backend arg))
+         (max (or max 5000))     ; sanity check: default to stop at 5K
+         (ignored-keys '(:create :delete :max :backend :require))
+         (search-keys (loop for i below (length spec) by 2
+                            unless (memq (nth i spec) ignored-keys)
+                            collect (nth i spec)))
+         ;; build a search spec without the ignored keys
+         ;; if a search key is nil or t (match anything), we skip it
+         (search-spec (apply 'append (mapcar
+                                      (lambda (k)
+                                        (let ((v (plist-get spec k)))
+                                          (if (or (null v)
+                                                  (eq t v))
+                                              nil
+                                            (if (stringp v)
+                                                (setq v (list v)))
+                                            (list k v))))
+                                      search-keys)))
+         ;; needed keys (always including host, login, port, and secret)
+         (returned-keys (mm-delete-duplicates (append
+                                               '(:host :login :port :secret)
+                                               search-keys)))
+         (items (plstore-find store search-spec))
+         (items (butlast items (- (length items) max)))
+         ;; convert the item to a full plist
+         (items (mapcar (lambda (item)
+                          (let* ((plist (copy-tree (cdr item)))
+                                 (secret (plist-member plist :secret)))
+                            (if secret
+                                (setcar
+                                 (cdr secret)
+                                 (lexical-let ((v (car (cdr secret))))
+                                   (lambda () v))))
+                            plist))
+                        items))
+         ;; ensure each item has each key in `returned-keys'
+         (items (mapcar (lambda (plist)
+                          (append
+                           (apply 'append
+                                  (mapcar (lambda (req)
+                                            (if (plist-get plist req)
+                                                nil
+                                              (list req nil)))
+                                          returned-keys))
+                           plist))
+                        items)))
+    ;; if we need to create an entry AND none were found to match
+    (when (and create
+               (not items))
+
+      ;; create based on the spec and record the value
+      (setq items (or
+                     ;; if the user did not want to create the entry
+                     ;; in the file, it will be returned
+                     (apply (slot-value backend 'create-function) spec)
+                     ;; if not, we do the search again without :create
+                     ;; to get the updated data.
+
+                     ;; the result will be returned, even if the search fails
+                     (apply 'auth-source-plstore-search
+                            (plist-put spec :create nil)))))
+    items))
+
+(defun* auth-source-plstore-create (&rest spec
+                                          &key backend
+                                          secret host user port create
+                                          &allow-other-keys)
+  (let* ((base-required '(host user port secret))
+         (base-secret '(secret))
+         ;; we know (because of an assertion in auth-source-search) that the
+         ;; :create parameter is either t or a list (which includes nil)
+         (create-extra (if (eq t create) nil create))
+         (current-data (car (auth-source-search :max 1
+                                                :host host
+                                                :port port)))
+         (required (append base-required create-extra))
+         (file (oref backend source))
+         (add "")
+         ;; `valist' is an alist
+         valist
+         ;; `artificial' will be returned if no creation is needed
+         artificial
+         secret-artificial)
+
+    ;; only for base required elements (defined as function parameters):
+    ;; fill in the valist with whatever data we may have from the search
+    ;; we complete the first value if it's a list and use the value otherwise
+    (dolist (br base-required)
+      (when (symbol-value br)
+        (let ((br-choice (cond
+                          ;; all-accepting choice (predicate is t)
+                          ((eq t (symbol-value br)) nil)
+                          ;; just the value otherwise
+                          (t (symbol-value br)))))
+          (when br-choice
+            (aput 'valist br br-choice)))))
+
+    ;; for extra required elements, see if the spec includes a value for them
+    (dolist (er create-extra)
+      (let ((name (concat ":" (symbol-name er)))
+            (keys (loop for i below (length spec) by 2
+                        collect (nth i spec))))
+        (dolist (k keys)
+          (when (equal (symbol-name k) name)
+            (aput 'valist er (plist-get spec k))))))
+
+    ;; for each required element
+    (dolist (r required)
+      (let* ((data (aget valist r))
+             ;; take the first element if the data is a list
+             (data (or (auth-source-netrc-element-or-first data)
+                       (plist-get current-data
+                                  (intern (format ":%s" r) obarray))))
+             ;; this is the default to be offered
+             (given-default (aget auth-source-creation-defaults r))
+             ;; the default supplementals are simple:
+             ;; for the user, try `given-default' and then (user-login-name);
+             ;; otherwise take `given-default'
+             (default (cond
+                       ((and (not given-default) (eq r 'user))
+                        (user-login-name))
+                       (t given-default)))
+             (printable-defaults (list
+                                  (cons 'user
+                                        (or
+                                         (auth-source-netrc-element-or-first
+                                          (aget valist 'user))
+                                         (plist-get artificial :user)
+                                         "[any user]"))
+                                  (cons 'host
+                                        (or
+                                         (auth-source-netrc-element-or-first
+                                          (aget valist 'host))
+                                         (plist-get artificial :host)
+                                         "[any host]"))
+                                  (cons 'port
+                                        (or
+                                         (auth-source-netrc-element-or-first
+                                          (aget valist 'port))
+                                         (plist-get artificial :port)
+                                         "[any port]"))))
+             (prompt (or (aget auth-source-creation-prompts r)
+                         (case r
+                           (secret "%p password for %u@%h: ")
+                           (user "%p user name for %h: ")
+                           (host "%p host name for user %u: ")
+                           (port "%p port for %u@%h: "))
+                         (format "Enter %s (%%u@%%h:%%p): " r)))
+             (prompt (auth-source-format-prompt
+                      prompt
+                      `((?u ,(aget printable-defaults 'user))
+                        (?h ,(aget printable-defaults 'host))
+                        (?p ,(aget printable-defaults 'port))))))
+
+        ;; Store the data, prompting for the password if needed.
+        (setq data
+              (cond
+               ((and (null data) (eq r 'secret))
+                ;; Special case prompt for passwords.
+                (read-passwd prompt))
+               ((null data)
+                (when default
+                  (setq prompt
+                        (if (string-match ": *\\'" prompt)
+                            (concat (substring prompt 0 (match-beginning 0))
+                                    " (default " default "): ")
+                          (concat prompt "(default " default ") "))))
+                (read-string prompt nil nil default))
+               (t (or data default))))
+
+        (when data
+          (if (member r base-secret)
+              (setq secret-artificial
+                    (plist-put secret-artificial
+                               (intern (concat ":" (symbol-name r)))
+                               data))
+            (setq artificial (plist-put artificial
+                                        (intern (concat ":" (symbol-name r)))
+                                        data))))))
+    (plstore-put (oref backend arg)
+                 (sha1 (format "%s@%s:%s"
+                               (plist-get artificial :user)
+                               (plist-get artificial :host)
+                               (plist-get artificial :port)))
+                 artificial secret-artificial)
+    (if (y-or-n-p (format "Save auth info to file %s? "
+                          (plstore-get-file (oref backend arg))))
+        (plstore-save (oref backend arg)))))
+
 ;;; older API
 
 ;;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
diff --git a/lisp/gnus/plstore.el b/lisp/gnus/plstore.el
new file mode 100644
index 00000000000..3aa3b84fcbc
--- /dev/null
+++ b/lisp/gnus/plstore.el
@@ -0,0 +1,319 @@
+;;; 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)
+                )))
+    (with-current-buffer (plstore--get-buffer store)
+      (goto-char (point-min))
+      (when (looking-at ";;; public entries\n")
+        (forward-line)
+        (plstore--set-alist store (read (point-marker)))
+        (forward-sexp)
+        (forward-char)
+        (when (looking-at ";;; secret entries\n")
+          (forward-line)
+          (plstore--set-encrypted-data store (read (point-marker))))
+        (plstore--merge-secret store)))
+    store))
+
+(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