Mercurial > emacs

comparison lisp/gnus/auth-source.el @ 107563:95c2fdf14356

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
2010-03-27 Teodor Zlatanov <tzz@lifelogs.com> * auth-source.el (auth-sources): Change default to be simpler. Explain about Secret Service API sources. Improve Customize options. (auth-source-pick): Change to accept any number of search parameters. Implement fallbacks iteratively, not recursively. Add scoring on the second pass and sort by score. Call Secret Service API when needed. (auth-source-user-or-password): Use it. Call Secret Service API directly when needed to get the user name and the password.
author Katsumi Yamaoka <yamaoka@jpl.org>
date Sun, 28 Mar 2010 23:52:01 +0000
parents 0fe940324254
children 3350692f1a89
comparison
equal deleted inserted replaced
107562:aae79c4d6845 107563:95c2fdf14356
36 (eval-when-compile (require 'cl)) 36 (eval-when-compile (require 'cl))
37 (autoload 'netrc-machine-user-or-password "netrc") 37 (autoload 'netrc-machine-user-or-password "netrc")
38 (autoload 'secrets-search-items "secrets") 38 (autoload 'secrets-search-items "secrets")
39 (autoload 'secrets-get-alias "secrets") 39 (autoload 'secrets-get-alias "secrets")
40 (autoload 'secrets-get-attribute "secrets") 40 (autoload 'secrets-get-attribute "secrets")
41 (autoload 'secrets-get-secret "secrets")
41 42
42 (defgroup auth-source nil 43 (defgroup auth-source nil
43 "Authentication sources." 44 "Authentication sources."
44 :version "23.1" ;; No Gnus 45 :version "23.1" ;; No Gnus
45 :group 'gnus) 46 :group 'gnus)
58 (symbol :tag "Protocol") 59 (symbol :tag "Protocol")
59 (repeat :tag "Names" 60 (repeat :tag "Names"
60 (string :tag "Name"))))) 61 (string :tag "Name")))))
61 62
62 ;;; generate all the protocols in a format Customize can use 63 ;;; generate all the protocols in a format Customize can use
64 ;;; TODO: generate on the fly from auth-source-protocols
63 (defconst auth-source-protocols-customize 65 (defconst auth-source-protocols-customize
64 (mapcar (lambda (a) 66 (mapcar (lambda (a)
65 (let ((p (car-safe a))) 67 (let ((p (car-safe a)))
66 (list 'const 68 (list 'const
67 :tag (upcase (symbol-name p)) 69 :tag (upcase (symbol-name p))
100 Only relevant if `auth-source-debug' is not nil." 102 Only relevant if `auth-source-debug' is not nil."
101 :group 'auth-source 103 :group 'auth-source
102 :version "23.2" ;; No Gnus 104 :version "23.2" ;; No Gnus
103 :type `boolean) 105 :type `boolean)
104 106
105 (defcustom auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t)) 107 (defcustom auth-sources '((:source "~/.authinfo.gpg"))
106 "List of authentication sources. 108 "List of authentication sources.
109
110 The default will get login and password information from a .gpg
111 file, which you should set up with the EPA/EPG packages to be
112 encrypted. See the auth.info manual for details.
107 113
108 Each entry is the authentication type with optional properties. 114 Each entry is the authentication type with optional properties.
109 115
110 It's best to customize this with `M-x customize-variable' because the choices 116 It's best to customize this with `M-x customize-variable' because the choices
111 can get pretty complex." 117 can get pretty complex."
119 (list :tag "secrets.el (Secret Service API/KWallet/GNOME KeyRing)" 125 (list :tag "secrets.el (Secret Service API/KWallet/GNOME KeyRing)"
120 (const :format "" :value :secrets) 126 (const :format "" :value :secrets)
121 (choice :tag "Collection to use" 127 (choice :tag "Collection to use"
122 (string :tag "Collection name") 128 (string :tag "Collection name")
123 (const :tag "Default" 'default) 129 (const :tag "Default" 'default)
124 (const :tag "Any" t) 130 (const :tag "Login" "login")
125 (const :tag "Temporary" "session") 131 (const :tag "Temporary" "session"))))
126 (string :tag "Specific session name")
127 (const :tag "Fallback" nil))))
128 (const :format "" :value :host)
129 (choice :tag "Host (machine) choice"
130 (const :tag "Any" t)
131 (regexp :tag "Host (machine) regular expression (TODO)")
132 (const :tag "Fallback" nil))
133 (const :format "" :value :protocol)
134 (choice :tag "Protocol"
135 (const :tag "Any" t)
136 (const :tag "Fallback" nil)
137 ,@auth-source-protocols-customize)
138 (repeat :tag "Extra Parameters" :inline t 132 (repeat :tag "Extra Parameters" :inline t
139 (choice :tag "Extra parameter" 133 (choice :tag "Extra parameter"
140 (list :tag "Preferred username" :inline t 134 (list :tag "Host (omit to match as a fallback)"
141 (const :format "" :value :preferred-username) 135 (const :format "" :value :host)
136 (choice :tag "Host (machine) choice"
137 (const :tag "Any" t)
138 (regexp :tag "Host (machine) regular expression")))
139 (list :tag "Protocol (omit to match as a fallback)"
140 (const :format "" :value :protocol)
141 (choice :tag "Protocol"
142 (const :tag "Any" t)
143 ,@auth-source-protocols-customize))
144 (list :tag "User (omit to match as a fallback)" :inline t
145 (const :format "" :value :user)
142 (choice :tag "Personality or username" 146 (choice :tag "Personality or username"
143 (const :tag "Any" t) 147 (const :tag "Any" t)
144 (const :tag "Fallback" nil)
145 (string :tag "Specific user name")))))))) 148 (string :tag "Specific user name"))))))))
146 149
147 ;; temp for debugging 150 ;; temp for debugging
148 ;; (unintern 'auth-source-protocols) 151 ;; (unintern 'auth-source-protocols)
149 ;; (unintern 'auth-sources) 152 ;; (unintern 'auth-sources)
151 ;; (setq auth-sources nil) 154 ;; (setq auth-sources nil)
152 ;; (format "%S" auth-sources) 155 ;; (format "%S" auth-sources)
153 ;; (customize-variable 'auth-source-protocols) 156 ;; (customize-variable 'auth-source-protocols)
154 ;; (setq auth-source-protocols nil) 157 ;; (setq auth-source-protocols nil)
155 ;; (format "%S" auth-source-protocols) 158 ;; (format "%S" auth-source-protocols)
156 ;; (auth-source-pick "a" 'imap) 159 ;; (auth-source-pick nil :host "a" :port 'imap)
157 ;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap) 160 ;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
158 ;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap) 161 ;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
159 ;; (auth-source-user-or-password-imap "login" "imap.myhost.com") 162 ;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
160 ;; (auth-source-user-or-password-imap "password" "imap.myhost.com") 163 ;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
161 ;; (auth-source-protocol-defaults 'imap) 164 ;; (auth-source-protocol-defaults 'imap)
171 (let ((logger (if (functionp auth-source-debug) 174 (let ((logger (if (functionp auth-source-debug)
172 auth-source-debug 175 auth-source-debug
173 'message))) 176 'message)))
174 (apply logger msg)))) 177 (apply logger msg))))
175 178
176 (defun auth-source-pick (host protocol &optional fallback) 179 ;; (auth-source-pick nil :host "any" :protocol 'imap :user "joe")
177 "Parse `auth-sources' for HOST, and PROTOCOL matches. 180 ;; (auth-source-pick t :host "any" :protocol 'imap :user "joe")
178 181 ;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
179 Returns fallback choices (where PROTOCOL or HOST are nil) with FALLBACK t." 182 ;; (:source (:secrets "session") :host t :protocol t :user "joe")
180 (interactive "sHost: \nsProtocol: \n") ;for testing 183 ;; (:source (:secrets "login") :host t :protocol t)
184 ;; (:source "~/.authinfo.gpg" :host t :protocol t)))
185
186 ;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
187 ;; (:source (:secrets "session") :host t :protocol t :user "joe")
188 ;; (:source (:secrets "login") :host t :protocol t)
189 ;; ))
190
191 ;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t)))
192
193 (defun auth-source-pick (&rest spec)
194 "Parse `auth-sources' for matches of the SPEC plist.
195
196 Common keys are :host, :protocol, and :user. A value of t in
197 SPEC means to always succeed in the match. A string value is
198 matched as a regex.
199
200 The first pass skips fallback choices. If no choices are found
201 on the first pass, a second pass is made including the fallback
202 choices.
203
204 For string (filename) sources, fallback choices are those where
205 PROTOCOL or HOST are nil.
206
207 For secrets.el collections, the :host and :protocol keys are not
208 checked for fallback choices."
181 (let (choices) 209 (let (choices)
182 (dolist (choice auth-sources) 210 (dolist (fallback '(nil t))
183 (let ((h (plist-get choice :host)) 211 (let ((keys (loop for i below (length spec) by 2
184 (p (plist-get choice :protocol))) 212 collect (nth i spec)))
185 (when (and 213 (default-session-fallback "login"))
186 (or (equal t h) 214 (dolist (choice auth-sources)
187 (and (stringp h) (string-match h host)) 215 (let* ((s (plist-get choice :source))
188 (and fallback (equal h nil))) 216 ;; this is only set for Secret Service API specs (see secrets.el)
189 (or (equal t p) 217 (coll (plist-get s :secrets))
190 (and (symbolp p) (equal p protocol)) 218 (score 0))
191 (and fallback (equal p nil)))) 219 (cond
192 (push choice choices)))) 220 (coll ; use secrets.el here
193 (if choices 221 (when (eq coll 'default)
194 choices 222 (setq coll (secrets-get-alias "default"))
195 (unless fallback 223 (unless coll
196 (auth-source-pick host protocol t))))) 224 (auth-source-do-debug
225 "No 'default' alias. Trying collection '%s'."
226 default-session-fallback)
227 (setq coll default-session-fallback)))
228 (let* ((coll-search (cond
229 ((stringp coll) coll)
230
231 ;; when the collection is nil:
232 ;; in fallback mode, accept it as any
233 ;; otherwise, hope to fail
234 ((null coll) (if fallback
235 nil
236 " *fallback-fail*"))))
237 ;; assemble a search query for secrets-search-items
238 ;; in fallback mode, host and protocol are not checked
239 (other-search (loop for k
240 in (if fallback
241 (remove :host
242 (remove :protocol keys))
243 keys)
244 append (list
245 k
246 ;; convert symbols to a string
247 (let ((v (plist-get spec k)))
248 (if (stringp v)
249 v
250 (prin1-to-string v))))))
251 ;; the score is based on how exact the search was,
252 ;; plus base score = 1 for any match
253 (score (1+ (length other-search)))
254 (results (apply 'secrets-search-items
255 coll-search
256 other-search)))
257 (auth-source-do-debug
258 "auth-source-pick: got items %s in collection '%s' + %s"
259 results coll-search other-search)
260 ;; put the results in the choices variable
261 (dolist (result results)
262 (setq choices (cons (list score
263 `(:source secrets
264 :item ,result
265 :collection ,coll
266 :search ,coll-search
267 ,@other-search))
268 choices)))))
269 ;; this is any non-secrets spec (currently means a string filename)
270 (t
271 (let ((match t))
272 (dolist (k keys)
273 (let* ((v (plist-get spec k))
274 (choicev (plist-get choice k)))
275 (setq match
276 (and match
277 (or (eq t choicev) ; source always matches spec key
278 ;; source key gives regex to match against spec
279 (and (stringp choicev) (string-match choicev v))
280 ;; source key gives symbol to match against spec
281 (and (symbolp choicev) (eq choicev v))
282 ;; in fallback mode, missing source key is OK
283 fallback)))
284 (when match (incf score)))) ; increment the score for each match
285
286 ;; now if the whole iteration resulted in a match:
287 (when match
288 (setq choices (cons (list score choice) choices))))))))
289 ;; when there were matches, skip the second pass
290 (when choices (return choices))))
291
292 ;; return the results sorted by score
293 (mapcar 'cadr (sort choices (lambda (x y) (> (car x) (car y)))))))
197 294
198 (defun auth-source-forget-user-or-password (mode host protocol) 295 (defun auth-source-forget-user-or-password (mode host protocol)
199 (interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing 296 (interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing
200 (remhash (format "%s %s:%s" mode host protocol) auth-source-cache)) 297 (remhash (format "%s %s:%s" mode host protocol) auth-source-cache))
201 298
202 (defun auth-source-forget-all-cached () 299 (defun auth-source-forget-all-cached ()
203 "Forget all cached auth-source authentication tokens." 300 "Forget all cached auth-source authentication tokens."
204 (interactive) 301 (interactive)
205 (setq auth-source-cache (make-hash-table :test 'equal))) 302 (setq auth-source-cache (make-hash-table :test 'equal)))
206 303
207 (defun auth-source-user-or-password (mode host protocol) 304 ;; (progn
305 ;; (auth-source-forget-all-cached)
306 ;; (list
307 ;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other")
308 ;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "tzz")
309 ;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "joe")))
310
311 (defun auth-source-user-or-password (mode host protocol &optional username)
208 "Find MODE (string or list of strings) matching HOST and PROTOCOL. 312 "Find MODE (string or list of strings) matching HOST and PROTOCOL.
313
314 USERNAME is optional and will be used as \"login\" in a search
315 across the Secret Service API (see secrets.el) if the resulting
316 items don't have a username. This means that if you search for
317 username \"joe\" and it matches an item but the item doesn't have
318 a :user attribute, the username \"joe\" will be returned.
319
209 MODE can be \"login\" or \"password\" for example." 320 MODE can be \"login\" or \"password\" for example."
210 (auth-source-do-debug 321 (auth-source-do-debug
211 "auth-source-user-or-password: get %s for %s (%s)" 322 "auth-source-user-or-password: get %s for %s (%s) + user=%s"
212 mode host protocol) 323 mode host protocol username)
213 (let* ((listy (listp mode)) 324 (let* ((listy (listp mode))
214 (mode (if listy mode (list mode))) 325 (mode (if listy mode (list mode)))
215 (cname (format "%s %s:%s" mode host protocol)) 326 (extras (when username `(:user ,username)))
327 (cname (format "%s %s:%s %s" mode host protocol extras))
328 (search (list :host host :protocol protocol))
329 (search (if username (append search (list :user username)) search))
216 (found (gethash cname auth-source-cache))) 330 (found (gethash cname auth-source-cache)))
217 (if found 331 (if found
218 (progn 332 (progn
219 (auth-source-do-debug 333 (auth-source-do-debug
220 "auth-source-user-or-password: cached %s=%s for %s (%s)" 334 "auth-source-user-or-password: cached %s=%s for %s (%s) + %s"
335 mode
336 ;; don't show the password
337 (if (and (member "password" mode) auth-source-hide-passwords)
338 "SECRET"
339 found)
340 host protocol extras)
341 found) ; return the found data
342 ;; else, if not found
343 (dolist (choice (apply 'auth-source-pick search))
344 (setq found (cond
345 ;; the secrets.el spec
346 ((eq (plist-get choice :source) 'secrets)
347 (let ((coll (plist-get choice :search))
348 (item (plist-get choice :item)))
349 (mapcar (lambda (m)
350 (if (equal "password" m)
351 (secrets-get-secret coll item)
352 ;; the user name is either
353 (or
354 ;; the secret's attribute :user, or
355 (secrets-get-attribute coll item :user)
356 ;; the originally requested :user
357 username
358 "unknown-user")))
359 mode)))
360 (t ; anything else is netrc
361 (netrc-machine-user-or-password
362 mode
363 (plist-get choice :source)
364 (list host)
365 (list (format "%s" protocol))
366 (auth-source-protocol-defaults protocol)))))
367 (when found
368 (auth-source-do-debug
369 "auth-source-user-or-password: found %s=%s for %s (%s) + %s"
221 mode 370 mode
222 ;; don't show the password 371 ;; don't show the password
223 (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found) 372 (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
224 host protocol) 373 host protocol extras)
225 found)
226 (dolist (choice (auth-source-pick host protocol))
227 (setq found (netrc-machine-user-or-password
228 mode
229 (plist-get choice :source)
230 (list host)
231 (list (format "%s" protocol))
232 (auth-source-protocol-defaults protocol)))
233 (when found
234 (auth-source-do-debug
235 "auth-source-user-or-password: found %s=%s for %s (%s)"
236 mode
237 ;; don't show the password
238 (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
239 host protocol)
240 (setq found (if listy found (car-safe found))) 374 (setq found (if listy found (car-safe found)))
241 (when auth-source-do-cache 375 (when auth-source-do-cache
242 (puthash cname found auth-source-cache))) 376 (puthash cname found auth-source-cache)))
243 (return found))))) 377 (return found)))))
244 378
245 (defun auth-source-protocol-defaults (protocol) 379 (defun auth-source-protocol-defaults (protocol)
246 "Return a list of default ports and names for PROTOCOL." 380 "Return a list of default ports and names for PROTOCOL."
247 (cdr-safe (assoc protocol auth-source-protocols))) 381 (cdr-safe (assoc protocol auth-source-protocols)))
248 382
249 (defun auth-source-user-or-password-imap (mode host) 383 (defun auth-source-user-or-password-imap (mode host)