Commit 8977de27 authored by Daiki Ueno's avatar Daiki Ueno
Browse files

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.
parent d0b36cbe
2011-06-30 Daiki Ueno <>
* 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 <>
* gnus-fun.el (gnus-convert-image-to-x-face-command): Doc fix.
......@@ -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))
(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")
(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)))
(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
&key backend create delete label
type max host user port
"Search the PLSTORE; spec is like `auth-source'."
(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))
(if (stringp v)
(setq v (list v)))
(list k v))))
;; needed keys (always including host, login, port, and secret)
(returned-keys (mm-delete-duplicates (append
'(:host :login :port :secret)
(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
(cdr secret)
(lexical-let ((v (car (cdr secret))))
(lambda () v))))
;; ensure each item has each key in `returned-keys'
(items (mapcar (lambda (plist)
(apply 'append
(mapcar (lambda (req)
(if (plist-get plist req)
(list req nil)))
;; 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)))))
(defun* auth-source-plstore-create (&rest spec
&key backend
secret host user port create
(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
;; `artificial' will be returned if no creation is needed
;; 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))
(t given-default)))
(printable-defaults (list
(cons 'user
(aget valist 'user))
(plist-get artificial :user)
"[any user]"))
(cons 'host
(aget valist 'host))
(plist-get artificial :host)
"[any host]"))
(cons 'port
(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
`((?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
((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)))
(setq artificial (plist-put artificial
(intern (concat ":" (symbol-name r)))
(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") "" t "tzz")
;;; plstore.el --- searchable, partially encrypted, persistent plist store -*- lexical-binding: t -*-
;; Copyright (C) 2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <>
;; 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
;; 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 <>.
;;; Commentary
;; Creating:
;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist")))
;; (plstore-put store "foo" '(:host "" :port 80) nil)
;; (plstore-save store)
;; ;; :user property is secret
;; (plstore-put store "bar" '(:host "") '(:user "test"))
;; (plstore-put store "baz" '(:host "") '(: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 ("")))
;; (plstore-find store '(:host (""))) ;<= 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))
(or (copy-sequence (cdr entry))
(unless entry
(setq entry (list file)
(cons entry
(setq passphrase
(read-passwd (format "Passphrase for PLSTORE %s: "
(plstore--get-buffer plstore))))
(setcdr entry (copy-sequence passphrase))
(read-passwd (format "Passphrase for PLSTORE %s: "
(plstore--get-buffer plstore)))))
(defun plstore-progress-callback-function (_context _what _char current total
(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)))
(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")
(plstore--set-alist store (read (point-marker)))
(when (looking-at ";;; secret entries\n")
(plstore--set-encrypted-data store (read (point-marker))))
(plstore--merge-secret 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))
(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
(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))
(cons #'plstore-passphrase-callback-function
(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
(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)))
(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)))
(setq plist (cdr entry))
(while plist
(if (string-match "\\`:secret-" (symbol-name (car plist)))
(plstore--decrypt plstore)
(setq entry (assoc name (plstore--get-merged-alist plstore))
plist nil))
(setq plist (nthcdr 2 plist))))
(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
(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)
(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)
(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)
(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)
(epg-context-set-armor context t)
(cons #'plstore-passphrase-callback-function
(setq cipher (epg-encrypt-string context
(plstore--get-secret-alist plstore))
(insert ";;; secret entries\n" (pp-to-string cipher))))
(provide 'plstore)
;;; plstore.el ends here
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment