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