cgit.sxemacs.org Git - gnus/blob - lisp/auth-source.el

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