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."
 335   (let ((entry (if (stringp entry)
 336                    nil
 337                  entry))
 338         val)
 339     (when (setq val (plist-get entry :host))
 340       (oset backend host val))
 341     (when (setq val (plist-get entry :user))
 342       (oset backend user val))
 343     ;; accept :port as an alias for :protocol
 344     (when (setq val (or (plist-get entry :protocol) (plist-get entry :port)))
 345       (oset backend protocol val)))
 346   backend)
 347
 348 ;; (mapcar 'auth-source-backend-parse auth-sources)
 349
 350 (defun* auth-source-search (&rest spec
 351                                   &key type max host user protocol secret
 352                                   create delete
 353                                   &allow-other-keys)
 354   "Search or modify authentication backends according to SPEC.
 355
 356 This function parses `auth-sources' for matches of the SPEC
 357 plist.  It can optionally create or update an authentication
 358 token if requested.  A token is just a standard Emacs property
 359 list with a :secret property that can be a function; all the
 360 other properties will always hold scalar values.
 361
 362 Typically the :secret property, if present, contains a password.
 363
 364 Common search keys are :max, :host, :protocol, and :user.  In
 365 addition, :create specifies how tokens will be or created.
 366 Finally, :type can specify which backend types you want to check.
 367
 368 A string value is always matched literally.  A symbol is matched
 369 as its string value, literally.  All the SPEC values can be
 370 single values (symbol or string) or lists thereof (in which case
 371 any of the search terms matches).
 372
 373 :create t means to create a token if possible.
 374
 375 A new token will be created if no matching tokens were found.
 376 The new token will have only the keys the backend requires.  For
 377 the netrc backend, for instance, that's the user, host, and
 378 protocol keys.
 379
 380 Here's an example:
 381
 382 \(let ((auth-source-creation-defaults '((user . \"defaultUser\")
 383                                         (A    . \"default A\"))))
 384   (auth-source-search :host \"mine\" :type 'netrc :max 1
 385                       :P \"pppp\" :Q \"qqqq\"
 386                       :create t))
 387
 388 which says:
 389
 390 \"Search for any entry matching host 'mine' in backends of type
 391  'netrc', maximum one result.
 392
 393  Create a new entry if you found none.  The netrc backend will
 394  automatically require host, user, and protocol.  The host will be
 395  'mine'.  We prompt for the user with default 'defaultUser' and
 396  for the protocol without a default.  We will not prompt for A, Q,
 397  or P.  The resulting token will only have keys user, host, and
 398  protocol.\"
 399
 400 :create '(A B C) also means to create a token if possible.
 401
 402 The behavior is like :create t but if the list contains any
 403 parameter, that parameter will be required in the resulting
 404 token.  The value for that parameter will be obtained from the
 405 search parameters or from user input.  If any queries are needed,
 406 the alist `auth-source-creation-defaults' will be checked for the
 407 default prompt.
 408
 409 Here's an example:
 410
 411 \(let ((auth-source-creation-defaults '((user . \"defaultUser\")
 412                                         (A    . \"default A\"))))
 413   (auth-source-search :host '(\"nonesuch\" \"twosuch\") :type 'netrc :max 1
 414                       :P \"pppp\" :Q \"qqqq\"
 415                       :create '(A B Q)))
 416
 417 which says:
 418
 419 \"Search for any entry matching host 'nonesuch'
 420  or 'twosuch' in backends of type 'netrc', maximum one result.
 421
 422  Create a new entry if you found none.  The netrc backend will
 423  automatically require host, user, and protocol.  The host will be
 424  'nonesuch' and Q will be 'qqqq'.  We prompt for A with default
 425  'default A', for B and protocol with default nil, and for the
 426  user with default 'defaultUser'.  We will not prompt for Q.  The
 427  resulting token will have keys user, host, protocol, A, B, and Q.
 428  It will not have P with any value, even though P is used in the
 429  search to find only entries that have P set to 'pppp'.\"
 430
 431 When multiple values are specified in the search parameter, the
 432 first one is used for creation.  So :host (X Y Z) would create a
 433 token for host X, for instance.
 434
 435 This creation can fail if the search was not specific enough to
 436 create a new token (it's up to the backend to decide that).  You
 437 should `catch' the backend-specific error as usual.  Some
 438 backends (netrc, at least) will prompt the user rather than throw
 439 an error.
 440
 441 :delete t means to delete any found entries.  nil by default.
 442 Use `auth-source-delete' in ELisp code instead of calling
 443 `auth-source-search' directly with this parameter.
 444
 445 :type (X Y Z) will check only those backend types.  'netrc and
 446 'secrets are the only ones supported right now.
 447
 448 :max N means to try to return at most N items (defaults to 1).
 449 When 0 the function will return just t or nil to indicate if any
 450 matches were found.  More than N items may be returned, depending
 451 on the search and the backend.
 452
 453 :host (X Y Z) means to match only hosts X, Y, or Z according to
 454 the match rules above.  Defaults to t.
 455
 456 :user (X Y Z) means to match only users X, Y, or Z according to
 457 the match rules above.  Defaults to t.
 458
 459 :protocol (P Q R) means to match only protocols P, Q, or R.
 460 Defaults to t.
 461
 462 :K (V1 V2 V3) for any other key K will match values V1, V2, or
 463 V3 (note the match rules above).
 464
 465 The return value is a list with at most :max tokens.  Each token
 466 is a plist with keys :backend :host :protocol :user, plus any other
 467 keys provided by the backend (notably :secret).  But note the
 468 exception for :max 0, which see above.
 469
 470 The token's :secret key can hold a function.  In that case you
 471 must call it to obtain the actual value."
 472   (let* ((backends (mapcar 'auth-source-backend-parse auth-sources))
 473          (max (or max 1))
 474          (ignored-keys '(:create :delete :max))
 475          (keys (loop for i below (length spec) by 2
 476                      unless (memq (nth i spec) ignored-keys)
 477                      collect (nth i spec)))
 478          (found (auth-source-recall spec))
 479          filtered-backends accessor-key found-here goal)
 480
 481     (if (and found auth-source-do-cache)
 482         (auth-source-do-debug
 483          "auth-source-search: found %d CACHED results matching %S"
 484          (length found) spec)
 485
 486       (assert
 487        (or (eq t create) (listp create)) t
 488        "Invalid auth-source :create parameter (must be nil, t, or a list): %s %s")
 489
 490       (setq filtered-backends (copy-sequence backends))
 491       (dolist (backend backends)
 492         (dolist (key keys)
 493           ;; ignore invalid slots
 494           (condition-case signal
 495               (unless (eval `(auth-source-search-collection
 496                               (plist-get spec key)
 497                               (oref backend ,key)))
 498                 (setq filtered-backends (delq backend filtered-backends))
 499                 (return))
 500             (invalid-slot-name))))
 501
 502       (auth-source-do-debug
 503        "auth-source-search: found %d backends matching %S"
 504        (length filtered-backends) spec)
 505
 506       ;; (debug spec "filtered" filtered-backends)
 507       (setq goal max)
 508       (dolist (backend filtered-backends)
 509         (setq found-here (apply
 510                           (slot-value backend 'search-function)
 511                           :backend backend
 512                           :create create
 513                           :delete delete
 514                           spec))
 515
 516         ;; if max is 0, as soon as we find something, return it
 517         (when (and (zerop max) (> 0 (length found-here)))
 518           (return t))
 519
 520         ;; decrement the goal by the number of new results
 521         (decf goal (length found-here))
 522         ;; and append the new results to the full list
 523         (setq found (append found found-here))
 524
 525         (auth-source-do-debug
 526          "auth-source-search: found %d results (max %d/%d) in %S matching %S"
 527          (length found-here) max goal backend spec)
 528
 529         ;; return full list if the goal is 0 or negative
 530         (when (zerop (max 0 goal))
 531           (return found))
 532
 533         ;; change the :max parameter in the spec to the goal
 534         (setq spec (plist-put spec :max goal)))
 535
 536       (when (and found auth-source-do-cache)
 537         (auth-source-remember spec found)))
 538
 539       found))
 540
 541 ;;; (auth-source-search :max 1)
 542 ;;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret))
 543 ;;; (auth-source-search :host "nonesuch" :type 'netrc :K 1)
 544 ;;; (auth-source-search :host "nonesuch" :type 'secrets)
 545
 546 (defun* auth-source-delete (&rest spec
 547                                   &key delete
 548                                   &allow-other-keys)
 549   "Delete entries from the authentication backends according to SPEC.
 550 Calls `auth-source-search' with the :delete property in SPEC set to t.
 551 The backend may not actually delete the entries.
 552
 553 Returns the deleted entries."
 554   (auth-source-search (plist-put spec :delete t)))
 555
 556 (defun auth-source-search-collection (collection value)
 557   "Returns t is VALUE is t or COLLECTION is t or contains VALUE."
 558   (when (and (atom collection) (not (eq t collection)))
 559     (setq collection (list collection)))
 560
 561   ;; (debug :collection collection :value value)
 562   (or (eq collection t)
 563       (eq value t)
 564       (equal collection value)
 565       (member value collection)))
 566
 567 (defun auth-source-forget-all-cached ()
 568   "Forget all cached auth-source data."
 569   (interactive)
 570   (loop for sym being the symbols of password-data
 571         ;; when the symbol name starts with auth-source-magic
 572         when (string-match (concat "^" auth-source-magic)
 573                            (symbol-name sym))
 574         ;; remove that key
 575         do (password-cache-remove (symbol-name sym))))
 576
 577 (defun auth-source-remember (spec found)
 578   "Remember FOUND search results for SPEC."
 579   (password-cache-add
 580    (concat auth-source-magic (format "%S" spec)) found))
 581
 582 (defun auth-source-recall (spec)
 583   "Recall FOUND search results for SPEC."
 584   (password-read-from-cache
 585    (concat auth-source-magic (format "%S" spec))))
 586
 587 (defun auth-source-forget (spec)
 588   "Forget any cached data matching SPEC exactly.
 589
 590 This is the same SPEC you passed to `auth-source-search'.
 591 Returns t or nil for forgotten or not found."
 592   (password-cache-remove (concat auth-source-magic (format "%S" spec))))
 593
 594 ;;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym))
 595
 596 ;;; (auth-source-remember '(:host "wedd") '(4 5 6))
 597 ;;; (auth-source-remember '(:host "xedd") '(1 2 3))
 598 ;;; (auth-source-recall '(:host "xedd"))
 599 ;;; (auth-source-recall '(:host t))
 600 ;;; (auth-source-forget+ :host t)
 601
 602 (defun* auth-source-forget+ (&rest spec &allow-other-keys)
 603   "Forget any cached data matching SPEC.  Returns forgotten count.
 604
 605 This is not a full `auth-source-search' spec but works similarly.
 606 For instance, \(:host \"myhost\" \"yourhost\") would find all the
 607 cached data that was found with a search for those two hosts,
 608 while \(:host t) would find all host entries."
 609   (let ((count 0)
 610         sname)
 611     (loop for sym being the symbols of password-data
 612           ;; when the symbol name matches with auth-source-magic
 613           when (and (setq sname (symbol-name sym))
 614                     (string-match (concat "^" auth-source-magic "\\(.+\\)")
 615                                   sname)
 616                     ;; and the spec matches what was stored in the cache
 617                     (auth-source-specmatchp spec (read (match-string 1 sname))))
 618           ;; remove that key
 619           do (progn
 620                (password-cache-remove sname)
 621                (incf count)))
 622     count))
 623
 624 (defun auth-source-specmatchp (spec stored)
 625   (let ((keys (loop for i below (length spec) by 2
 626                    collect (nth i spec))))
 627     (not (eq
 628           (dolist (key keys)
 629             (unless (auth-source-search-collection (plist-get stored key)
 630                                                    (plist-get spec key))
 631               (return 'no)))
 632           'no))))
 633
 634 ;;; Backend specific parsing: netrc/authinfo backend
 635
 636 ;;; (auth-source-netrc-parse "~/.authinfo.gpg")
 637 (defun* auth-source-netrc-parse (&rest
 638                                  spec
 639                                  &key file max host user protocol delete
 640                                  &allow-other-keys)
 641   "Parse FILE and return a list of all entries in the file.
 642 Note that the MAX parameter is used so we can exit the parse early."
 643   (if (listp file)
 644       ;; We got already parsed contents; just return it.
 645       file
 646     (when (file-exists-p file)
 647       (with-temp-buffer
 648         (let ((tokens '("machine" "host" "default" "login" "user"
 649                         "password" "account" "macdef" "force"
 650                         "port" "protocol"))
 651               (max (or max 5000))       ; sanity check: default to stop at 5K
 652               (modified 0)
 653               alist elem result pair)
 654           (insert-file-contents file)
 655           (goto-char (point-min))
 656           ;; Go through the file, line by line.
 657           (while (and (not (eobp))
 658                       (> max 0))
 659
 660             (narrow-to-region (point) (point-at-eol))
 661             ;; For each line, get the tokens and values.
 662             (while (not (eobp))
 663               (skip-chars-forward "\t ")
 664               ;; Skip lines that begin with a "#".
 665               (if (eq (char-after) ?#)
 666                   (goto-char (point-max))
 667                 (unless (eobp)
 668                   (setq elem
 669                         (if (= (following-char) ?\")
 670                             (read (current-buffer))
 671                           (buffer-substring
 672                            (point) (progn (skip-chars-forward "^\t ")
 673                                           (point)))))
 674                   (cond
 675                    ((equal elem "macdef")
 676                     ;; We skip past the macro definition.
 677                     (widen)
 678                     (while (and (zerop (forward-line 1))
 679                                 (looking-at "$")))
 680                     (narrow-to-region (point) (point)))
 681                    ((member elem tokens)
 682                     ;; Tokens that don't have a following value are ignored,
 683                     ;; except "default".
 684                     (when (and pair (or (cdr pair)
 685                                         (equal (car pair) "default")))
 686                       (push pair alist))
 687                     (setq pair (list elem)))
 688                    (t
 689                     ;; Values that haven't got a preceding token are ignored.
 690                     (when pair
 691                       (setcdr pair elem)
 692                       (push pair alist)
 693                       (setq pair nil)))))))
 694
 695             (when (and alist
 696                        (> max 0)
 697                        (auth-source-search-collection
 698                         host
 699                         (or
 700                          (aget alist "machine")
 701                          (aget alist "host")))
 702                        (auth-source-search-collection
 703                         user
 704                         (or
 705                          (aget alist "login")
 706                          (aget alist "account")
 707                          (aget alist "user")))
 708                        (auth-source-search-collection
 709                         protocol
 710                         (or
 711                          (aget alist "port")
 712                          (aget alist "protocol"))))
 713               (decf max)
 714               (push (nreverse alist) result)
 715               ;; to delete a line, we just comment it out
 716               (when delete
 717                 (goto-char (point-min))
 718                 (insert "#")
 719                 (incf modified)))
 720             (setq alist nil
 721                   pair nil)
 722             (widen)
 723             (forward-line 1))
 724
 725           (when (< 0 modified)
 726             (when auth-source-gpg-encrypt-to
 727               ;; (see bug#7487) making `epa-file-encrypt-to' local to
 728               ;; this buffer lets epa-file skip the key selection query
 729               ;; (see the `local-variable-p' check in
 730               ;; `epa-file-write-region').
 731               (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
 732                 (make-local-variable 'epa-file-encrypt-to))
 733               (if (listp auth-source-gpg-encrypt-to)
 734                   (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
 735
 736             ;; ask AFTER we've successfully opened the file
 737             (when (y-or-n-p (format "Save file %s? (%d modifications)"
 738                                     file modified))
 739               (write-region (point-min) (point-max) file nil 'silent)
 740               (auth-source-do-debug
 741                "auth-source-netrc-parse: modified %d lines in %s"
 742                modified file)))
 743
 744           (nreverse result))))))
 745
 746 (defun auth-source-netrc-normalize (alist)
 747   (mapcar (lambda (entry)
 748             (let (ret item)
 749               (while (setq item (pop entry))
 750                 (let ((k (car item))
 751                       (v (cdr item)))
 752
 753                   ;; apply key aliases
 754                   (setq k (cond ((member k '("machine")) "host")
 755                                 ((member k '("login" "account")) "user")
 756                                 ((member k '("protocol")) "port")
 757                                 ((member k '("password")) "secret")
 758                                 (t k)))
 759
 760                   ;; send back the secret in a function (lexical binding)
 761                   (when (equal k "secret")
 762                     (setq v (lexical-let ((v v))
 763                               (lambda () v))))
 764
 765                   (setq ret (plist-put ret
 766                                        (intern (concat ":" k))
 767                                        v))
 768                   ))
 769               ret))
 770           alist))
 771
 772 ;;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret))
 773 ;;; (funcall secret)
 774
 775 (defun* auth-source-netrc-search (&rest
 776                                   spec
 777                                   &key backend create delete
 778                                   type max host user protocol
 779                                   &allow-other-keys)
 780 "Given a property list SPEC, return search matches from the :backend.
 781 See `auth-source-search' for details on SPEC."
 782   ;; just in case, check that the type is correct (null or same as the backend)
 783   (assert (or (null type) (eq type (oref backend type)))
 784           t "Invalid netrc search: %s %s")
 785
 786   (let ((results (auth-source-netrc-normalize
 787                   (auth-source-netrc-parse
 788                    :max max
 789                    :delete delete
 790                    :file (oref backend source)
 791                    :host (or host t)
 792                    :user (or user t)
 793                    :protocol (or protocol t)))))
 794
 795     ;; if we need to create an entry AND none were found to match
 796     (when (and create
 797                (= 0 (length results)))
 798
 799       ;; create based on the spec
 800       (apply (slot-value backend 'create-function) spec)
 801       ;; turn off the :create key
 802       (setq spec (plist-put spec :create nil))
 803       ;; run the search again to get the updated data
 804       ;; the result will be returned, even if the search fails
 805       (setq results (apply 'auth-source-netrc-search spec)))
 806
 807     results))
 808
 809 ;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
 810 ;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
 811
 812 (defun* auth-source-netrc-create (&rest spec
 813                                         &key backend
 814                                         secret host user protocol create
 815                                         &allow-other-keys)
 816   (let* ((base-required '(host user protocol secret))
 817          ;; we know (because of an assertion in auth-source-search) that the
 818          ;; :create parameter is either t or a list (which includes nil)
 819          (create-extra (if (eq t create) nil create))
 820          (required (append base-required create-extra))
 821          (file (oref backend source))
 822          (add "")
 823          ;; `valist' is an alist
 824          valist)
 825
 826     ;; only for base required elements (defined as function parameters):
 827     ;; fill in the valist with whatever data we may have from the search
 828     ;; we take the first value if it's a list, the whole value otherwise
 829     (dolist (br base-required)
 830       (when (symbol-value br)
 831         (aput 'valist br (if (listp (symbol-value br))
 832                              (nth 0 (symbol-value br))
 833                            (symbol-value br)))))
 834
 835     ;; for extra required elements, see if the spec includes a value for them
 836     (dolist (er create-extra)
 837       (let ((name (concat ":" (symbol-name er)))
 838             (keys (loop for i below (length spec) by 2
 839                         collect (nth i spec))))
 840         (dolist (k keys)
 841           (when (equal (symbol-name k) name)
 842             (aput 'valist er (plist-get spec k))))))
 843
 844     ;; for each required element
 845     (dolist (r required)
 846       (let* ((data (aget valist r))
 847              (given-default (aget auth-source-creation-defaults r))
 848              ;; the defaults are simple
 849              (default (cond
 850                        ((and (not given-default) (eq r 'user))
 851                         (user-login-name))
 852                        ;; note we need this empty string
 853                        ((and (not given-default) (eq r 'protocol))
 854                         "")
 855                        (t given-default)))
 856              ;; the prompt's default string depends on the data so far
 857              (default-string (if (and default (< 0 (length default)))
 858                                  (format " (default %s)" default)
 859                                " (no default)"))
 860              ;; the prompt should also show what's entered so far
 861              (user-value (aget valist 'user))
 862              (host-value (aget valist 'host))
 863              (protocol-value (aget valist 'protocol))
 864              (info-so-far (concat (if user-value
 865                                       (format "%s@" user-value)
 866                                     "[USER?]")
 867                                   (if host-value
 868                                       (format "%s" host-value)
 869                                     "[HOST?]")
 870                                   (if protocol-value
 871                                       ;; this distinguishes protocol between
 872                                       (if (zerop (length protocol-value))
 873                                           "" ; 'entered as "no default"' vs.
 874                                         (format ":%s" protocol-value)) ; given
 875                                     ;; and this is when the protocol is unknown
 876                                     "[PROTOCOL?]"))))
 877
 878         ;; now prompt if the search SPEC did not include a required key;
 879         ;; take the result and put it in `data' AND store it in `valist'
 880         (aput 'valist r
 881               (setq data
 882                     (cond
 883                      ((and (null data) (eq r 'secret))
 884                       ;; special case prompt for passwords
 885                       (read-passwd (format "Password for %s: " info-so-far)))
 886                      ((null data)
 887                       (read-string
 888                        (format "Enter %s for %s%s: "
 889                                r info-so-far default-string)
 890                        nil nil default))
 891                      (t data))))
 892
 893         ;; when r is not an empty string...
 894         (when (and (stringp data)
 895                    (< 0 (length data)))
 896           ;; append the key (the symbol name of r) and the value in r
 897           (setq add (concat add
 898                             (format "%s%s %S"
 899                                     ;; prepend a space
 900                                     (if (zerop (length add)) "" " ")
 901                                     ;; remap auth-source tokens to netrc
 902                                     (case r
 903                                      ('user "login")
 904                                      ('host "machine")
 905                                      ('secret "password")
 906                                      ('protocol "port")
 907                                      (t (symbol-name r)))
 908                                     ;; the value will be printed in %S format
 909                                     data))))))
 910
 911     (with-temp-buffer
 912       (when (file-exists-p file)
 913         (insert-file-contents file))
 914       (when auth-source-gpg-encrypt-to
 915         ;; (see bug#7487) making `epa-file-encrypt-to' local to
 916         ;; this buffer lets epa-file skip the key selection query
 917         ;; (see the `local-variable-p' check in
 918         ;; `epa-file-write-region').
 919         (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
 920           (make-local-variable 'epa-file-encrypt-to))
 921         (if (listp auth-source-gpg-encrypt-to)
 922             (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
 923       (goto-char (point-max))
 924
 925       ;; ask AFTER we've successfully opened the file
 926       (when (y-or-n-p (format "Add to file %s: line [%s]" file add))
 927         (unless (bolp)
 928           (insert "\n"))
 929         (insert add "\n")
 930         (write-region (point-min) (point-max) file nil 'silent)
 931         (auth-source-do-debug
 932          "auth-source-netrc-create: wrote 1 new line to %s"
 933          file)))))
 934
 935 ;;; Backend specific parsing: Secrets API backend
 936
 937 ;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t))
 938 ;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t))
 939 ;;; (let ((auth-sources '(default))) (auth-source-search :max 1))
 940 ;;; (let ((auth-sources '(default))) (auth-source-search))
 941 ;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1))
 942 ;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git"))
 943
 944 (defun* auth-source-secrets-search (&rest
 945                                     spec
 946                                     &key backend create delete label
 947                                     type max host user protocol
 948                                     &allow-other-keys)
 949   "Search the Secrets API; spec is like `auth-source'.
 950
 951 The :label key specifies the item's label.  It is the only key
 952 that can specify a substring.  Any :label value besides a string
 953 will allow any label.
 954
 955 All other search keys must match exactly.  If you need substring
 956 matching, do a wider search and narrow it down yourself.
 957
 958 You'll get back all the properties of the token as a plist.
 959
 960 Here's an example that looks for the first item in the 'Login'
 961 Secrets collection:
 962
 963  \(let ((auth-sources '(\"secrets:Login\")))
 964     (auth-source-search :max 1)
 965
 966 Here's another that looks for the first item in the 'Login'
 967 Secrets collection whose label contains 'gnus':
 968
 969  \(let ((auth-sources '(\"secrets:Login\")))
 970     (auth-source-search :max 1 :label \"gnus\")
 971
 972 And this one looks for the first item in the 'Login' Secrets
 973 collection that's a Google Chrome entry for the git.gnus.org site
 974 authentication tokens:
 975
 976  \(let ((auth-sources '(\"secrets:Login\")))
 977     (auth-source-search :max 1 :signon_realm \"https://git.gnus.org/Git\"))
 978 "
 979
 980   ;; TODO
 981   (assert (not create) nil
 982           "The Secrets API auth-source backend doesn't support creation yet")
 983   ;; TODO
 984   ;; (secrets-delete-item coll elt)
 985   (assert (not delete) nil
 986           "The Secrets API auth-source backend doesn't support deletion yet")
 987
 988   (let* ((coll (oref backend source))
 989          (max (or max 5000))     ; sanity check: default to stop at 5K
 990          (ignored-keys '(:create :delete :max :backend :label))
 991          (search-keys (loop for i below (length spec) by 2
 992                             unless (memq (nth i spec) ignored-keys)
 993                             collect (nth i spec)))
 994          ;; build a search spec without the ignored keys
 995          ;; if a search key is nil or t (match anything), we skip it
 996          (search-spec (apply 'append (mapcar
 997                                       (lambda (k)
 998                                         (if (or (null (plist-get spec k))
 999                                                 (eq t (plist-get spec k)))
1000                                             nil
1001                                           (list k (plist-get spec k))))
1002                               search-keys)))
1003          ;; needed keys (always including host, login, protocol, and secret)
1004          (returned-keys (delete-dups (append
1005                                       '(:host :login :protocol :secret)
1006                                       search-keys)))
1007          (items (loop for item in (apply 'secrets-search-items coll search-spec)
1008                       unless (and (stringp label)
1009                                   (not (string-match label item)))
1010                       collect item))
1011          ;; TODO: respect max in `secrets-search-items', not after the fact
1012          (items (butlast items (- (length items) max)))
1013          ;; convert the item name to a full plist
1014          (items (mapcar (lambda (item)
1015                           (append
1016                            ;; make an entry for the secret (password) element
1017                            (list
1018                             :secret
1019                             (lexical-let ((v (secrets-get-secret coll item)))
1020                               (lambda () v)))
1021                            ;; rewrite the entry from ((k1 v1) (k2 v2)) to plist
1022                            (apply 'append
1023                                   (mapcar (lambda (entry)
1024                                             (list (car entry) (cdr entry)))
1025                                           (secrets-get-attributes coll item)))))
1026                         items))
1027          ;; ensure each item has each key in `returned-keys'
1028          (items (mapcar (lambda (plist)
1029                           (append
1030                            (apply 'append
1031                                   (mapcar (lambda (req)
1032                                             (if (plist-get plist req)
1033                                                 nil
1034                                               (list req nil)))
1035                                           returned-keys))
1036                            plist))
1037                         items)))
1038     items))
1039
1040 (defun* auth-source-secrets-create (&rest
1041                                     spec
1042                                     &key backend type max host user protocol
1043                                     &allow-other-keys)
1044   ;; TODO
1045   ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
1046   (debug spec))
1047
1048 ;;; older API
1049
1050 ;;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
1051
1052 ;; deprecate the old interface
1053 (make-obsolete 'auth-source-user-or-password
1054                'auth-source-search "Emacs 24.1")
1055 (make-obsolete 'auth-source-forget-user-or-password
1056                'auth-source-forget "Emacs 24.1")
1057
1058 (defun auth-source-user-or-password
1059   (mode host protocol &optional username create-missing delete-existing)
1060   "Find MODE (string or list of strings) matching HOST and PROTOCOL.
1061
1062 DEPRECATED in favor of `auth-source-search'!
1063
1064 USERNAME is optional and will be used as \"login\" in a search
1065 across the Secret Service API (see secrets.el) if the resulting
1066 items don't have a username.  This means that if you search for
1067 username \"joe\" and it matches an item but the item doesn't have
1068 a :user attribute, the username \"joe\" will be returned.
1069
1070 A non nil DELETE-EXISTING means deleting any matching password
1071 entry in the respective sources.  This is useful only when
1072 CREATE-MISSING is non nil as well; the intended use case is to
1073 remove wrong password entries.
1074
1075 If no matching entry is found, and CREATE-MISSING is non nil,
1076 the password will be retrieved interactively, and it will be
1077 stored in the password database which matches best (see
1078 `auth-sources').
1079
1080 MODE can be \"login\" or \"password\"."
1081   (auth-source-do-debug
1082    "auth-source-user-or-password: DEPRECATED get %s for %s (%s) + user=%s"
1083    mode host protocol username)
1084
1085   (let* ((listy (listp mode))
1086          (mode (if listy mode (list mode)))
1087          (cname (if username
1088                     (format "%s %s:%s %s" mode host protocol username)
1089                   (format "%s %s:%s" mode host protocol)))
1090          (search (list :host host :protocol protocol))
1091          (search (if username (append search (list :user username)) search))
1092          (search (if create-missing
1093                      (append search (list :create t))
1094                    search))
1095          (search (if delete-existing
1096                      (append search (list :delete t))
1097                    search))
1098          ;; (found (if (not delete-existing)
1099          ;;            (gethash cname auth-source-cache)
1100          ;;          (remhash cname auth-source-cache)
1101          ;;          nil)))
1102          (found nil))
1103     (if found
1104         (progn
1105           (auth-source-do-debug
1106            "auth-source-user-or-password: DEPRECATED cached %s=%s for %s (%s) + %s"
1107            mode
1108            ;; don't show the password
1109            (if (and (member "password" mode) t)
1110                "SECRET"
1111              found)
1112            host protocol username)
1113           found)                        ; return the found data
1114       ;; else, if not found, search with a max of 1
1115       (let ((choice (nth 0 (apply 'auth-source-search
1116                                   (append '(:max 1) search)))))
1117         (when choice
1118           (dolist (m mode)
1119             (cond
1120              ((equal "password" m)
1121               (push (if (plist-get choice :secret)
1122                       (funcall (plist-get choice :secret))
1123                     nil) found))
1124              ((equal "login" m)
1125               (push (plist-get choice :user) found)))))
1126         (setq found (nreverse found))
1127         (setq found (if listy found (car-safe found)))))
1128
1129         found))
1130
1131 (provide 'auth-source)
1132
1133 ;;; auth-source.el ends here