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