cgit.sxemacs.org Git - gnus/blob - lisp/auth-source.el

   1 ;;; auth-source.el --- authentication sources for Gnus and Emacs
   2
   3 ;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  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
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  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.
  29
  30 ;; See the auth.info Info documentation for details.
  31
  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
  40 ;;; Code:
  41
  42 (require 'password-cache)
  43 (require 'mm-util)
  44 (require 'gnus-util)
  45 (require 'assoc)
  46 (eval-when-compile (require 'cl))
  47 (eval-when-compile (require 'dropdown-list nil t))
  48 (eval-and-compile
  49   (or (ignore-errors (require 'eieio))
  50       ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib
  51       (ignore-errors
  52         (let ((load-path (cons (expand-file-name
  53                                 "gnus-fallback-lib/eieio"
  54                                 (file-name-directory (locate-library "gnus")))
  55                                load-path)))
  56           (require 'eieio)))
  57       (error
  58        "eieio not found in `load-path' or gnus-fallback-lib/ directory.")))
  59
  60 (autoload 'secrets-create-item "secrets")
  61 (autoload 'secrets-delete-item "secrets")
  62 (autoload 'secrets-get-alias "secrets")
  63 (autoload 'secrets-get-attributes "secrets")
  64 (autoload 'secrets-get-secret "secrets")
  65 (autoload 'secrets-list-collections "secrets")
  66 (autoload 'secrets-search-items "secrets")
  67
  68 (defvar secrets-enabled)
  69
  70 (defgroup auth-source nil
  71   "Authentication sources."
  72   :version "23.1" ;; No Gnus
  73   :group 'gnus)
  74
  75 ;;;###autoload
  76 (defcustom auth-source-cache-expiry 7200
  77   "How many seconds passwords are cached, or nil to disable
  78 expiring.  Overrides `password-cache-expiry' through a
  79 let-binding."
  80   :group 'auth-source
  81   :type '(choice (const :tag "Never" nil)
  82                  (const :tag "All Day" 86400)
  83                  (const :tag "2 Hours" 7200)
  84                  (const :tag "30 Minutes" 1800)
  85                  (integer :tag "Seconds")))
  86
  87 (defclass auth-source-backend ()
  88   ((type :initarg :type
  89          :initform 'netrc
  90          :type symbol
  91          :custom symbol
  92          :documentation "The backend type.")
  93    (source :initarg :source
  94            :type string
  95            :custom string
  96            :documentation "The backend source.")
  97    (host :initarg :host
  98          :initform t
  99          :type t
 100          :custom string
 101          :documentation "The backend host.")
 102    (user :initarg :user
 103          :initform t
 104          :type t
 105          :custom string
 106          :documentation "The backend user.")
 107    (port :initarg :port
 108          :initform t
 109          :type t
 110          :custom string
 111          :documentation "The backend protocol.")
 112    (create-function :initarg :create-function
 113                     :initform ignore
 114                     :type function
 115                     :custom function
 116                     :documentation "The create function.")
 117    (search-function :initarg :search-function
 118                     :initform ignore
 119                     :type function
 120                     :custom function
 121                     :documentation "The search function.")))
 122
 123 (defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
 124                                    (pop3 "pop3" "pop" "pop3s" "110" "995")
 125                                    (ssh  "ssh" "22")
 126                                    (sftp "sftp" "115")
 127                                    (smtp "smtp" "25"))
 128   "List of authentication protocols and their names"
 129
 130   :group 'auth-source
 131   :version "23.2" ;; No Gnus
 132   :type '(repeat :tag "Authentication Protocols"
 133                  (cons :tag "Protocol Entry"
 134                        (symbol :tag "Protocol")
 135                        (repeat :tag "Names"
 136                                (string :tag "Name")))))
 137
 138 ;;; generate all the protocols in a format Customize can use
 139 ;;; TODO: generate on the fly from auth-source-protocols
 140 (defconst auth-source-protocols-customize
 141   (mapcar (lambda (a)
 142             (let ((p (car-safe a)))
 143               (list 'const
 144                     :tag (upcase (symbol-name p))
 145                     p)))
 146           auth-source-protocols))
 147
 148 (defvar auth-source-creation-defaults nil
 149   "Defaults for creating token values.  Usually let-bound.")
 150
 151 (defvar auth-source-creation-prompts nil
 152   "Default prompts for token values.  Usually let-bound.")
 153
 154 (make-obsolete 'auth-source-hide-passwords nil "Emacs 24.1")
 155
 156 (defcustom auth-source-save-behavior 'ask
 157   "If set, auth-source will respect it for save behavior."
 158   :group 'auth-source
 159   :version "23.2" ;; No Gnus
 160   :type `(choice
 161           :tag "auth-source new token save behavior"
 162           (const :tag "Always save" t)
 163           (const :tag "Never save" nil)
 164           (const :tag "Ask" ask)))
 165
 166 (defvar auth-source-magic "auth-source-magic ")
 167
 168 (defcustom auth-source-do-cache t
 169   "Whether auth-source should cache information with `password-cache'."
 170   :group 'auth-source
 171   :version "23.2" ;; No Gnus
 172   :type `boolean)
 173
 174 (defcustom auth-source-debug nil
 175   "Whether auth-source should log debug messages.
 176
 177 If the value is nil, debug messages are not logged.
 178
 179 If the value is t, debug messages are logged with `message'.  In
 180 that case, your authentication data will be in the clear (except
 181 for passwords).
 182
 183 If the value is a function, debug messages are logged by calling
 184  that function using the same arguments as `message'."
 185   :group 'auth-source
 186   :version "23.2" ;; No Gnus
 187   :type `(choice
 188           :tag "auth-source debugging mode"
 189           (const :tag "Log using `message' to the *Messages* buffer" t)
 190           (const :tag "Log all trivia with `message' to the *Messages* buffer"
 191                  trivia)
 192           (function :tag "Function that takes arguments like `message'")
 193           (const :tag "Don't log anything" nil)))
 194
 195 (defcustom auth-sources '("~/.authinfo.gpg" "~/.authinfo" "~/.netrc")
 196   "List of authentication sources.
 197
 198 The default will get login and password information from
 199 \"~/.authinfo.gpg\", which you should set up with the EPA/EPG
 200 packages to be encrypted.  If that file doesn't exist, it will
 201 try the unencrypted version \"~/.authinfo\" and the famous
 202 \"~/.netrc\" file.
 203
 204 See the auth.info manual for details.
 205
 206 Each entry is the authentication type with optional properties.
 207
 208 It's best to customize this with `M-x customize-variable' because the choices
 209 can get pretty complex."
 210   :group 'auth-source
 211   :version "24.1" ;; No Gnus
 212   :type `(repeat :tag "Authentication Sources"
 213                  (choice
 214                   (string :tag "Just a file")
 215                   (const :tag "Default Secrets API Collection" 'default)
 216                   (const :tag "Login Secrets API Collection" "secrets:Login")
 217                   (const :tag "Temp Secrets API Collection" "secrets:session")
 218                   (list :tag "Source definition"
 219                         (const :format "" :value :source)
 220                         (choice :tag "Authentication backend choice"
 221                                 (string :tag "Authentication Source (file)")
 222                                 (list
 223                                  :tag "Secret Service API/KWallet/GNOME Keyring"
 224                                  (const :format "" :value :secrets)
 225                                  (choice :tag "Collection to use"
 226                                          (string :tag "Collection name")
 227                                          (const :tag "Default" 'default)
 228                                          (const :tag "Login" "Login")
 229                                          (const
 230                                           :tag "Temporary" "session"))))
 231                         (repeat :tag "Extra Parameters" :inline t
 232                                 (choice :tag "Extra parameter"
 233                                         (list
 234                                          :tag "Host"
 235                                          (const :format "" :value :host)
 236                                          (choice :tag "Host (machine) choice"
 237                                                  (const :tag "Any" t)
 238                                                  (regexp
 239                                                   :tag "Regular expression")))
 240                                         (list
 241                                          :tag "Protocol"
 242                                          (const :format "" :value :port)
 243                                          (choice
 244                                           :tag "Protocol"
 245                                           (const :tag "Any" t)
 246                                           ,@auth-source-protocols-customize))
 247                                         (list :tag "User" :inline t
 248                                               (const :format "" :value :user)
 249                                               (choice :tag "Personality/Username"
 250                                                       (const :tag "Any" t)
 251                                                       (string :tag "Name")))))))))
 252
 253 (defcustom auth-source-gpg-encrypt-to t
 254   "List of recipient keys that `authinfo.gpg' encrypted to.
 255 If the value is not a list, symmetric encryption will be used."
 256   :group 'auth-source
 257   :version "24.1" ;; No Gnus
 258   :type '(choice (const :tag "Symmetric encryption" t)
 259                  (repeat :tag "Recipient public keys"
 260                          (string :tag "Recipient public key"))))
 261
 262 ;; temp for debugging
 263 ;; (unintern 'auth-source-protocols)
 264 ;; (unintern 'auth-sources)
 265 ;; (customize-variable 'auth-sources)
 266 ;; (setq auth-sources nil)
 267 ;; (format "%S" auth-sources)
 268 ;; (customize-variable 'auth-source-protocols)
 269 ;; (setq auth-source-protocols nil)
 270 ;; (format "%S" auth-source-protocols)
 271 ;; (auth-source-pick nil :host "a" :port 'imap)
 272 ;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
 273 ;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
 274 ;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
 275 ;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
 276 ;; (auth-source-protocol-defaults 'imap)
 277
 278 ;; (let ((auth-source-debug 'debug)) (auth-source-do-debug "hello"))
 279 ;; (let ((auth-source-debug t)) (auth-source-do-debug "hello"))
 280 ;; (let ((auth-source-debug nil)) (auth-source-do-debug "hello"))
 281 (defun auth-source-do-debug (&rest msg)
 282   (when auth-source-debug
 283     (apply 'auth-source-do-warn msg)))
 284
 285 (defun auth-source-do-trivia (&rest msg)
 286   (when (or (eq auth-source-debug 'trivia)
 287             (functionp auth-source-debug))
 288     (apply 'auth-source-do-warn msg)))
 289
 290 (defun auth-source-do-warn (&rest msg)
 291   (apply
 292     ;; set logger to either the function in auth-source-debug or 'message
 293     ;; note that it will be 'message if auth-source-debug is nil
 294    (if (functionp auth-source-debug)
 295        auth-source-debug
 296      'message)
 297    msg))
 298
 299
 300 ;;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q))
 301 (defun auth-source-read-char-choice (prompt choices)
 302   "Read one of CHOICES by `read-char-choice', or `read-char'.
 303 `dropdown-list' support is disabled because it doesn't work reliably.
 304 Only one of CHOICES will be returned.  The PROMPT is augmented
 305 with \"[a/b/c] \" if CHOICES is '\(?a ?b ?c\)."
 306   (when choices
 307     (let* ((prompt-choices
 308             (apply 'concat (loop for c in choices
 309                                  collect (format "%c/" c))))
 310            (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] "))
 311            (full-prompt (concat prompt prompt-choices))
 312            k)
 313
 314       (while (not (memq k choices))
 315         (setq k (cond
 316                  ((and nil (featurep 'dropdown-list))
 317                   (let* ((blank (fill (copy-sequence prompt) ?.))
 318                          (dlc (cons (format "%s %c" prompt (car choices))
 319                                     (loop for c in (cdr choices)
 320                                           collect (format "%s %c" blank c)))))
 321                     (nth (dropdown-list dlc) choices)))
 322                  ((fboundp 'read-char-choice)
 323                   (read-char-choice full-prompt choices))
 324                  (t (message "%s" full-prompt)
 325                     (setq k (read-char))))))
 326       k)))
 327
 328 ;; (auth-source-pick nil :host "any" :port 'imap :user "joe")
 329 ;; (auth-source-pick t :host "any" :port 'imap :user "joe")
 330 ;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
 331 ;;                   (:source (:secrets "session") :host t :port t :user "joe")
 332 ;;                   (:source (:secrets "Login") :host t :port t)
 333 ;;                   (:source "~/.authinfo.gpg" :host t :port t)))
 334
 335 ;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
 336 ;;                   (:source (:secrets "session") :host t :port t :user "joe")
 337 ;;                   (:source (:secrets "Login") :host t :port t)
 338 ;;                   ))
 339
 340 ;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :port t)))
 341
 342 ;; (auth-source-backend-parse "myfile.gpg")
 343 ;; (auth-source-backend-parse 'default)
 344 ;; (auth-source-backend-parse "secrets:Login")
 345
 346 (defun auth-source-backend-parse (entry)
 347   "Creates an auth-source-backend from an ENTRY in `auth-sources'."
 348   (auth-source-backend-parse-parameters
 349    entry
 350    (cond
 351     ;; take 'default and recurse to get it as a Secrets API default collection
 352     ;; matching any user, host, and protocol
 353     ((eq entry 'default)
 354      (auth-source-backend-parse '(:source (:secrets default))))
 355     ;; take secrets:XYZ and recurse to get it as Secrets API collection "XYZ"
 356     ;; matching any user, host, and protocol
 357     ((and (stringp entry) (string-match "^secrets:\\(.+\\)" entry))
 358      (auth-source-backend-parse `(:source (:secrets ,(match-string 1 entry)))))
 359     ;; take just a file name and recurse to get it as a netrc file
 360     ;; matching any user, host, and protocol
 361     ((stringp entry)
 362      (auth-source-backend-parse `(:source ,entry)))
 363
 364     ;; a file name with parameters
 365     ((stringp (plist-get entry :source))
 366      (auth-source-backend
 367       (plist-get entry :source)
 368       :source (plist-get entry :source)
 369       :type 'netrc
 370       :search-function 'auth-source-netrc-search
 371       :create-function 'auth-source-netrc-create))
 372
 373     ;; the Secrets API.  We require the package, in order to have a
 374     ;; defined value for `secrets-enabled'.
 375     ((and
 376       (not (null (plist-get entry :source))) ; the source must not be nil
 377       (listp (plist-get entry :source))      ; and it must be a list
 378       (require 'secrets nil t)               ; and we must load the Secrets API
 379       secrets-enabled)                       ; and that API must be enabled
 380
 381      ;; the source is either the :secrets key in ENTRY or
 382      ;; if that's missing or nil, it's "session"
 383      (let ((source (or (plist-get (plist-get entry :source) :secrets)
 384                        "session")))
 385
 386        ;; if the source is a symbol, we look for the alias named so,
 387        ;; and if that alias is missing, we use "Login"
 388        (when (symbolp source)
 389          (setq source (or (secrets-get-alias (symbol-name source))
 390                           "Login")))
 391
 392        (if (featurep 'secrets)
 393            (auth-source-backend
 394             (format "Secrets API (%s)" source)
 395             :source source
 396             :type 'secrets
 397             :search-function 'auth-source-secrets-search
 398             :create-function 'auth-source-secrets-create)
 399          (auth-source-do-warn
 400           "auth-source-backend-parse: no Secrets API, ignoring spec: %S" entry)
 401          (auth-source-backend
 402           (format "Ignored Secrets API (%s)" source)
 403           :source ""
 404           :type 'ignore))))
 405
 406     ;; none of them
 407     (t
 408      (auth-source-do-warn
 409       "auth-source-backend-parse: invalid backend spec: %S" entry)
 410      (auth-source-backend
 411       "Empty"
 412       :source ""
 413       :type 'ignore)))))
 414
 415 (defun auth-source-backend-parse-parameters (entry backend)
 416   "Fills in the extra auth-source-backend parameters of ENTRY.
 417 Using the plist ENTRY, get the :host, :port, and :user search
 418 parameters."
 419   (let ((entry (if (stringp entry)
 420                    nil
 421                  entry))
 422         val)
 423     (when (setq val (plist-get entry :host))
 424       (oset backend host val))
 425     (when (setq val (plist-get entry :user))
 426       (oset backend user val))
 427     (when (setq val (plist-get entry :port))
 428       (oset backend port val)))
 429   backend)
 430
 431 ;; (mapcar 'auth-source-backend-parse auth-sources)
 432
 433 (defun* auth-source-search (&rest spec
 434                                   &key type max host user port secret
 435                                   require create delete
 436                                   &allow-other-keys)
 437   "Search or modify authentication backends according to SPEC.
 438
 439 This function parses `auth-sources' for matches of the SPEC
 440 plist.  It can optionally create or update an authentication
 441 token if requested.  A token is just a standard Emacs property
 442 list with a :secret property that can be a function; all the
 443 other properties will always hold scalar values.
 444
 445 Typically the :secret property, if present, contains a password.
 446
 447 Common search keys are :max, :host, :port, and :user.  In
 448 addition, :create specifies how tokens will be or created.
 449 Finally, :type can specify which backend types you want to check.
 450
 451 A string value is always matched literally.  A symbol is matched
 452 as its string value, literally.  All the SPEC values can be
 453 single values (symbol or string) or lists thereof (in which case
 454 any of the search terms matches).
 455
 456 :create t means to create a token if possible.
 457
 458 A new token will be created if no matching tokens were found.
 459 The new token will have only the keys the backend requires.  For
 460 the netrc backend, for instance, that's the user, host, and
 461 port keys.
 462
 463 Here's an example:
 464
 465 \(let ((auth-source-creation-defaults '((user . \"defaultUser\")
 466                                         (A    . \"default A\"))))
 467   (auth-source-search :host \"mine\" :type 'netrc :max 1
 468                       :P \"pppp\" :Q \"qqqq\"
 469                       :create t))
 470
 471 which says:
 472
 473 \"Search for any entry matching host 'mine' in backends of type
 474  'netrc', maximum one result.
 475
 476  Create a new entry if you found none.  The netrc backend will
 477  automatically require host, user, and port.  The host will be
 478  'mine'.  We prompt for the user with default 'defaultUser' and
 479  for the port without a default.  We will not prompt for A, Q,
 480  or P.  The resulting token will only have keys user, host, and
 481  port.\"
 482
 483 :create '(A B C) also means to create a token if possible.
 484
 485 The behavior is like :create t but if the list contains any
 486 parameter, that parameter will be required in the resulting
 487 token.  The value for that parameter will be obtained from the
 488 search parameters or from user input.  If any queries are needed,
 489 the alist `auth-source-creation-defaults' will be checked for the
 490 default value.  If the user, host, or port are missing, the alist
 491 `auth-source-creation-prompts' will be used to look up the
 492 prompts IN THAT ORDER (so the 'user prompt will be queried first,
 493 then 'host, then 'port, and finally 'secret).  Each prompt string
 494 can use %u, %h, and %p to show the user, host, and port.
 495
 496 Here's an example:
 497
 498 \(let ((auth-source-creation-defaults '((user . \"defaultUser\")
 499                                         (A    . \"default A\")))
 500        (auth-source-creation-prompts
 501         '((password . \"Enter IMAP password for %h:%p: \"))))
 502   (auth-source-search :host '(\"nonesuch\" \"twosuch\") :type 'netrc :max 1
 503                       :P \"pppp\" :Q \"qqqq\"
 504                       :create '(A B Q)))
 505
 506 which says:
 507
 508 \"Search for any entry matching host 'nonesuch'
 509  or 'twosuch' in backends of type 'netrc', maximum one result.
 510
 511  Create a new entry if you found none.  The netrc backend will
 512  automatically require host, user, and port.  The host will be
 513  'nonesuch' and Q will be 'qqqq'.  We prompt for the password
 514  with the shown prompt.  We will not prompt for Q.  The resulting
 515  token will have keys user, host, port, A, B, and Q.  It will not
 516  have P with any value, even though P is used in the search to
 517  find only entries that have P set to 'pppp'.\"
 518
 519 When multiple values are specified in the search parameter, the
 520 user is prompted for which one.  So :host (X Y Z) would ask the
 521 user to choose between X, Y, and Z.
 522
 523 This creation can fail if the search was not specific enough to
 524 create a new token (it's up to the backend to decide that).  You
 525 should `catch' the backend-specific error as usual.  Some
 526 backends (netrc, at least) will prompt the user rather than throw
 527 an error.
 528
 529 :require (A B C) means that only results that contain those
 530 tokens will be returned.  Thus for instance requiring :secret
 531 will ensure that any results will actually have a :secret
 532 property.
 533
 534 :delete t means to delete any found entries.  nil by default.
 535 Use `auth-source-delete' in ELisp code instead of calling
 536 `auth-source-search' directly with this parameter.
 537
 538 :type (X Y Z) will check only those backend types.  'netrc and
 539 'secrets are the only ones supported right now.
 540
 541 :max N means to try to return at most N items (defaults to 1).
 542 When 0 the function will return just t or nil to indicate if any
 543 matches were found.  More than N items may be returned, depending
 544 on the search and the backend.
 545
 546 :host (X Y Z) means to match only hosts X, Y, or Z according to
 547 the match rules above.  Defaults to t.
 548
 549 :user (X Y Z) means to match only users X, Y, or Z according to
 550 the match rules above.  Defaults to t.
 551
 552 :port (P Q R) means to match only protocols P, Q, or R.
 553 Defaults to t.
 554
 555 :K (V1 V2 V3) for any other key K will match values V1, V2, or
 556 V3 (note the match rules above).
 557
 558 The return value is a list with at most :max tokens.  Each token
 559 is a plist with keys :backend :host :port :user, plus any other
 560 keys provided by the backend (notably :secret).  But note the
 561 exception for :max 0, which see above.
 562
 563 The token can hold a :save-function key.  If you call that, the
 564 user will be prompted to save the data to the backend.  You can't
 565 request that this should happen right after creation, because
 566 `auth-source-search' has no way of knowing if the token is
 567 actually useful.  So the caller must arrange to call this function.
 568
 569 The token's :secret key can hold a function.  In that case you
 570 must call it to obtain the actual value."
 571   (let* ((backends (mapcar 'auth-source-backend-parse auth-sources))
 572          (max (or max 1))
 573          (ignored-keys '(:require :create :delete :max))
 574          (keys (loop for i below (length spec) by 2
 575                      unless (memq (nth i spec) ignored-keys)
 576                      collect (nth i spec)))
 577          (cached (auth-source-remembered-p spec))
 578          ;; note that we may have cached results but found is still nil
 579          ;; (there were no results from the search)
 580          (found (auth-source-recall spec))
 581          filtered-backends accessor-key backend)
 582
 583     (if (and cached auth-source-do-cache)
 584         (auth-source-do-debug
 585          "auth-source-search: found %d CACHED results matching %S"
 586          (length found) spec)
 587
 588       (assert
 589        (or (eq t create) (listp create)) t
 590        "Invalid auth-source :create parameter (must be t or a list): %s %s")
 591
 592       (assert
 593        (listp require) t
 594        "Invalid auth-source :require parameter (must be a list): %s")
 595
 596       (setq filtered-backends (copy-sequence backends))
 597       (dolist (backend backends)
 598         (dolist (key keys)
 599           ;; ignore invalid slots
 600           (condition-case signal
 601               (unless (eval `(auth-source-search-collection
 602                               (plist-get spec key)
 603                               (oref backend ,key)))
 604                 (setq filtered-backends (delq backend filtered-backends))
 605                 (return))
 606             (invalid-slot-name))))
 607
 608       (auth-source-do-trivia
 609        "auth-source-search: found %d backends matching %S"
 610        (length filtered-backends) spec)
 611
 612       ;; (debug spec "filtered" filtered-backends)
 613       ;; First go through all the backends without :create, so we can
 614       ;; query them all.
 615       (setq found (auth-source-search-backends filtered-backends
 616                                                spec
 617                                                ;; to exit early
 618                                                max
 619                                                ;; create is always nil here
 620                                                nil delete
 621                                                require))
 622
 623       (auth-source-do-debug
 624        "auth-source-search: found %d results (max %d) matching %S"
 625        (length found) max spec)
 626
 627       ;; If we didn't find anything, then we allow the backend(s) to
 628       ;; create the entries.
 629       (when (and create
 630                  (not found))
 631         (setq found (auth-source-search-backends filtered-backends
 632                                                  spec
 633                                                  ;; to exit early
 634                                                  max
 635                                                  create delete
 636                                                  require))
 637         (auth-source-do-debug
 638          "auth-source-search: CREATED %d results (max %d) matching %S"
 639          (length found) max spec))
 640
 641       ;; note we remember the lack of result too, if it's applicable
 642       (when auth-source-do-cache
 643         (auth-source-remember spec found)))
 644
 645       found))
 646
 647 (defun auth-source-search-backends (backends spec max create delete require)
 648   (let (matches)
 649     (dolist (backend backends)
 650       (when (> max (length matches))   ; when we need more matches...
 651         (let* ((bmatches (apply
 652                           (slot-value backend 'search-function)
 653                           :backend backend
 654                           ;; note we're overriding whatever the spec
 655                           ;; has for :require, :create, and :delete
 656                           :require require
 657                           :create create
 658                           :delete delete
 659                           spec)))
 660           (when bmatches
 661             (auth-source-do-trivia
 662              "auth-source-search-backend: got %d (max %d) in %s:%s matching %S"
 663              (length bmatches) max
 664              (slot-value backend :type)
 665              (slot-value backend :source)
 666              spec)
 667             (setq matches (append matches bmatches))))))
 668     matches))
 669
 670 ;;; (auth-source-search :max 1)
 671 ;;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret))
 672 ;;; (auth-source-search :host "nonesuch" :type 'netrc :K 1)
 673 ;;; (auth-source-search :host "nonesuch" :type 'secrets)
 674
 675 (defun* auth-source-delete (&rest spec
 676                                   &key delete
 677                                   &allow-other-keys)
 678   "Delete entries from the authentication backends according to SPEC.
 679 Calls `auth-source-search' with the :delete property in SPEC set to t.
 680 The backend may not actually delete the entries.
 681
 682 Returns the deleted entries."
 683   (auth-source-search (plist-put spec :delete t)))
 684
 685 (defun auth-source-search-collection (collection value)
 686   "Returns t is VALUE is t or COLLECTION is t or contains VALUE."
 687   (when (and (atom collection) (not (eq t collection)))
 688     (setq collection (list collection)))
 689
 690   ;; (debug :collection collection :value value)
 691   (or (eq collection t)
 692       (eq value t)
 693       (equal collection value)
 694       (member value collection)))
 695
 696 (defun auth-source-forget-all-cached ()
 697   "Forget all cached auth-source data."
 698   (interactive)
 699   (loop for sym being the symbols of password-data
 700         ;; when the symbol name starts with auth-source-magic
 701         when (string-match (concat "^" auth-source-magic)
 702                            (symbol-name sym))
 703         ;; remove that key
 704         do (password-cache-remove (symbol-name sym))))
 705
 706 (defun auth-source-remember (spec found)
 707   "Remember FOUND search results for SPEC."
 708   (let ((password-cache-expiry auth-source-cache-expiry))
 709     (password-cache-add
 710      (concat auth-source-magic (format "%S" spec)) found)))
 711
 712 (defun auth-source-recall (spec)
 713   "Recall FOUND search results for SPEC."
 714   (password-read-from-cache
 715    (concat auth-source-magic (format "%S" spec))))
 716
 717 (defun auth-source-remembered-p (spec)
 718   "Check if SPEC is remembered."
 719   (password-in-cache-p
 720    (concat auth-source-magic (format "%S" spec))))
 721
 722 (defun auth-source-forget (spec)
 723   "Forget any cached data matching SPEC exactly.
 724
 725 This is the same SPEC you passed to `auth-source-search'.
 726 Returns t or nil for forgotten or not found."
 727   (password-cache-remove (concat auth-source-magic (format "%S" spec))))
 728
 729 ;;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym))
 730
 731 ;;; (auth-source-remember '(:host "wedd") '(4 5 6))
 732 ;;; (auth-source-remembered-p '(:host "wedd"))
 733 ;;; (auth-source-remember '(:host "xedd") '(1 2 3))
 734 ;;; (auth-source-remembered-p '(:host "xedd"))
 735 ;;; (auth-source-remembered-p '(:host "zedd"))
 736 ;;; (auth-source-recall '(:host "xedd"))
 737 ;;; (auth-source-recall '(:host t))
 738 ;;; (auth-source-forget+ :host t)
 739
 740 (defun* auth-source-forget+ (&rest spec &allow-other-keys)
 741   "Forget any cached data matching SPEC.  Returns forgotten count.
 742
 743 This is not a full `auth-source-search' spec but works similarly.
 744 For instance, \(:host \"myhost\" \"yourhost\") would find all the
 745 cached data that was found with a search for those two hosts,
 746 while \(:host t) would find all host entries."
 747   (let ((count 0)
 748         sname)
 749     (loop for sym being the symbols of password-data
 750           ;; when the symbol name matches with auth-source-magic
 751           when (and (setq sname (symbol-name sym))
 752                     (string-match (concat "^" auth-source-magic "\\(.+\\)")
 753                                   sname)
 754                     ;; and the spec matches what was stored in the cache
 755                     (auth-source-specmatchp spec (read (match-string 1 sname))))
 756           ;; remove that key
 757           do (progn
 758                (password-cache-remove sname)
 759                (incf count)))
 760     count))
 761
 762 (defun auth-source-specmatchp (spec stored)
 763   (let ((keys (loop for i below (length spec) by 2
 764                    collect (nth i spec))))
 765     (not (eq
 766           (dolist (key keys)
 767             (unless (auth-source-search-collection (plist-get stored key)
 768                                                    (plist-get spec key))
 769               (return 'no)))
 770           'no))))
 771
 772 ;;; Backend specific parsing: netrc/authinfo backend
 773
 774 (defun auth-source-ensure-strings (values)
 775   (unless (listp values)
 776     (setq values (list values)))
 777   (mapcar (lambda (value)
 778             (if (numberp value)
 779                 (format "%s" value)
 780               value))
 781           values))
 782
 783 (defvar auth-source-netrc-cache nil)
 784
 785 ;;; (auth-source-netrc-parse "~/.authinfo.gpg")
 786 (defun* auth-source-netrc-parse (&rest
 787                                  spec
 788                                  &key file max host user port delete require
 789                                  &allow-other-keys)
 790   "Parse FILE and return a list of all entries in the file.
 791 Note that the MAX parameter is used so we can exit the parse early."
 792   (if (listp file)
 793       ;; We got already parsed contents; just return it.
 794       file
 795     (when (file-exists-p file)
 796       (setq port (auth-source-ensure-strings port))
 797       (with-temp-buffer
 798         (let* ((tokens '("machine" "host" "default" "login" "user"
 799                          "password" "account" "macdef" "force"
 800                          "port" "protocol"))
 801                (max (or max 5000))       ; sanity check: default to stop at 5K
 802                (modified 0)
 803                (cached (cdr-safe (assoc file auth-source-netrc-cache)))
 804                (cached-mtime (plist-get cached :mtime))
 805                (cached-secrets (plist-get cached :secret))
 806                alist elem result pair)
 807
 808           (if (and (functionp cached-secrets)
 809                    (equal cached-mtime
 810                           (nth 5 (file-attributes file))))
 811               (progn
 812                 (auth-source-do-trivia
 813                  "auth-source-netrc-parse: using CACHED file data for %s"
 814                  file)
 815                 (insert (funcall cached-secrets)))
 816             (insert-file-contents file)
 817             ;; cache all netrc files (used to be just .gpg files)
 818             ;; Store the contents of the file heavily encrypted in memory.
 819             ;; (note for the irony-impaired: they are just obfuscated)
 820             (aput 'auth-source-netrc-cache file
 821                   (list :mtime (nth 5 (file-attributes file))
 822                         :secret (lexical-let ((v (rot13-string
 823                                                   (base64-encode-string
 824                                                    (buffer-string)))))
 825                                   (lambda () (base64-decode-string
 826                                          (rot13-string v)))))))
 827           (goto-char (point-min))
 828           ;; Go through the file, line by line.
 829           (while (and (not (eobp))
 830                       (> max 0))
 831
 832             (narrow-to-region (point) (point-at-eol))
 833             ;; For each line, get the tokens and values.
 834             (while (not (eobp))
 835               (skip-chars-forward "\t ")
 836               ;; Skip lines that begin with a "#".
 837               (if (eq (char-after) ?#)
 838                   (goto-char (point-max))
 839                 (unless (eobp)
 840                   (setq elem
 841                         (if (= (following-char) ?\")
 842                             (read (current-buffer))
 843                           (buffer-substring
 844                            (point) (progn (skip-chars-forward "^\t ")
 845                                           (point)))))
 846                   (cond
 847                    ((equal elem "macdef")
 848                     ;; We skip past the macro definition.
 849                     (widen)
 850                     (while (and (zerop (forward-line 1))
 851                                 (looking-at "$")))
 852                     (narrow-to-region (point) (point)))
 853                    ((member elem tokens)
 854                     ;; Tokens that don't have a following value are ignored,
 855                     ;; except "default".
 856                     (when (and pair (or (cdr pair)
 857                                         (equal (car pair) "default")))
 858                       (push pair alist))
 859                     (setq pair (list elem)))
 860                    (t
 861                     ;; Values that haven't got a preceding token are ignored.
 862                     (when pair
 863                       (setcdr pair elem)
 864                       (push pair alist)
 865                       (setq pair nil)))))))
 866
 867             (when (and alist
 868                        (> max 0)
 869                        (auth-source-search-collection
 870                         host
 871                         (or
 872                          (aget alist "machine")
 873                          (aget alist "host")
 874                          t))
 875                        (auth-source-search-collection
 876                         user
 877                         (or
 878                          (aget alist "login")
 879                          (aget alist "account")
 880                          (aget alist "user")
 881                          t))
 882                        (auth-source-search-collection
 883                         port
 884                         (or
 885                          (aget alist "port")
 886                          (aget alist "protocol")
 887                          t))
 888                        (or
 889                         ;; the required list of keys is nil, or
 890                         (null require)
 891                         ;; every element of require is in the normalized list
 892                         (let ((normalized (nth 0 (auth-source-netrc-normalize
 893                                                  (list alist)))))
 894                           (loop for req in require
 895                                 always (plist-get normalized req)))))
 896               (decf max)
 897               (push (nreverse alist) result)
 898               ;; to delete a line, we just comment it out
 899               (when delete
 900                 (goto-char (point-min))
 901                 (insert "#")
 902                 (incf modified)))
 903             (setq alist nil
 904                   pair nil)
 905             (widen)
 906             (forward-line 1))
 907
 908           (when (< 0 modified)
 909             (when auth-source-gpg-encrypt-to
 910               ;; (see bug#7487) making `epa-file-encrypt-to' local to
 911               ;; this buffer lets epa-file skip the key selection query
 912               ;; (see the `local-variable-p' check in
 913               ;; `epa-file-write-region').
 914               (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
 915                 (make-local-variable 'epa-file-encrypt-to))
 916               (if (listp auth-source-gpg-encrypt-to)
 917                   (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
 918
 919             ;; ask AFTER we've successfully opened the file
 920             (when (y-or-n-p (format "Save file %s? (%d deletions)"
 921                                     file modified))
 922               (write-region (point-min) (point-max) file nil 'silent)
 923               (auth-source-do-debug
 924                "auth-source-netrc-parse: modified %d lines in %s"
 925                modified file)))
 926
 927           (nreverse result))))))
 928
 929 (defun auth-source-netrc-normalize (alist)
 930   (mapcar (lambda (entry)
 931             (let (ret item)
 932               (while (setq item (pop entry))
 933                 (let ((k (car item))
 934                       (v (cdr item)))
 935
 936                   ;; apply key aliases
 937                   (setq k (cond ((member k '("machine")) "host")
 938                                 ((member k '("login" "account")) "user")
 939                                 ((member k '("protocol")) "port")
 940                                 ((member k '("password")) "secret")
 941                                 (t k)))
 942
 943                   ;; send back the secret in a function (lexical binding)
 944                   (when (equal k "secret")
 945                     (setq v (lexical-let ((v v))
 946                               (lambda () v))))
 947
 948                   (setq ret (plist-put ret
 949                                        (intern (concat ":" k))
 950                                        v))
 951                   ))
 952               ret))
 953           alist))
 954
 955 ;;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret))
 956 ;;; (funcall secret)
 957
 958 (defun* auth-source-netrc-search (&rest
 959                                   spec
 960                                   &key backend require create delete
 961                                   type max host user port
 962                                   &allow-other-keys)
 963 "Given a property list SPEC, return search matches from the :backend.
 964 See `auth-source-search' for details on SPEC."
 965   ;; just in case, check that the type is correct (null or same as the backend)
 966   (assert (or (null type) (eq type (oref backend type)))
 967           t "Invalid netrc search: %s %s")
 968
 969   (let ((results (auth-source-netrc-normalize
 970                   (auth-source-netrc-parse
 971                    :max max
 972                    :require require
 973                    :delete delete
 974                    :file (oref backend source)
 975                    :host (or host t)
 976                    :user (or user t)
 977                    :port (or port t)))))
 978
 979     ;; if we need to create an entry AND none were found to match
 980     (when (and create
 981                (not results))
 982
 983       ;; create based on the spec and record the value
 984       (setq results (or
 985                      ;; if the user did not want to create the entry
 986                      ;; in the file, it will be returned
 987                      (apply (slot-value backend 'create-function) spec)
 988                      ;; if not, we do the search again without :create
 989                      ;; to get the updated data.
 990
 991                      ;; the result will be returned, even if the search fails
 992                      (apply 'auth-source-netrc-search
 993                             (plist-put spec :create nil)))))
 994     results))
 995
 996 (defun auth-source-netrc-element-or-first (v)
 997   (if (listp v)
 998       (nth 0 v)
 999     v))
1000
1001 ;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host")))
1002
1003 (defun auth-source-format-prompt (prompt alist)
1004   "Format PROMPT using %x (for any character x) specifiers in ALIST."
1005   (dolist (cell alist)
1006     (let ((c (nth 0 cell))
1007           (v (nth 1 cell)))
1008       (when (and c v)
1009         (setq prompt (replace-regexp-in-string (format "%%%c" c) v prompt)))))
1010   prompt)
1011
1012 ;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
1013 ;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
1014
1015 (defun* auth-source-netrc-create (&rest spec
1016                                         &key backend
1017                                         secret host user port create
1018                                         &allow-other-keys)
1019   (let* ((base-required '(host user port secret))
1020          ;; we know (because of an assertion in auth-source-search) that the
1021          ;; :create parameter is either t or a list (which includes nil)
1022          (create-extra (if (eq t create) nil create))
1023          (required (append base-required create-extra))
1024          (file (oref backend source))
1025          (add "")
1026          ;; `valist' is an alist
1027          valist
1028          ;; `artificial' will be returned if no creation is needed
1029          artificial)
1030
1031     ;; only for base required elements (defined as function parameters):
1032     ;; fill in the valist with whatever data we may have from the search
1033     ;; we complete the first value if it's a list and use the value otherwise
1034     (dolist (br base-required)
1035       (when (symbol-value br)
1036         (let ((br-choice (cond
1037                           ;; all-accepting choice (predicate is t)
1038                           ((eq t (symbol-value br)) nil)
1039                           ;; just the value otherwise
1040                           (t (symbol-value br)))))
1041           (when br-choice
1042             (aput 'valist br br-choice)))))
1043
1044     ;; for extra required elements, see if the spec includes a value for them
1045     (dolist (er create-extra)
1046       (let ((name (concat ":" (symbol-name er)))
1047             (keys (loop for i below (length spec) by 2
1048                         collect (nth i spec))))
1049         (dolist (k keys)
1050           (when (equal (symbol-name k) name)
1051             (aput 'valist er (plist-get spec k))))))
1052
1053     ;; for each required element
1054     (dolist (r required)
1055       (let* ((data (aget valist r))
1056              ;; take the first element if the data is a list
1057              (data (auth-source-netrc-element-or-first data))
1058              ;; this is the default to be offered
1059              (given-default (aget auth-source-creation-defaults r))
1060              ;; the default supplementals are simple:
1061              ;; for the user, try `given-default' and then (user-login-name);
1062              ;; otherwise take `given-default'
1063              (default (cond
1064                        ((and (not given-default) (eq r 'user))
1065                         (user-login-name))
1066                        (t given-default)))
1067              (printable-defaults (list
1068                                   (cons 'user
1069                                         (or
1070                                          (auth-source-netrc-element-or-first
1071                                           (aget valist 'user))
1072                                          (plist-get artificial :user)
1073                                          "[any user]"))
1074                                   (cons 'host
1075                                         (or
1076                                          (auth-source-netrc-element-or-first
1077                                           (aget valist 'host))
1078                                          (plist-get artificial :host)
1079                                          "[any host]"))
1080                                   (cons 'port
1081                                         (or
1082                                          (auth-source-netrc-element-or-first
1083                                           (aget valist 'port))
1084                                          (plist-get artificial :port)
1085                                          "[any port]"))))
1086              (prompt (or (aget auth-source-creation-prompts r)
1087                          (case r
1088                            (secret "%p password for %u@%h: ")
1089                            (user "%p user name for %h: ")
1090                            (host "%p host name for user %u: ")
1091                            (port "%p port for %u@%h: "))
1092                          (format "Enter %s (%%u@%%h:%%p): " r)))
1093              (prompt (auth-source-format-prompt
1094                       prompt
1095                       `((?u ,(aget printable-defaults 'user))
1096                         (?h ,(aget printable-defaults 'host))
1097                         (?p ,(aget printable-defaults 'port))))))
1098
1099         ;; store the data, prompting for the password if needed
1100         (setq data
1101               (cond
1102                ((and (null data) (eq r 'secret))
1103                 ;; special case prompt for passwords
1104                 (read-passwd prompt))
1105                ((null data)
1106                 (read-string prompt default))
1107                (t (or data default))))
1108
1109         (when data
1110           (setq artificial (plist-put artificial
1111                                       (intern (concat ":" (symbol-name r)))
1112                                       (if (eq r 'secret)
1113                                           (lexical-let ((data data))
1114                                             (lambda () data))
1115                                         data))))
1116
1117         ;; when r is not an empty string...
1118         (when (and (stringp data)
1119                    (< 0 (length data)))
1120           ;; this function is not strictly necessary but I think it
1121           ;; makes the code clearer -tzz
1122           (let ((printer (lambda ()
1123                            ;; append the key (the symbol name of r)
1124                            ;; and the value in r
1125                            (format "%s%s %S"
1126                                    ;; prepend a space
1127                                    (if (zerop (length add)) "" " ")
1128                                    ;; remap auth-source tokens to netrc
1129                                    (case r
1130                                      ('user   "login")
1131                                      ('host   "machine")
1132                                      ('secret "password")
1133                                      ('port   "port") ; redundant but clearer
1134                                      (t (symbol-name r)))
1135                                    ;; the value will be printed in %S format
1136                                    data))))
1137             (setq add (concat add (funcall printer)))))))
1138
1139     (plist-put
1140      artificial
1141      :save-function
1142      (lexical-let ((file file)
1143                    (add add))
1144        (lambda () (auth-source-netrc-saver file add))))
1145
1146     (list artificial)))
1147
1148 ;;(funcall (plist-get (nth 0 (auth-source-search :host '("nonesuch") :user "tzz" :port "imap" :create t :max 1)) :save-function))
1149 (defun auth-source-netrc-saver (file add)
1150   "Save a line ADD in FILE, prompting along the way.
1151 Respects `auth-source-save-behavior'."
1152   (with-temp-buffer
1153     (when (file-exists-p file)
1154       (insert-file-contents file))
1155     (when auth-source-gpg-encrypt-to
1156       ;; (see bug#7487) making `epa-file-encrypt-to' local to
1157       ;; this buffer lets epa-file skip the key selection query
1158       ;; (see the `local-variable-p' check in
1159       ;; `epa-file-write-region').
1160       (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
1161         (make-local-variable 'epa-file-encrypt-to))
1162       (if (listp auth-source-gpg-encrypt-to)
1163           (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
1164     ;; we want the new data to be found first, so insert at beginning
1165     (goto-char (point-min))
1166
1167     ;; ask AFTER we've successfully opened the file
1168     (let ((prompt (format "Save auth info to file %s? " file))
1169           (done (not (eq auth-source-save-behavior 'ask)))
1170           (bufname "*auth-source Help*")
1171           k)
1172       (while (not done)
1173         (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??)))
1174         (case k
1175           (?y (setq done t))
1176           (?? (save-excursion
1177                 (with-output-to-temp-buffer bufname
1178                   (princ
1179                    (concat "(y)es, save\n"
1180                            "(n)o but use the info\n"
1181                            "(N)o and don't ask to save again\n"
1182                            "(e)dit the line\n"
1183                            "(?) for help as you can see.\n"))
1184                   (set-buffer standard-output)
1185                   (help-mode))))
1186           (?n (setq add ""
1187                     done t))
1188           (?N (setq add ""
1189                     done t
1190                     auth-source-save-behavior nil))
1191           (?e (setq add (read-string "Line to add: " add)))
1192           (t nil)))
1193
1194       (when (get-buffer-window bufname)
1195         (delete-window (get-buffer-window bufname)))
1196
1197       ;; make sure the info is not saved
1198       (when (null auth-source-save-behavior)
1199         (setq add ""))
1200
1201       (when (< 0 (length add))
1202         (progn
1203           (unless (bolp)
1204             (insert "\n"))
1205           (insert add "\n")
1206           (write-region (point-min) (point-max) file nil 'silent)
1207           (auth-source-do-debug
1208            "auth-source-netrc-create: wrote 1 new line to %s"
1209            file)
1210           (message "Saved new authentication information to %s" file)
1211           nil)))))
1212
1213 ;;; Backend specific parsing: Secrets API backend
1214
1215 ;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t))
1216 ;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t))
1217 ;;; (let ((auth-sources '(default))) (auth-source-search :max 1))
1218 ;;; (let ((auth-sources '(default))) (auth-source-search))
1219 ;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1))
1220 ;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git"))
1221
1222 (defun* auth-source-secrets-search (&rest
1223                                     spec
1224                                     &key backend create delete label
1225                                     type max host user port
1226                                     &allow-other-keys)
1227   "Search the Secrets API; spec is like `auth-source'.
1228
1229 The :label key specifies the item's label.  It is the only key
1230 that can specify a substring.  Any :label value besides a string
1231 will allow any label.
1232
1233 All other search keys must match exactly.  If you need substring
1234 matching, do a wider search and narrow it down yourself.
1235
1236 You'll get back all the properties of the token as a plist.
1237
1238 Here's an example that looks for the first item in the 'Login'
1239 Secrets collection:
1240
1241  \(let ((auth-sources '(\"secrets:Login\")))
1242     (auth-source-search :max 1)
1243
1244 Here's another that looks for the first item in the 'Login'
1245 Secrets collection whose label contains 'gnus':
1246
1247  \(let ((auth-sources '(\"secrets:Login\")))
1248     (auth-source-search :max 1 :label \"gnus\")
1249
1250 And this one looks for the first item in the 'Login' Secrets
1251 collection that's a Google Chrome entry for the git.gnus.org site
1252 authentication tokens:
1253
1254  \(let ((auth-sources '(\"secrets:Login\")))
1255     (auth-source-search :max 1 :signon_realm \"https://git.gnus.org/Git\"))
1256 "
1257
1258   ;; TODO
1259   (assert (not create) nil
1260           "The Secrets API auth-source backend doesn't support creation yet")
1261   ;; TODO
1262   ;; (secrets-delete-item coll elt)
1263   (assert (not delete) nil
1264           "The Secrets API auth-source backend doesn't support deletion yet")
1265
1266   (let* ((coll (oref backend source))
1267          (max (or max 5000))     ; sanity check: default to stop at 5K
1268          (ignored-keys '(:create :delete :max :backend :label))
1269          (search-keys (loop for i below (length spec) by 2
1270                             unless (memq (nth i spec) ignored-keys)
1271                             collect (nth i spec)))
1272          ;; build a search spec without the ignored keys
1273          ;; if a search key is nil or t (match anything), we skip it
1274          (search-spec (apply 'append (mapcar
1275                                       (lambda (k)
1276                                         (if (or (null (plist-get spec k))
1277                                                 (eq t (plist-get spec k)))
1278                                             nil
1279                                           (list k (plist-get spec k))))
1280                               search-keys)))
1281          ;; needed keys (always including host, login, port, and secret)
1282          (returned-keys (mm-delete-duplicates (append
1283                                                '(:host :login :port :secret)
1284                                                search-keys)))
1285          (items (loop for item in (apply 'secrets-search-items coll search-spec)
1286                       unless (and (stringp label)
1287                                   (not (string-match label item)))
1288                       collect item))
1289          ;; TODO: respect max in `secrets-search-items', not after the fact
1290          (items (butlast items (- (length items) max)))
1291          ;; convert the item name to a full plist
1292          (items (mapcar (lambda (item)
1293                           (append
1294                            ;; make an entry for the secret (password) element
1295                            (list
1296                             :secret
1297                             (lexical-let ((v (secrets-get-secret coll item)))
1298                               (lambda () v)))
1299                            ;; rewrite the entry from ((k1 v1) (k2 v2)) to plist
1300                            (apply 'append
1301                                   (mapcar (lambda (entry)
1302                                             (list (car entry) (cdr entry)))
1303                                           (secrets-get-attributes coll item)))))
1304                         items))
1305          ;; ensure each item has each key in `returned-keys'
1306          (items (mapcar (lambda (plist)
1307                           (append
1308                            (apply 'append
1309                                   (mapcar (lambda (req)
1310                                             (if (plist-get plist req)
1311                                                 nil
1312                                               (list req nil)))
1313                                           returned-keys))
1314                            plist))
1315                         items)))
1316     items))
1317
1318 (defun* auth-source-secrets-create (&rest
1319                                     spec
1320                                     &key backend type max host user port
1321                                     &allow-other-keys)
1322   ;; TODO
1323   ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
1324   (debug spec))
1325
1326 ;;; older API
1327
1328 ;;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
1329
1330 ;; deprecate the old interface
1331 (make-obsolete 'auth-source-user-or-password
1332                'auth-source-search "Emacs 24.1")
1333 (make-obsolete 'auth-source-forget-user-or-password
1334                'auth-source-forget "Emacs 24.1")
1335
1336 (defun auth-source-user-or-password
1337   (mode host port &optional username create-missing delete-existing)
1338   "Find MODE (string or list of strings) matching HOST and PORT.
1339
1340 DEPRECATED in favor of `auth-source-search'!
1341
1342 USERNAME is optional and will be used as \"login\" in a search
1343 across the Secret Service API (see secrets.el) if the resulting
1344 items don't have a username.  This means that if you search for
1345 username \"joe\" and it matches an item but the item doesn't have
1346 a :user attribute, the username \"joe\" will be returned.
1347
1348 A non nil DELETE-EXISTING means deleting any matching password
1349 entry in the respective sources.  This is useful only when
1350 CREATE-MISSING is non nil as well; the intended use case is to
1351 remove wrong password entries.
1352
1353 If no matching entry is found, and CREATE-MISSING is non nil,
1354 the password will be retrieved interactively, and it will be
1355 stored in the password database which matches best (see
1356 `auth-sources').
1357
1358 MODE can be \"login\" or \"password\"."
1359   (auth-source-do-debug
1360    "auth-source-user-or-password: DEPRECATED get %s for %s (%s) + user=%s"
1361    mode host port username)
1362
1363   (let* ((listy (listp mode))
1364          (mode (if listy mode (list mode)))
1365          (cname (if username
1366                     (format "%s %s:%s %s" mode host port username)
1367                   (format "%s %s:%s" mode host port)))
1368          (search (list :host host :port port))
1369          (search (if username (append search (list :user username)) search))
1370          (search (if create-missing
1371                      (append search (list :create t))
1372                    search))
1373          (search (if delete-existing
1374                      (append search (list :delete t))
1375                    search))
1376          ;; (found (if (not delete-existing)
1377          ;;            (gethash cname auth-source-cache)
1378          ;;          (remhash cname auth-source-cache)
1379          ;;          nil)))
1380          (found nil))
1381     (if found
1382         (progn
1383           (auth-source-do-debug
1384            "auth-source-user-or-password: DEPRECATED cached %s=%s for %s (%s) + %s"
1385            mode
1386            ;; don't show the password
1387            (if (and (member "password" mode) t)
1388                "SECRET"
1389              found)
1390            host port username)
1391           found)                        ; return the found data
1392       ;; else, if not found, search with a max of 1
1393       (let ((choice (nth 0 (apply 'auth-source-search
1394                                   (append '(:max 1) search)))))
1395         (when choice
1396           (dolist (m mode)
1397             (cond
1398              ((equal "password" m)
1399               (push (if (plist-get choice :secret)
1400                       (funcall (plist-get choice :secret))
1401                     nil) found))
1402              ((equal "login" m)
1403               (push (plist-get choice :user) found)))))
1404         (setq found (nreverse found))
1405         (setq found (if listy found (car-safe found)))))
1406
1407         found))
1408
1409 (provide 'auth-source)
1410
1411 ;;; auth-source.el ends here