lisp/gnus/auth-source.el

   1 ;;; auth-source.el --- authentication sources for Gnus and Emacs
   2
   3 ;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This is the auth-source.el package.  It lets users tell Gnus how to
  26 ;; authenticate in a single place.  Simplicity is the goal.  Instead
  27 ;; of providing 5000 options, we'll stick to simple, easy to
  28 ;; understand options.
  29
  30 ;; See the auth.info Info documentation for details.
  31
  32 ;; TODO:
  33
  34 ;; - never decode the backend file unless it's necessary
  35 ;; - a more generic way to match backends and search backend contents
  36 ;; - absorb netrc.el and simplify it
  37 ;; - protect passwords better
  38 ;; - allow creating and changing netrc lines (not files) e.g. change a password
  39
  40 ;;; Code:
  41
  42 (require 'password-cache)
  43 (require 'mm-util)
  44 (require 'gnus-util)
  45 (require 'assoc)
  46 (require 'epa)
  47 (require 'epg)
  48
  49 (eval-when-compile (require 'cl))
  50 (require 'eieio)
  51
  52 (autoload 'secrets-create-item "secrets")
  53 (autoload 'secrets-delete-item "secrets")
  54 (autoload 'secrets-get-alias "secrets")
  55 (autoload 'secrets-get-attributes "secrets")
  56 (autoload 'secrets-get-secret "secrets")
  57 (autoload 'secrets-list-collections "secrets")
  58 (autoload 'secrets-search-items "secrets")
  59
  60 (autoload 'rfc2104-hash "rfc2104")
  61
  62 (autoload 'plstore-open "plstore")
  63 (autoload 'plstore-find "plstore")
  64 (autoload 'plstore-put "plstore")
  65 (autoload 'plstore-save "plstore")
  66 (autoload 'plstore-get-file "plstore")
  67
  68 (defvar secrets-enabled)
  69
  70 (defgroup auth-source nil
  71   "Authentication sources."
  72   :version "23.1" ;; No Gnus
  73   :group 'gnus)
  74
  75 ;;;###autoload
  76 (defcustom auth-source-cache-expiry 7200
  77   "How many seconds passwords are cached, or nil to disable
  78 expiring.  Overrides `password-cache-expiry' through a
  79 let-binding."
  80   :group 'auth-source
  81   :type '(choice (const :tag "Never" nil)
  82                  (const :tag "All Day" 86400)
  83                  (const :tag "2 Hours" 7200)
  84                  (const :tag "30 Minutes" 1800)
  85                  (integer :tag "Seconds")))
  86
  87 (defclass auth-source-backend ()
  88   ((type :initarg :type
  89          :initform 'netrc
  90          :type symbol
  91          :custom symbol
  92          :documentation "The backend type.")
  93    (source :initarg :source
  94            :type string
  95            :custom string
  96            :documentation "The backend source.")
  97    (host :initarg :host
  98          :initform t
  99          :type t
 100          :custom string
 101          :documentation "The backend host.")
 102    (user :initarg :user
 103          :initform t
 104          :type t
 105          :custom string
 106          :documentation "The backend user.")
 107    (port :initarg :port
 108          :initform t
 109          :type t
 110          :custom string
 111          :documentation "The backend protocol.")
 112    (arg :initarg :arg
 113         :initform nil
 114         :documentation "The backend arg.")
 115    (create-function :initarg :create-function
 116                     :initform ignore
 117                     :type function
 118                     :custom function
 119                     :documentation "The create function.")
 120    (search-function :initarg :search-function
 121                     :initform ignore
 122                     :type function
 123                     :custom function
 124                     :documentation "The search function.")))
 125
 126 (defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
 127                                    (pop3 "pop3" "pop" "pop3s" "110" "995")
 128                                    (ssh  "ssh" "22")
 129                                    (sftp "sftp" "115")
 130                                    (smtp "smtp" "25"))
 131   "List of authentication protocols and their names"
 132
 133   :group 'auth-source
 134   :version "23.2" ;; No Gnus
 135   :type '(repeat :tag "Authentication Protocols"
 136                  (cons :tag "Protocol Entry"
 137                        (symbol :tag "Protocol")
 138                        (repeat :tag "Names"
 139                                (string :tag "Name")))))
 140
 141 ;;; generate all the protocols in a format Customize can use
 142 ;;; TODO: generate on the fly from auth-source-protocols
 143 (defconst auth-source-protocols-customize
 144   (mapcar (lambda (a)
 145             (let ((p (car-safe a)))
 146               (list 'const
 147                     :tag (upcase (symbol-name p))
 148                     p)))
 149           auth-source-protocols))
 150
 151 (defvar auth-source-creation-defaults nil
 152   "Defaults for creating token values.  Usually let-bound.")
 153
 154 (defvar auth-source-creation-prompts nil
 155   "Default prompts for token values.  Usually let-bound.")
 156
 157 (make-obsolete 'auth-source-hide-passwords nil "Emacs 24.1")
 158
 159 (defcustom auth-source-save-behavior 'ask
 160   "If set, auth-source will respect it for save behavior."
 161   :group 'auth-source
 162   :version "23.2" ;; No Gnus
 163   :type `(choice
 164           :tag "auth-source new token save behavior"
 165           (const :tag "Always save" t)
 166           (const :tag "Never save" nil)
 167           (const :tag "Ask" ask)))
 168
 169 ;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car (symbol-value 'epa-file-auto-mode-alist-entry)) "\\.gpg\\'") never) (t gpg)))
 170 ;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
 171
 172 (defcustom auth-source-netrc-use-gpg-tokens 'never
 173   "Set this to tell auth-source when to create GPG password
 174 tokens in netrc files.  It's either an alist or `never'."
 175   :group 'auth-source
 176   :version "23.2" ;; No Gnus
 177   :type `(choice
 178           (const :tag "Always use GPG password tokens" (t gpg))
 179           (const :tag "Never use GPG password tokens" never)
 180           (repeat :tag "Use a lookup list"
 181                   (list
 182                    (choice :tag "Matcher"
 183                            (const :tag "Match anything" t)
 184                            (const :tag "The EPA encrypted file extensions"
 185                                   ,(if (boundp 'epa-file-auto-mode-alist-entry)
 186                                        (car (symbol-value
 187                                              'epa-file-auto-mode-alist-entry))
 188                                      "\\.gpg\\'"))
 189                            (regexp :tag "Regular expression"))
 190                    (choice :tag "What to do"
 191                            (const :tag "Save GPG-encrypted password tokens" gpg)
 192                            (const :tag "Don't encrypt tokens" never))))))
 193
 194 (defvar auth-source-magic "auth-source-magic ")
 195
 196 (defcustom auth-source-do-cache t
 197   "Whether auth-source should cache information with `password-cache'."
 198   :group 'auth-source
 199   :version "23.2" ;; No Gnus
 200   :type `boolean)
 201
 202 (defcustom auth-source-debug nil
 203   "Whether auth-source should log debug messages.
 204
 205 If the value is nil, debug messages are not logged.
 206
 207 If the value is t, debug messages are logged with `message'.  In
 208 that case, your authentication data will be in the clear (except
 209 for passwords).
 210
 211 If the value is a function, debug messages are logged by calling
 212  that function using the same arguments as `message'."
 213   :group 'auth-source
 214   :version "23.2" ;; No Gnus
 215   :type `(choice
 216           :tag "auth-source debugging mode"
 217           (const :tag "Log using `message' to the *Messages* buffer" t)
 218           (const :tag "Log all trivia with `message' to the *Messages* buffer"
 219                  trivia)
 220           (function :tag "Function that takes arguments like `message'")
 221           (const :tag "Don't log anything" nil)))
 222
 223 (defcustom auth-sources '("~/.authinfo" "~/.authinfo.gpg" "~/.netrc")
 224   "List of authentication sources.
 225
 226 The default will get login and password information from
 227 \"~/.authinfo.gpg\", which you should set up with the EPA/EPG
 228 packages to be encrypted.  If that file doesn't exist, it will
 229 try the unencrypted version \"~/.authinfo\" and the famous
 230 \"~/.netrc\" file.
 231
 232 See the auth.info manual for details.
 233
 234 Each entry is the authentication type with optional properties.
 235
 236 It's best to customize this with `M-x customize-variable' because the choices
 237 can get pretty complex."
 238   :group 'auth-source
 239   :version "24.1" ;; No Gnus
 240   :type `(repeat :tag "Authentication Sources"
 241                  (choice
 242                   (string :tag "Just a file")
 243                   (const :tag "Default Secrets API Collection" 'default)
 244                   (const :tag "Login Secrets API Collection" "secrets:Login")
 245                   (const :tag "Temp Secrets API Collection" "secrets:session")
 246                   (list :tag "Source definition"
 247                         (const :format "" :value :source)
 248                         (choice :tag "Authentication backend choice"
 249                                 (string :tag "Authentication Source (file)")
 250                                 (list
 251                                  :tag "Secret Service API/KWallet/GNOME Keyring"
 252                                  (const :format "" :value :secrets)
 253                                  (choice :tag "Collection to use"
 254                                          (string :tag "Collection name")
 255                                          (const :tag "Default" 'default)
 256                                          (const :tag "Login" "Login")
 257                                          (const
 258                                           :tag "Temporary" "session"))))
 259                         (repeat :tag "Extra Parameters" :inline t
 260                                 (choice :tag "Extra parameter"
 261                                         (list
 262                                          :tag "Host"
 263                                          (const :format "" :value :host)
 264                                          (choice :tag "Host (machine) choice"
 265                                                  (const :tag "Any" t)
 266                                                  (regexp
 267                                                   :tag "Regular expression")))
 268                                         (list
 269                                          :tag "Protocol"
 270                                          (const :format "" :value :port)
 271                                          (choice
 272                                           :tag "Protocol"
 273                                           (const :tag "Any" t)
 274                                           ,@auth-source-protocols-customize))
 275                                         (list :tag "User" :inline t
 276                                               (const :format "" :value :user)
 277                                               (choice
 278                                                :tag "Personality/Username"
 279                                                       (const :tag "Any" t)
 280                                                       (string
 281                                                        :tag "Name")))))))))
 282
 283 (defcustom auth-source-gpg-encrypt-to t
 284   "List of recipient keys that `authinfo.gpg' encrypted to.
 285 If the value is not a list, symmetric encryption will be used."
 286   :group 'auth-source
 287   :version "24.1" ;; No Gnus
 288   :type '(choice (const :tag "Symmetric encryption" t)
 289                  (repeat :tag "Recipient public keys"
 290                          (string :tag "Recipient public key"))))
 291
 292 ;; temp for debugging
 293 ;; (unintern 'auth-source-protocols)
 294 ;; (unintern 'auth-sources)
 295 ;; (customize-variable 'auth-sources)
 296 ;; (setq auth-sources nil)
 297 ;; (format "%S" auth-sources)
 298 ;; (customize-variable 'auth-source-protocols)
 299 ;; (setq auth-source-protocols nil)
 300 ;; (format "%S" auth-source-protocols)
 301 ;; (auth-source-pick nil :host "a" :port 'imap)
 302 ;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
 303 ;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
 304 ;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
 305 ;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
 306 ;; (auth-source-protocol-defaults 'imap)
 307
 308 ;; (let ((auth-source-debug 'debug)) (auth-source-do-debug "hello"))
 309 ;; (let ((auth-source-debug t)) (auth-source-do-debug "hello"))
 310 ;; (let ((auth-source-debug nil)) (auth-source-do-debug "hello"))
 311 (defun auth-source-do-debug (&rest msg)
 312   (when auth-source-debug
 313     (apply 'auth-source-do-warn msg)))
 314
 315 (defun auth-source-do-trivia (&rest msg)
 316   (when (or (eq auth-source-debug 'trivia)
 317             (functionp auth-source-debug))
 318     (apply 'auth-source-do-warn msg)))
 319
 320 (defun auth-source-do-warn (&rest msg)
 321   (apply
 322     ;; set logger to either the function in auth-source-debug or 'message
 323     ;; note that it will be 'message if auth-source-debug is nil
 324    (if (functionp auth-source-debug)
 325        auth-source-debug
 326      'message)
 327    msg))
 328
 329
 330 ;;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q))
 331 (defun auth-source-read-char-choice (prompt choices)
 332   "Read one of CHOICES by `read-char-choice', or `read-char'.
 333 `dropdown-list' support is disabled because it doesn't work reliably.
 334 Only one of CHOICES will be returned.  The PROMPT is augmented
 335 with \"[a/b/c] \" if CHOICES is '\(?a ?b ?c\)."
 336   (when choices
 337     (let* ((prompt-choices
 338             (apply 'concat (loop for c in choices
 339                                  collect (format "%c/" c))))
 340            (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] "))
 341            (full-prompt (concat prompt prompt-choices))
 342            k)
 343
 344       (while (not (memq k choices))
 345         (setq k (cond
 346                  ((fboundp 'read-char-choice)
 347                   (read-char-choice full-prompt choices))
 348                  (t (message "%s" full-prompt)
 349                     (setq k (read-char))))))
 350       k)))
 351
 352 ;; (auth-source-pick nil :host "any" :port 'imap :user "joe")
 353 ;; (auth-source-pick t :host "any" :port 'imap :user "joe")
 354 ;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
 355 ;;                   (:source (:secrets "session") :host t :port t :user "joe")
 356 ;;                   (:source (:secrets "Login") :host t :port t)
 357 ;;                   (:source "~/.authinfo.gpg" :host t :port t)))
 358
 359 ;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
 360 ;;                   (:source (:secrets "session") :host t :port t :user "joe")
 361 ;;                   (:source (:secrets "Login") :host t :port t)
 362 ;;                   ))
 363
 364 ;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :port t)))
 365
 366 ;; (auth-source-backend-parse "myfile.gpg")
 367 ;; (auth-source-backend-parse 'default)
 368 ;; (auth-source-backend-parse "secrets:Login")
 369
 370 (defun auth-source-backend-parse (entry)
 371   "Creates an auth-source-backend from an ENTRY in `auth-sources'."
 372   (auth-source-backend-parse-parameters
 373    entry
 374    (cond
 375     ;; take 'default and recurse to get it as a Secrets API default collection
 376     ;; matching any user, host, and protocol
 377     ((eq entry 'default)
 378      (auth-source-backend-parse '(:source (:secrets default))))
 379     ;; take secrets:XYZ and recurse to get it as Secrets API collection "XYZ"
 380     ;; matching any user, host, and protocol
 381     ((and (stringp entry) (string-match "^secrets:\\(.+\\)" entry))
 382      (auth-source-backend-parse `(:source (:secrets ,(match-string 1 entry)))))
 383     ;; take just a file name and recurse to get it as a netrc file
 384     ;; matching any user, host, and protocol
 385     ((stringp entry)
 386      (auth-source-backend-parse `(:source ,entry)))
 387
 388     ;; a file name with parameters
 389     ((stringp (plist-get entry :source))
 390      (if (equal (file-name-extension (plist-get entry :source)) "plist")
 391          (auth-source-backend
 392           (plist-get entry :source)
 393           :source (plist-get entry :source)
 394           :type 'plstore
 395           :search-function 'auth-source-plstore-search
 396           :create-function 'auth-source-plstore-create
 397           :arg (plstore-open (plist-get entry :source)))
 398        (auth-source-backend
 399         (plist-get entry :source)
 400         :source (plist-get entry :source)
 401         :type 'netrc
 402         :search-function 'auth-source-netrc-search
 403         :create-function 'auth-source-netrc-create)))
 404
 405     ;; the Secrets API.  We require the package, in order to have a
 406     ;; defined value for `secrets-enabled'.
 407     ((and
 408       (not (null (plist-get entry :source))) ; the source must not be nil
 409       (listp (plist-get entry :source))      ; and it must be a list
 410       (require 'secrets nil t)               ; and we must load the Secrets API
 411       secrets-enabled)                       ; and that API must be enabled
 412
 413      ;; the source is either the :secrets key in ENTRY or
 414      ;; if that's missing or nil, it's "session"
 415      (let ((source (or (plist-get (plist-get entry :source) :secrets)
 416                        "session")))
 417
 418        ;; if the source is a symbol, we look for the alias named so,
 419        ;; and if that alias is missing, we use "Login"
 420        (when (symbolp source)
 421          (setq source (or (secrets-get-alias (symbol-name source))
 422                           "Login")))
 423
 424        (if (featurep 'secrets)
 425            (auth-source-backend
 426             (format "Secrets API (%s)" source)
 427             :source source
 428             :type 'secrets
 429             :search-function 'auth-source-secrets-search
 430             :create-function 'auth-source-secrets-create)
 431          (auth-source-do-warn
 432           "auth-source-backend-parse: no Secrets API, ignoring spec: %S" entry)
 433          (auth-source-backend
 434           (format "Ignored Secrets API (%s)" source)
 435           :source ""
 436           :type 'ignore))))
 437
 438     ;; none of them
 439     (t
 440      (auth-source-do-warn
 441       "auth-source-backend-parse: invalid backend spec: %S" entry)
 442      (auth-source-backend
 443       "Empty"
 444       :source ""
 445       :type 'ignore)))))
 446
 447 (defun auth-source-backend-parse-parameters (entry backend)
 448   "Fills in the extra auth-source-backend parameters of ENTRY.
 449 Using the plist ENTRY, get the :host, :port, and :user search
 450 parameters."
 451   (let ((entry (if (stringp entry)
 452                    nil
 453                  entry))
 454         val)
 455     (when (setq val (plist-get entry :host))
 456       (oset backend host val))
 457     (when (setq val (plist-get entry :user))
 458       (oset backend user val))
 459     (when (setq val (plist-get entry :port))
 460       (oset backend port val)))
 461   backend)
 462
 463 ;; (mapcar 'auth-source-backend-parse auth-sources)
 464
 465 (defun* auth-source-search (&rest spec
 466                                   &key type max host user port secret
 467                                   require create delete
 468                                   &allow-other-keys)
 469   "Search or modify authentication backends according to SPEC.
 470
 471 This function parses `auth-sources' for matches of the SPEC
 472 plist.  It can optionally create or update an authentication
 473 token if requested.  A token is just a standard Emacs property
 474 list with a :secret property that can be a function; all the
 475 other properties will always hold scalar values.
 476
 477 Typically the :secret property, if present, contains a password.
 478
 479 Common search keys are :max, :host, :port, and :user.  In
 480 addition, :create specifies how tokens will be or created.
 481 Finally, :type can specify which backend types you want to check.
 482
 483 A string value is always matched literally.  A symbol is matched
 484 as its string value, literally.  All the SPEC values can be
 485 single values (symbol or string) or lists thereof (in which case
 486 any of the search terms matches).
 487
 488 :create t means to create a token if possible.
 489
 490 A new token will be created if no matching tokens were found.
 491 The new token will have only the keys the backend requires.  For
 492 the netrc backend, for instance, that's the user, host, and
 493 port keys.
 494
 495 Here's an example:
 496
 497 \(let ((auth-source-creation-defaults '((user . \"defaultUser\")
 498                                         (A    . \"default A\"))))
 499   (auth-source-search :host \"mine\" :type 'netrc :max 1
 500                       :P \"pppp\" :Q \"qqqq\"
 501                       :create t))
 502
 503 which says:
 504
 505 \"Search for any entry matching host 'mine' in backends of type
 506  'netrc', maximum one result.
 507
 508  Create a new entry if you found none.  The netrc backend will
 509  automatically require host, user, and port.  The host will be
 510  'mine'.  We prompt for the user with default 'defaultUser' and
 511  for the port without a default.  We will not prompt for A, Q,
 512  or P.  The resulting token will only have keys user, host, and
 513  port.\"
 514
 515 :create '(A B C) also means to create a token if possible.
 516
 517 The behavior is like :create t but if the list contains any
 518 parameter, that parameter will be required in the resulting
 519 token.  The value for that parameter will be obtained from the
 520 search parameters or from user input.  If any queries are needed,
 521 the alist `auth-source-creation-defaults' will be checked for the
 522 default value.  If the user, host, or port are missing, the alist
 523 `auth-source-creation-prompts' will be used to look up the
 524 prompts IN THAT ORDER (so the 'user prompt will be queried first,
 525 then 'host, then 'port, and finally 'secret).  Each prompt string
 526 can use %u, %h, and %p to show the user, host, and port.
 527
 528 Here's an example:
 529
 530 \(let ((auth-source-creation-defaults '((user . \"defaultUser\")
 531                                         (A    . \"default A\")))
 532        (auth-source-creation-prompts
 533         '((password . \"Enter IMAP password for %h:%p: \"))))
 534   (auth-source-search :host '(\"nonesuch\" \"twosuch\") :type 'netrc :max 1
 535                       :P \"pppp\" :Q \"qqqq\"
 536                       :create '(A B Q)))
 537
 538 which says:
 539
 540 \"Search for any entry matching host 'nonesuch'
 541  or 'twosuch' in backends of type 'netrc', maximum one result.
 542
 543  Create a new entry if you found none.  The netrc backend will
 544  automatically require host, user, and port.  The host will be
 545  'nonesuch' and Q will be 'qqqq'.  We prompt for the password
 546  with the shown prompt.  We will not prompt for Q.  The resulting
 547  token will have keys user, host, port, A, B, and Q.  It will not
 548  have P with any value, even though P is used in the search to
 549  find only entries that have P set to 'pppp'.\"
 550
 551 When multiple values are specified in the search parameter, the
 552 user is prompted for which one.  So :host (X Y Z) would ask the
 553 user to choose between X, Y, and Z.
 554
 555 This creation can fail if the search was not specific enough to
 556 create a new token (it's up to the backend to decide that).  You
 557 should `catch' the backend-specific error as usual.  Some
 558 backends (netrc, at least) will prompt the user rather than throw
 559 an error.
 560
 561 :require (A B C) means that only results that contain those
 562 tokens will be returned.  Thus for instance requiring :secret
 563 will ensure that any results will actually have a :secret
 564 property.
 565
 566 :delete t means to delete any found entries.  nil by default.
 567 Use `auth-source-delete' in ELisp code instead of calling
 568 `auth-source-search' directly with this parameter.
 569
 570 :type (X Y Z) will check only those backend types.  'netrc and
 571 'secrets are the only ones supported right now.
 572
 573 :max N means to try to return at most N items (defaults to 1).
 574 When 0 the function will return just t or nil to indicate if any
 575 matches were found.  More than N items may be returned, depending
 576 on the search and the backend.
 577
 578 :host (X Y Z) means to match only hosts X, Y, or Z according to
 579 the match rules above.  Defaults to t.
 580
 581 :user (X Y Z) means to match only users X, Y, or Z according to
 582 the match rules above.  Defaults to t.
 583
 584 :port (P Q R) means to match only protocols P, Q, or R.
 585 Defaults to t.
 586
 587 :K (V1 V2 V3) for any other key K will match values V1, V2, or
 588 V3 (note the match rules above).
 589
 590 The return value is a list with at most :max tokens.  Each token
 591 is a plist with keys :backend :host :port :user, plus any other
 592 keys provided by the backend (notably :secret).  But note the
 593 exception for :max 0, which see above.
 594
 595 The token can hold a :save-function key.  If you call that, the
 596 user will be prompted to save the data to the backend.  You can't
 597 request that this should happen right after creation, because
 598 `auth-source-search' has no way of knowing if the token is
 599 actually useful.  So the caller must arrange to call this function.
 600
 601 The token's :secret key can hold a function.  In that case you
 602 must call it to obtain the actual value."
 603   (let* ((backends (mapcar 'auth-source-backend-parse auth-sources))
 604          (max (or max 1))
 605          (ignored-keys '(:require :create :delete :max))
 606          (keys (loop for i below (length spec) by 2
 607                      unless (memq (nth i spec) ignored-keys)
 608                      collect (nth i spec)))
 609          (cached (auth-source-remembered-p spec))
 610          ;; note that we may have cached results but found is still nil
 611          ;; (there were no results from the search)
 612          (found (auth-source-recall spec))
 613          filtered-backends accessor-key backend)
 614
 615     (if (and cached auth-source-do-cache)
 616         (auth-source-do-debug
 617          "auth-source-search: found %d CACHED results matching %S"
 618          (length found) spec)
 619
 620       (assert
 621        (or (eq t create) (listp create)) t
 622        "Invalid auth-source :create parameter (must be t or a list): %s %s")
 623
 624       (assert
 625        (listp require) t
 626        "Invalid auth-source :require parameter (must be a list): %s")
 627
 628       (setq filtered-backends (copy-sequence backends))
 629       (dolist (backend backends)
 630         (dolist (key keys)
 631           ;; ignore invalid slots
 632           (condition-case signal
 633               (unless (eval `(auth-source-search-collection
 634                               (plist-get spec key)
 635                               (oref backend ,key)))
 636                 (setq filtered-backends (delq backend filtered-backends))
 637                 (return))
 638             (invalid-slot-name))))
 639
 640       (auth-source-do-trivia
 641        "auth-source-search: found %d backends matching %S"
 642        (length filtered-backends) spec)
 643
 644       ;; (debug spec "filtered" filtered-backends)
 645       ;; First go through all the backends without :create, so we can
 646       ;; query them all.
 647       (setq found (auth-source-search-backends filtered-backends
 648                                                spec
 649                                                ;; to exit early
 650                                                max
 651                                                ;; create is always nil here
 652                                                nil delete
 653                                                require))
 654
 655       (auth-source-do-debug
 656        "auth-source-search: found %d results (max %d) matching %S"
 657        (length found) max spec)
 658
 659       ;; If we didn't find anything, then we allow the backend(s) to
 660       ;; create the entries.
 661       (when (and create
 662                  (not found))
 663         (setq found (auth-source-search-backends filtered-backends
 664                                                  spec
 665                                                  ;; to exit early
 666                                                  max
 667                                                  create delete
 668                                                  require))
 669         (auth-source-do-debug
 670          "auth-source-search: CREATED %d results (max %d) matching %S"
 671          (length found) max spec))
 672
 673       ;; note we remember the lack of result too, if it's applicable
 674       (when auth-source-do-cache
 675         (auth-source-remember spec found)))
 676
 677       found))
 678
 679 (defun auth-source-search-backends (backends spec max create delete require)
 680   (let (matches)
 681     (dolist (backend backends)
 682       (when (> max (length matches))   ; when we need more matches...
 683         (let* ((bmatches (apply
 684                           (slot-value backend 'search-function)
 685                           :backend backend
 686                           ;; note we're overriding whatever the spec
 687                           ;; has for :require, :create, and :delete
 688                           :require require
 689                           :create create
 690                           :delete delete
 691                           spec)))
 692           (when bmatches
 693             (auth-source-do-trivia
 694              "auth-source-search-backend: got %d (max %d) in %s:%s matching %S"
 695              (length bmatches) max
 696              (slot-value backend :type)
 697              (slot-value backend :source)
 698              spec)
 699             (setq matches (append matches bmatches))))))
 700     matches))
 701
 702 ;;; (auth-source-search :max 1)
 703 ;;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret))
 704 ;;; (auth-source-search :host "nonesuch" :type 'netrc :K 1)
 705 ;;; (auth-source-search :host "nonesuch" :type 'secrets)
 706
 707 (defun* auth-source-delete (&rest spec
 708                                   &key delete
 709                                   &allow-other-keys)
 710   "Delete entries from the authentication backends according to SPEC.
 711 Calls `auth-source-search' with the :delete property in SPEC set to t.
 712 The backend may not actually delete the entries.
 713
 714 Returns the deleted entries."
 715   (auth-source-search (plist-put spec :delete t)))
 716
 717 (defun auth-source-search-collection (collection value)
 718   "Returns t is VALUE is t or COLLECTION is t or contains VALUE."
 719   (when (and (atom collection) (not (eq t collection)))
 720     (setq collection (list collection)))
 721
 722   ;; (debug :collection collection :value value)
 723   (or (eq collection t)
 724       (eq value t)
 725       (equal collection value)
 726       (member value collection)))
 727
 728 (defvar auth-source-netrc-cache nil)
 729
 730 (defun auth-source-forget-all-cached ()
 731   "Forget all cached auth-source data."
 732   (interactive)
 733   (loop for sym being the symbols of password-data
 734         ;; when the symbol name starts with auth-source-magic
 735         when (string-match (concat "^" auth-source-magic)
 736                            (symbol-name sym))
 737         ;; remove that key
 738         do (password-cache-remove (symbol-name sym)))
 739   (setq auth-source-netrc-cache nil))
 740
 741 (defun auth-source-remember (spec found)
 742   "Remember FOUND search results for SPEC."
 743   (let ((password-cache-expiry auth-source-cache-expiry))
 744     (password-cache-add
 745      (concat auth-source-magic (format "%S" spec)) found)))
 746
 747 (defun auth-source-recall (spec)
 748   "Recall FOUND search results for SPEC."
 749   (password-read-from-cache
 750    (concat auth-source-magic (format "%S" spec))))
 751
 752 (defun auth-source-remembered-p (spec)
 753   "Check if SPEC is remembered."
 754   (password-in-cache-p
 755    (concat auth-source-magic (format "%S" spec))))
 756
 757 (defun auth-source-forget (spec)
 758   "Forget any cached data matching SPEC exactly.
 759
 760 This is the same SPEC you passed to `auth-source-search'.
 761 Returns t or nil for forgotten or not found."
 762   (password-cache-remove (concat auth-source-magic (format "%S" spec))))
 763
 764 ;;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym))
 765
 766 ;;; (auth-source-remember '(:host "wedd") '(4 5 6))
 767 ;;; (auth-source-remembered-p '(:host "wedd"))
 768 ;;; (auth-source-remember '(:host "xedd") '(1 2 3))
 769 ;;; (auth-source-remembered-p '(:host "xedd"))
 770 ;;; (auth-source-remembered-p '(:host "zedd"))
 771 ;;; (auth-source-recall '(:host "xedd"))
 772 ;;; (auth-source-recall '(:host t))
 773 ;;; (auth-source-forget+ :host t)
 774
 775 (defun* auth-source-forget+ (&rest spec &allow-other-keys)
 776   "Forget any cached data matching SPEC.  Returns forgotten count.
 777
 778 This is not a full `auth-source-search' spec but works similarly.
 779 For instance, \(:host \"myhost\" \"yourhost\") would find all the
 780 cached data that was found with a search for those two hosts,
 781 while \(:host t) would find all host entries."
 782   (let ((count 0)
 783         sname)
 784     (loop for sym being the symbols of password-data
 785           ;; when the symbol name matches with auth-source-magic
 786           when (and (setq sname (symbol-name sym))
 787                     (string-match (concat "^" auth-source-magic "\\(.+\\)")
 788                                   sname)
 789                     ;; and the spec matches what was stored in the cache
 790                     (auth-source-specmatchp spec (read (match-string 1 sname))))
 791           ;; remove that key
 792           do (progn
 793                (password-cache-remove sname)
 794                (incf count)))
 795     count))
 796
 797 (defun auth-source-specmatchp (spec stored)
 798   (let ((keys (loop for i below (length spec) by 2
 799                    collect (nth i spec))))
 800     (not (eq
 801           (dolist (key keys)
 802             (unless (auth-source-search-collection (plist-get stored key)
 803                                                    (plist-get spec key))
 804               (return 'no)))
 805           'no))))
 806
 807 ;;; (auth-source-pick-first-password :host "z.lifelogs.com")
 808 ;;; (auth-source-pick-first-password :port "imap")
 809 (defun auth-source-pick-first-password (&rest spec)
 810   "Pick the first secret found from applying SPEC to `auth-source-search'."
 811   (let* ((result (nth 0 (apply 'auth-source-search (plist-put spec :max 1))))
 812          (secret (plist-get result :secret)))
 813
 814     (if (functionp secret)
 815         (funcall secret)
 816       secret)))
 817
 818 ;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host")))
 819 (defun auth-source-format-prompt (prompt alist)
 820   "Format PROMPT using %x (for any character x) specifiers in ALIST."
 821   (dolist (cell alist)
 822     (let ((c (nth 0 cell))
 823           (v (nth 1 cell)))
 824       (when (and c v)
 825         (setq prompt (replace-regexp-in-string (format "%%%c" c)
 826                                                (format "%s" v)
 827                                                prompt)))))
 828   prompt)
 829
 830 (defun auth-source-ensure-strings (values)
 831   (unless (listp values)
 832     (setq values (list values)))
 833   (mapcar (lambda (value)
 834             (if (numberp value)
 835                 (format "%s" value)
 836               value))
 837           values))
 838
 839 ;;; Backend specific parsing: netrc/authinfo backend
 840
 841 ;;; (auth-source-netrc-parse "~/.authinfo.gpg")
 842 (defun* auth-source-netrc-parse (&rest
 843                                  spec
 844                                  &key file max host user port delete require
 845                                  &allow-other-keys)
 846   "Parse FILE and return a list of all entries in the file.
 847 Note that the MAX parameter is used so we can exit the parse early."
 848   (if (listp file)
 849       ;; We got already parsed contents; just return it.
 850       file
 851     (when (file-exists-p file)
 852       (setq port (auth-source-ensure-strings port))
 853       (with-temp-buffer
 854         (let* ((tokens '("machine" "host" "default" "login" "user"
 855                          "password" "account" "macdef" "force"
 856                          "port" "protocol"))
 857                (max (or max 5000))       ; sanity check: default to stop at 5K
 858                (modified 0)
 859                (cached (cdr-safe (assoc file auth-source-netrc-cache)))
 860                (cached-mtime (plist-get cached :mtime))
 861                (cached-secrets (plist-get cached :secret))
 862                alist elem result pair)
 863
 864           (if (and (functionp cached-secrets)
 865                    (equal cached-mtime
 866                           (nth 5 (file-attributes file))))
 867               (progn
 868                 (auth-source-do-trivia
 869                  "auth-source-netrc-parse: using CACHED file data for %s"
 870                  file)
 871                 (insert (funcall cached-secrets)))
 872             (insert-file-contents file)
 873             ;; cache all netrc files (used to be just .gpg files)
 874             ;; Store the contents of the file heavily encrypted in memory.
 875             ;; (note for the irony-impaired: they are just obfuscated)
 876             (aput 'auth-source-netrc-cache file
 877                   (list :mtime (nth 5 (file-attributes file))
 878                         :secret (lexical-let ((v (rot13-string
 879                                                   (base64-encode-string
 880                                                    (buffer-string)))))
 881                                   (lambda () (base64-decode-string
 882                                          (rot13-string v)))))))
 883           (goto-char (point-min))
 884           ;; Go through the file, line by line.
 885           (while (and (not (eobp))
 886                       (> max 0))
 887
 888             (narrow-to-region (point) (point-at-eol))
 889             ;; For each line, get the tokens and values.
 890             (while (not (eobp))
 891               (skip-chars-forward "\t ")
 892               ;; Skip lines that begin with a "#".
 893               (if (eq (char-after) ?#)
 894                   (goto-char (point-max))
 895                 (unless (eobp)
 896                   (setq elem
 897                         (if (= (following-char) ?\")
 898                             (read (current-buffer))
 899                           (buffer-substring
 900                            (point) (progn (skip-chars-forward "^\t ")
 901                                           (point)))))
 902                   (cond
 903                    ((equal elem "macdef")
 904                     ;; We skip past the macro definition.
 905                     (widen)
 906                     (while (and (zerop (forward-line 1))
 907                                 (looking-at "$")))
 908                     (narrow-to-region (point) (point)))
 909                    ((member elem tokens)
 910                     ;; Tokens that don't have a following value are ignored,
 911                     ;; except "default".
 912                     (when (and pair (or (cdr pair)
 913                                         (equal (car pair) "default")))
 914                       (push pair alist))
 915                     (setq pair (list elem)))
 916                    (t
 917                     ;; Values that haven't got a preceding token are ignored.
 918                     (when pair
 919                       (setcdr pair elem)
 920                       (push pair alist)
 921                       (setq pair nil)))))))
 922
 923             (when (and alist
 924                        (> max 0)
 925                        (auth-source-search-collection
 926                         host
 927                         (or
 928                          (aget alist "machine")
 929                          (aget alist "host")
 930                          t))
 931                        (auth-source-search-collection
 932                         user
 933                         (or
 934                          (aget alist "login")
 935                          (aget alist "account")
 936                          (aget alist "user")
 937                          t))
 938                        (auth-source-search-collection
 939                         port
 940                         (or
 941                          (aget alist "port")
 942                          (aget alist "protocol")
 943                          t))
 944                        (or
 945                         ;; the required list of keys is nil, or
 946                         (null require)
 947                         ;; every element of require is in the normalized list
 948                         (let ((normalized (nth 0 (auth-source-netrc-normalize
 949                                                  (list alist) file))))
 950                           (loop for req in require
 951                                 always (plist-get normalized req)))))
 952               (decf max)
 953               (push (nreverse alist) result)
 954               ;; to delete a line, we just comment it out
 955               (when delete
 956                 (goto-char (point-min))
 957                 (insert "#")
 958                 (incf modified)))
 959             (setq alist nil
 960                   pair nil)
 961             (widen)
 962             (forward-line 1))
 963
 964           (when (< 0 modified)
 965             (when auth-source-gpg-encrypt-to
 966               ;; (see bug#7487) making `epa-file-encrypt-to' local to
 967               ;; this buffer lets epa-file skip the key selection query
 968               ;; (see the `local-variable-p' check in
 969               ;; `epa-file-write-region').
 970               (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
 971                 (make-local-variable 'epa-file-encrypt-to))
 972               (if (listp auth-source-gpg-encrypt-to)
 973                   (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
 974
 975             ;; ask AFTER we've successfully opened the file
 976             (when (y-or-n-p (format "Save file %s? (%d deletions)"
 977                                     file modified))
 978               (write-region (point-min) (point-max) file nil 'silent)
 979               (auth-source-do-debug
 980                "auth-source-netrc-parse: modified %d lines in %s"
 981                modified file)))
 982
 983           (nreverse result))))))
 984
 985 (defvar auth-source-passphrase-alist nil)
 986
 987 (defun auth-source-passphrase-callback-function (context key-id handback
 988                                                          &optional sym-detail)
 989   "Exactly like `epa-passphrase-callback-function' but takes an
 990 extra SYM-DETAIL parameter which will be printed at the end of
 991 the symmetric passphrase prompt, and assumes symmetric
 992 encryption."
 993   (read-passwd
 994    (format "Passphrase for symmetric encryption%s%s: "
 995            ;; Add the file name to the prompt, if any.
 996            (if (stringp handback)
 997                (format " for %s" handback)
 998              "")
 999            (if (stringp sym-detail)
1000                sym-detail
1001              ""))
1002    (eq (epg-context-operation context) 'encrypt)))
1003
1004 (defun auth-source-token-passphrase-callback-function (context key-id file)
1005   (if (eq key-id 'SYM)
1006       (let* ((file (file-truename file))
1007              (entry (assoc file auth-source-passphrase-alist))
1008              passphrase)
1009         ;; return the saved passphrase, calling a function if needed
1010         (or (copy-sequence (if (functionp (cdr entry))
1011                                (funcall (cdr entry))
1012                              (cdr entry)))
1013             (progn
1014               (unless entry
1015                 (setq entry (list file))
1016                 (push entry auth-source-passphrase-alist))
1017               (setq passphrase (auth-source-passphrase-callback-function context
1018                                                                  key-id
1019                                                                  file
1020                                                                  " tokens"))
1021               (setcdr entry (lexical-let ((p (copy-sequence passphrase)))
1022                               (lambda () p)))
1023               passphrase)))
1024     (epa-passphrase-callback-function context key-id file)))
1025
1026 ;; (auth-source-epa-extract-gpg-token "gpg:LS0tLS1CRUdJTiBQR1AgTUVTU0FHRS0tLS0tClZlcnNpb246IEdudVBHIHYxLjQuMTEgKEdOVS9MaW51eCkKCmpBMEVBd01DT25qMjB1ak9rZnRneVI3K21iNm9aZWhuLzRad3cySkdlbnVaKzRpeEswWDY5di9icDI1U1dsQT0KPS9yc2wKLS0tLS1FTkQgUEdQIE1FU1NBR0UtLS0tLQo=" "~/.netrc")
1027 (defun auth-source-epa-extract-gpg-token (secret file)
1028   "Pass either the decoded SECRET or the gpg:BASE64DATA version.
1029 FILE is the file from which we obtained this token."
1030   (when (string-match "^gpg:\\(.+\\)" secret)
1031     (setq secret (base64-decode-string (match-string 1 secret))))
1032   (let ((context (epg-make-context 'OpenPGP))
1033         plain)
1034     (epg-context-set-passphrase-callback
1035      context
1036      (cons #'auth-source-token-passphrase-callback-function
1037            file))
1038     (epg-decrypt-string context secret)))
1039
1040 ;; (insert (auth-source-epa-make-gpg-token "mysecret" "~/.netrc"))
1041 (defun auth-source-epa-make-gpg-token (secret file)
1042   (let ((context (epg-make-context 'OpenPGP))
1043         (pp-escape-newlines nil)
1044         cipher)
1045     (epg-context-set-armor context t)
1046     (epg-context-set-passphrase-callback
1047      context
1048      (cons #'auth-source-token-passphrase-callback-function
1049            file))
1050     (setq cipher (epg-encrypt-string context secret nil))
1051     (with-temp-buffer
1052       (insert cipher)
1053       (base64-encode-region (point-min) (point-max) t)
1054       (concat "gpg:" (buffer-substring-no-properties
1055                       (point-min)
1056                       (point-max))))))
1057
1058 (defun auth-source-netrc-normalize (alist filename)
1059   (mapcar (lambda (entry)
1060             (let (ret item)
1061               (while (setq item (pop entry))
1062                 (let ((k (car item))
1063                       (v (cdr item)))
1064
1065                   ;; apply key aliases
1066                   (setq k (cond ((member k '("machine")) "host")
1067                                 ((member k '("login" "account")) "user")
1068                                 ((member k '("protocol")) "port")
1069                                 ((member k '("password")) "secret")
1070                                 (t k)))
1071
1072                   ;; send back the secret in a function (lexical binding)
1073                   (when (equal k "secret")
1074                     (setq v (lexical-let ((lexv v)
1075                                           (token-decoder nil))
1076                               (when (string-match "^gpg:" lexv)
1077                                 ;; it's a GPG token: create a token decoder
1078                                 ;; which unsets itself once
1079                                 (setq token-decoder
1080                                       (lambda (val)
1081                                         (prog1
1082                                             (auth-source-epa-extract-gpg-token
1083                                              val
1084                                              filename)
1085                                           (setq token-decoder nil)))))
1086                               (lambda ()
1087                                 (when token-decoder
1088                                   (setq lexv (funcall token-decoder lexv)))
1089                                 lexv))))
1090                 (setq ret (plist-put ret
1091                                      (intern (concat ":" k))
1092                                      v))))
1093             ret))
1094   alist))
1095
1096 ;;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret))
1097 ;;; (funcall secret)
1098
1099 (defun* auth-source-netrc-search (&rest
1100                                   spec
1101                                   &key backend require create delete
1102                                   type max host user port
1103                                   &allow-other-keys)
1104 "Given a property list SPEC, return search matches from the :backend.
1105 See `auth-source-search' for details on SPEC."
1106   ;; just in case, check that the type is correct (null or same as the backend)
1107   (assert (or (null type) (eq type (oref backend type)))
1108           t "Invalid netrc search: %s %s")
1109
1110   (let ((results (auth-source-netrc-normalize
1111                   (auth-source-netrc-parse
1112                    :max max
1113                    :require require
1114                    :delete delete
1115                    :file (oref backend source)
1116                    :host (or host t)
1117                    :user (or user t)
1118                    :port (or port t))
1119                   (oref backend source))))
1120
1121     ;; if we need to create an entry AND none were found to match
1122     (when (and create
1123                (not results))
1124
1125       ;; create based on the spec and record the value
1126       (setq results (or
1127                      ;; if the user did not want to create the entry
1128                      ;; in the file, it will be returned
1129                      (apply (slot-value backend 'create-function) spec)
1130                      ;; if not, we do the search again without :create
1131                      ;; to get the updated data.
1132
1133                      ;; the result will be returned, even if the search fails
1134                      (apply 'auth-source-netrc-search
1135                             (plist-put spec :create nil)))))
1136     results))
1137
1138 (defun auth-source-netrc-element-or-first (v)
1139   (if (listp v)
1140       (nth 0 v)
1141     v))
1142
1143 ;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
1144 ;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
1145
1146 (defun* auth-source-netrc-create (&rest spec
1147                                         &key backend
1148                                         secret host user port create
1149                                         &allow-other-keys)
1150   (let* ((base-required '(host user port secret))
1151          ;; we know (because of an assertion in auth-source-search) that the
1152          ;; :create parameter is either t or a list (which includes nil)
1153          (create-extra (if (eq t create) nil create))
1154          (current-data (car (auth-source-search :max 1
1155                                                 :host host
1156                                                 :port port)))
1157          (required (append base-required create-extra))
1158          (file (oref backend source))
1159          (add "")
1160          ;; `valist' is an alist
1161          valist
1162          ;; `artificial' will be returned if no creation is needed
1163          artificial)
1164
1165     ;; only for base required elements (defined as function parameters):
1166     ;; fill in the valist with whatever data we may have from the search
1167     ;; we complete the first value if it's a list and use the value otherwise
1168     (dolist (br base-required)
1169       (when (symbol-value br)
1170         (let ((br-choice (cond
1171                           ;; all-accepting choice (predicate is t)
1172                           ((eq t (symbol-value br)) nil)
1173                           ;; just the value otherwise
1174                           (t (symbol-value br)))))
1175           (when br-choice
1176             (aput 'valist br br-choice)))))
1177
1178     ;; for extra required elements, see if the spec includes a value for them
1179     (dolist (er create-extra)
1180       (let ((name (concat ":" (symbol-name er)))
1181             (keys (loop for i below (length spec) by 2
1182                         collect (nth i spec))))
1183         (dolist (k keys)
1184           (when (equal (symbol-name k) name)
1185             (aput 'valist er (plist-get spec k))))))
1186
1187     ;; for each required element
1188     (dolist (r required)
1189       (let* ((data (aget valist r))
1190              ;; take the first element if the data is a list
1191              (data (or (auth-source-netrc-element-or-first data)
1192                        (plist-get current-data
1193                                   (intern (format ":%s" r) obarray))))
1194              ;; this is the default to be offered
1195              (given-default (aget auth-source-creation-defaults r))
1196              ;; the default supplementals are simple:
1197              ;; for the user, try `given-default' and then (user-login-name);
1198              ;; otherwise take `given-default'
1199              (default (cond
1200                        ((and (not given-default) (eq r 'user))
1201                         (user-login-name))
1202                        (t given-default)))
1203              (printable-defaults (list
1204                                   (cons 'user
1205                                         (or
1206                                          (auth-source-netrc-element-or-first
1207                                           (aget valist 'user))
1208                                          (plist-get artificial :user)
1209                                          "[any user]"))
1210                                   (cons 'host
1211                                         (or
1212                                          (auth-source-netrc-element-or-first
1213                                           (aget valist 'host))
1214                                          (plist-get artificial :host)
1215                                          "[any host]"))
1216                                   (cons 'port
1217                                         (or
1218                                          (auth-source-netrc-element-or-first
1219                                           (aget valist 'port))
1220                                          (plist-get artificial :port)
1221                                          "[any port]"))))
1222              (prompt (or (aget auth-source-creation-prompts r)
1223                          (case r
1224                            (secret "%p password for %u@%h: ")
1225                            (user "%p user name for %h: ")
1226                            (host "%p host name for user %u: ")
1227                            (port "%p port for %u@%h: "))
1228                          (format "Enter %s (%%u@%%h:%%p): " r)))
1229              (prompt (auth-source-format-prompt
1230                       prompt
1231                       `((?u ,(aget printable-defaults 'user))
1232                         (?h ,(aget printable-defaults 'host))
1233                         (?p ,(aget printable-defaults 'port))))))
1234
1235         ;; Store the data, prompting for the password if needed.
1236         (setq data
1237               (cond
1238                ((and (null data) (eq r 'secret))
1239                 ;; Special case prompt for passwords.
1240 ;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car (symbol-value 'epa-file-auto-mode-alist-entry)) "\\.gpg\\'") nil) (t gpg)))
1241 ;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
1242                 (let* ((ep (format "Use GPG password tokens in %s?" file))
1243                        (gpg-encrypt
1244                         (cond
1245                          ((eq auth-source-netrc-use-gpg-tokens 'never)
1246                           'never)
1247                          ((listp auth-source-netrc-use-gpg-tokens)
1248                           (let ((check (copy-sequence
1249                                         auth-source-netrc-use-gpg-tokens))
1250                                 item ret)
1251                             (while check
1252                               (setq item (pop check))
1253                               (when (or (eq (car item) t)
1254                                         (string-match (car item) file))
1255                                 (setq ret (cdr item))
1256                                 (setq check nil)))))
1257                          (t 'never)))
1258                         (plain (read-passwd prompt)))
1259                   ;; ask if we don't know what to do (in which case
1260                   ;; auth-source-netrc-use-gpg-tokens must be a list)
1261                   (unless gpg-encrypt
1262                     (setq gpg-encrypt (if (y-or-n-p ep) 'gpg 'never))
1263                     ;; TODO: save the defcustom now? or ask?
1264                     (setq auth-source-netrc-use-gpg-tokens
1265                           (cons `(,file ,gpg-encrypt)
1266                                 auth-source-netrc-use-gpg-tokens)))
1267                   (if (eq gpg-encrypt 'gpg)
1268                       (auth-source-epa-make-gpg-token plain file)
1269                     plain)))
1270                ((null data)
1271                 (when default
1272                   (setq prompt
1273                         (if (string-match ": *\\'" prompt)
1274                             (concat (substring prompt 0 (match-beginning 0))
1275                                     " (default " default "): ")
1276                           (concat prompt "(default " default ") "))))
1277                 (read-string prompt nil nil default))
1278                (t (or data default))))
1279
1280         (when data
1281           (setq artificial (plist-put artificial
1282                                       (intern (concat ":" (symbol-name r)))
1283                                       (if (eq r 'secret)
1284                                           (lexical-let ((data data))
1285                                             (lambda () data))
1286                                         data))))
1287
1288         ;; When r is not an empty string...
1289         (when (and (stringp data)
1290                    (< 0 (length data)))
1291           ;; this function is not strictly necessary but I think it
1292           ;; makes the code clearer -tzz
1293           (let ((printer (lambda ()
1294                            ;; append the key (the symbol name of r)
1295                            ;; and the value in r
1296                            (format "%s%s %s"
1297                                    ;; prepend a space
1298                                    (if (zerop (length add)) "" " ")
1299                                    ;; remap auth-source tokens to netrc
1300                                    (case r
1301                                      (user   "login")
1302                                      (host   "machine")
1303                                      (secret "password")
1304                                      (port   "port") ; redundant but clearer
1305                                      (t (symbol-name r)))
1306                                    (if (string-match "[\" ]" data)
1307                                        (format "%S" data)
1308                                      data)))))
1309             (setq add (concat add (funcall printer)))))))
1310
1311     (plist-put
1312      artificial
1313      :save-function
1314      (lexical-let ((file file)
1315                    (add add))
1316        (lambda () (auth-source-netrc-saver file add))))
1317
1318     (list artificial)))
1319
1320 ;;(funcall (plist-get (nth 0 (auth-source-search :host '("nonesuch2") :user "tzz" :port "imap" :create t :max 1)) :save-function))
1321 (defun auth-source-netrc-saver (file add)
1322   "Save a line ADD in FILE, prompting along the way.
1323 Respects `auth-source-save-behavior'.  Uses
1324 `auth-source-netrc-cache' to avoid prompting more than once."
1325   (let* ((key (format "%s %s" file (rfc2104-hash 'md5 64 16 file add)))
1326          (cached (assoc key auth-source-netrc-cache)))
1327
1328     (if cached
1329         (auth-source-do-trivia
1330          "auth-source-netrc-saver: found previous run for key %s, returning"
1331          key)
1332       (with-temp-buffer
1333         (when (file-exists-p file)
1334           (insert-file-contents file))
1335         (when auth-source-gpg-encrypt-to
1336           ;; (see bug#7487) making `epa-file-encrypt-to' local to
1337           ;; this buffer lets epa-file skip the key selection query
1338           ;; (see the `local-variable-p' check in
1339           ;; `epa-file-write-region').
1340           (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
1341             (make-local-variable 'epa-file-encrypt-to))
1342           (if (listp auth-source-gpg-encrypt-to)
1343               (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
1344         ;; we want the new data to be found first, so insert at beginning
1345         (goto-char (point-min))
1346
1347         ;; Ask AFTER we've successfully opened the file.
1348         (let ((prompt (format "Save auth info to file %s? " file))
1349               (done (not (eq auth-source-save-behavior 'ask)))
1350               (bufname "*auth-source Help*")
1351               k)
1352           (while (not done)
1353             (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??)))
1354             (case k
1355               (?y (setq done t))
1356               (?? (save-excursion
1357                     (with-output-to-temp-buffer bufname
1358                       (princ
1359                        (concat "(y)es, save\n"
1360                                "(n)o but use the info\n"
1361                                "(N)o and don't ask to save again\n"
1362                                "(e)dit the line\n"
1363                                "(?) for help as you can see.\n"))
1364                       ;; Why?  Doesn't with-output-to-temp-buffer already do
1365                       ;; the exact same thing anyway?  --Stef
1366                       (set-buffer standard-output)
1367                       (help-mode))))
1368               (?n (setq add ""
1369                         done t))
1370               (?N
1371                (setq add ""
1372                      done t)
1373                (customize-save-variable 'auth-source-save-behavior nil))
1374               (?e (setq add (read-string "Line to add: " add)))
1375               (t nil)))
1376
1377           (when (get-buffer-window bufname)
1378             (delete-window (get-buffer-window bufname)))
1379
1380           ;; Make sure the info is not saved.
1381           (when (null auth-source-save-behavior)
1382             (setq add ""))
1383
1384           (when (< 0 (length add))
1385             (progn
1386               (unless (bolp)
1387                 (insert "\n"))
1388               (insert add "\n")
1389               (write-region (point-min) (point-max) file nil 'silent)
1390               (auth-source-do-debug
1391                "auth-source-netrc-create: wrote 1 new line to %s"
1392                file)
1393               (message "Saved new authentication information to %s" file)
1394               nil))))
1395       (aput 'auth-source-netrc-cache key "ran"))))
1396
1397 ;;; Backend specific parsing: Secrets API backend
1398
1399 ;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t))
1400 ;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t))
1401 ;;; (let ((auth-sources '(default))) (auth-source-search :max 1))
1402 ;;; (let ((auth-sources '(default))) (auth-source-search))
1403 ;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1))
1404 ;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git"))
1405
1406 (defun* auth-source-secrets-search (&rest
1407                                     spec
1408                                     &key backend create delete label
1409                                     type max host user port
1410                                     &allow-other-keys)
1411   "Search the Secrets API; spec is like `auth-source'.
1412
1413 The :label key specifies the item's label.  It is the only key
1414 that can specify a substring.  Any :label value besides a string
1415 will allow any label.
1416
1417 All other search keys must match exactly.  If you need substring
1418 matching, do a wider search and narrow it down yourself.
1419
1420 You'll get back all the properties of the token as a plist.
1421
1422 Here's an example that looks for the first item in the 'Login'
1423 Secrets collection:
1424
1425  \(let ((auth-sources '(\"secrets:Login\")))
1426     (auth-source-search :max 1)
1427
1428 Here's another that looks for the first item in the 'Login'
1429 Secrets collection whose label contains 'gnus':
1430
1431  \(let ((auth-sources '(\"secrets:Login\")))
1432     (auth-source-search :max 1 :label \"gnus\")
1433
1434 And this one looks for the first item in the 'Login' Secrets
1435 collection that's a Google Chrome entry for the git.gnus.org site
1436 authentication tokens:
1437
1438  \(let ((auth-sources '(\"secrets:Login\")))
1439     (auth-source-search :max 1 :signon_realm \"https://git.gnus.org/Git\"))
1440 "
1441
1442   ;; TODO
1443   (assert (not create) nil
1444           "The Secrets API auth-source backend doesn't support creation yet")
1445   ;; TODO
1446   ;; (secrets-delete-item coll elt)
1447   (assert (not delete) nil
1448           "The Secrets API auth-source backend doesn't support deletion yet")
1449
1450   (let* ((coll (oref backend source))
1451          (max (or max 5000))     ; sanity check: default to stop at 5K
1452          (ignored-keys '(:create :delete :max :backend :label))
1453          (search-keys (loop for i below (length spec) by 2
1454                             unless (memq (nth i spec) ignored-keys)
1455                             collect (nth i spec)))
1456          ;; build a search spec without the ignored keys
1457          ;; if a search key is nil or t (match anything), we skip it
1458          (search-spec (apply 'append (mapcar
1459                                       (lambda (k)
1460                                         (if (or (null (plist-get spec k))
1461                                                 (eq t (plist-get spec k)))
1462                                             nil
1463                                           (list k (plist-get spec k))))
1464                               search-keys)))
1465          ;; needed keys (always including host, login, port, and secret)
1466          (returned-keys (mm-delete-duplicates (append
1467                                                '(:host :login :port :secret)
1468                                                search-keys)))
1469          (items (loop for item in (apply 'secrets-search-items coll search-spec)
1470                       unless (and (stringp label)
1471                                   (not (string-match label item)))
1472                       collect item))
1473          ;; TODO: respect max in `secrets-search-items', not after the fact
1474          (items (butlast items (- (length items) max)))
1475          ;; convert the item name to a full plist
1476          (items (mapcar (lambda (item)
1477                           (append
1478                            ;; make an entry for the secret (password) element
1479                            (list
1480                             :secret
1481                             (lexical-let ((v (secrets-get-secret coll item)))
1482                               (lambda () v)))
1483                            ;; rewrite the entry from ((k1 v1) (k2 v2)) to plist
1484                            (apply 'append
1485                                   (mapcar (lambda (entry)
1486                                             (list (car entry) (cdr entry)))
1487                                           (secrets-get-attributes coll item)))))
1488                         items))
1489          ;; ensure each item has each key in `returned-keys'
1490          (items (mapcar (lambda (plist)
1491                           (append
1492                            (apply 'append
1493                                   (mapcar (lambda (req)
1494                                             (if (plist-get plist req)
1495                                                 nil
1496                                               (list req nil)))
1497                                           returned-keys))
1498                            plist))
1499                         items)))
1500     items))
1501
1502 (defun* auth-source-secrets-create (&rest
1503                                     spec
1504                                     &key backend type max host user port
1505                                     &allow-other-keys)
1506   ;; TODO
1507   ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
1508   (debug spec))
1509
1510 ;;; Backend specific parsing: PLSTORE backend
1511
1512 (defun* auth-source-plstore-search (&rest
1513                                     spec
1514                                     &key backend create delete label
1515                                     type max host user port
1516                                     &allow-other-keys)
1517   "Search the PLSTORE; spec is like `auth-source'."
1518
1519   ;; TODO
1520   (assert (not delete) nil
1521           "The PLSTORE auth-source backend doesn't support deletion yet")
1522
1523   (let* ((store (oref backend arg))
1524          (max (or max 5000))     ; sanity check: default to stop at 5K
1525          (ignored-keys '(:create :delete :max :backend :require))
1526          (search-keys (loop for i below (length spec) by 2
1527                             unless (memq (nth i spec) ignored-keys)
1528                             collect (nth i spec)))
1529          ;; build a search spec without the ignored keys
1530          ;; if a search key is nil or t (match anything), we skip it
1531          (search-spec (apply 'append (mapcar
1532                                       (lambda (k)
1533                                         (let ((v (plist-get spec k)))
1534                                           (if (or (null v)
1535                                                   (eq t v))
1536                                               nil
1537                                             (if (stringp v)
1538                                                 (setq v (list v)))
1539                                             (list k v))))
1540                                       search-keys)))
1541          ;; needed keys (always including host, login, port, and secret)
1542          (returned-keys (mm-delete-duplicates (append
1543                                                '(:host :login :port :secret)
1544                                                search-keys)))
1545          (items (plstore-find store search-spec))
1546          (items (butlast items (- (length items) max)))
1547          ;; convert the item to a full plist
1548          (items (mapcar (lambda (item)
1549                           (let* ((plist (copy-tree (cdr item)))
1550                                  (secret (plist-member plist :secret)))
1551                             (if secret
1552                                 (setcar
1553                                  (cdr secret)
1554                                  (lexical-let ((v (car (cdr secret))))
1555                                    (lambda () v))))
1556                             plist))
1557                         items))
1558          ;; ensure each item has each key in `returned-keys'
1559          (items (mapcar (lambda (plist)
1560                           (append
1561                            (apply 'append
1562                                   (mapcar (lambda (req)
1563                                             (if (plist-get plist req)
1564                                                 nil
1565                                               (list req nil)))
1566                                           returned-keys))
1567                            plist))
1568                         items)))
1569     ;; if we need to create an entry AND none were found to match
1570     (when (and create
1571                (not items))
1572
1573       ;; create based on the spec and record the value
1574       (setq items (or
1575                      ;; if the user did not want to create the entry
1576                      ;; in the file, it will be returned
1577                      (apply (slot-value backend 'create-function) spec)
1578                      ;; if not, we do the search again without :create
1579                      ;; to get the updated data.
1580
1581                      ;; the result will be returned, even if the search fails
1582                      (apply 'auth-source-plstore-search
1583                             (plist-put spec :create nil)))))
1584     items))
1585
1586 (defun* auth-source-plstore-create (&rest spec
1587                                           &key backend
1588                                           secret host user port create
1589                                           &allow-other-keys)
1590   (let* ((base-required '(host user port secret))
1591          (base-secret '(secret))
1592          ;; we know (because of an assertion in auth-source-search) that the
1593          ;; :create parameter is either t or a list (which includes nil)
1594          (create-extra (if (eq t create) nil create))
1595          (current-data (car (auth-source-search :max 1
1596                                                 :host host
1597                                                 :port port)))
1598          (required (append base-required create-extra))
1599          (file (oref backend source))
1600          (add "")
1601          ;; `valist' is an alist
1602          valist
1603          ;; `artificial' will be returned if no creation is needed
1604          artificial
1605          secret-artificial)
1606
1607     ;; only for base required elements (defined as function parameters):
1608     ;; fill in the valist with whatever data we may have from the search
1609     ;; we complete the first value if it's a list and use the value otherwise
1610     (dolist (br base-required)
1611       (when (symbol-value br)
1612         (let ((br-choice (cond
1613                           ;; all-accepting choice (predicate is t)
1614                           ((eq t (symbol-value br)) nil)
1615                           ;; just the value otherwise
1616                           (t (symbol-value br)))))
1617           (when br-choice
1618             (aput 'valist br br-choice)))))
1619
1620     ;; for extra required elements, see if the spec includes a value for them
1621     (dolist (er create-extra)
1622       (let ((name (concat ":" (symbol-name er)))
1623             (keys (loop for i below (length spec) by 2
1624                         collect (nth i spec))))
1625         (dolist (k keys)
1626           (when (equal (symbol-name k) name)
1627             (aput 'valist er (plist-get spec k))))))
1628
1629     ;; for each required element
1630     (dolist (r required)
1631       (let* ((data (aget valist r))
1632              ;; take the first element if the data is a list
1633              (data (or (auth-source-netrc-element-or-first data)
1634                        (plist-get current-data
1635                                   (intern (format ":%s" r) obarray))))
1636              ;; this is the default to be offered
1637              (given-default (aget auth-source-creation-defaults r))
1638              ;; the default supplementals are simple:
1639              ;; for the user, try `given-default' and then (user-login-name);
1640              ;; otherwise take `given-default'
1641              (default (cond
1642                        ((and (not given-default) (eq r 'user))
1643                         (user-login-name))
1644                        (t given-default)))
1645              (printable-defaults (list
1646                                   (cons 'user
1647                                         (or
1648                                          (auth-source-netrc-element-or-first
1649                                           (aget valist 'user))
1650                                          (plist-get artificial :user)
1651                                          "[any user]"))
1652                                   (cons 'host
1653                                         (or
1654                                          (auth-source-netrc-element-or-first
1655                                           (aget valist 'host))
1656                                          (plist-get artificial :host)
1657                                          "[any host]"))
1658                                   (cons 'port
1659                                         (or
1660                                          (auth-source-netrc-element-or-first
1661                                           (aget valist 'port))
1662                                          (plist-get artificial :port)
1663                                          "[any port]"))))
1664              (prompt (or (aget auth-source-creation-prompts r)
1665                          (case r
1666                            (secret "%p password for %u@%h: ")
1667                            (user "%p user name for %h: ")
1668                            (host "%p host name for user %u: ")
1669                            (port "%p port for %u@%h: "))
1670                          (format "Enter %s (%%u@%%h:%%p): " r)))
1671              (prompt (auth-source-format-prompt
1672                       prompt
1673                       `((?u ,(aget printable-defaults 'user))
1674                         (?h ,(aget printable-defaults 'host))
1675                         (?p ,(aget printable-defaults 'port))))))
1676
1677         ;; Store the data, prompting for the password if needed.
1678         (setq data
1679               (cond
1680                ((and (null data) (eq r 'secret))
1681                 ;; Special case prompt for passwords.
1682                 (read-passwd prompt))
1683                ((null data)
1684                 (when default
1685                   (setq prompt
1686                         (if (string-match ": *\\'" prompt)
1687                             (concat (substring prompt 0 (match-beginning 0))
1688                                     " (default " default "): ")
1689                           (concat prompt "(default " default ") "))))
1690                 (read-string prompt nil nil default))
1691                (t (or data default))))
1692
1693         (when data
1694           (if (member r base-secret)
1695               (setq secret-artificial
1696                     (plist-put secret-artificial
1697                                (intern (concat ":" (symbol-name r)))
1698                                data))
1699             (setq artificial (plist-put artificial
1700                                         (intern (concat ":" (symbol-name r)))
1701                                         data))))))
1702     (plstore-put (oref backend arg)
1703                  (sha1 (format "%s@%s:%s"
1704                                (plist-get artificial :user)
1705                                (plist-get artificial :host)
1706                                (plist-get artificial :port)))
1707                  artificial secret-artificial)
1708     (if (y-or-n-p (format "Save auth info to file %s? "
1709                           (plstore-get-file (oref backend arg))))
1710         (plstore-save (oref backend arg)))))
1711
1712 ;;; older API
1713
1714 ;;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
1715
1716 ;; deprecate the old interface
1717 (make-obsolete 'auth-source-user-or-password
1718                'auth-source-search "Emacs 24.1")
1719 (make-obsolete 'auth-source-forget-user-or-password
1720                'auth-source-forget "Emacs 24.1")
1721
1722 (defun auth-source-user-or-password
1723   (mode host port &optional username create-missing delete-existing)
1724   "Find MODE (string or list of strings) matching HOST and PORT.
1725
1726 DEPRECATED in favor of `auth-source-search'!
1727
1728 USERNAME is optional and will be used as \"login\" in a search
1729 across the Secret Service API (see secrets.el) if the resulting
1730 items don't have a username.  This means that if you search for
1731 username \"joe\" and it matches an item but the item doesn't have
1732 a :user attribute, the username \"joe\" will be returned.
1733
1734 A non nil DELETE-EXISTING means deleting any matching password
1735 entry in the respective sources.  This is useful only when
1736 CREATE-MISSING is non nil as well; the intended use case is to
1737 remove wrong password entries.
1738
1739 If no matching entry is found, and CREATE-MISSING is non nil,
1740 the password will be retrieved interactively, and it will be
1741 stored in the password database which matches best (see
1742 `auth-sources').
1743
1744 MODE can be \"login\" or \"password\"."
1745   (auth-source-do-debug
1746    "auth-source-user-or-password: DEPRECATED get %s for %s (%s) + user=%s"
1747    mode host port username)
1748
1749   (let* ((listy (listp mode))
1750          (mode (if listy mode (list mode)))
1751          (cname (if username
1752                     (format "%s %s:%s %s" mode host port username)
1753                   (format "%s %s:%s" mode host port)))
1754          (search (list :host host :port port))
1755          (search (if username (append search (list :user username)) search))
1756          (search (if create-missing
1757                      (append search (list :create t))
1758                    search))
1759          (search (if delete-existing
1760                      (append search (list :delete t))
1761                    search))
1762          ;; (found (if (not delete-existing)
1763          ;;            (gethash cname auth-source-cache)
1764          ;;          (remhash cname auth-source-cache)
1765          ;;          nil)))
1766          (found nil))
1767     (if found
1768         (progn
1769           (auth-source-do-debug
1770            "auth-source-user-or-password: DEPRECATED cached %s=%s for %s (%s) + %s"
1771            mode
1772            ;; don't show the password
1773            (if (and (member "password" mode) t)
1774                "SECRET"
1775              found)
1776            host port username)
1777           found)                        ; return the found data
1778       ;; else, if not found, search with a max of 1
1779       (let ((choice (nth 0 (apply 'auth-source-search
1780                                   (append '(:max 1) search)))))
1781         (when choice
1782           (dolist (m mode)
1783             (cond
1784              ((equal "password" m)
1785               (push (if (plist-get choice :secret)
1786                       (funcall (plist-get choice :secret))
1787                     nil) found))
1788              ((equal "login" m)
1789               (push (plist-get choice :user) found)))))
1790         (setq found (nreverse found))
1791         (setq found (if listy found (car-safe found)))))
1792
1793         found))
1794
1795 (provide 'auth-source)
1796
1797 ;;; auth-source.el ends here