;; See the auth.info Info documentation for details.
+;; TODO:
+
+;; - never decode the backend file unless it's necessary
+;; - a more generic way to match backends and search backend contents
+;; - absorb netrc.el and simplify it
+;; - protect passwords better
+;; - allow creating and changing netrc lines (not files) e.g. change a password
+
;;; Code:
(require 'gnus-util)
+(require 'netrc)
(eval-when-compile (require 'cl))
-(eval-when-compile (require 'netrc))
-
-(autoload 'secrets-search-items "secrets")
+(autoload 'secrets-create-item "secrets")
+(autoload 'secrets-delete-item "secrets")
(autoload 'secrets-get-alias "secrets")
(autoload 'secrets-get-attribute "secrets")
+(autoload 'secrets-get-secret "secrets")
+(autoload 'secrets-list-collections "secrets")
+(autoload 'secrets-search-items "secrets")
(defgroup auth-source nil
"Authentication sources."
:group 'gnus)
(defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
- (pop3 "pop3" "pop" "pop3s" "110" "995")
- (ssh "ssh" "22")
- (sftp "sftp" "115")
- (smtp "smtp" "25"))
+ (pop3 "pop3" "pop" "pop3s" "110" "995")
+ (ssh "ssh" "22")
+ (sftp "sftp" "115")
+ (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"
- (symbol :tag "Protocol")
- (repeat :tag "Names"
- (string :tag "Name")))))
+ (cons :tag "Protocol Entry"
+ (symbol :tag "Protocol")
+ (repeat :tag "Names"
+ (string :tag "Name")))))
;;; generate all the protocols in a format Customize can use
+;;; TODO: generate on the fly from auth-source-protocols
(defconst auth-source-protocols-customize
(mapcar (lambda (a)
- (let ((p (car-safe a)))
- (list 'const
- :tag (upcase (symbol-name p))
- p)))
- auth-source-protocols))
+ (let ((p (car-safe a)))
+ (list 'const
+ :tag (upcase (symbol-name p))
+ p)))
+ auth-source-protocols))
(defvar auth-source-cache (make-hash-table :test 'equal)
"Cache for auth-source data")
that function using the same arguments as `message'."
:group 'auth-source
:version "23.2" ;; No Gnus
- :type `(choice
- :tag "auth-source debugging mode"
- (const :tag "Log using `message' to the *Messages* buffer" t)
- (function :tag "Function that takes arguments like `message'")
- (const :tag "Don't log anything" nil)))
+ :type `(choice
+ :tag "auth-source debugging mode"
+ (const :tag "Log using `message' to the *Messages* buffer" t)
+ (function :tag "Function that takes arguments like `message'")
+ (const :tag "Don't log anything" nil)))
(defcustom auth-source-hide-passwords t
"Whether auth-source should hide passwords in log messages.
:version "23.2" ;; No Gnus
:type `boolean)
-(defcustom auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t))
+(defcustom auth-sources '((:source "~/.authinfo.gpg")
+ (:source "~/.authinfo"))
"List of authentication sources.
+The default will get login and password information from a .gpg
+file, which you should set up with the EPA/EPG packages to be
+encrypted. See the auth.info manual for details.
+
Each entry is the authentication type with optional properties.
It's best to customize this with `M-x customize-variable' because the choices
:group 'auth-source
:version "23.2" ;; No Gnus
:type `(repeat :tag "Authentication Sources"
- (list :tag "Source definition"
- (const :format "" :value :source)
- (choice :tag "Authentication backend choice"
- (string :tag "Authentication Source (file)")
- (list :tag "secrets.el (Secret Service API/KWallet/GNOME KeyRing)"
+ (list :tag "Source definition"
+ (const :format "" :value :source)
+ (choice :tag "Authentication backend choice"
+ (string :tag "Authentication Source (file)")
+ (list :tag "secrets.el (Secret Service API/KWallet/GNOME Keyring)"
(const :format "" :value :secrets)
(choice :tag "Collection to use"
(string :tag "Collection name")
(const :tag "Default" 'default)
- (const :tag "Any" t)
- (const :tag "Temporary" "session")
- (string :tag "Specific session name")
- (const :tag "Fallback" nil))))
- (const :format "" :value :host)
- (choice :tag "Host (machine) choice"
- (const :tag "Any" t)
- (regexp :tag "Host (machine) regular expression (TODO)")
- (const :tag "Fallback" nil))
- (const :format "" :value :protocol)
- (choice :tag "Protocol"
- (const :tag "Any" t)
- (const :tag "Fallback" nil)
- ,@auth-source-protocols-customize)
- (repeat :tag "Extra Parameters" :inline t
- (choice :tag "Extra parameter"
- (list :tag "Preferred username" :inline t
- (const :format "" :value :preferred-username)
- (choice :tag "Personality or username"
- (const :tag "Any" t)
- (const :tag "Fallback" nil)
- (string :tag "Specific user name"))))))))
+ (const :tag "Login" "login")
+ (const :tag "Temporary" "session"))))
+ (repeat :tag "Extra Parameters" :inline t
+ (choice :tag "Extra parameter"
+ (list :tag "Host (omit to match as a fallback)"
+ (const :format "" :value :host)
+ (choice :tag "Host (machine) choice"
+ (const :tag "Any" t)
+ (regexp :tag "Host (machine) regular expression")))
+ (list :tag "Protocol (omit to match as a fallback)"
+ (const :format "" :value :protocol)
+ (choice :tag "Protocol"
+ (const :tag "Any" t)
+ ,@auth-source-protocols-customize))
+ (list :tag "User (omit to match as a fallback)" :inline t
+ (const :format "" :value :user)
+ (choice :tag "Personality or username"
+ (const :tag "Any" t)
+ (string :tag "Specific user name"))))))))
;; temp for debugging
;; (unintern 'auth-source-protocols)
;; (customize-variable 'auth-source-protocols)
;; (setq auth-source-protocols nil)
;; (format "%S" auth-source-protocols)
-;; (auth-source-pick "a" 'imap)
+;; (auth-source-pick nil :host "a" :port 'imap)
;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
;; we also check the value
(when auth-source-debug
(let ((logger (if (functionp auth-source-debug)
- auth-source-debug
- 'message)))
+ auth-source-debug
+ 'message)))
(apply logger msg))))
-(defun auth-source-pick (host protocol &optional fallback)
- "Parse `auth-sources' for HOST, and PROTOCOL matches.
-
-Returns fallback choices (where PROTOCOL or HOST are nil) with FALLBACK t."
- (interactive "sHost: \nsProtocol: \n") ;for testing
- (let (choices)
- (dolist (choice auth-sources)
- (let ((h (plist-get choice :host))
- (p (plist-get choice :protocol)))
- (when (and
- (or (equal t h)
- (and (stringp h) (string-match h host))
- (and fallback (equal h nil)))
- (or (equal t p)
- (and (symbolp p) (equal p protocol))
- (and fallback (equal p nil))))
- (push choice choices))))
- (if choices
- choices
- (unless fallback
- (auth-source-pick host protocol t)))))
-
-(defun auth-source-forget-user-or-password (mode host protocol)
+;; (auth-source-pick nil :host "any" :protocol 'imap :user "joe")
+;; (auth-source-pick t :host "any" :protocol 'imap :user "joe")
+;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
+;; (:source (:secrets "session") :host t :protocol t :user "joe")
+;; (:source (:secrets "login") :host t :protocol t)
+;; (:source "~/.authinfo.gpg" :host t :protocol t)))
+
+;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
+;; (:source (:secrets "session") :host t :protocol t :user "joe")
+;; (:source (:secrets "login") :host t :protocol t)
+;; ))
+
+;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t)))
+
+(defun auth-get-source (entry)
+ "Return the source string of ENTRY, which is one entry in `auth-sources'.
+If it is a Secret Service API, return the collection name, otherwise
+the file name."
+ (let ((source (plist-get entry :source)))
+ (if (stringp source)
+ source
+ ;; Secret Service API.
+ (setq source (plist-get source :secrets))
+ (when (eq source 'default)
+ (setq source (or (secrets-get-alias "default") "login")))
+ (or source "session"))))
+
+(defun auth-source-pick (&rest spec)
+ "Parse `auth-sources' for matches of the SPEC plist.
+
+Common keys are :host, :protocol, and :user. A value of t in
+SPEC means to always succeed in the match. A string value is
+matched as a regex."
+ (let ((keys (loop for i below (length spec) by 2 collect (nth i spec)))
+ choices)
+ (dolist (choice (copy-tree auth-sources) choices)
+ (let ((source (plist-get choice :source))
+ (match t))
+ (when
+ (and
+ ;; Check existence of source.
+ (if (consp source)
+ ;; Secret Service API.
+ (member (auth-get-source choice) (secrets-list-collections))
+ ;; authinfo file.
+ (file-exists-p source))
+
+ ;; Check keywords.
+ (dolist (k keys match)
+ (let* ((v (plist-get spec k))
+ (choicev (if (plist-member choice k)
+ (plist-get choice k) t)))
+ (setq match
+ (and match
+ (or
+ ;; source always matches spec key
+ (eq t choicev)
+ ;; source key gives regex to match against spec
+ (and (stringp choicev) (string-match choicev v))
+ ;; source key gives symbol to match against spec
+ (and (symbolp choicev) (eq choicev v))))))))
+
+ (add-to-list 'choices choice 'append))))))
+
+(defun auth-source-retrieve (mode entry &rest spec)
+ "Retrieve MODE credentials according to SPEC from ENTRY."
+ (catch 'no-password
+ (let ((host (plist-get spec :host))
+ (user (plist-get spec :user))
+ (prot (plist-get spec :protocol))
+ (source (plist-get entry :source))
+ result)
+ (cond
+ ;; Secret Service API.
+ ((consp source)
+ (let ((coll (auth-get-source entry))
+ item)
+ ;; Loop over candidates with a matching host attribute.
+ (dolist (elt (secrets-search-items coll :host host) item)
+ (when (and (or (not user)
+ (string-equal
+ user (secrets-get-attribute coll elt :user)))
+ (or (not prot)
+ (string-equal
+ prot (secrets-get-attribute coll elt :protocol))))
+ (setq item elt)
+ (return elt)))
+ ;; Compose result.
+ (when item
+ (setq result
+ (mapcar (lambda (m)
+ (if (string-equal "password" m)
+ (or (secrets-get-secret coll item)
+ ;; When we do not find a password,
+ ;; we return nil anyway.
+ (throw 'no-password nil))
+ (or (secrets-get-attribute coll item :user)
+ user)))
+ (if (consp mode) mode (list mode)))))
+ (if (consp mode) result (car result))))
+ ;; Anything else is netrc.
+ (t
+ (let ((search (list source (list host) (list (format "%s" prot))
+ (auth-source-protocol-defaults prot))))
+ (setq result
+ (mapcar (lambda (m)
+ (if (string-equal "password" m)
+ (or (apply
+ 'netrc-machine-user-or-password m search)
+ ;; When we do not find a password, we
+ ;; return nil anyway.
+ (throw 'no-password nil))
+ (or (apply
+ 'netrc-machine-user-or-password m search)
+ user)))
+ (if (consp mode) mode (list mode)))))
+ (if (consp mode) result (car result)))))))
+
+(defun auth-source-create (mode entry &rest spec)
+ "Create interactively credentials according to SPEC in ENTRY.
+Return structure as specified by MODE."
+ (let* ((host (plist-get spec :host))
+ (user (plist-get spec :user))
+ (prot (plist-get spec :protocol))
+ (source (plist-get entry :source))
+ (name (concat (if user (format "%s@" user))
+ host
+ (if prot (format ":%s" prot))))
+ result)
+ (setq result
+ (mapcar
+ (lambda (m)
+ (cons
+ m
+ (cond
+ ((equal "password" m)
+ (let ((passwd (read-passwd
+ (format "Password for %s on %s: " prot host))))
+ (cond
+ ;; Secret Service API.
+ ((consp source)
+ (apply
+ 'secrets-create-item
+ (auth-get-source entry) name passwd spec))
+ (t)) ;; netrc not implemented yes.
+ passwd))
+ ((equal "login" m)
+ (or user
+ (read-string
+ (format "User name for %s on %s (default %s): " prot host
+ (user-login-name))
+ nil nil (user-login-name))))
+ (t
+ "unknownuser"))))
+ (if (consp mode) mode (list mode))))
+ ;; Allow the source to save the data.
+ (cond
+ ((consp source)
+ ;; Secret Service API -- not implemented.
+ )
+ (t
+ ;; netrc interface.
+ (when (y-or-n-p (format "Do you want to save this password in %s? "
+ source))
+ (netrc-store-data source host prot
+ (or user (cdr (assoc "login" result)))
+ (cdr (assoc "password" result))))))
+ (if (consp mode)
+ (mapcar #'cdr result)
+ (cdar result))))
+
+(defun auth-source-delete (entry &rest spec)
+ "Delete credentials according to SPEC in ENTRY."
+ (let ((host (plist-get spec :host))
+ (user (plist-get spec :user))
+ (prot (plist-get spec :protocol))
+ (source (plist-get entry :source)))
+ (cond
+ ;; Secret Service API.
+ ((consp source)
+ (let ((coll (auth-get-source entry)))
+ ;; Loop over candidates with a matching host attribute.
+ (dolist (elt (secrets-search-items coll :host host))
+ (when (and (or (not user)
+ (string-equal
+ user (secrets-get-attribute coll elt :user)))
+ (or (not prot)
+ (string-equal
+ prot (secrets-get-attribute coll elt :protocol))))
+ (secrets-delete-item coll elt)))))
+ (t)))) ;; netrc not implemented yes.
+
+(defun auth-source-forget-user-or-password
+ (mode host protocol &optional username)
+ "Remove cached authentication token."
(interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing
- (remhash (format "%s %s:%s" mode host protocol) auth-source-cache))
+ (remhash
+ (if username
+ (format "%s %s:%s %s" mode host protocol username)
+ (format "%s %s:%s" mode host protocol))
+ auth-source-cache))
(defun auth-source-forget-all-cached ()
"Forget all cached auth-source authentication tokens."
(interactive)
(setq auth-source-cache (make-hash-table :test 'equal)))
-(defun auth-source-user-or-password (mode host protocol)
+;; (progn
+;; (auth-source-forget-all-cached)
+;; (list
+;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other")
+;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "tzz")
+;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "joe")))
+
+(defun auth-source-user-or-password
+ (mode host protocol &optional username create-missing delete-existing)
"Find MODE (string or list of strings) matching HOST and PROTOCOL.
-MODE can be \"login\" or \"password\" for example."
+
+USERNAME is optional and will be used as \"login\" in a search
+across the Secret Service API (see secrets.el) if the resulting
+items don't have a username. This means that if you search for
+username \"joe\" and it matches an item but the item doesn't have
+a :user attribute, the username \"joe\" will be returned.
+
+A non nil DELETE-EXISTING means deleting any matching password
+entry in the respective sources. This is useful only when
+CREATE-MISSING is non nil as well; the intended use case is to
+remove wrong password entries.
+
+If no matching entry is found, and CREATE-MISSING is non nil,
+the password will be retrieved interactively, and it will be
+stored in the password database which matches best (see
+`auth-sources').
+
+MODE can be \"login\" or \"password\"."
(auth-source-do-debug
- "auth-source-user-or-password: get %s for %s (%s)"
- mode host protocol)
+ "auth-source-user-or-password: get %s for %s (%s) + user=%s"
+ mode host protocol username)
(let* ((listy (listp mode))
- (mode (if listy mode (list mode)))
- (cname (format "%s %s:%s" mode host protocol))
- (found (gethash cname auth-source-cache)))
+ (mode (if listy mode (list mode)))
+ (cname (if username
+ (format "%s %s:%s %s" mode host protocol username)
+ (format "%s %s:%s" mode host protocol)))
+ (search (list :host host :protocol protocol))
+ (search (if username (append search (list :user username)) search))
+ (found (if (not delete-existing)
+ (gethash cname auth-source-cache)
+ (remhash cname auth-source-cache)
+ nil)))
(if found
- (progn
- (auth-source-do-debug
- "auth-source-user-or-password: cached %s=%s for %s (%s)"
- mode
- ;; don't show the password
- (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
- host protocol)
- found)
- (dolist (choice (auth-source-pick host protocol))
- (setq found (netrc-machine-user-or-password
- mode
- (plist-get choice :source)
- (list host)
- (list (format "%s" protocol))
- (auth-source-protocol-defaults protocol)))
- (when found
- (auth-source-do-debug
- "auth-source-user-or-password: found %s=%s for %s (%s)"
- mode
- ;; don't show the password
- (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
- host protocol)
- (setq found (if listy found (car-safe found)))
- (when auth-source-do-cache
- (puthash cname found auth-source-cache)))
- (return found)))))
+ (progn
+ (auth-source-do-debug
+ "auth-source-user-or-password: cached %s=%s for %s (%s) + %s"
+ mode
+ ;; don't show the password
+ (if (and (member "password" mode) auth-source-hide-passwords)
+ "SECRET"
+ found)
+ host protocol username)
+ found) ; return the found data
+ ;; else, if not found
+ (let ((choices (apply 'auth-source-pick search)))
+ (dolist (choice choices)
+ (if delete-existing
+ (apply 'auth-source-delete choice search)
+ (setq found (apply 'auth-source-retrieve mode choice search)))
+ (and found (return found)))
+
+ ;; We haven't found something, so we will create it interactively.
+ (when (and (not found) create-missing)
+ (setq found (apply 'auth-source-create
+ mode (if choices
+ (car choices)
+ (car auth-sources))
+ search)))
+
+ ;; Cache the result.
+ (when found
+ (auth-source-do-debug
+ "auth-source-user-or-password: found %s=%s for %s (%s) + %s"
+ mode
+ ;; don't show the password
+ (if (and (member "password" mode) auth-source-hide-passwords)
+ "SECRET" found)
+ host protocol username)
+ (setq found (if listy found (car-safe found)))
+ (when auth-source-do-cache
+ (puthash cname found auth-source-cache)))
+
+ found))))
(defun auth-source-protocol-defaults (protocol)
"Return a list of default ports and names for PROTOCOL."
(provide 'auth-source)
-;; arch-tag: ff1afe78-06e9-42c2-b693-e9f922cbe4ab
;;; auth-source.el ends here
projects / gnus / blobdiff