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

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