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