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