[bpt/emacs.git] / lisp / gnus / auth-source.el

;;; auth-source.el --- authentication sources for Gnus and Emacs

;; Copyright (C) 2008-2011 Free Software Foundation, Inc.

;; Author: Ted Zlatanov <tzz@lifelogs.com>
;; Keywords: news

;; 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 <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This is the auth-source.el package.  It lets users tell Gnus how to
;; authenticate in a single place.  Simplicity is the goal.  Instead
;; of providing 5000 options, we'll stick to simple, easy to
;; understand options.

;; 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 '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."
  :version "23.1" ;; No Gnus
  :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"))
  "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")))))

;;; 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))

(defvar auth-source-cache (make-hash-table :test 'equal)
  "Cache for auth-source data")

(defcustom auth-source-do-cache t
  "Whether auth-source should cache information."
  :group 'auth-source
  :version "23.2" ;; No Gnus
  :type `boolean)

(defcustom auth-source-debug nil
  "Whether auth-source should log debug messages.
Also see `auth-source-hide-passwords'.

If the value is nil, debug messages are not logged.
If the value is t, debug messages are logged with `message'.
 In that case, your authentication data will be in the
 clear (except for passwords, which are always stripped out).
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"
          (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.
Only relevant if `auth-source-debug' is not nil."
  :group 'auth-source
  :version "23.2" ;; No Gnus
  :type `boolean)

(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
can get pretty complex."
  :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)"
                                     (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"))))))))

(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)
;; (unintern 'auth-sources)
;; (customize-variable 'auth-sources)
;; (setq auth-sources nil)
;; (format "%S" auth-sources)
;; (customize-variable 'auth-source-protocols)
;; (setq auth-source-protocols nil)
;; (format "%S" auth-source-protocols)
;; (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")
;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
;; (auth-source-protocol-defaults 'imap)

;; (let ((auth-source-debug 'debug)) (auth-source-debug "hello"))
;; (let ((auth-source-debug t)) (auth-source-debug "hello"))
;; (let ((auth-source-debug nil)) (auth-source-debug "hello"))
(defun auth-source-do-debug (&rest msg)
  ;; set logger to either the function in auth-source-debug or 'message
  ;; note that it will be 'message if auth-source-debug is nil, so
  ;; we also check the value
  (when auth-source-debug
    (let ((logger (if (functionp auth-source-debug)
                      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)
;;                   ))

;; (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))
	;; 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
   (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)))

;; (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.

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) + user=%s"
   mode host protocol username)
  (let* ((listy (listp mode))
         (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 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."
  (cdr-safe (assoc protocol auth-source-protocols)))

(defun auth-source-user-or-password-imap (mode host)
  (auth-source-user-or-password mode host 'imap))

(defun auth-source-user-or-password-pop3 (mode host)
  (auth-source-user-or-password mode host 'pop3))

(defun auth-source-user-or-password-ssh (mode host)
  (auth-source-user-or-password mode host 'ssh))

(defun auth-source-user-or-password-sftp (mode host)
  (auth-source-user-or-password mode host 'sftp))

(defun auth-source-user-or-password-smtp (mode host)
  (auth-source-user-or-password mode host 'smtp))

(provide 'auth-source)

;;; auth-source.el ends here
Commit	Line	Data
8f7abae3 MB	1	;;; auth-source.el --- authentication sources for Gnus and Emacs
8f7abae3 MB	2
73b0cd50	3	;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
8f7abae3 MB	4
	5	;; Author: Ted Zlatanov <tzz@lifelogs.com>
	6	;; Keywords: news
	7
	8	;; This file is part of GNU Emacs.
	9
5e809f55	10	;; GNU Emacs is free software: you can redistribute it and/or modify
8f7abae3	11	;; it under the terms of the GNU General Public License as published by
5e809f55 GM	12	;; the Free Software Foundation, either version 3 of the License, or
5e809f55 GM	13	;; (at your option) any later version.
8f7abae3 MB	14
	15	;; GNU Emacs is distributed in the hope that it will be useful,
	16	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
5e809f55	17	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
8f7abae3 MB	18	;; GNU General Public License for more details.
	19
	20	;; You should have received a copy of the GNU General Public License
5e809f55	21	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
8f7abae3 MB	22
	23	;;; Commentary:
	24
	25	;; This is the auth-source.el package. It lets users tell Gnus how to
	26	;; authenticate in a single place. Simplicity is the goal. Instead
	27	;; of providing 5000 options, we'll stick to simple, easy to
	28	;; understand options.
d55fe5bb	29
554a69b8	30	;; See the auth.info Info documentation for details.
4079589f	31
cbabe91f TZ	32	;; TODO:
	33
	34	;; - never decode the backend file unless it's necessary
	35	;; - a more generic way to match backends and search backend contents
	36	;; - absorb netrc.el and simplify it
	37	;; - protect passwords better
	38	;; - allow creating and changing netrc lines (not files) e.g. change a password
	39
8f7abae3 MB	40	;;; Code:
8f7abae3 MB	41
e952b711	42	(require 'gnus-util)
1821a7b4	43	(require 'netrc)
e952b711	44
8f7abae3	45	(eval-when-compile (require 'cl))
0e4966fb MA	46	(autoload 'secrets-create-item "secrets")
0e4966fb MA	47	(autoload 'secrets-delete-item "secrets")
ec7995fa KY	48	(autoload 'secrets-get-alias "secrets")
ec7995fa KY	49	(autoload 'secrets-get-attribute "secrets")
fb178e4c	50	(autoload 'secrets-get-secret "secrets")
0e4966fb MA	51	(autoload 'secrets-list-collections "secrets")
0e4966fb MA	52	(autoload 'secrets-search-items "secrets")
8f7abae3 MB	53
	54	(defgroup auth-source nil
	55	"Authentication sources."
9b3ebcb6	56	:version "23.1" ;; No Gnus
8f7abae3 MB	57	:group 'gnus)
8f7abae3 MB	58
9b3ebcb6	59	(defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
cbabe91f TZ	60	(pop3 "pop3" "pop" "pop3s" "110" "995")
	61	(ssh "ssh" "22")
	62	(sftp "sftp" "115")
	63	(smtp "smtp" "25"))
9b3ebcb6 MB	64	"List of authentication protocols and their names"
	65
	66	:group 'auth-source
ec7995fa	67	:version "23.2" ;; No Gnus
9b3ebcb6	68	:type '(repeat :tag "Authentication Protocols"
cbabe91f TZ	69	(cons :tag "Protocol Entry"
	70	(symbol :tag "Protocol")
	71	(repeat :tag "Names"
	72	(string :tag "Name")))))
9b3ebcb6 MB	73
9b3ebcb6 MB	74	;;; generate all the protocols in a format Customize can use
fb178e4c	75	;;; TODO: generate on the fly from auth-source-protocols
9b3ebcb6 MB	76	(defconst auth-source-protocols-customize
9b3ebcb6 MB	77	(mapcar (lambda (a)
cbabe91f TZ	78	(let ((p (car-safe a)))
	79	(list 'const
	80	:tag (upcase (symbol-name p))
	81	p)))
	82	auth-source-protocols))
9b3ebcb6	83
ed778fad MB	84	(defvar auth-source-cache (make-hash-table :test 'equal)
	85	"Cache for auth-source data")
	86
	87	(defcustom auth-source-do-cache t
	88	"Whether auth-source should cache information."
	89	:group 'auth-source
ec7995fa	90	:version "23.2" ;; No Gnus
ed778fad MB	91	:type `boolean)
ed778fad MB	92
554a69b8 KY	93	(defcustom auth-source-debug nil
	94	"Whether auth-source should log debug messages.
	95	Also see `auth-source-hide-passwords'.
	96
	97	If the value is nil, debug messages are not logged.
	98	If the value is t, debug messages are logged with `message'.
	99	In that case, your authentication data will be in the
	100	clear (except for passwords, which are always stripped out).
	101	If the value is a function, debug messages are logged by calling
	102	that function using the same arguments as `message'."
	103	:group 'auth-source
ec7995fa	104	:version "23.2" ;; No Gnus
cbabe91f TZ	105	:type `(choice
	106	:tag "auth-source debugging mode"
	107	(const :tag "Log using `message' to the Messages buffer" t)
	108	(function :tag "Function that takes arguments like `message'")
	109	(const :tag "Don't log anything" nil)))
554a69b8 KY	110
	111	(defcustom auth-source-hide-passwords t
	112	"Whether auth-source should hide passwords in log messages.
	113	Only relevant if `auth-source-debug' is not nil."
	114	:group 'auth-source
ec7995fa	115	:version "23.2" ;; No Gnus
554a69b8 KY	116	:type `boolean)
554a69b8 KY	117
20a673b2	118	(defcustom auth-sources '((:source "~/.authinfo.gpg")
cbabe91f	119	(:source "~/.authinfo"))
8f7abae3 MB	120	"List of authentication sources.
8f7abae3 MB	121
fb178e4c KY	122	The default will get login and password information from a .gpg
	123	file, which you should set up with the EPA/EPG packages to be
	124	encrypted. See the auth.info manual for details.
	125
ec7995fa KY	126	Each entry is the authentication type with optional properties.
	127
	128	It's best to customize this with `M-x customize-variable' because the choices
	129	can get pretty complex."
8f7abae3	130	:group 'auth-source
ec7995fa	131	:version "23.2" ;; No Gnus
9b3ebcb6	132	:type `(repeat :tag "Authentication Sources"
cbabe91f TZ	133	(list :tag "Source definition"
	134	(const :format "" :value :source)
	135	(choice :tag "Authentication backend choice"
	136	(string :tag "Authentication Source (file)")
	137	(list :tag "secrets.el (Secret Service API/KWallet/GNOME Keyring)"
ec7995fa KY	138	(const :format "" :value :secrets)
	139	(choice :tag "Collection to use"
	140	(string :tag "Collection name")
	141	(const :tag "Default" 'default)
fb178e4c KY	142	(const :tag "Login" "login")
fb178e4c KY	143	(const :tag "Temporary" "session"))))
cbabe91f TZ	144	(repeat :tag "Extra Parameters" :inline t
	145	(choice :tag "Extra parameter"
	146	(list :tag "Host (omit to match as a fallback)"
	147	(const :format "" :value :host)
	148	(choice :tag "Host (machine) choice"
	149	(const :tag "Any" t)
	150	(regexp :tag "Host (machine) regular expression")))
	151	(list :tag "Protocol (omit to match as a fallback)"
	152	(const :format "" :value :protocol)
	153	(choice :tag "Protocol"
	154	(const :tag "Any" t)
	155	,@auth-source-protocols-customize))
	156	(list :tag "User (omit to match as a fallback)" :inline t
	157	(const :format "" :value :user)
	158	(choice :tag "Personality or username"
	159	(const :tag "Any" t)
	160	(string :tag "Specific user name"))))))))
8f7abae3	161
549c9aed G	162	(defcustom auth-source-gpg-encrypt-to t
	163	"List of recipient keys that `authinfo.gpg' encrypted to.
	164	If the value is not a list, symmetric encryption will be used."
	165	:group 'auth-source
	166	:version "23.2" ;; No Gnus
	167	:type '(choice (const :tag "Symmetric encryption" t)
	168	(repeat :tag "Recipient public keys"
	169	(string :tag "Recipient public key"))))
	170
