diff options
Diffstat (limited to 'lisp/auth-source.el')
| -rw-r--r-- | lisp/auth-source.el | 357 |
1 files changed, 312 insertions, 45 deletions
diff --git a/lisp/auth-source.el b/lisp/auth-source.el index afb35c8f044..fd529b392ab 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)) @@ -82,7 +83,6 @@ expiring. Overrides `password-cache-expiry' through a let-binding." :version "24.1" - :group 'auth-source :type '(choice (const :tag "Never" nil) (const :tag "All Day" 86400) (const :tag "2 Hours" 7200) @@ -138,7 +138,6 @@ let-binding." (smtp "smtp" "25")) "List of authentication protocols and their names" - :group 'auth-source :version "23.2" ;; No Gnus :type '(repeat :tag "Authentication Protocols" (cons :tag "Protocol Entry" @@ -167,7 +166,6 @@ let-binding." (defcustom auth-source-save-behavior 'ask "If set, auth-source will respect it for save behavior." - :group 'auth-source :version "23.2" ;; No Gnus :type `(choice :tag "auth-source new token save behavior" @@ -182,7 +180,6 @@ let-binding." "Set this to tell auth-source when to create GPG password tokens in netrc files. It's either an alist or `never'. Note that if EPA/EPG is not available, this should NOT be used." - :group 'auth-source :version "23.2" ;; No Gnus :type `(choice (const :tag "Always use GPG password tokens" (t gpg)) @@ -202,7 +199,6 @@ Note that if EPA/EPG is not available, this should NOT be used." (defcustom auth-source-do-cache t "Whether auth-source should cache information with `password-cache'." - :group 'auth-source :version "23.2" ;; No Gnus :type `boolean) @@ -217,7 +213,6 @@ for passwords). If the value is a function, debug messages are logged by calling that function using the same arguments as `message'." - :group 'auth-source :version "23.2" ;; No Gnus :type `(choice :tag "auth-source debugging mode" @@ -240,8 +235,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") @@ -310,7 +304,6 @@ can get pretty complex." (defcustom auth-source-gpg-encrypt-to t "List of recipient keys that `authinfo.gpg' encrypted to. If the value is not a list, symmetric encryption will be used." - :group 'auth-source :version "24.1" ;; No Gnus :type '(choice (const :tag "Symmetric encryption" t) (repeat :tag "Recipient public keys" @@ -362,10 +355,9 @@ soon as a function returns non-nil.") (defun auth-source-backend-parse (entry) "Create an auth-source-backend from an ENTRY in `auth-sources'." - (let (backend) - (cl-dolist (f auth-source-backend-parser-functions) - (when (setq backend (funcall f entry)) - (cl-return))) + (let ((backend + (run-hook-with-args-until-success 'auth-source-backend-parser-functions + entry))) (unless backend ;; none of the parsers worked @@ -380,27 +372,42 @@ 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) +(add-hook 'auth-source-backend-parser-functions #'auth-source-backends-parser-file) (defun auth-source-backends-parser-macos-keychain (entry) ;; take macos-keychain-{internet,generic}:XYZ and use it as macOS @@ -447,7 +454,7 @@ soon as a function returns non-nil.") :search-function #'auth-source-macos-keychain-search :create-function #'auth-source-macos-keychain-create))))) -(add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-macos-keychain) +(add-hook 'auth-source-backend-parser-functions #'auth-source-backends-parser-macos-keychain) (defun auth-source-backends-parser-secrets (entry) ;; take secrets:XYZ and use it as Secrets API collection "XYZ" @@ -494,7 +501,7 @@ soon as a function returns non-nil.") :source "" :type 'ignore)))))) -(add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-secrets) +(add-hook 'auth-source-backend-parser-functions #'auth-source-backends-parser-secrets) (defun auth-source-backend-parse-parameters (entry backend) "Fills in the extra auth-source-backend parameters of ENTRY. @@ -512,7 +519,7 @@ parameters." (oset backend port val))) backend) -;; (mapcar 'auth-source-backend-parse auth-sources) +;; (mapcar #'auth-source-backend-parse auth-sources) (cl-defun auth-source-search (&rest spec &key max require create delete @@ -940,7 +947,8 @@ Note that the MAX parameter is used so we can exit the parse early." (if (and (functionp cached-secrets) (equal cached-mtime - (nth 5 (file-attributes file)))) + (file-attribute-modification-time + (file-attributes file)))) (progn (auth-source-do-trivia "auth-source-netrc-parse: using CACHED file data for %s" @@ -952,7 +960,8 @@ Note that the MAX parameter is used so we can exit the parse early." ;; (note for the irony-impaired: they are just obfuscated) (auth-source--aput auth-source-netrc-cache file - (list :mtime (nth 5 (file-attributes file)) + (list :mtime (file-attribute-modification-time + (file-attributes file)) :secret (let ((v (mapcar #'1+ (buffer-string)))) (lambda () (apply #'string (mapcar #'1- v))))))) (goto-char (point-min)) @@ -1302,9 +1311,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 @@ -1485,13 +1492,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 @@ -1502,9 +1509,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") @@ -1564,12 +1568,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 @@ -1970,6 +2166,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") |