From 8977de272444fe109c0266591e2107c5563802bf Mon Sep 17 00:00:00 2001 From: Daiki Ueno Date: Thu, 30 Jun 2011 16:27:25 +0900 Subject: [PATCH] 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. --- lisp/gnus/ChangeLog | 6 + lisp/gnus/auth-source.el | 230 +++++++++++++++++++++++++++- lisp/gnus/plstore.el | 319 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 549 insertions(+), 6 deletions(-) create mode 100644 lisp/gnus/plstore.el 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 + + * 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. 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 +;; 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 . + +;;; 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 -- 2.39.2