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