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