;;; auth-source.el --- authentication sources for Gnus and Emacs
-;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Ted Zlatanov <tzz@lifelogs.com>
;; Keywords: news
;; 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))
-(autoload 'netrc-machine-user-or-password "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"))
+(defcustom auth-sources '((:source "~/.authinfo.gpg")
+ (:source "~/.authinfo"))
"List of authentication sources.
The default will get login and password information from a .gpg
: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 "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"))))))))
+ (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"))))))))
+
+(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 "23.2" ;; No Gnus
+ :type '(choice (const :tag "Symmetric encryption" t)
+ (repeat :tag "Recipient public keys"
+ (string :tag "Recipient public key"))))
;; temp for debugging
;; (unintern 'auth-source-protocols)
;; 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))))
;; (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)
+;; (: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 (: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.
-
-The first pass skips fallback choices. If no choices are found
-on the first pass, a second pass is made including the fallback
-choices.
-
-For string (filename) sources, fallback choices are those where
-PROTOCOL or HOST are nil.
-
-For secrets.el collections, the :host and :protocol keys are not
-checked for fallback choices."
- (let (choices)
- (dolist (fallback '(nil t))
- (let ((keys (loop for i below (length spec) by 2
- collect (nth i spec)))
- (default-session-fallback "login"))
- (dolist (choice auth-sources)
- (let* ((s (plist-get choice :source))
- ;; this is only set for Secret Service API specs (see secrets.el)
- (coll (plist-get s :secrets))
- (score 0))
- (cond
- (coll ; use secrets.el here
- (when (eq coll 'default)
- (setq coll (secrets-get-alias "default"))
- (unless coll
- (auth-source-do-debug
- "No 'default' alias. Trying collection '%s'."
- default-session-fallback)
- (setq coll default-session-fallback)))
- (let* ((coll-search (cond
- ((stringp coll) coll)
-
- ;; when the collection is nil:
- ;; in fallback mode, accept it as any
- ;; otherwise, hope to fail
- ((null coll) (if fallback
- nil
- " *fallback-fail*"))))
- ;; assemble a search query for secrets-search-items
- ;; in fallback mode, host and protocol are not checked
- (other-search (loop for k
- in (if fallback
- (remove :host
- (remove :protocol keys))
- keys)
- append (list
- k
- ;; convert symbols to a string
- (let ((v (plist-get spec k)))
- (if (stringp v)
- v
- (prin1-to-string v))))))
- ;; the score is based on how exact the search was,
- ;; plus base score = 1 for any match
- (score (1+ (length other-search)))
- (results (apply 'secrets-search-items
- coll-search
- other-search)))
- (auth-source-do-debug
- "auth-source-pick: got items %s in collection '%s' + %s"
- results coll-search other-search)
- ;; put the results in the choices variable
- (dolist (result results)
- (setq choices (cons (list score
- `(:source secrets
- :item ,result
- :collection ,coll
- :search ,coll-search
- ,@other-search))
- choices)))))
- ;; this is any non-secrets spec (currently means a string filename)
- (t
- (let ((match t))
- (dolist (k keys)
- (let* ((v (plist-get spec k))
- (choicev (plist-get choice k)))
- (setq match
- (and match
- (or (eq t choicev) ; source always matches spec key
- ;; 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))
- ;; in fallback mode, missing source key is OK
- fallback)))
- (when match (incf score)))) ; increment the score for each match
-
- ;; now if the whole iteration resulted in a match:
- (when match
- (setq choices (cons (list score choice) choices))))))))
- ;; when there were matches, skip the second pass
- (when choices (return choices))))
-
- ;; return the results sorted by score
- (mapcar 'cadr (sort choices (lambda (x y) (> (car x) (car y)))))))
-
-(defun auth-source-forget-user-or-password (mode host protocol)
+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))
+ ;; the code below is almost same as `netrc-store-data' except
+ ;; the `epa-file-encrypt-to' hack (see bug#7487).
+ (with-temp-buffer
+ (when (file-exists-p source)
+ (insert-file-contents source))
+ (when auth-source-gpg-encrypt-to
+ ;; making `epa-file-encrypt-to' local to this buffer lets
+ ;; epa-file skip the key selection query (see the
+ ;; `local-variable-p' check in `epa-file-write-region').
+ (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
+ (make-local-variable 'epa-file-encrypt-to))
+ (if (listp auth-source-gpg-encrypt-to)
+ (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (insert (format "machine %s login %s password %s port %s\n"
+ host
+ (or user (cdr (assoc "login" result)))
+ (cdr (assoc "password" result))
+ prot))
+ (write-region (point-min) (point-max) source nil 'silent)))))
+ (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."
;; (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)
+(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.
USERNAME is optional and will be used as \"login\" in a search
username \"joe\" and it matches an item but the item doesn't have
a :user attribute, the username \"joe\" will be returned.
-MODE can be \"login\" or \"password\" for example."
+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) + user=%s"
mode host protocol username)
(let* ((listy (listp mode))
- (mode (if listy mode (list mode)))
- (extras (when username `(:user ,username)))
- (cname (format "%s %s:%s %s" mode host protocol extras))
- (search (list :host host :protocol protocol))
- (search (if username (append search (list :user username)) search))
- (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) + %s"
- mode
- ;; don't show the password
- (if (and (member "password" mode) auth-source-hide-passwords)
- "SECRET"
- found)
- host protocol extras)
- found) ; return the found data
+ (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
- (dolist (choice (apply 'auth-source-pick search))
- (setq found (cond
- ;; the secrets.el spec
- ((eq (plist-get choice :source) 'secrets)
- (let ((coll (plist-get choice :search))
- (item (plist-get choice :item)))
- (mapcar (lambda (m)
- (if (equal "password" m)
- (secrets-get-secret coll item)
- ;; the user name is either
- (or
- ;; the secret's attribute :user, or
- (secrets-get-attribute coll item :user)
- ;; the originally requested :user
- username
- "unknown-user")))
- mode)))
- (t ; anything else is netrc
- (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) + %s"
- mode
- ;; don't show the password
- (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
- host protocol extras)
- (setq found (if listy found (car-safe found)))
- (when auth-source-do-cache
- (puthash cname found auth-source-cache)))
- (return 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."
(cdr-safe (assoc protocol auth-source-protocols)))
(provide 'auth-source)
-;; arch-tag: ff1afe78-06e9-42c2-b693-e9f922cbe4ab
;;; auth-source.el ends here
projects / gnus / blobdiff