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