diff options
Diffstat (limited to 'lisp/auth-source.el')
| -rw-r--r-- | lisp/auth-source.el | 340 |
1 files changed, 308 insertions, 32 deletions
diff --git a/lisp/auth-source.el b/lisp/auth-source.el index b733054ae5f..abff0def95f 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -39,6 +39,7 @@ ;;; Code: +(require 'json) (require 'password-cache) (eval-when-compile (require 'cl-lib)) @@ -241,7 +242,7 @@ for details. It's best to customize this with `\\[customize-variable]' because the choices can get pretty complex." :group 'auth-source - :version "26.1" ;; No Gnus + :version "26.1" ; neither new nor changed default :type `(repeat :tag "Authentication Sources" (choice (string :tag "Just a file") @@ -380,24 +381,39 @@ soon as a function returns non-nil.") ;; take just a file name use it as a netrc/plist file ;; matching any user, host, and protocol (when (stringp entry) - (setq entry `(:source ,entry))) - (cond - ;; a file name with parameters - ((stringp (plist-get entry :source)) - (if (equal (file-name-extension (plist-get entry :source)) "plist") + (setq entry (list :source entry))) + (let* ((source (plist-get entry :source)) + (source-without-gpg + (if (and (stringp source) + (equal (file-name-extension source) "gpg")) + (file-name-sans-extension source) + (or source ""))) + (extension (or (and (stringp source-without-gpg) + (file-name-extension source-without-gpg)) + ""))) + (when (stringp source) + (cond + ((equal extension "plist") (auth-source-backend - (plist-get entry :source) - :source (plist-get entry :source) + source + :source source :type 'plstore :search-function #'auth-source-plstore-search :create-function #'auth-source-plstore-create - :data (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))))) + :data (plstore-open source))) + ((member-ignore-case extension '("json")) + (auth-source-backend + source + :source source + :type 'json + :search-function #'auth-source-json-search)) + (t + (auth-source-backend + source + :source source + :type 'netrc + :search-function #'auth-source-netrc-search + :create-function #'auth-source-netrc-create)))))) ;; Note this function should be last in the parser functions, so we add it first (add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-file) @@ -984,12 +1000,13 @@ Note that the MAX parameter is used so we can exit the parse early." (defun auth-source-netrc-parse-next-interesting () "Advance to the next interesting position in the current buffer." + (skip-chars-forward "\t ") ;; If we're looking at a comment or are at the end of the line, move forward - (while (or (looking-at "#") + (while (or (eq (char-after) ?#) (and (eolp) (not (eobp)))) - (forward-line 1)) - (skip-chars-forward "\t ")) + (forward-line 1) + (skip-chars-forward "\t "))) (defun auth-source-netrc-parse-one () "Read one thing from the current buffer." @@ -999,8 +1016,9 @@ Note that the MAX parameter is used so we can exit the parse early." (looking-at "\"\\([^\"]*\\)\"") (looking-at "\\([^ \t\n]+\\)")) (forward-char (length (match-string 0))) - (auth-source-netrc-parse-next-interesting) - (match-string-no-properties 1))) + (prog1 + (match-string-no-properties 1) + (auth-source-netrc-parse-next-interesting)))) ;; with thanks to org-mode (defsubst auth-source-current-line (&optional pos) @@ -1300,9 +1318,7 @@ See `auth-source-search' for details on SPEC." (string-match (car item) file)) (setq ret (cdr item)) (setq check nil))) - ;; FIXME: `ret' unused. - ;; Should we return it here? - )) + ret)) (t 'never))) (plain (or (eval default) (read-passwd prompt)))) ;; ask if we don't know what to do (in which case @@ -1483,13 +1499,13 @@ Here's an example that looks for the first item in the `Login' Secrets collection: (let ((auth-sources \\='(\"secrets:Login\"))) - (auth-source-search :max 1) + (auth-source-search :max 1)) Here's another that looks for the first item in the `Login' Secrets collection whose label contains `gnus': (let ((auth-sources \\='(\"secrets:Login\"))) - (auth-source-search :max 1 :label \"gnus\") + (auth-source-search :max 1 :label \"gnus\")) And this one looks for the first item in the `Login' Secrets collection that's a Google Chrome entry for the git.gnus.org site @@ -1500,9 +1516,6 @@ authentication tokens: " ;; TODO - (cl-assert (not create) nil - "The Secrets API auth-source backend doesn't support creation yet") - ;; TODO ;; (secrets-delete-item coll elt) (cl-assert (not delete) nil "The Secrets API auth-source backend doesn't support deletion yet") @@ -1562,12 +1575,204 @@ authentication tokens: returned-keys)) plist)) items))) + (cond + ;; if we need to create an entry AND none were found to match + ((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-secrets-search + (plist-put spec :create nil)))))) items)) -(defun auth-source-secrets-create (&rest spec) - ;; TODO - ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec) - (debug spec)) +(cl-defun auth-source-secrets-create (&rest spec + &key backend host port create + &allow-other-keys) + (let* ((base-required '(host user port secret label)) + ;; 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)) + (collection (oref backend source)) + ;; `args' are the arguments for `secrets-create-item'. + args + ;; `valist' is an alist + valist + ;; `artificial' will be returned if no creation is needed + 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) + (let ((val (plist-get spec (auth-source--symbol-keyword br)))) + (when val + (let ((br-choice (cond + ;; all-accepting choice (predicate is t) + ((eq t val) nil) + ;; just the value otherwise + (t val)))) + (when br-choice + (auth-source--aput valist br br-choice)))))) + + ;; for extra required elements, see if the spec includes a value for them + (dolist (er create-extra) + (let ((k (auth-source--symbol-keyword er)) + (keys (cl-loop for i below (length spec) by 2 + collect (nth i spec)))) + (when (memq k keys) + (auth-source--aput valist er (plist-get spec k))))) + + ;; for each required element + (dolist (r required) + (let* ((data (auth-source--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 + (auth-source--symbol-keyword r)))) + ;; this is the default to be offered + (given-default (auth-source--aget + auth-source-creation-defaults r)) + ;; the default supplementals are simple: + ;; for the user, try `given-default' and then (user-login-name); + ;; for the label, try `given-default' and then user@host; + ;; otherwise take `given-default' + (default (cond + ((and (not given-default) (eq r 'user)) + (user-login-name)) + ((and (not given-default) (eq r 'label)) + (format "%s@%s" + (or (auth-source-netrc-element-or-first + (auth-source--aget valist 'user)) + (plist-get artificial :user)) + (or (auth-source-netrc-element-or-first + (auth-source--aget valist 'host)) + (plist-get artificial :host)))) + (t given-default))) + (printable-defaults (list + (cons 'user + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'user)) + (plist-get artificial :user) + "[any user]")) + (cons 'host + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'host)) + (plist-get artificial :host) + "[any host]")) + (cons 'port + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'port)) + (plist-get artificial :port) + "[any port]")) + (cons 'label + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'label)) + (plist-get artificial :label) + "[any label]")))) + (prompt (or (auth-source--aget auth-source-creation-prompts r) + (cl-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: ") + (label "Enter label for %u@%h: ")) + (format "Enter %s (%%u@%%h:%%p): " r))) + (prompt (auth-source-format-prompt + prompt + `((?u ,(auth-source--aget printable-defaults 'user)) + (?h ,(auth-source--aget printable-defaults 'host)) + (?p ,(auth-source--aget printable-defaults 'port)))))) + + ;; Store the data, prompting for the password if needed. + (setq data (or data + (if (eq r 'secret) + (or (eval default) (read-passwd prompt)) + (if (stringp default) + (read-string (if (string-match ": *\\'" prompt) + (concat (substring prompt 0 (match-beginning 0)) + " (default " default "): ") + (concat prompt "(default " default ") ")) + nil nil default) + (eval default))))) + + (when data + (setq artificial (plist-put artificial + (auth-source--symbol-keyword r) + (if (eq r 'secret) + (let ((data data)) + (lambda () data)) + data)))) + + ;; When r is not an empty string... + (when (and (stringp data) + (< 0 (length data)) + (not (member r '(secret label)))) + ;; append the key (the symbol name of r) + ;; and the value in r + (setq args (append args (list (auth-source--symbol-keyword r) data)))))) + + (plist-put + artificial + :save-function + (let* ((collection collection) + (item (plist-get artificial :label)) + (secret (plist-get artificial :secret)) + (secret (if (functionp secret) (funcall secret) secret))) + (lambda () + (auth-source-secrets-saver collection item secret args)))) + + (list artificial))) + +(defun auth-source-secrets-saver (collection item secret args) + "Wrapper around `secrets-create-item', prompting along the way. +Respects `auth-source-save-behavior'." + (let ((prompt (format "Save auth info to secrets collection %s? " collection)) + (done (not (eq auth-source-save-behavior 'ask))) + (doit (eq auth-source-save-behavior t)) + (bufname "*auth-source Help*") + k) + (while (not done) + (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ??))) + (cl-case k + (?y (setq done t doit t)) + (?? (save-excursion + (with-output-to-temp-buffer bufname + (princ + (concat "(y)es, save\n" + "(n)o but use the info\n" + "(N)o and don't ask to save again\n" + "(?) for help as you can see.\n")) + ;; Why? Doesn't with-output-to-temp-buffer already do + ;; the exact same thing anyway? --Stef + (set-buffer standard-output) + (help-mode)))) + (?n (setq done t doit nil)) + (?N (setq done t doit nil) + (customize-save-variable 'auth-source-save-behavior nil)) + (t nil))) + + (when doit + (progn + (auth-source-do-debug + "secrets-create-item: wrote 1 new item to %s" collection) + (message "Saved new authentication information to %s" collection) + (apply 'secrets-create-item collection item secret args))))) ;;; Backend specific parsing: Mac OS Keychain (using /usr/bin/security) backend @@ -1968,6 +2173,77 @@ entries for git.gnus.org: (plstore-get-file (oref backend data)))) (plstore-save (oref backend data))))) +;;; Backend specific parsing: JSON backend +;;; (auth-source-search :max 1 :machine "imap.gmail.com") +;;; (auth-source-search :max 1 :host '("my-gmail" "imap.gmail.com") :port '(993 "imaps" "imap" "993" "143") :user nil :require '(:user :secret)) + +(defun auth-source-json-check (host user port require item) + (and item + (auth-source-search-collection + (or host t) + (or + (plist-get item :machine) + (plist-get item :host) + t)) + (auth-source-search-collection + (or user t) + (or + (plist-get item :login) + (plist-get item :account) + (plist-get item :user) + t)) + (auth-source-search-collection + (or port t) + (or + (plist-get item :port) + (plist-get item :protocol) + t)) + (or + ;; the required list of keys is nil, or + (null require) + ;; every element of require is in + (cl-loop for req in require + always (plist-get item req))))) + +(cl-defun auth-source-json-search (&rest spec + &key backend require + type max host user port + &allow-other-keys) + "Given a property list SPEC, return search matches from the :backend. +See `auth-source-search' for details on SPEC." + ;; just in case, check that the type is correct (null or same as the backend) + (cl-assert (or (null type) (eq type (oref backend type))) + t "Invalid JSON search: %s %s") + + ;; Hide the secrets early to avoid accidental exposure. + (let* ((jdata + (mapcar (lambda (entry) + (let (ret) + (while entry + (let* ((item (pop entry)) + (k (auth-source--symbol-keyword (car item))) + (v (cdr item))) + (setq k (cond ((memq k '(:machine)) :host) + ((memq k '(:login :account)) :user) + ((memq k '(:protocol)) :port) + ((memq k '(:password)) :secret) + (t k))) + ;; send back the secret in a function (lexical binding) + (when (eq k :secret) + (setq v (let ((lexv v)) + (lambda () lexv)))) + (setq ret (plist-put ret k v)))) + ret)) + (json-read-file (oref backend source)))) + (max (or max 5000)) ; sanity check: default to stop at 5K + all) + (dolist (item jdata) + (when (and item + (> max (length all)) + (auth-source-json-check host user port require item)) + (push item all))) + (nreverse all))) + ;;; older API ;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz") |