8f7abae3	171	;; temp for debugging
9b3ebcb6 MB	172	;; (unintern 'auth-source-protocols)
	173	;; (unintern 'auth-sources)
	174	;; (customize-variable 'auth-sources)
	175	;; (setq auth-sources nil)
	176	;; (format "%S" auth-sources)
	177	;; (customize-variable 'auth-source-protocols)
	178	;; (setq auth-source-protocols nil)
	179	;; (format "%S" auth-source-protocols)
fb178e4c	180	;; (auth-source-pick nil :host "a" :port 'imap)
9b3ebcb6 MB	181	;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
	182	;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
	183	;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
	184	;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
	185	;; (auth-source-protocol-defaults 'imap)
	186
554a69b8 KY	187	;; (let ((auth-source-debug 'debug)) (auth-source-debug "hello"))
	188	;; (let ((auth-source-debug t)) (auth-source-debug "hello"))
	189	;; (let ((auth-source-debug nil)) (auth-source-debug "hello"))
	190	(defun auth-source-do-debug (&rest msg)
	191	;; set logger to either the function in auth-source-debug or 'message
	192	;; note that it will be 'message if auth-source-debug is nil, so
	193	;; we also check the value
	194	(when auth-source-debug
	195	(let ((logger (if (functionp auth-source-debug)
cbabe91f TZ	196	auth-source-debug
cbabe91f TZ	197	'message)))
554a69b8 KY	198	(apply logger msg))))
554a69b8 KY	199
fb178e4c KY	200	;; (auth-source-pick nil :host "any" :protocol 'imap :user "joe")
fb178e4c KY	201	;; (auth-source-pick t :host "any" :protocol 'imap :user "joe")
0e4966fb	202	;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
cbabe91f TZ	203	;; (:source (:secrets "session") :host t :protocol t :user "joe")
	204	;; (:source (:secrets "login") :host t :protocol t)
	205	;; (:source "~/.authinfo.gpg" :host t :protocol t)))
fb178e4c	206
0e4966fb	207	;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
cbabe91f TZ	208	;; (:source (:secrets "session") :host t :protocol t :user "joe")
	209	;; (:source (:secrets "login") :host t :protocol t)
	210	;; ))
fb178e4c KY	211
	212	;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t)))
	213
0e4966fb MA	214	(defun auth-get-source (entry)
	215	"Return the source string of ENTRY, which is one entry in `auth-sources'.
	216	If it is a Secret Service API, return the collection name, otherwise
	217	the file name."
	218	(let ((source (plist-get entry :source)))
	219	(if (stringp source)
cbabe91f	220	source
0e4966fb MA	221	;; Secret Service API.
	222	(setq source (plist-get source :secrets))
	223	(when (eq source 'default)
cbabe91f	224	(setq source (or (secrets-get-alias "default") "login")))
0e4966fb MA	225	(or source "session"))))
0e4966fb MA	226
fb178e4c KY	227	(defun auth-source-pick (&rest spec)
	228	"Parse `auth-sources' for matches of the SPEC plist.
	229
	230	Common keys are :host, :protocol, and :user. A value of t in
	231	SPEC means to always succeed in the match. A string value is
0e4966fb MA	232	matched as a regex."
0e4966fb MA	233	(let ((keys (loop for i below (length spec) by 2 collect (nth i spec)))
cbabe91f	234	choices)
0e4966fb MA	235	(dolist (choice (copy-tree auth-sources) choices)
0e4966fb MA	236	(let ((source (plist-get choice :source))
cbabe91f TZ	237	(match t))
	238	(when
	239	(and
	240	;; Check existence of source.
	241	(if (consp source)
	242	;; Secret Service API.
	243	(member (auth-get-source choice) (secrets-list-collections))
	244	;; authinfo file.
	245	(file-exists-p source))
	246
	247	;; Check keywords.
	248	(dolist (k keys match)
	249	(let* ((v (plist-get spec k))
	250	(choicev (if (plist-member choice k)
	251	(plist-get choice k) t)))
	252	(setq match
	253	(and match
	254	(or
	255	;; source always matches spec key
	256	(eq t choicev)
	257	;; source key gives regex to match against spec
	258	(and (stringp choicev) (string-match choicev v))
	259	;; source key gives symbol to match against spec
	260	(and (symbolp choicev) (eq choicev v))))))))
	261
	262	(add-to-list 'choices choice 'append))))))
0e4966fb MA	263
	264	(defun auth-source-retrieve (mode entry &rest spec)
	265	"Retrieve MODE credentials according to SPEC from ENTRY."
	266	(catch 'no-password
	267	(let ((host (plist-get spec :host))
cbabe91f TZ	268	(user (plist-get spec :user))
	269	(prot (plist-get spec :protocol))
	270	(source (plist-get entry :source))
	271	result)
0e4966fb MA	272	(cond
	273	;; Secret Service API.
	274	((consp source)
cbabe91f TZ	275	(let ((coll (auth-get-source entry))
	276	item)
	277	;; Loop over candidates with a matching host attribute.
	278	(dolist (elt (secrets-search-items coll :host host) item)
	279	(when (and (or (not user)
	280	(string-equal
	281	user (secrets-get-attribute coll elt :user)))
	282	(or (not prot)
	283	(string-equal
	284	prot (secrets-get-attribute coll elt :protocol))))
	285	(setq item elt)
	286	(return elt)))
	287	;; Compose result.
	288	(when item
	289	(setq result
	290	(mapcar (lambda (m)
	291	(if (string-equal "password" m)
	292	(or (secrets-get-secret coll item)
	293	;; When we do not find a password,
	294	;; we return nil anyway.
	295	(throw 'no-password nil))
	296	(or (secrets-get-attribute coll item :user)
	297	user)))
	298	(if (consp mode) mode (list mode)))))
	299	(if (consp mode) result (car result))))
0e4966fb MA	300	;; Anything else is netrc.
0e4966fb MA	301	(t
cbabe91f TZ	302	(let ((search (list source (list host) (list (format "%s" prot))
	303	(auth-source-protocol-defaults prot))))
	304	(setq result
	305	(mapcar (lambda (m)
	306	(if (string-equal "password" m)
	307	(or (apply
	308	'netrc-machine-user-or-password m search)
	309	;; When we do not find a password, we
	310	;; return nil anyway.
	311	(throw 'no-password nil))
	312	(or (apply
	313	'netrc-machine-user-or-password m search)
	314	user)))
	315	(if (consp mode) mode (list mode)))))
	316	(if (consp mode) result (car result)))))))
0e4966fb MA	317
	318	(defun auth-source-create (mode entry &rest spec)
	319	"Create interactively credentials according to SPEC in ENTRY.
	320	Return structure as specified by MODE."
	321	(let* ((host (plist-get spec :host))
cbabe91f TZ	322	(user (plist-get spec :user))
	323	(prot (plist-get spec :protocol))
	324	(source (plist-get entry :source))
	325	(name (concat (if user (format "%s@" user))
	326	host
	327	(if prot (format ":%s" prot))))
	328	result)
0e4966fb	329	(setq result
cbabe91f TZ	330	(mapcar
	331	(lambda (m)
	332	(cons
	333	m
	334	(cond
	335	((equal "password" m)
	336	(let ((passwd (read-passwd
	337	(format "Password for %s on %s: " prot host))))
	338	(cond
	339	;; Secret Service API.
	340	((consp source)
	341	(apply
	342	'secrets-create-item
	343	(auth-get-source entry) name passwd spec))
	344	(t)) ;; netrc not implemented yes.
	345	passwd))
	346	((equal "login" m)
	347	(or user
dab0271f G	348	(read-string
	349	(format "User name for %s on %s (default %s): " prot host
	350	(user-login-name))
	351	nil nil (user-login-name))))
cbabe91f TZ	352	(t
	353	"unknownuser"))))
	354	(if (consp mode) mode (list mode))))
1821a7b4 LMI	355	;; Allow the source to save the data.
	356	(cond
	357	((consp source)
	358	;; Secret Service API -- not implemented.
	359	)
	360	(t
	361	;; netrc interface.
	362	(when (y-or-n-p (format "Do you want to save this password in %s? "
cbabe91f	363	source))
549c9aed G	364	;; the code below is almost same as `netrc-store-data' except
	365	;; the `epa-file-encrypt-to' hack (see bug#7487).
	366	(with-temp-buffer
	367	(when (file-exists-p source)
	368	(insert-file-contents source))
	369	(when auth-source-gpg-encrypt-to
	370	;; making `epa-file-encrypt-to' local to this buffer lets
	371	;; epa-file skip the key selection query (see the
	372	;; `local-variable-p' check in `epa-file-write-region').
bb7f5cbc	373	(unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
549c9aed G	374	(make-local-variable 'epa-file-encrypt-to))
	375	(if (listp auth-source-gpg-encrypt-to)
	376	(setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
	377	(goto-char (point-max))
	378	(unless (bolp)
	379	(insert "\n"))
	380	(insert (format "machine %s login %s password %s port %s\n"
	381	host
	382	(or user (cdr (assoc "login" result)))
	383	(cdr (assoc "password" result))
	384	prot))
	385	(write-region (point-min) (point-max) source nil 'silent)))))
1821a7b4	386	(if (consp mode)
cbabe91f	387	(mapcar #'cdr result)
1821a7b4	388	(cdar result))))
0e4966fb MA	389
	390	(defun auth-source-delete (entry &rest spec)
	391	"Delete credentials according to SPEC in ENTRY."
	392	(let ((host (plist-get spec :host))
cbabe91f TZ	393	(user (plist-get spec :user))
	394	(prot (plist-get spec :protocol))
	395	(source (plist-get entry :source)))
0e4966fb MA	396	(cond
	397	;; Secret Service API.
	398	((consp source)
	399	(let ((coll (auth-get-source entry)))
cbabe91f TZ	400	;; Loop over candidates with a matching host attribute.
	401	(dolist (elt (secrets-search-items coll :host host))
	402	(when (and (or (not user)
	403	(string-equal
	404	user (secrets-get-attribute coll elt :user)))
	405	(or (not prot)
	406	(string-equal
	407	prot (secrets-get-attribute coll elt :protocol))))
	408	(secrets-delete-item coll elt)))))
0e4966fb MA	409	(t)))) ;; netrc not implemented yes.
	410
	411	(defun auth-source-forget-user-or-password
	412	(mode host protocol &optional username)
	413	"Remove cached authentication token."
ed778fad	414	(interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing
0e4966fb MA	415	(remhash
	416	(if username
	417	(format "%s %s:%s %s" mode host protocol username)
	418	(format "%s %s:%s" mode host protocol))
	419	auth-source-cache))
ed778fad	420
3b36c17e MB	421	(defun auth-source-forget-all-cached ()
	422	"Forget all cached auth-source authentication tokens."
	423	(interactive)
	424	(setq auth-source-cache (make-hash-table :test 'equal)))
	425
fb178e4c KY	426	;; (progn
	427	;; (auth-source-forget-all-cached)
	428	;; (list
	429	;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other")
	430	;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "tzz")
	431	;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "joe")))
	432
0e4966fb MA	433	(defun auth-source-user-or-password
0e4966fb MA	434	(mode host protocol &optional username create-missing delete-existing)
3b36c17e	435	"Find MODE (string or list of strings) matching HOST and PROTOCOL.
fb178e4c KY	436
	437	USERNAME is optional and will be used as \"login\" in a search
	438	across the Secret Service API (see secrets.el) if the resulting
	439	items don't have a username. This means that if you search for
	440	username \"joe\" and it matches an item but the item doesn't have
	441	a :user attribute, the username \"joe\" will be returned.
	442
0e4966fb MA	443	A non nil DELETE-EXISTING means deleting any matching password
	444	entry in the respective sources. This is useful only when
	445	CREATE-MISSING is non nil as well; the intended use case is to
	446	remove wrong password entries.
	447
	448	If no matching entry is found, and CREATE-MISSING is non nil,
	449	the password will be retrieved interactively, and it will be
	450	stored in the password database which matches best (see
	451	`auth-sources').
	452
	453	MODE can be \"login\" or \"password\"."
554a69b8	454	(auth-source-do-debug
fb178e4c KY	455	"auth-source-user-or-password: get %s for %s (%s) + user=%s"
fb178e4c KY	456	mode host protocol username)
3b36c17e	457	(let* ((listy (listp mode))
cbabe91f TZ	458	(mode (if listy mode (list mode)))
	459	(cname (if username
	460	(format "%s %s:%s %s" mode host protocol username)
	461	(format "%s %s:%s" mode host protocol)))
	462	(search (list :host host :protocol protocol))
	463	(search (if username (append search (list :user username)) search))
	464	(found (if (not delete-existing)
	465	(gethash cname auth-source-cache)
	466	(remhash cname auth-source-cache)
	467	nil)))
ed778fad	468	(if found
cbabe91f TZ	469	(progn
	470	(auth-source-do-debug
	471	"auth-source-user-or-password: cached %s=%s for %s (%s) + %s"
	472	mode
	473	;; don't show the password
	474	(if (and (member "password" mode) auth-source-hide-passwords)
	475	"SECRET"
	476	found)
	477	host protocol username)
	478	found) ; return the found data
fb178e4c	479	;; else, if not found
0e4966fb	480	(let ((choices (apply 'auth-source-pick search)))
cbabe91f TZ	481	(dolist (choice choices)
	482	(if delete-existing
	483	(apply 'auth-source-delete choice search)
	484	(setq found (apply 'auth-source-retrieve mode choice search)))
	485	(and found (return found)))
	486
	487	;; We haven't found something, so we will create it interactively.
	488	(when (and (not found) create-missing)
	489	(setq found (apply 'auth-source-create
	490	mode (if choices
	491	(car choices)
	492	(car auth-sources))
	493	search)))
	494
	495	;; Cache the result.
	496	(when found
	497	(auth-source-do-debug
	498	"auth-source-user-or-password: found %s=%s for %s (%s) + %s"
	499	mode
	500	;; don't show the password
	501	(if (and (member "password" mode) auth-source-hide-passwords)
	502	"SECRET" found)
	503	host protocol username)
	504	(setq found (if listy found (car-safe found)))
	505	(when auth-source-do-cache
	506	(puthash cname found auth-source-cache)))
	507
	508	found))))
0e4966fb	509
9b3ebcb6 MB	510	(defun auth-source-protocol-defaults (protocol)
	511	"Return a list of default ports and names for PROTOCOL."
	512	(cdr-safe (assoc protocol auth-source-protocols)))
	513
58a67d68 MB	514	(defun auth-source-user-or-password-imap (mode host)
58a67d68 MB	515	(auth-source-user-or-password mode host 'imap))
9b3ebcb6	516
58a67d68 MB	517	(defun auth-source-user-or-password-pop3 (mode host)
58a67d68 MB	518	(auth-source-user-or-password mode host 'pop3))
9b3ebcb6	519
58a67d68 MB	520	(defun auth-source-user-or-password-ssh (mode host)
58a67d68 MB	521	(auth-source-user-or-password mode host 'ssh))
9b3ebcb6	522
58a67d68 MB	523	(defun auth-source-user-or-password-sftp (mode host)
58a67d68 MB	524	(auth-source-user-or-password mode host 'sftp))
9b3ebcb6	525
58a67d68 MB	526	(defun auth-source-user-or-password-smtp (mode host)
58a67d68 MB	527	(auth-source-user-or-password mode host 'smtp))
8f7abae3 MB	528
	529	(provide 'auth-source)
	530
8f7abae3	531	;;; auth-source.el ends here