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