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