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